{-# LANGUAGE OverloadedStrings #-}

module Network.DomainAuth.DK.Verify (
    verifyDK,
    prepareDK,
) where

import Crypto.Hash
import Crypto.PubKey.RSA
import Crypto.PubKey.RSA.PKCS15
import Data.ByteString (ByteString)
import Data.ByteString.Builder (Builder)
import qualified Data.ByteString.Builder as BB
import qualified Data.ByteString.Lazy as BL
import qualified Data.Map as M
import Network.DomainAuth.DK.Types
import Network.DomainAuth.Mail
import qualified Network.DomainAuth.Pubkey.Base64 as B
import Network.DomainAuth.Utils

----------------------------------------------------------------

prepareDK :: DK -> Mail -> Builder
prepareDK :: DK -> Mail -> Builder
prepareDK DK
dk Mail
mail = Builder
cmail
  where
    header' :: Builder
header' = DK -> Header -> Builder
canonDkHeader DK
dk (Mail -> Header
mailHeader Mail
mail)
    body' :: Builder
body' = DkCanonAlgo -> Body -> Builder
canonDkBody (DK -> DkCanonAlgo
dkCanonAlgo DK
dk) (Mail -> Body
mailBody Mail
mail)
    cmail :: Builder
cmail =
        if Body -> Bool
isEmpty (Mail -> Body
mailBody Mail
mail)
            then
                Builder
header'
            else
                Builder
header' Builder -> Builder -> Builder
`appendCRLF` Builder
body'

----------------------------------------------------------------

canonDkHeader :: DK -> Header -> Builder
canonDkHeader :: DK -> Header -> Builder
canonDkHeader DK
dk Header
hdr = (Field -> ByteString) -> Header -> Builder
forall a. (a -> ByteString) -> [a] -> Builder
concatCRLFWith (DkCanonAlgo -> Field -> ByteString
canonDkField DkCanonAlgo
calgo) Header
flds
  where
    calgo :: DkCanonAlgo
calgo = DK -> DkCanonAlgo
dkCanonAlgo DK
dk
    hFields :: Maybe DkFields
hFields = DK -> Maybe DkFields
dkFields DK
dk
    flds :: Header
flds = Maybe DkFields -> Header -> Header
prepareDkHeader Maybe DkFields
hFields Header
hdr

canonDkField :: DkCanonAlgo -> Field -> ByteString
canonDkField :: DkCanonAlgo -> Field -> ByteString
canonDkField DkCanonAlgo
DK_SIMPLE Field
fld = Field -> ByteString
fieldKey Field
fld ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ ByteString
": " ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ Field -> ByteString
fieldValueFolded Field
fld
canonDkField DkCanonAlgo
DK_NOFWS Field
fld = Field -> ByteString
fieldKey Field
fld ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ ByteString
":" ByteString -> ByteString -> ByteString
forall a. Monoid a => a -> a -> a
+++ ByteString -> ByteString
removeFWS (Field -> ByteString
fieldValueUnfolded Field
fld)

prepareDkHeader :: Maybe DkFields -> Header -> Header
prepareDkHeader :: Maybe DkFields -> Header -> Header
prepareDkHeader Maybe DkFields
Nothing Header
hdr = ByteString -> Header -> Header
fieldsAfter ByteString
dkFieldKey Header
hdr
prepareDkHeader (Just DkFields
hFields) Header
hdr = (Field -> Bool) -> Header -> Header
forall a. (a -> Bool) -> [a] -> [a]
filter Field -> Bool
isInHTag (Header -> Header) -> Header -> Header
forall a b. (a -> b) -> a -> b
$ ByteString -> Header -> Header
fieldsAfter ByteString
dkFieldKey Header
hdr
  where
    isInHTag :: Field -> Bool
isInHTag Field
fld = ByteString -> DkFields -> Bool
forall k a. Ord k => k -> Map k a -> Bool
M.member (Field -> ByteString
fieldSearchKey Field
fld) DkFields
hFields

----------------------------------------------------------------

canonDkBody :: DkCanonAlgo -> Body -> Builder
canonDkBody :: DkCanonAlgo -> Body -> Builder
canonDkBody DkCanonAlgo
DK_SIMPLE = Body -> Builder
fromBody (Body -> Builder) -> (Body -> Body) -> Body -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body -> Body
removeTrailingEmptyLine
canonDkBody DkCanonAlgo
DK_NOFWS = (ByteString -> ByteString) -> Body -> Builder
fromBodyWith ByteString -> ByteString
removeFWS (Body -> Builder) -> (Body -> Body) -> Body -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body -> Body
removeTrailingEmptyLine

----------------------------------------------------------------

verifyDK :: Mail -> DK -> PublicKey -> Bool
verifyDK :: Mail -> DK -> PublicKey -> Bool
verifyDK Mail
mail DK
dk PublicKey
pub = Maybe SHA1 -> PublicKey -> ByteString -> ByteString -> Bool
forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
verify (SHA1 -> Maybe SHA1
forall a. a -> Maybe a
Just SHA1
SHA1) PublicKey
pub ByteString
cmail ByteString
sig
  where
    sig :: ByteString
sig = ByteString -> ByteString
B.decode (ByteString -> ByteString)
-> (DK -> ByteString) -> DK -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DK -> ByteString
dkSignature (DK -> ByteString) -> DK -> ByteString
forall a b. (a -> b) -> a -> b
$ DK
dk
    cmail :: ByteString
cmail = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString (Builder -> ByteString) -> Builder -> ByteString
forall a b. (a -> b) -> a -> b
$ DK -> Mail -> Builder
prepareDK DK
dk Mail
mail