diff options
| -rw-r--r-- | .gitignore | 2 | ||||
| -rw-r--r-- | Regfish.hs | 224 | ||||
| -rw-r--r-- | Regfish/AcidState.hs | 47 | ||||
| -rw-r--r-- | Regfish/Default.hs | 37 | ||||
| -rw-r--r-- | Regfish/Parser.hs | 100 | ||||
| -rw-r--r-- | Regfish/Types.hs | 81 | ||||
| -rw-r--r-- | env.nix | 55 |
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 @@ -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 : |