support decoding "[email protected]" in rrdata

1 files changed, 42 insertions, 2 deletions

diff --git a/Regfish/Parser.hs b/Regfish/Parser.hs
index 4cfc5d6..be131e7 100644
--- a/Regfish/Parser.hs
+++ b/Regfish/Parser.hs
@@ -6,11 +6,17 @@ module Regfish.Parser
     ( readZoneIO
     ) where
 
+import qualified Data.Char as C
 import qualified Data.List as L
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Data.Text as T
+import Data.Bits (xor)
+import Data.Maybe (fromMaybe)
 import Regfish.Types
 import Text.HandsomeSoup
 import Text.XML.HXT.Core
+import Text.Hex (decodeHex)
 
 
 normalizeId :: String -> String
@@ -55,7 +61,7 @@ readRRs rrtype s = do
     rrname  <- runX $ css "#name" //> getText <<< t
     rrttl   <- runX $ css "#ttl"  //> getText <<< t
     rraux   <- runX $ css "#aux"  //> getText <<< t
-    rrdata  <- runX $ css "#data" //> getText <<< t
+    rrdata  <- runX $ css "#data" //> getText <<< decodeAllProtectedEmail <<< t
     return $ map (parse rrtype) $
         L.transpose [rrid, rrname, rrttl, rraux, rrdata]
 
@@ -96,7 +102,41 @@ readRRs rrtype s = do
     parse x y = errorBadArgument "readRRs.parse" (x, y)
 
 
-
+
+decodeAllProtectedEmail :: ArrowXml a => a XmlTree XmlTree
+decodeAllProtectedEmail =
+    (
+      processTopDown (
+        (
+          getAttrValue "data-cfemail"
+          >>> arr (\x -> fromMaybe x (decodeEmail x))
+          >>> mkText
+        )
+        `when` hasAttr "data-cfemail"
+      )
+      >>> processTopDown (
+        replaceChildren (
+          listA (deep getText) >>> arr concat
+          >>> mkText
+        )
+        `when` hasAttrValue "id" (== "data")
+      )
+    ) `when` css ".__cf_email__"
+
+
+decodeEmail :: String -> Maybe String
+decodeEmail cfemail =
+    case decodeHexString cfemail of
+        Just (x:text) ->
+            Just $ map (C.chr . (`xor` x)) text
+
+        _ ->
+            Nothing
+
+
+decodeHexString :: String -> Maybe [Int]
+decodeHexString =
+    fmap (map fromIntegral . BS.unpack) . decodeHex . T.pack
 
 removeAllWhiteSpace' :: ArrowXml a => a XmlTree XmlTree
 removeAllWhiteSpace' =