{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.DK.Parser (
    parseDK,
) where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Network.DomainAuth.DK.Types
import Network.DomainAuth.Mail

-- $setup
-- >>> import Text.Pretty.Simple
-- >>> import Data.ByteString.Char8 as BS8

-- | Parsing DomainKey-Signature:.
--
-- >>> :{
-- let dk = BS8.concat [
--                 "a=rsa-sha1; s=brisbane; d=football.example.com;\n"
--               , "  c=simple; q=dns;\n"
--               , "  b=dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZ\n"
--               , "    VoG4ZHRNiYzR;"
--               ]
-- in pPrintNoColor $ parseDK dk
-- :}
-- Just
--     ( DK
--         { dkAlgorithm = DK_RSA_SHA1
--         , dkSignature = "dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZVoG4ZHRNiYzR"
--         , dkCanonAlgo = DK_SIMPLE
--         , dkDomain0 = "football.example.com"
--         , dkFields = Nothing
--         , dkSelector0 = "brisbane"
--         }
--     )
parseDK :: RawFieldValue -> Maybe DK
parseDK :: ByteString -> Maybe DK
parseDK ByteString
val = MDK -> Maybe DK
toDK MDK
domkey
  where
    ([ByteString]
ts, [ByteString]
vs) = [(ByteString, ByteString)] -> ([ByteString], [ByteString])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(ByteString, ByteString)] -> ([ByteString], [ByteString]))
-> [(ByteString, ByteString)] -> ([ByteString], [ByteString])
forall a b. (a -> b) -> a -> b
$ ByteString -> [(ByteString, ByteString)]
parseTaggedValue ByteString
val
    fs :: [ByteString -> MDK -> MDK]
fs = (ByteString -> ByteString -> MDK -> MDK)
-> [ByteString] -> [ByteString -> MDK -> MDK]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString -> MDK -> MDK
tagToSetter [ByteString]
ts
    tagToSetter :: ByteString -> ByteString -> MDK -> MDK
tagToSetter ByteString
tag = (ByteString -> MDK -> MDK)
-> Maybe (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK
forall a. a -> Maybe a -> a
fromMaybe (\ByteString
_ MDK
mdk -> MDK
mdk) (Maybe (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK)
-> Maybe (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK
forall a b. (a -> b) -> a -> b
$ Char
-> [(Char, ByteString -> MDK -> MDK)]
-> Maybe (ByteString -> MDK -> MDK)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> Char
BS.head ByteString
tag) [(Char, ByteString -> MDK -> MDK)]
dkTagDB
    pfs :: [MDK -> MDK]
pfs = ((ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK)
-> [ByteString -> MDK -> MDK] -> [ByteString] -> [MDK -> MDK]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK
forall a b. (a -> b) -> a -> b
($) [ByteString -> MDK -> MDK]
fs [ByteString]
vs
    domkey :: MDK
domkey = ((MDK -> MDK) -> MDK -> MDK) -> MDK -> [MDK -> MDK] -> MDK
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (MDK -> MDK) -> MDK -> MDK
forall a b. (a -> b) -> a -> b
($) MDK
initialMDK [MDK -> MDK]
pfs
    toDK :: MDK -> Maybe DK
toDK MDK
mdk = do
        DkAlgorithm
alg <- MDK -> Maybe DkAlgorithm
mdkAlgorithm MDK
mdk
        ByteString
sig <- MDK -> Maybe ByteString
mdkSignature MDK
mdk
        DkCanonAlgo
cal <- MDK -> Maybe DkCanonAlgo
mdkCanonAlgo MDK
mdk
        ByteString
dom <- MDK -> Maybe ByteString
mdkDomain MDK
mdk
        ByteString
sel <- MDK -> Maybe ByteString
mdkSelector MDK
mdk
        DK -> Maybe DK
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
            DK
                { dkAlgorithm :: DkAlgorithm
dkAlgorithm = DkAlgorithm
alg
                , dkSignature :: ByteString
dkSignature = ByteString
sig
                , dkCanonAlgo :: DkCanonAlgo
dkCanonAlgo = DkCanonAlgo
cal
                , dkDomain0 :: ByteString
dkDomain0 = ByteString
dom
                , dkFields :: Maybe DkFields
dkFields = MDK -> Maybe DkFields
mdkFields MDK
mdk
                , dkSelector0 :: ByteString
dkSelector0 = ByteString
sel
                }

data MDK = MDK
    { MDK -> Maybe DkAlgorithm
mdkAlgorithm :: Maybe DkAlgorithm
    , MDK -> Maybe ByteString
mdkSignature :: Maybe ByteString
    , MDK -> Maybe DkCanonAlgo
mdkCanonAlgo :: Maybe DkCanonAlgo
    , MDK -> Maybe ByteString
mdkDomain :: Maybe ByteString
    , MDK -> Maybe DkFields
mdkFields :: Maybe DkFields
    , MDK -> Maybe ByteString
mdkSelector :: Maybe ByteString
    }
    deriving (MDK -> MDK -> Bool
(MDK -> MDK -> Bool) -> (MDK -> MDK -> Bool) -> Eq MDK
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MDK -> MDK -> Bool
== :: MDK -> MDK -> Bool
$c/= :: MDK -> MDK -> Bool
/= :: MDK -> MDK -> Bool
Eq, Int -> MDK -> ShowS
[MDK] -> ShowS
MDK -> String
(Int -> MDK -> ShowS)
-> (MDK -> String) -> ([MDK] -> ShowS) -> Show MDK
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MDK -> ShowS
showsPrec :: Int -> MDK -> ShowS
$cshow :: MDK -> String
show :: MDK -> String
$cshowList :: [MDK] -> ShowS
showList :: [MDK] -> ShowS
Show)

initialMDK :: MDK
initialMDK :: MDK
initialMDK =
    MDK
        { mdkAlgorithm :: Maybe DkAlgorithm
mdkAlgorithm = DkAlgorithm -> Maybe DkAlgorithm
forall a. a -> Maybe a
Just DkAlgorithm
DK_RSA_SHA1
        , mdkSignature :: Maybe ByteString
mdkSignature = Maybe ByteString
forall a. Maybe a
Nothing
        , mdkCanonAlgo :: Maybe DkCanonAlgo
mdkCanonAlgo = Maybe DkCanonAlgo
forall a. Maybe a
Nothing
        , mdkDomain :: Maybe ByteString
mdkDomain = Maybe ByteString
forall a. Maybe a
Nothing
        , mdkFields :: Maybe DkFields
mdkFields = Maybe DkFields
forall a. Maybe a
Nothing
        , mdkSelector :: Maybe ByteString
mdkSelector = Maybe ByteString
forall a. Maybe a
Nothing
        }

type DKSetter = ByteString -> MDK -> MDK

dkTagDB :: [(Char, DKSetter)]
dkTagDB :: [(Char, ByteString -> MDK -> MDK)]
dkTagDB =
    [ (Char
'a', ByteString -> MDK -> MDK
setDkAlgorithm)
    , (Char
'b', ByteString -> MDK -> MDK
setDkSignature)
    , (Char
'c', ByteString -> MDK -> MDK
setDkCanonAlgo)
    , (Char
'd', ByteString -> MDK -> MDK
setDkDomain)
    , (Char
'h', ByteString -> MDK -> MDK
setDkFields)
    , --  , ('q',setDkQuery)
      (Char
's', ByteString -> MDK -> MDK
setDkSelector)
    ]

setDkAlgorithm :: DKSetter
setDkAlgorithm :: ByteString -> MDK -> MDK
setDkAlgorithm ByteString
"rsa-sha1" MDK
dk = MDK
dk{mdkAlgorithm = Just DK_RSA_SHA1}
setDkAlgorithm ByteString
_ MDK
_ = String -> MDK
forall a. HasCallStack => String -> a
error String
"setDkAlgorithm"

setDkSignature :: DKSetter
setDkSignature :: ByteString -> MDK -> MDK
setDkSignature ByteString
sig MDK
dk = MDK
dk{mdkSignature = Just sig}

setDkCanonAlgo :: DKSetter
setDkCanonAlgo :: ByteString -> MDK -> MDK
setDkCanonAlgo ByteString
"simple" MDK
dk = MDK
dk{mdkCanonAlgo = Just DK_SIMPLE}
setDkCanonAlgo ByteString
"nofws" MDK
dk = MDK
dk{mdkCanonAlgo = Just DK_NOFWS}
setDkCanonAlgo ByteString
_ MDK
_ = String -> MDK
forall a. HasCallStack => String -> a
error String
"setDkCanonAlgo"

setDkDomain :: DKSetter
setDkDomain :: ByteString -> MDK -> MDK
setDkDomain ByteString
dom MDK
dk = MDK
dk{mdkDomain = Just dom}

setDkFields :: DKSetter
setDkFields :: ByteString -> MDK -> MDK
setDkFields ByteString
keys MDK
dk = MDK
dk{mdkFields = Just mx}
  where
    flds :: [ByteString]
flds = Char -> ByteString -> [ByteString]
BS.split Char
':' ByteString
keys
    mx :: DkFields
mx = (DkFields -> ByteString -> DkFields)
-> DkFields -> [ByteString] -> DkFields
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DkFields -> ByteString -> DkFields
forall {k}. Ord k => Map k Bool -> k -> Map k Bool
func DkFields
forall k a. Map k a
M.empty [ByteString]
flds
    func :: Map k Bool -> k -> Map k Bool
func Map k Bool
m k
fld = k -> Bool -> Map k Bool -> Map k Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
fld Bool
True Map k Bool
m

{-
setDkQuery :: DKSetter
setDkQuery "dns" dk = dk { mdkQuery = Just DK_DNS }
setDkQuery _ _      = error "setDkQuery"
-}

setDkSelector :: DKSetter
setDkSelector :: ByteString -> MDK -> MDK
setDkSelector ByteString
sel MDK
dk = MDK
dk{mdkSelector = Just sel}