From 179d8980e55578e3553bad0b237368d74e074f15 Mon Sep 17 00:00:00 2001 From: tv Date: Tue, 18 Nov 2014 16:05:40 +0100 Subject: initial commit --- Regfish.hs | 224 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 224 insertions(+) create mode 100644 Regfish.hs (limited to 'Regfish.hs') 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 + ] -- cgit v1.2.3