initial commit

1 files changed, 224 insertions, 0 deletions

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
+    ]