summaryrefslogtreecommitdiffstats
path: root/Regfish
diff options
context:
space:
mode:
Diffstat (limited to 'Regfish')
-rw-r--r--Regfish/AcidState.hs47
-rw-r--r--Regfish/Default.hs37
-rw-r--r--Regfish/Parser.hs100
-rw-r--r--Regfish/Types.hs81
4 files changed, 265 insertions, 0 deletions
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-25 01:06:34 +0000