support decoding "[email protected]" in rrdata

3 files changed, 49 insertions, 5 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' =
diff --git a/regfish.cabal b/regfish.cabal
index 87a8865..4dd4b9a 100644
--- a/regfish.cabal
+++ b/regfish.cabal
@@ -12,11 +12,14 @@ library
                , acid-state
                , bytestring
                , data-default
+               , hex-text
                , http-client
                , hxt
                , lens
                , mtl
                , safecopy
+               , split
+               , text
                , wreq
   exposed-modules: Regfish
                  , Regfish.AcidState
diff --git a/regfish.nix b/regfish.nix
index d0be0c9..14c7dc6 100644
--- a/regfish.nix
+++ b/regfish.nix
@@ -1,13 +1,14 @@
 { mkDerivation, acid-state, base, bytestring, data-default
-, HandsomeSoup, http-client, hxt, lens, lib, mtl, safecopy, wreq
+, HandsomeSoup, hex-text, http-client, hxt, lens, lib, mtl
+, safecopy, split, text, wreq
 }:
 mkDerivation {
   pname = "regfish";
   version = "2.0.0";
   src = ./.;
   libraryHaskellDepends = [
-    acid-state base bytestring data-default HandsomeSoup http-client
-    hxt lens mtl safecopy wreq
+    acid-state base bytestring data-default HandsomeSoup hex-text
+    http-client hxt lens mtl safecopy split text wreq
   ];
   license = lib.licenses.mit;
 }