{-# LANGUAGE OverloadedStrings #-}
module Network.DomainAuth.DK.Parser (
parseDK,
) where
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS
import Data.List
import qualified Data.Map as M
import Data.Maybe
import Network.DomainAuth.DK.Types
import Network.DomainAuth.Mail
parseDK :: RawFieldValue -> Maybe DK
parseDK :: ByteString -> Maybe DK
parseDK ByteString
val = MDK -> Maybe DK
toDK MDK
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 -> MDK -> MDK]
fs = (ByteString -> ByteString -> MDK -> MDK)
-> [ByteString] -> [ByteString -> MDK -> MDK]
forall a b. (a -> b) -> [a] -> [b]
map ByteString -> ByteString -> MDK -> MDK
tagToSetter [ByteString]
ts
tagToSetter :: ByteString -> ByteString -> MDK -> MDK
tagToSetter ByteString
tag = (ByteString -> MDK -> MDK)
-> Maybe (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK
forall a. a -> Maybe a -> a
fromMaybe (\ByteString
_ MDK
mdk -> MDK
mdk) (Maybe (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK)
-> Maybe (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK
forall a b. (a -> b) -> a -> b
$ Char
-> [(Char, ByteString -> MDK -> MDK)]
-> Maybe (ByteString -> MDK -> MDK)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (ByteString -> Char
BS.head ByteString
tag) [(Char, ByteString -> MDK -> MDK)]
dkTagDB
pfs :: [MDK -> MDK]
pfs = ((ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK)
-> [ByteString -> MDK -> MDK] -> [ByteString] -> [MDK -> MDK]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (ByteString -> MDK -> MDK) -> ByteString -> MDK -> MDK
forall a b. (a -> b) -> a -> b
($) [ByteString -> MDK -> MDK]
fs [ByteString]
vs
domkey :: MDK
domkey = ((MDK -> MDK) -> MDK -> MDK) -> MDK -> [MDK -> MDK] -> MDK
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (MDK -> MDK) -> MDK -> MDK
forall a b. (a -> b) -> a -> b
($) MDK
initialMDK [MDK -> MDK]
pfs
toDK :: MDK -> Maybe DK
toDK MDK
mdk = do
DkAlgorithm
alg <- MDK -> Maybe DkAlgorithm
mdkAlgorithm MDK
mdk
ByteString
sig <- MDK -> Maybe ByteString
mdkSignature MDK
mdk
DkCanonAlgo
cal <- MDK -> Maybe DkCanonAlgo
mdkCanonAlgo MDK
mdk
ByteString
dom <- MDK -> Maybe ByteString
mdkDomain MDK
mdk
ByteString
sel <- MDK -> Maybe ByteString
mdkSelector MDK
mdk
DK -> Maybe DK
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return
DK
{ dkAlgorithm :: DkAlgorithm
dkAlgorithm = DkAlgorithm
alg
, dkSignature :: ByteString
dkSignature = ByteString
sig
, dkCanonAlgo :: DkCanonAlgo
dkCanonAlgo = DkCanonAlgo
cal
, dkDomain0 :: ByteString
dkDomain0 = ByteString
dom
, dkFields :: Maybe DkFields
dkFields = MDK -> Maybe DkFields
mdkFields MDK
mdk
, dkSelector0 :: ByteString
dkSelector0 = ByteString
sel
}
data MDK = MDK
{ MDK -> Maybe DkAlgorithm
mdkAlgorithm :: Maybe DkAlgorithm
, MDK -> Maybe ByteString
mdkSignature :: Maybe ByteString
, MDK -> Maybe DkCanonAlgo
mdkCanonAlgo :: Maybe DkCanonAlgo
, MDK -> Maybe ByteString
mdkDomain :: Maybe ByteString
, MDK -> Maybe DkFields
mdkFields :: Maybe DkFields
, MDK -> Maybe ByteString
mdkSelector :: Maybe ByteString
}
deriving (MDK -> MDK -> Bool
(MDK -> MDK -> Bool) -> (MDK -> MDK -> Bool) -> Eq MDK
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MDK -> MDK -> Bool
== :: MDK -> MDK -> Bool
$c/= :: MDK -> MDK -> Bool
/= :: MDK -> MDK -> Bool
Eq, Int -> MDK -> ShowS
[MDK] -> ShowS
MDK -> String
(Int -> MDK -> ShowS)
-> (MDK -> String) -> ([MDK] -> ShowS) -> Show MDK
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MDK -> ShowS
showsPrec :: Int -> MDK -> ShowS
$cshow :: MDK -> String
show :: MDK -> String
$cshowList :: [MDK] -> ShowS
showList :: [MDK] -> ShowS
Show)
initialMDK :: MDK
initialMDK :: MDK
initialMDK =
MDK
{ mdkAlgorithm :: Maybe DkAlgorithm
mdkAlgorithm = DkAlgorithm -> Maybe DkAlgorithm
forall a. a -> Maybe a
Just DkAlgorithm
DK_RSA_SHA1
, mdkSignature :: Maybe ByteString
mdkSignature = Maybe ByteString
forall a. Maybe a
Nothing
, mdkCanonAlgo :: Maybe DkCanonAlgo
mdkCanonAlgo = Maybe DkCanonAlgo
forall a. Maybe a
Nothing
, mdkDomain :: Maybe ByteString
mdkDomain = Maybe ByteString
forall a. Maybe a
Nothing
, mdkFields :: Maybe DkFields
mdkFields = Maybe DkFields
forall a. Maybe a
Nothing
, mdkSelector :: Maybe ByteString
mdkSelector = Maybe ByteString
forall a. Maybe a
Nothing
}
type DKSetter = ByteString -> MDK -> MDK
dkTagDB :: [(Char, DKSetter)]
dkTagDB :: [(Char, ByteString -> MDK -> MDK)]
dkTagDB =
[ (Char
'a', ByteString -> MDK -> MDK
setDkAlgorithm)
, (Char
'b', ByteString -> MDK -> MDK
setDkSignature)
, (Char
'c', ByteString -> MDK -> MDK
setDkCanonAlgo)
, (Char
'd', ByteString -> MDK -> MDK
setDkDomain)
, (Char
'h', ByteString -> MDK -> MDK
setDkFields)
,
(Char
's', ByteString -> MDK -> MDK
setDkSelector)
]
setDkAlgorithm :: DKSetter
setDkAlgorithm :: ByteString -> MDK -> MDK
setDkAlgorithm ByteString
"rsa-sha1" MDK
dk = MDK
dk{mdkAlgorithm = Just DK_RSA_SHA1}
setDkAlgorithm ByteString
_ MDK
_ = String -> MDK
forall a. HasCallStack => String -> a
error String
"setDkAlgorithm"
setDkSignature :: DKSetter
setDkSignature :: ByteString -> MDK -> MDK
setDkSignature ByteString
sig MDK
dk = MDK
dk{mdkSignature = Just sig}
setDkCanonAlgo :: DKSetter
setDkCanonAlgo :: ByteString -> MDK -> MDK
setDkCanonAlgo ByteString
"simple" MDK
dk = MDK
dk{mdkCanonAlgo = Just DK_SIMPLE}
setDkCanonAlgo ByteString
"nofws" MDK
dk = MDK
dk{mdkCanonAlgo = Just DK_NOFWS}
setDkCanonAlgo ByteString
_ MDK
_ = String -> MDK
forall a. HasCallStack => String -> a
error String
"setDkCanonAlgo"
setDkDomain :: DKSetter
setDkDomain :: ByteString -> MDK -> MDK
setDkDomain ByteString
dom MDK
dk = MDK
dk{mdkDomain = Just dom}
setDkFields :: DKSetter
setDkFields :: ByteString -> MDK -> MDK
setDkFields ByteString
keys MDK
dk = MDK
dk{mdkFields = Just mx}
where
flds :: [ByteString]
flds = Char -> ByteString -> [ByteString]
BS.split Char
':' ByteString
keys
mx :: DkFields
mx = (DkFields -> ByteString -> DkFields)
-> DkFields -> [ByteString] -> DkFields
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DkFields -> ByteString -> DkFields
forall {k}. Ord k => Map k Bool -> k -> Map k Bool
func DkFields
forall k a. Map k a
M.empty [ByteString]
flds
func :: Map k Bool -> k -> Map k Bool
func Map k Bool
m k
fld = k -> Bool -> Map k Bool -> Map k Bool
forall k a. Ord k => k -> a -> Map k a -> Map k a
M.insert k
fld Bool
True Map k Bool
m
setDkSelector :: DKSetter
setDkSelector :: ByteString -> MDK -> MDK
setDkSelector ByteString
sel MDK
dk = MDK
dk{mdkSelector = Just sel}