{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}


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
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)
        [ "NS"
        , "MX"
        , "A"
        , "AAAA"
        , "ALIAS"
        , "CNAME"
        , "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 <<< decodeAllProtectedEmail <<< t
    return $ map (parse rrtype) $
        L.transpose [rrid, rrname, rrttl, rraux, rrdata]

  where

    -- TODO note that "0"-values should be different

    parse "A" [rrid, rrname, rrttl, rrdata] =
        RR rrid rrname (read rrttl) (A rrdata)

    parse "AAAA" [rrid, rrname, rrttl, rrdata] =
        RR rrid rrname (read rrttl) (AAAA rrdata)

    parse "ALIAS" [rrid, rrname, rrttl, rrdata] =
        RR rrid rrname (read rrttl) (ALIAS rrdata)

    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)

    parse "NS" [rrid, rrname, rrttl, rrdata] =
        RR rrid rrname (read rrttl) (NS rrdata)

    parse "NS" [rrid, rrname, rrdata] =
        RR rrid rrname 0 (NS rrdata)

    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)

    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' =
    fromLA $ editNTreeA [isWhiteSpace' :-> Text.XML.HXT.Core.none]
    -- fromLA $ processBottomUp removeWhiteSpace'    -- less efficient
  where
    isWhiteSpace' = hasText (all isXmlSpaceChar')
    isXmlSpaceChar' = (`elem` (" \n\t\r\160" :: [Char]))


errorBadArgument :: Show a => String -> a -> b
errorBadArgument name x =
    error $ "Regfish.Parser." ++ name ++ ": bad argument: " ++ show x