From 179d8980e55578e3553bad0b237368d74e074f15 Mon Sep 17 00:00:00 2001 From: tv Date: Tue, 18 Nov 2014 16:05:40 +0100 Subject: initial commit --- Regfish/AcidState.hs | 47 ++++++++++++++++++++++++ Regfish/Default.hs | 37 +++++++++++++++++++ Regfish/Parser.hs | 100 +++++++++++++++++++++++++++++++++++++++++++++++++++ Regfish/Types.hs | 81 +++++++++++++++++++++++++++++++++++++++++ 4 files changed, 265 insertions(+) create mode 100644 Regfish/AcidState.hs create mode 100644 Regfish/Default.hs create mode 100644 Regfish/Parser.hs create mode 100644 Regfish/Types.hs (limited to 'Regfish') 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 -- cgit v1.2.3