{-# LANGUAGE OverloadedStrings #-}

-- | A library for DomainKeys (<http://www.ietf.org/rfc/rfc4870.txt>).
--   Currently, only receiver side is implemented.

module Network.DomainAuth.DK (
  -- * Documentation
  -- ** Authentication with DK
    runDK, runDK'
  -- ** Parsing DomainKey-Signature:
  , parseDK
  , DK, dkDomain, dkSelector
  -- ** Field key for DomainKey-Signature:
  , dkFieldKey
  ) where

import Network.DNS as DNS (Resolver)
import Network.DomainAuth.DK.Parser
import Network.DomainAuth.DK.Types
import Network.DomainAuth.DK.Verify
import Network.DomainAuth.Mail
import Network.DomainAuth.Pubkey.RSAPub
import Network.DomainAuth.Types
import qualified Data.ByteString as BS (append)

-- | Verifying 'Mail' with DomainKeys.
runDK :: Resolver -> Mail -> IO DAResult
runDK :: Resolver -> Mail -> IO DAResult
runDK Resolver
resolver Mail
mail = IO DAResult
dk1
  where
    dk1 :: IO DAResult
dk1     = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return DAResult
DANone)      Field -> IO DAResult
dk2 forall a b. (a -> b) -> a -> b
$ FieldKey -> Header -> Maybe Field
lookupField FieldKey
dkFieldKey (Mail -> Header
mailHeader Mail
mail)
    dk2 :: Field -> IO DAResult
dk2 Field
dkv = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return DAResult
DAPermError) DK -> IO DAResult
dk3 forall a b. (a -> b) -> a -> b
$ FieldKey -> Maybe DK
parseDK (Field -> FieldKey
fieldValueUnfolded Field
dkv)
    dk3 :: DK -> IO DAResult
dk3     = Resolver -> Mail -> DK -> IO DAResult
runDK' Resolver
resolver Mail
mail

-- | Verifying 'Mail' with DomainKeys. The value of DomainKey-Signature:
--   should be parsed beforehand.
runDK' :: Resolver -> Mail -> DK -> IO DAResult
runDK' :: Resolver -> Mail -> DK -> IO DAResult
runDK' Resolver
resolver Mail
mail DK
dk = forall b a. b -> (a -> b) -> Maybe a -> b
maybe DAResult
DATempError (Mail -> DK -> PublicKey -> DAResult
verify Mail
mail DK
dk) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (Maybe PublicKey)
pub
  where
    pub :: IO (Maybe PublicKey)
pub = Resolver -> FieldKey -> IO (Maybe PublicKey)
lookupPublicKey Resolver
resolver FieldKey
dom
    dom :: FieldKey
dom = DK -> FieldKey
dkSelector DK
dk FieldKey -> FieldKey -> FieldKey
+++ FieldKey
"._domainkey." FieldKey -> FieldKey -> FieldKey
+++ DK -> FieldKey
dkDomain DK
dk
    verify :: Mail -> DK -> PublicKey -> DAResult
verify Mail
m DK
d PublicKey
p = if Mail -> DK -> PublicKey -> Bool
verifyDK Mail
m DK
d PublicKey
p then DAResult
DAPass else DAResult
DAFail
    +++ :: FieldKey -> FieldKey -> FieldKey
(+++) = FieldKey -> FieldKey -> FieldKey
BS.append