Parser.hs

{-# 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 val = toDKIM domkey
  where
    (ts, vs) = unzip $ parseTaggedValue val
    fs = map tagToSetter ts
    tagToSetter tag = fromMaybe (\_ mdkim -> mdkim) $ lookup (BS.unpack tag) dkimTagDB
    pfs = zipWith ($) fs vs
    domkey = foldr ($) initialMDKIM pfs
    toDKIM mdkim = do
        ver <- mdkimVersion mdkim
        alg <- mdkimSigAlgo mdkim
        sig <- mdkimSignature mdkim
        bhs <- mdkimBodyHash mdkim
        hca <- mdkimHeaderCanon mdkim
        bca <- mdkimBodyCanon mdkim
        dom <- mdkimDomain mdkim
        fld <- mdkimFields mdkim
        sel <- mdkimSelector mdkim
        return
            DKIM
                { dkimVersion = ver
                , dkimSigAlgo = alg
                , dkimSignature = sig
                , dkimBodyHash = bhs
                , dkimHeaderCanon = hca
                , dkimBodyCanon = bca
                , dkimDomain0 = dom
                , dkimFields = fld
                , dkimLength = mdkimLength mdkim
                , dkimSelector0 = sel
                }

data MDKIM = MDKIM
    { mdkimVersion :: Maybe ByteString
    , mdkimSigAlgo :: Maybe DkimSigAlgo
    , mdkimSignature :: Maybe ByteString
    , mdkimBodyHash :: Maybe ByteString
    , mdkimHeaderCanon :: Maybe DkimCanonAlgo
    , mdkimBodyCanon :: Maybe DkimCanonAlgo
    , mdkimDomain :: Maybe ByteString
    , mdkimFields :: Maybe [CanonFieldKey]
    , mdkimLength :: Maybe Int
    , mdkimSelector :: Maybe ByteString
    }
    deriving (Eq, Show)

initialMDKIM :: MDKIM
initialMDKIM =
    MDKIM
        { mdkimVersion = Nothing
        , mdkimSigAlgo = Nothing
        , mdkimSignature = Nothing
        , mdkimBodyHash = Nothing
        , mdkimHeaderCanon = Just DKIM_SIMPLE
        , mdkimBodyCanon = Just DKIM_SIMPLE
        , mdkimDomain = Nothing
        , mdkimFields = Nothing
        , mdkimLength = Nothing
        , mdkimSelector = Nothing
        }

type DKIMSetter = ByteString -> MDKIM -> MDKIM

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

setDkimVersion :: DKIMSetter
setDkimVersion ver dkim = dkim{mdkimVersion = Just ver}

setDkimSigAlgo :: DKIMSetter
setDkimSigAlgo "rsa-sha1" dkim = dkim{mdkimSigAlgo = Just RSA_SHA1}
setDkimSigAlgo "rsa-sha256" dkim = dkim{mdkimSigAlgo = Just RSA_SHA256}
setDkimSigAlgo _ _ = error "setDkimSigAlgo"

setDkimSignature :: DKIMSetter
setDkimSignature sig dkim = dkim{mdkimSignature = Just sig}

setDkimBodyHash :: DKIMSetter
setDkimBodyHash bh dkim = dkim{mdkimBodyHash = Just bh}

setDkimCanonAlgo :: DKIMSetter
setDkimCanonAlgo "relaxed" dkim =
    dkim
        { mdkimHeaderCanon = Just DKIM_RELAXED
        , mdkimBodyCanon = Just DKIM_SIMPLE
        }
setDkimCanonAlgo "relaxed/relaxed" dkim =
    dkim
        { mdkimHeaderCanon = Just DKIM_RELAXED
        , mdkimBodyCanon = Just DKIM_RELAXED
        }
setDkimCanonAlgo "relaxed/simple" dkim =
    dkim
        { mdkimHeaderCanon = Just DKIM_RELAXED
        , mdkimBodyCanon = Just DKIM_SIMPLE
        }
setDkimCanonAlgo "simple/relaxed" dkim =
    dkim
        { mdkimHeaderCanon = Just DKIM_SIMPLE
        , mdkimBodyCanon = Just DKIM_RELAXED
        }
setDkimCanonAlgo "simple/simple" dkim =
    dkim
        { mdkimHeaderCanon = Just DKIM_SIMPLE
        , mdkimBodyCanon = Just DKIM_SIMPLE
        }
setDkimCanonAlgo _ _ = error "setDkimCanonAlgo"

setDkimDomain :: DKIMSetter
setDkimDomain dom dkim = dkim{mdkimDomain = Just dom}

setDkimFields :: DKIMSetter
setDkimFields keys dkim = dkim{mdkimFields = Just flds}
  where
    flds = map canonicalizeKey $ BS.split ':' keys

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

setDkimSelector :: DKIMSetter
setDkimSelector sel dkim = dkim{mdkimSelector = Just sel}