{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.DKIM.Parser (
    parseDKIM,
) where

import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.Maybe
import Network.DomainAuth.DKIM.Types
import Network.DomainAuth.Mail

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

-- | Parsing DKIM-Signature:.
--
-- >>> :{
-- let dkim = BS8.concat [
--                   "v=1; a=rsa-sha256; s=brisbane; d=example.com;\n"
--                 , "         c=relaxed/simple; q=dns/txt; i=joe@football.example.com;\n"
--                 , "         h=Received : From : To : Subject : Date : Message-ID;\n"
--                 , "         bh=2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8=;\n"
--                 , "         b=AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB\n"
--                 , "           4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHut\n"
--                 , "           KVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV\n"
--                 , "           4bmp/YzhwvcubU4=;"
--                 ]
-- in pPrintNoColor $ parseDKIM dkim
-- :}
-- Just
--     ( DKIM
--         { dkimVersion = "1"
--         , dkimSigAlgo = RSA_SHA256
--         , dkimSignature = "AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHutKVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV4bmp/YzhwvcubU4="
--         , dkimBodyHash = "2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8="
--         , dkimHeaderCanon = DKIM_RELAXED
--         , dkimBodyCanon = DKIM_SIMPLE
--         , dkimDomain0 = "example.com"
--         , dkimFields =
--             [ "received"
--             , "from"
--             , "to"
--             , "subject"
--             , "date"
--             , "message-id"
--             ]
--         , dkimLength = Nothing
--         , dkimSelector0 = "brisbane"
--         }
--     )
--
-- >>> :{
-- let dkim = BS8.concat [
--                  "v=1; a=rsa-sha256; s=brisbane; d=example.com;\n"
--                , "         q=dns/txt; i=joe@football.example.com;\n"
--                , "         h=Received : From : To : Subject : Date : Message-ID;\n"
--                , "         bh=2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8=;\n"
--                , "         b=AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB\n"
--                , "           4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHut\n"
--                , "           KVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV\n"
--                , "           4bmp/YzhwvcubU4=;"
--                ]
-- in pPrintNoColor $ parseDKIM dkim
-- :}
-- Just
--     ( DKIM
--         { dkimVersion = "1"
--         , dkimSigAlgo = RSA_SHA256
--         , dkimSignature = "AuUoFEfDxTDkHlLXSZEpZj79LICEps6eda7W3deTVFOk4yAUoqOB4nujc7YopdG5dWLSdNg6xNAZpOPr+kHxt1IrE+NahM6L/LbvaHutKVdkLLkpVaVVQPzeRDI009SO2Il5Lu7rDNH6mZckBdrIx0orEtZV4bmp/YzhwvcubU4="
--         , dkimBodyHash = "2jUSOH9NhtVGCQWNr9BrIAPreKQjO6Sn7XIkfJVOzv8="
--         , dkimHeaderCanon = DKIM_SIMPLE
--         , dkimBodyCanon = DKIM_SIMPLE
--         , dkimDomain0 = "example.com"
--         , dkimFields =
--             [ "received"
--             , "from"
--             , "to"
--             , "subject"
--             , "date"
--             , "message-id"
--             ]
--         , dkimLength = Nothing
--         , dkimSelector0 = "brisbane"
--         }
--     )
parseDKIM :: RawFieldValue -> Maybe DKIM
parseDKIM :: ByteString -> Maybe DKIM
parseDKIM ByteString
val = MDKIM -> Maybe DKIM
toDKIM MDKIM
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 -> MDKIM -> MDKIM]
fs = (ByteString -> ByteString -> MDKIM -> MDKIM)
-> [ByteString] -> [ByteString -> MDKIM -> MDKIM]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString -> MDKIM -> MDKIM
tagToSetter [ByteString]
ts
    tagToSetter :: ByteString -> ByteString -> MDKIM -> MDKIM
tagToSetter ByteString
tag = (ByteString -> MDKIM -> MDKIM)
-> Maybe (ByteString -> MDKIM -> MDKIM)
-> ByteString
-> MDKIM
-> MDKIM
forall a. a -> Maybe a -> a
fromMaybe (\ByteString
_ MDKIM
mdkim -> MDKIM
mdkim) (Maybe (ByteString -> MDKIM -> MDKIM)
 -> ByteString -> MDKIM -> MDKIM)
-> Maybe (ByteString -> MDKIM -> MDKIM)
-> ByteString
-> MDKIM
-> MDKIM
forall a b. (a -> b) -> a -> b
$ [Char]
-> [([Char], ByteString -> MDKIM -> MDKIM)]
-> Maybe (ByteString -> MDKIM -> MDKIM)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> [Char]
BS.unpack ByteString
tag) [([Char], ByteString -> MDKIM -> MDKIM)]
dkimTagDB
    pfs :: [MDKIM -> MDKIM]
pfs = ((ByteString -> MDKIM -> MDKIM) -> ByteString -> MDKIM -> MDKIM)
-> [ByteString -> MDKIM -> MDKIM]
-> [ByteString]
-> [MDKIM -> MDKIM]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ByteString -> MDKIM -> MDKIM) -> ByteString -> MDKIM -> MDKIM
forall a b. (a -> b) -> a -> b
($) [ByteString -> MDKIM -> MDKIM]
fs [ByteString]
vs
    domkey :: MDKIM
domkey = ((MDKIM -> MDKIM) -> MDKIM -> MDKIM)
-> MDKIM -> [MDKIM -> MDKIM] -> MDKIM
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (MDKIM -> MDKIM) -> MDKIM -> MDKIM
forall a b. (a -> b) -> a -> b
($) MDKIM
initialMDKIM [MDKIM -> MDKIM]
pfs
    toDKIM :: MDKIM -> Maybe DKIM
toDKIM MDKIM
mdkim = do
        ByteString
ver <- MDKIM -> Maybe ByteString
mdkimVersion MDKIM
mdkim
        DkimSigAlgo
alg <- MDKIM -> Maybe DkimSigAlgo
mdkimSigAlgo MDKIM
mdkim
        ByteString
sig <- MDKIM -> Maybe ByteString
mdkimSignature MDKIM
mdkim
        ByteString
bhs <- MDKIM -> Maybe ByteString
mdkimBodyHash MDKIM
mdkim
        DkimCanonAlgo
hca <- MDKIM -> Maybe DkimCanonAlgo
mdkimHeaderCanon MDKIM
mdkim
        DkimCanonAlgo
bca <- MDKIM -> Maybe DkimCanonAlgo
mdkimBodyCanon MDKIM
mdkim
        ByteString
dom <- MDKIM -> Maybe ByteString
mdkimDomain MDKIM
mdkim
        [ByteString]
fld <- MDKIM -> Maybe [ByteString]
mdkimFields MDKIM
mdkim
        ByteString
sel <- MDKIM -> Maybe ByteString
mdkimSelector MDKIM
mdkim
        DKIM -> Maybe DKIM
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
            DKIM
                { dkimVersion :: ByteString
dkimVersion = ByteString
ver
                , dkimSigAlgo :: DkimSigAlgo
dkimSigAlgo = DkimSigAlgo
alg
                , dkimSignature :: ByteString
dkimSignature = ByteString
sig
                , dkimBodyHash :: ByteString
dkimBodyHash = ByteString
bhs
                , dkimHeaderCanon :: DkimCanonAlgo
dkimHeaderCanon = DkimCanonAlgo
hca
                , dkimBodyCanon :: DkimCanonAlgo
dkimBodyCanon = DkimCanonAlgo
bca
                , dkimDomain0 :: ByteString
dkimDomain0 = ByteString
dom
                , dkimFields :: [ByteString]
dkimFields = [ByteString]
fld
                , dkimLength :: Maybe Int
dkimLength = MDKIM -> Maybe Int
mdkimLength MDKIM
mdkim
                , dkimSelector0 :: ByteString
dkimSelector0 = ByteString
sel
                }

data MDKIM = MDKIM
    { MDKIM -> Maybe ByteString
mdkimVersion :: Maybe ByteString
    , MDKIM -> Maybe DkimSigAlgo
mdkimSigAlgo :: Maybe DkimSigAlgo
    , MDKIM -> Maybe ByteString
mdkimSignature :: Maybe ByteString
    , MDKIM -> Maybe ByteString
mdkimBodyHash :: Maybe ByteString
    , MDKIM -> Maybe DkimCanonAlgo
mdkimHeaderCanon :: Maybe DkimCanonAlgo
    , MDKIM -> Maybe DkimCanonAlgo
mdkimBodyCanon :: Maybe DkimCanonAlgo
    , MDKIM -> Maybe ByteString
mdkimDomain :: Maybe ByteString
    , MDKIM -> Maybe [ByteString]
mdkimFields :: Maybe [CanonFieldKey]
    , MDKIM -> Maybe Int
mdkimLength :: Maybe Int
    , MDKIM -> Maybe ByteString
mdkimSelector :: Maybe ByteString
    }
    deriving (MDKIM -> MDKIM -> Bool
(MDKIM -> MDKIM -> Bool) -> (MDKIM -> MDKIM -> Bool) -> Eq MDKIM
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MDKIM -> MDKIM -> Bool
== :: MDKIM -> MDKIM -> Bool
$c/= :: MDKIM -> MDKIM -> Bool
/= :: MDKIM -> MDKIM -> Bool
Eq, Int -> MDKIM -> ShowS
[MDKIM] -> ShowS
MDKIM -> [Char]
(Int -> MDKIM -> ShowS)
-> (MDKIM -> [Char]) -> ([MDKIM] -> ShowS) -> Show MDKIM
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MDKIM -> ShowS
showsPrec :: Int -> MDKIM -> ShowS
$cshow :: MDKIM -> [Char]
show :: MDKIM -> [Char]
$cshowList :: [MDKIM] -> ShowS
showList :: [MDKIM] -> ShowS
Show)

initialMDKIM :: MDKIM
initialMDKIM :: MDKIM
initialMDKIM =
    MDKIM
        { mdkimVersion :: Maybe ByteString
mdkimVersion = Maybe ByteString
forall a. Maybe a
Nothing
        , mdkimSigAlgo :: Maybe DkimSigAlgo
mdkimSigAlgo = Maybe DkimSigAlgo
forall a. Maybe a
Nothing
        , mdkimSignature :: Maybe ByteString
mdkimSignature = Maybe ByteString
forall a. Maybe a
Nothing
        , mdkimBodyHash :: Maybe ByteString
mdkimBodyHash = Maybe ByteString
forall a. Maybe a
Nothing
        , mdkimHeaderCanon :: Maybe DkimCanonAlgo
mdkimHeaderCanon = DkimCanonAlgo -> Maybe DkimCanonAlgo
forall a. a -> Maybe a
Just DkimCanonAlgo
DKIM_SIMPLE
        , mdkimBodyCanon :: Maybe DkimCanonAlgo
mdkimBodyCanon = DkimCanonAlgo -> Maybe DkimCanonAlgo
forall a. a -> Maybe a
Just DkimCanonAlgo
DKIM_SIMPLE
        , mdkimDomain :: Maybe ByteString
mdkimDomain = Maybe ByteString
forall a. Maybe a
Nothing
        , mdkimFields :: Maybe [ByteString]
mdkimFields = Maybe [ByteString]
forall a. Maybe a
Nothing
        , mdkimLength :: Maybe Int
mdkimLength = Maybe Int
forall a. Maybe a
Nothing
        , mdkimSelector :: Maybe ByteString
mdkimSelector = Maybe ByteString
forall a. Maybe a
Nothing
        }

type DKIMSetter = ByteString -> MDKIM -> MDKIM

dkimTagDB :: [(String, DKIMSetter)]
dkimTagDB :: [([Char], ByteString -> MDKIM -> MDKIM)]
dkimTagDB =
    [ ([Char]
"v", ByteString -> MDKIM -> MDKIM
setDkimVersion)
    , ([Char]
"a", ByteString -> MDKIM -> MDKIM
setDkimSigAlgo)
    , ([Char]
"b", ByteString -> MDKIM -> MDKIM
setDkimSignature)
    , ([Char]
"bh", ByteString -> MDKIM -> MDKIM
setDkimBodyHash)
    , ([Char]
"c", ByteString -> MDKIM -> MDKIM
setDkimCanonAlgo)
    , ([Char]
"d", ByteString -> MDKIM -> MDKIM
setDkimDomain)
    , ([Char]
"h", ByteString -> MDKIM -> MDKIM
setDkimFields)
    , ([Char]
"l", ByteString -> MDKIM -> MDKIM
setDkimLength)
    , ([Char]
"s", ByteString -> MDKIM -> MDKIM
setDkimSelector)
    ]

setDkimVersion :: DKIMSetter
setDkimVersion :: ByteString -> MDKIM -> MDKIM
setDkimVersion ByteString
ver MDKIM
dkim = MDKIM
dkim{mdkimVersion = Just ver}

setDkimSigAlgo :: DKIMSetter
setDkimSigAlgo :: ByteString -> MDKIM -> MDKIM
setDkimSigAlgo ByteString
"rsa-sha1" MDKIM
dkim = MDKIM
dkim{mdkimSigAlgo = Just RSA_SHA1}
setDkimSigAlgo ByteString
"rsa-sha256" MDKIM
dkim = MDKIM
dkim{mdkimSigAlgo = Just RSA_SHA256}
setDkimSigAlgo ByteString
_ MDKIM
_ = [Char] -> MDKIM
forall a. HasCallStack => [Char] -> a
error [Char]
"setDkimSigAlgo"

setDkimSignature :: DKIMSetter
setDkimSignature :: ByteString -> MDKIM -> MDKIM
setDkimSignature ByteString
sig MDKIM
dkim = MDKIM
dkim{mdkimSignature = Just sig}

setDkimBodyHash :: DKIMSetter
setDkimBodyHash :: ByteString -> MDKIM -> MDKIM
setDkimBodyHash ByteString
bh MDKIM
dkim = MDKIM
dkim{mdkimBodyHash = Just bh}

setDkimCanonAlgo :: DKIMSetter
setDkimCanonAlgo :: ByteString -> MDKIM -> MDKIM
setDkimCanonAlgo ByteString
"relaxed" MDKIM
dkim =
    MDKIM
dkim
        { mdkimHeaderCanon = Just DKIM_RELAXED
        , mdkimBodyCanon = Just DKIM_SIMPLE
        }
setDkimCanonAlgo ByteString
"relaxed/relaxed" MDKIM
dkim =
    MDKIM
dkim
        { mdkimHeaderCanon = Just DKIM_RELAXED
        , mdkimBodyCanon = Just DKIM_RELAXED
        }
setDkimCanonAlgo ByteString
"relaxed/simple" MDKIM
dkim =
    MDKIM
dkim
        { mdkimHeaderCanon = Just DKIM_RELAXED
        , mdkimBodyCanon = Just DKIM_SIMPLE
        }
setDkimCanonAlgo ByteString
"simple/relaxed" MDKIM
dkim =
    MDKIM
dkim
        { mdkimHeaderCanon = Just DKIM_SIMPLE
        , mdkimBodyCanon = Just DKIM_RELAXED
        }
setDkimCanonAlgo ByteString
"simple/simple" MDKIM
dkim =
    MDKIM
dkim
        { mdkimHeaderCanon = Just DKIM_SIMPLE
        , mdkimBodyCanon = Just DKIM_SIMPLE
        }
setDkimCanonAlgo ByteString
_ MDKIM
_ = [Char] -> MDKIM
forall a. HasCallStack => [Char] -> a
error [Char]
"setDkimCanonAlgo"

setDkimDomain :: DKIMSetter
setDkimDomain :: ByteString -> MDKIM -> MDKIM
setDkimDomain ByteString
dom MDKIM
dkim = MDKIM
dkim{mdkimDomain = Just dom}

setDkimFields :: DKIMSetter
setDkimFields :: ByteString -> MDKIM -> MDKIM
setDkimFields ByteString
keys MDKIM
dkim = MDKIM
dkim{mdkimFields = Just flds}
  where
    flds :: [ByteString]
flds = (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString
canonicalizeKey ([ByteString] -> [ByteString]) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> a -> b
$ Char -> ByteString -> [ByteString]
BS.split Char
':' ByteString
keys

setDkimLength :: DKIMSetter
setDkimLength :: ByteString -> MDKIM -> MDKIM
setDkimLength ByteString
len MDKIM
dkim = MDKIM
dkim{mdkimLength = fst <$> BS.readInt len}

setDkimSelector :: DKIMSetter
setDkimSelector :: ByteString -> MDKIM -> MDKIM
setDkimSelector ByteString
sel MDKIM
dkim = MDKIM
dkim{mdkimSelector = Just sel}