{-# 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 = 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 forall a. Monoid a => a -> a -> a
+++ ByteString
": " forall a. Monoid a => a -> a -> a
+++ Field -> ByteString
fieldValueFolded Field
fld
canonDkField DkCanonAlgo
DK_NOFWS  Field
fld = Field -> ByteString
fieldKey Field
fld forall a. Monoid a => a -> a -> a
+++ ByteString
":" forall a. Monoid a => a -> a -> a
+++ FWSRemover
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 = forall a. (a -> Bool) -> [a] -> [a]
filter Field -> Bool
isInHTag forall a b. (a -> b) -> a -> b
$ ByteString -> Header -> Header
fieldsAfter ByteString
dkFieldKey Header
hdr
  where
    isInHTag :: Field -> Bool
isInHTag Field
fld = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Body -> Body
removeTrailingEmptyLine
canonDkBody DkCanonAlgo
DK_NOFWS  = FWSRemover -> Body -> Builder
fromBodyWith FWSRemover
removeFWS 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 = forall hashAlg.
HashAlgorithmASN1 hashAlg =>
Maybe hashAlg -> PublicKey -> ByteString -> ByteString -> Bool
verify (forall a. a -> Maybe a
Just SHA1
SHA1) PublicKey
pub ByteString
cmail ByteString
sig
  where
    sig :: ByteString
sig = FWSRemover
B.decode forall b c a. (b -> c) -> (a -> b) -> a -> c
. DK -> ByteString
dkSignature forall a b. (a -> b) -> a -> b
$ DK
dk
    cmail :: ByteString
cmail = ByteString -> ByteString
BL.toStrict forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
BB.toLazyByteString forall a b. (a -> b) -> a -> b
$ DK -> Mail -> Builder
prepareDK DK
dk Mail
mail