From 179d8980e55578e3553bad0b237368d74e074f15 Mon Sep 17 00:00:00 2001
From: tv <tv@shackspace.de>
Date: Tue, 18 Nov 2014 16:05:40 +0100
Subject: initial commit

---
 Regfish/Parser.hs | 100 ++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 100 insertions(+)
 create mode 100644 Regfish/Parser.hs

(limited to 'Regfish/Parser.hs')

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
-- 
cgit v1.2.3