initial commit

7 files changed, 546 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..754e930
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+/.graveyard
+/state
diff --git a/Regfish.hs b/Regfish.hs
new file mode 100644
index 0000000..4119d4d
--- /dev/null
+++ b/Regfish.hs
@@ -0,0 +1,224 @@
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+
+
+module Regfish
+    ( dump
+    , login
+    , list
+    , add
+    , edit
+    , del
+    ) where
+
+import Control.Lens
+import Control.Monad.IO.Class
+import Data.Default
+import Data.Monoid
+import qualified Data.Acid as A
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Data.List as L
+import qualified Network.HTTP.Client as C
+import qualified Network.Wreq as W
+import qualified Network.Wreq.Types as W (Postable)
+import Regfish.AcidState
+import Regfish.Default ()
+import Regfish.Parser
+import Regfish.Types
+import Text.Printf
+
+
+loginUrl :: Url
+loginUrl = "https://www.regfish.de/my/login"
+
+
+sessionCookieName :: BS8.ByteString
+sessionCookieName = "rf51"
+
+
+sessionToken :: C.CookieJar -> Maybe SessionToken
+sessionToken =
+    fmap C.cookie_value .
+    L.find ((==sessionCookieName) . C.cookie_name) .
+    C.destroyCookieJar
+
+
+responseSessionToken :: Getter (W.Response body) (Maybe SessionToken)
+responseSessionToken =
+    W.responseCookieJar . to sessionToken
+
+dump :: IO ()
+dump =
+    withLocalState def $ \qa -> do
+        print =<< A.query qa DumpQuery
+
+
+login :: IO ()
+login =
+    withLocalState def $ \qa -> do
+
+        cj <- A.query qa CookieJarQuery
+
+        putStrLn $ "session token: " <> show (sessionToken cj)
+
+        putStrLn $ "Logging in..."
+
+        res <- liftIO $ W.post loginUrl
+            [ "u" W.:= _username def
+            , "p" W.:= _password def
+            ]
+
+        putStrLn $ "session token: " <> show (res ^. responseSessionToken)
+
+        A.update qa $ CookieJarUpdate $ res ^. W.responseCookieJar
+
+
+list :: IO ()
+list =
+    regfishGet (_allinone def) >>= \case
+        Left err -> error err
+        Right r -> do
+            let body = r ^. W.responseBody
+            if isLoginPage $ LBS8.unpack body
+                then do
+                    -- TODO login and try again (once)
+                    error "not logged in"
+                else do
+                    mapM_ pr $ readZone $ body
+  where
+    pr (Record rrid rrtype rrname rrttl rraux rrdata) = do
+        printf "%-8s %-24s\t%s\tIN\t%-5s\t%s\n"
+                  rrid
+                  rrname
+                  (if rrttl /= 0 then show rrttl else mempty)
+                  rrtype $
+                  (if rraux /= 0 then show rraux <> " " else mempty)
+                  <> rrdata
+
+
+
+regfishGet :: Url -> IO (Either String (W.Response LBS8.ByteString))
+regfishGet url =
+    withLocalState def $ \qa -> do
+
+        cj <- A.query qa CookieJarQuery
+
+        --putStrLn $ "session token: " <> show (sessionToken cj)
+
+        case sessionToken cj of
+            Nothing -> do
+                putStrLn "Not logged in."
+                -- TODO log in
+                return $ Left "not logged in"
+
+            Just _ -> do
+                --putStrLn $ "GET " <> url
+
+                let opts = W.defaults & W.cookies .~ cj
+
+                res <- liftIO $ W.getWith opts url
+
+                --now <- getCurrentTime
+
+                --putStrLn $ "session token: " <> show (res ^. W.responseCookieJar . to sessionToken)
+
+                let cj' = res ^. W.responseCookieJar
+                    --cj'' = C.evictExpiredCookies cj' now
+
+                A.update qa $ CookieJarUpdate cj'
+
+                return $ Right res
+
+
+regfishPost :: W.Postable p =>
+    Url -> p -> IO (Either String (W.Response LBS8.ByteString))
+regfishPost url params = do
+    withLocalState def $ \qa -> do
+
+        cj <- A.query qa CookieJarQuery
+
+        --putStrLn $ "session token: " <> show (sessionToken cj)
+
+        case sessionToken cj of
+            Nothing -> do
+                putStrLn "Not logged in."
+                -- TODO log in
+                return $ Left "not logged in"
+
+            Just _ -> do
+                --putStrLn $ "POST " <> url <> " " <> show params
+
+                let opts = W.defaults & W.cookies .~ cj
+
+                res <- liftIO $ W.postWith opts url params
+
+                -- TODO check error
+
+                --putStrLn $ "session token: " <> show (res ^. W.responseCookieJar . to sessionToken)
+
+                A.update qa $ CookieJarUpdate $ res ^. W.responseCookieJar
+
+                return $ Right res
+
+
+
+-- | We're on a login page, when a form action is `loginUrl`.
+isLoginPage :: String -> Bool
+isLoginPage =
+    (("action=" ++ show loginUrl) `L.isInfixOf`)
+
+
+
+undata :: RRData -> (String -> Integer -> String -> a) -> a
+undata (A rrdata) f = f "A" 0 rrdata
+undata (MX rraux rrdata) f = f "MX" rraux rrdata
+undata (CNAME rrdata) f = f "CNAME" 0 rrdata
+
+add :: RRname -> RRttl -> RRData -> IO (Either String (W.Response LBS8.ByteString))
+add rrname rrttl rrdata =
+    regfishPost (_allinone def) $ undata rrdata $ getRRAddValidation rrname rrttl
+
+edit :: RRid -> RRname -> RRttl -> RRData -> IO (Either String (W.Response LBS8.ByteString))
+edit rrid rrname rrttl rrdata =
+    regfishPost (_allinone def) $ undata rrdata $ commitRRChanges rrid rrname rrttl
+
+del :: RRid -> IO (Either String (W.Response LBS8.ByteString))
+del rrid =
+    regfishPost (_allinone def) $ removeRREntry rrid
+
+
+
+removeRREntry :: RRid -> [W.FormParam]
+removeRREntry rrid =
+    [ "action"  W.:= ("removeRREntry" :: String)
+    , "rrid"  W.:= rrid
+    ]
+
+commitRRChanges ::
+    RRid -> RRname -> RRttl -> RRtype -> RRaux -> RRdata -> [W.FormParam]
+commitRRChanges rrid rrname rrttl rrtype rraux rrdata =
+    [ "action"  W.:= ("commitRRChanges" :: String)
+    , "rrid"  W.:= rrid
+    , "type"  W.:= rrtype
+    , "name"  W.:= rrname
+    , "ttl"   W.:= rrttl
+    , "data"  W.:= rrdata
+    , "aux"   W.:= rraux
+    ]
+
+getRRAddValidation ::
+    RRname -> RRttl -> RRtype -> RRaux -> RRdata -> [W.FormParam]
+getRRAddValidation rrname rrttl rrtype rraux rrdata =
+    [ "action"  W.:= ("getRRAddValidation" :: String)
+    , "type"  W.:= rrtype
+    , "name"  W.:= rrname
+    , "ttl"   W.:= rrttl
+    , "data"  W.:= rrdata
+    , "aux"   W.:= rraux
+    ]
diff --git a/Regfish/AcidState.hs b/Regfish/AcidState.hs
new file mode 100644
index 0000000..6137f0b
--- /dev/null
+++ b/Regfish/AcidState.hs
@@ -0,0 +1,47 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+
+module Regfish.AcidState where
+
+import Control.Exception (bracket)
+import Control.Lens
+import Control.Monad.Reader
+import Data.Acid
+import Data.Typeable
+import Regfish.Types
+import Network.HTTP.Client (CookieJar)
+-- TODO Regfish.Types.CookieJar ?
+
+
+withLocalState :: (IsAcidic q, Typeable q) =>
+    q -> (AcidState q -> IO a) -> IO a
+withLocalState initialState a =
+    bracket (liftIO $ openLocalState initialState)
+            --(liftIO . createCheckpointAndClose)
+            (liftIO . closeAcidState)
+            (\q -> createArchive q >> a q)
+
+
+cookieJarQuery :: Query RFState CookieJar
+cookieJarQuery =
+    asks _cookieJar
+
+
+cookieJarUpdate :: CookieJar -> Update RFState ()
+cookieJarUpdate =
+    (cookieJar .=)
+
+
+dumpQuery :: Query RFState RFState
+dumpQuery =
+    ask
+
+
+makeAcidic ''RFState
+    [ 'cookieJarQuery
+    , 'cookieJarUpdate
+    , 'dumpQuery
+    ]
diff --git a/Regfish/Default.hs b/Regfish/Default.hs
new file mode 100644
index 0000000..bb78dd3
--- /dev/null
+++ b/Regfish/Default.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+
+module Regfish.Default () where
+
+import Control.Applicative
+import Data.Default
+import Regfish.Types
+import System.Environment (getEnv)
+import System.IO.Unsafe (unsafePerformIO)
+
+
+instance Default RFConfig where
+    def = RFConfig
+        { _username = user
+        , _password = pass
+        , _allinone = mkAllInOne domain
+        }
+      where
+        (user, pass, domain) =
+            unsafePerformIO $
+              (,,) <$> getEnv "REGFISH_USER"
+                   <*> getEnv "REGFISH_PASS"
+                   <*> getEnv "REGFISH_DOMAIN"
+
+
+instance Default RFState where
+    def = RFState def
+
+
+
+mkAllInOne :: String -> String
+mkAllInOne domain =
+    "https://www.regfish.de/my/domains/*/"++tld++"/"++sld++"/rr/allinone"
+  where
+    (sld, '.':tld) = break (=='.') domain
diff --git a/Regfish/Parser.hs b/Regfish/Parser.hs
new file mode 100644
index 0000000..bc294b6
--- /dev/null
+++ b/Regfish/Parser.hs
@@ -0,0 +1,100 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+
+module Regfish.Parser
+    ( readZone
+    ) where
+
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import Regfish.Types
+import Text.HTML.TagSoup
+
+
+readZone :: LBS8.ByteString -> [Record]
+readZone = parseRecords . dnszone
+
+
+parseRecords :: [Tag LBS8.ByteString] -> [Record]
+parseRecords =
+    map toRecord . filter knownRecord . rec []
+  where
+    knownRecord (_ : _ : _ : namespace : type_ : _) =
+        namespace == "IN" && type_ `elem` ["MX", "A", "CNAME"]
+
+    knownRecord x =
+        errorBadArgument "parseRecords.knownRecord" x
+
+    rec ys = \case
+        (TagOpen "tr" attrs:xs) ->
+            case getRecordId attrs of
+                Just id_ ->
+                    let (r,_:xs') = span (/=TagClose "tr") xs
+                    in rec (parseRecord id_ r:ys) xs'
+                _ ->
+                    let xs' = drop 1 $ dropWhile (/=TagClose "tr") xs
+                    in rec ys xs'
+
+        [] -> ys
+
+        x -> errorBadArgument "parseRecords.rec" x
+
+    getRecordId attrs =
+        case maybe Nothing (Just . LBS8.unpack) $ lookup "id" attrs of
+            Just ('a':'_':xs) -> Just (LBS8.pack xs)
+            _ -> Nothing
+
+
+
+toRecord :: [LBS8.ByteString] -> Record
+toRecord xs = case map LBS8.unpack xs of
+    [rrid, rrname, rrttl, "IN", rrtype, rraux, rrdata] ->
+        Record rrid rrtype rrname (read rrttl) (read rraux) rrdata
+    [rrid, rrname, rrttl, "IN", rrtype, rrdata] ->
+        Record rrid rrtype rrname (read rrttl) 0 rrdata
+    x ->
+        errorBadArgument "toRecord" x
+
+
+dnszone :: LBS8.ByteString -> [Tag LBS8.ByteString]
+dnszone =
+    filter p . (dnszoneSoup . parseTags)
+  where
+    p = \case
+        TagOpen "tr" _ -> True
+        TagClose "tr" -> True
+        TagText x
+          | x /= "\n" -> True
+          | otherwise -> False
+        _ -> False
+
+
+parseRecord :: LBS8.ByteString -> [Tag LBS8.ByteString] -> [LBS8.ByteString]
+parseRecord id_ =
+    (id_:) . add_def_ttl "0" . filter p . map f
+  where
+    f (TagText x) = x
+    f x = errorBadArgument "parseRecord" x
+    p x
+        | x == "\160" = False
+        | x == " "    = False
+        | otherwise   = True
+
+    add_def_ttl def_ttl (x:"IN":xs) = x : def_ttl : "IN" : xs
+    add_def_ttl _ xs = xs
+
+
+dnszoneSoup :: [Tag LBS8.ByteString] -> [Tag LBS8.ByteString]
+dnszoneSoup =
+    takeWhile (\t -> not $ t ~== dnszoneClose) .
+    dropWhile (\t -> not $ t ~== dnszoneOpen)
+
+
+dnszoneOpen, dnszoneClose :: Tag LBS8.ByteString
+dnszoneOpen  = TagOpen "table" [("id", "dnszone")]
+dnszoneClose = TagClose "table"
+
+
+errorBadArgument :: Show a => String -> a -> b
+errorBadArgument name x =
+    error $ "Regfish.Parser." ++ name ++ ": bad argument: " ++ show x
diff --git a/Regfish/Types.hs b/Regfish/Types.hs
new file mode 100644
index 0000000..cef2808
--- /dev/null
+++ b/Regfish/Types.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+
+module Regfish.Types where
+
+import Control.Applicative
+import Control.Lens
+import Control.Monad.Reader
+import Control.Monad.State
+import qualified Data.ByteString.Char8 as BS8
+import Data.SafeCopy (base, deriveSafeCopy)
+import Data.Typeable
+import qualified Network.HTTP.Client as C
+import qualified Network.Wreq as W
+
+
+deriveSafeCopy 0 'base ''C.CookieJar
+deriveSafeCopy 0 'base ''W.Cookie
+
+
+newtype Regfish a = Regfish
+    { runRegfish_ :: ReaderT RFConfig (StateT RFState IO) a
+    }
+  deriving
+    ( Applicative
+    , Functor
+    , Monad
+    , MonadIO
+    , MonadReader RFConfig
+    , MonadState RFState
+    )
+
+
+-- TODO reduce number of aliases?
+type Password = String
+type RRaux = Integer
+type RRdata = String
+type RRid = Integer
+type RRname = String
+type RRttl = Integer
+type RRtype = String
+type SessionToken = BS8.ByteString
+type Url = String
+type Username = String
+
+
+data RFConfig = RFConfig
+    { _username :: Username
+    , _password :: Password
+    , _allinone :: Url
+    }
+  deriving (Show)
+
+
+data RFState = RFState
+    { _cookieJar :: C.CookieJar
+    }
+  deriving (Show, Typeable)
+          -- ^ TODO rm Show
+
+
+makeLenses ''RFState
+
+
+data RRData
+    = A String
+    | MX Integer String
+    | CNAME String
+  deriving (Show)
+
+
+-- TODO kill Record?
+data Record = Record String String String Int Int String
+    deriving (Show)
+
+
+deriveSafeCopy 0 'base ''RFState
+deriveSafeCopy 0 'base ''RFConfig
diff --git a/env.nix b/env.nix
new file mode 100644
index 0000000..f0ea840
--- /dev/null
+++ b/env.nix
@@ -0,0 +1,55 @@
+{ nixpkgs ? import <nixpkgs> {} }:
+
+let
+  pname = "regfish";
+  version = "1";
+
+  buildInputs = with pkgs; [
+    hsEnv
+  ];
+
+  extraCmds = with pkgs; ''
+    export HISTFILE="\$HOME/.history/env-${pname}"
+    export MANPATH=\$MANPATH:${lftp}/share/man
+    $(grep export ${hsEnv.outPath}/bin/ghc)
+    ${mkExports staticPkgs}
+    if test -f "\$HOME/.env-${pname}"; then
+      . "\$HOME/.env-${pname}"
+    fi
+  '';
+
+  hsEnv = hsPkgs.ghcWithPackagesOld (self: with self;
+    [
+      acidState
+      cabalInstall
+      tagsoup
+      wreq
+    ]
+  );
+
+  hsPkgs = pkgs.haskellPackages_ghc783_profiling.override {
+    extension = self: super: with self; {
+    };
+  };
+
+  pkgs = nixpkgs // staticPkgs;
+  staticPkgs = with nixpkgs; {
+  };
+
+  #{{{ mkExports : set -> string
+  # Create shell script that exports a set's attributes.
+  mkExports = set: with builtins; with pkgs.lib.strings;
+    let
+      # XXX attribute names are not escaped, they have to be sane
+      # XXX the value should not contain <newline>
+      mkExport = k: "export ${k}=${escapeSh (getAttr k set)}";
+      escapeSh = stringAsChars (c: "\\${c}");
+    in
+      concatStringsSep "\n" (map mkExport (attrNames set));
+  #}}}
+
+in pkgs.myEnvFun {
+  name = "${pname}-${version}";
+  inherit buildInputs extraCmds;
+}
+# vim: set fdm=marker :