Scrape zone with hxt.

2 files changed, 93 insertions, 70 deletions

diff --git a/Regfish/Parser.hs b/Regfish/Parser.hs
index bc294b6..a1af5a5 100644
--- a/Regfish/Parser.hs
+++ b/Regfish/Parser.hs
@@ -3,96 +3,110 @@
 
 
 module Regfish.Parser
-    ( readZone
+    ( readZoneIO
     ) where
 
+import Control.Applicative
+import qualified Data.List as L
 import qualified Data.ByteString.Lazy.Char8 as LBS8
 import Regfish.Types
-import Text.HTML.TagSoup
+import Text.HandsomeSoup
+import Text.XML.HXT.Core
+
+
+normalizeId :: String -> String
+normalizeId = \case
+    'a':'_':xs -> xs
+    'r':'r':'_':xs -> drop 1 . dropWhile (/='_') $ xs
+    xs -> xs
+
+
+normalizeRR :: IOSLA (XIOState ()) XmlTree XmlTree
+normalizeRR =
+    processAttrl (changeAttrValue normalizeId `when` hasName "id")
+        <<< (filterA $ neg $ hasAttr "nowrap")
+        <<< (removeAttr "style")
+
+
+readZoneIO :: LBS8.ByteString -> IO [RR]
+readZoneIO b =
+    concat <$> mapM (flip readRRs $ LBS8.unpack b)
+        [ "A"
+        , "AAAA"
+        , "ALIAS"
+        , "CNAME"
+        , "MX"
+        , "NS"
+        , "TXT"
+        , "SRV"
+        ]
+
+
+readRRs :: String -> String -> IO [RR]
+readRRs rrtype s = do
+    let --body = LBS8.unpack b -- $ r ^. W.responseBody
+        doc = parseHtml s
+        t = processTopDown normalizeRR
+                  <<< removeAllWhiteSpace'
+                  <<< css ("." ++ rrtype)
+                  <<< doc
+
+    -- t also contains <td>IN</td> and <td id="type">TXT</td>
+    rrid    <- runX $ getAttrValue "id" <<< t
+    rrname  <- runX $ css "#name" //> getText <<< t
+    rrttl   <- runX $ css "#ttl"  //> getText <<< t
+    rraux   <- runX $ css "#aux"  //> getText <<< t
+    rrdata  <- runX $ css "#data" //> getText <<< t
+    return $ map (parse rrtype) $
+        L.transpose [rrid, rrname, rrttl, rraux, rrdata]
 
-
-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
+    -- TODO note that "0"-values should be different
 
-    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'
+    parse "A" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (A rrdata)
 
-        [] -> ys
+    parse "AAAA" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (AAAA rrdata)
 
-        x -> errorBadArgument "parseRecords.rec" x
+    parse "ALIAS" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (ALIAS rrdata)
 
-    getRecordId attrs =
-        case maybe Nothing (Just . LBS8.unpack) $ lookup "id" attrs of
-            Just ('a':'_':xs) -> Just (LBS8.pack xs)
-            _ -> Nothing
+    parse "CNAME" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (CNAME rrdata)
 
+    parse "MX" [rrid, rrname, rrttl, rraux, rrdata] =
+        RR rrid rrname (read rrttl) (MX (read rraux) rrdata)
 
+    parse "MX" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (MX 0 rrdata)
 
-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
+    parse "NS" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (NS rrdata)
 
+    parse "NS" [rrid, rrname, rrdata] =
+        RR rrid rrname 0 (NS rrdata)
 
-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
+    parse "TXT" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (TXT rrdata)
+
+    parse "SRV" [rrid, rrname, rrttl, rrdata] =
+        RR rrid rrname (read rrttl) (SRV rrdata)
 
-    add_def_ttl def_ttl (x:"IN":xs) = x : def_ttl : "IN" : xs
-    add_def_ttl _ xs = xs
+    parse x y = errorBadArgument "readRRs.parse" (x, y)
 
 
-dnszoneSoup :: [Tag LBS8.ByteString] -> [Tag LBS8.ByteString]
-dnszoneSoup =
-    takeWhile (\t -> not $ t ~== dnszoneClose) .
-    dropWhile (\t -> not $ t ~== dnszoneOpen)
 
+
+removeAllWhiteSpace' :: ArrowXml a => a XmlTree XmlTree
+removeAllWhiteSpace' =
+    fromLA $ editNTreeA [isWhiteSpace' :-> Text.XML.HXT.Core.none]
+    -- fromLA $ processBottomUp removeWhiteSpace'    -- less efficient
+  where
+    isWhiteSpace' = hasText (all isXmlSpaceChar')
+    isXmlSpaceChar' = (`elem` " \n\t\r\160")
 
-dnszoneOpen, dnszoneClose :: Tag LBS8.ByteString
-dnszoneOpen  = TagOpen "table" [("id", "dnszone")]
-dnszoneClose = TagClose "table"
 
 
 errorBadArgument :: Show a => String -> a -> b
diff --git a/Regfish/Types.hs b/Regfish/Types.hs
index cef2808..c453947 100644
--- a/Regfish/Types.hs
+++ b/Regfish/Types.hs
@@ -65,10 +65,19 @@ data RFState = RFState
 makeLenses ''RFState
 
 
+data RR = RR String String Integer RRData
+  deriving (Show)
+
+
 data RRData
     = A String
-    | MX Integer String
+    | AAAA String
+    | ALIAS String
     | CNAME String
+    | MX Integer String
+    | NS String
+    | TXT String
+    | SRV String
   deriving (Show)