Parser.hs

{-# 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

-- $setup
-- >>> import Text.Pretty.Simple
-- >>> import Data.ByteString.Char8 as BS8


-- | Parsing DomainKey-Signature:.
--
-- >>> :{
-- let dk = BS8.concat [
--                 "a=rsa-sha1; s=brisbane; d=football.example.com;\n"
--               , "  c=simple; q=dns;\n"
--               , "  b=dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZ\n"
--               , "    VoG4ZHRNiYzR;"
--               ]
-- in pPrintNoColor $ parseDK dk
-- :}
-- Just 
--     ( DK 
--         { dkAlgorithm = DK_RSA_SHA1
--         , dkSignature = "dzdVyOfAKCdLXdJOc9G2q8LoXSlEniSbav+yuU4zGeeruD00lszZVoG4ZHRNiYzR"
--         , dkCanonAlgo = DK_SIMPLE
--         , dkDomain0 = "football.example.com"
--         , dkFields = Nothing
--         , dkSelector0 = "brisbane"
--         } 
--     )
parseDK :: RawFieldValue -> Maybe DK
parseDK val = toDK domkey
  where
    (ts,vs) = unzip $ parseTaggedValue val
    fs = map tagToSetter ts
    tagToSetter tag = fromMaybe (\_ mdk -> mdk) $ lookup (BS.head tag) dkTagDB
    pfs = zipWith ($) fs vs
    domkey = foldr ($) initialMDK pfs
    toDK mdk = do
        alg <- mdkAlgorithm mdk
        sig <- mdkSignature mdk
        cal <- mdkCanonAlgo mdk
        dom <- mdkDomain    mdk
        sel <- mdkSelector  mdk
        return DK {
            dkAlgorithm = alg
          , dkSignature = sig
          , dkCanonAlgo = cal
          , dkDomain0   = dom
          , dkFields    = mdkFields mdk
          , dkSelector0 = sel
          }

data MDK = MDK {
    mdkAlgorithm :: Maybe DkAlgorithm
  , mdkSignature :: Maybe ByteString
  , mdkCanonAlgo :: Maybe DkCanonAlgo
  , mdkDomain    :: Maybe ByteString
  , mdkFields    :: Maybe DkFields
  , mdkSelector  :: Maybe ByteString
  } deriving (Eq,Show)

initialMDK :: MDK
initialMDK = MDK {
    mdkAlgorithm = Just DK_RSA_SHA1
  , mdkSignature = Nothing
  , mdkCanonAlgo = Nothing
  , mdkDomain    = Nothing
  , mdkFields    = Nothing
  , mdkSelector  = Nothing
  }

type DKSetter = ByteString -> MDK -> MDK

dkTagDB :: [(Char,DKSetter)]
dkTagDB = [
    ('a',setDkAlgorithm)
  , ('b',setDkSignature)
  , ('c',setDkCanonAlgo)
  , ('d',setDkDomain)
  , ('h',setDkFields)
--  , ('q',setDkQuery)
  , ('s',setDkSelector)
  ]

setDkAlgorithm :: DKSetter
setDkAlgorithm "rsa-sha1" dk = dk { mdkAlgorithm = Just DK_RSA_SHA1 }
setDkAlgorithm _ _           = error "setDkAlgorithm"

setDkSignature :: DKSetter
setDkSignature sig dk = dk { mdkSignature = Just sig }

setDkCanonAlgo :: DKSetter
setDkCanonAlgo "simple" dk = dk { mdkCanonAlgo = Just DK_SIMPLE }
setDkCanonAlgo "nofws"  dk = dk { mdkCanonAlgo = Just DK_NOFWS }
setDkCanonAlgo  _ _        = error "setDkCanonAlgo"

setDkDomain :: DKSetter
setDkDomain dom dk = dk { mdkDomain = Just dom }

setDkFields :: DKSetter
setDkFields keys dk = dk { mdkFields = Just mx }
  where
    flds = BS.split ':' keys
    mx = foldl' func M.empty flds
    func m fld = M.insert fld True m

{-
setDkQuery :: DKSetter
setDkQuery "dns" dk = dk { mdkQuery = Just DK_DNS }
setDkQuery _ _      = error "setDkQuery"
-}

setDkSelector :: DKSetter
setDkSelector sel dk = dk { mdkSelector = Just sel }