packages feed

domain-auth (empty) → 0.1.0

raw patch · 32 files changed

+2031/−0 lines, 32 filesdep +RSAdep +SHAdep +apparsetup-changed

Dependencies added: RSA, SHA, appar, base, binary, bytestring, containers, dns, iproute, network

Files

+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2009, IIJ Innovation Institute Inc.+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++  * Redistributions of source code must retain the above copyright+    notice, this list of conditions and the following disclaimer.+  * Redistributions in binary form must reproduce the above copyright+    notice, this list of conditions and the following disclaimer in+    the documentation and/or other materials provided with the+    distribution.+  * Neither the name of the copyright holders nor the names of its+    contributors may be used to endorse or promote products derived+    from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS+FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE+COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,+INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,+BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN+ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE+POSSIBILITY OF SUCH DAMAGE.
+ Network/DomainAuth.hs view
@@ -0,0 +1,19 @@+{-|+  Library for Sender Policy Framework, SenderID, DomainKeys and DKIM.+-}++module Network.DomainAuth (+    module Network.DomainAuth.Mail+  , module Network.DomainAuth.DK+  , module Network.DomainAuth.DKIM+  , module Network.DomainAuth.PRD+  , module Network.DomainAuth.SPF+  , module Network.DomainAuth.Types+  ) where++import Network.DomainAuth.Mail+import Network.DomainAuth.DK+import Network.DomainAuth.DKIM+import Network.DomainAuth.PRD+import Network.DomainAuth.SPF+import Network.DomainAuth.Types
+ Network/DomainAuth/DK.hs view
@@ -0,0 +1,45 @@+{-|+  A library for DomainKeys (<http://www.ietf.org/rfc/rfc4070>).+  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 Control.Applicative+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++{-|+  Verifying 'Mail' with DomainKeys.+-}+runDK :: Resolver -> Mail -> IO DAResult+runDK resolver mail = dk1+  where+    dk1     = maybe (return DANone)      dk2 $ lookupField dkFieldKey (mailHeader mail)+    dk2 dkv = maybe (return DAPermError) dk3 $ parseDK (fieldValueUnfolded dkv)+    dk3     = runDK' resolver mail++{-|+  Verifying 'Mail' with DomainKeys. The value of DomainKey-Signature:+  should be parsed beforehand.+-}+runDK' :: Resolver -> Mail -> DK -> IO DAResult+runDK' resolver mail dk = maybe DATempError (verify mail dk) <$> pub+  where+    pub = lookupPublicKey resolver dom+    dom = dkSelector dk ++ "._domainkey." ++ dkDomain dk+    verify m d p = if verifyDK m d p then DAPass else DAFail
+ Network/DomainAuth/DK/Parser.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.DK.Parser where++import qualified Data.ByteString.Lazy.Char8 as L+import Data.List+import qualified Data.Map as M+import Data.Maybe+import Network.DomainAuth.DK.Types+import Network.DomainAuth.Mail+import Prelude hiding (catch)++{-|+  Parsing DomainKey-Signature:.+-}+parseDK :: RawFieldValue -> Maybe DK+parseDK val = toDK domkey+  where+    (ts,vs) = unzip $ parseTaggedValue val+    fs = map tagToSetter ts+    tagToSetter tag = fromMaybe (\_ mdk -> mdk) $ lookup (L.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 L.ByteString+  , mdkCanonAlgo :: Maybe DkCanonAlgo+  , mdkDomain    :: Maybe L.ByteString+  , mdkFields    :: Maybe DkFields+  , mdkSelector  :: Maybe L.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 = L.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 = L.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 }
+ Network/DomainAuth/DK/Types.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.DK.Types where++import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Map as M+import Network.DNS+import Network.DomainAuth.Mail++----------------------------------------------------------------++{-|+  Canonicalized key for DomainKey-Signature:.+-}+dkFieldKey :: CanonFieldKey+dkFieldKey = "domainkey-signature"++----------------------------------------------------------------++data DkAlgorithm = DK_RSA_SHA1 deriving (Eq,Show)+data DkCanonAlgo = DK_SIMPLE | DK_NOFWS deriving (Eq,Show)+--data DkQuery = DK_DNS deriving (Eq,Show)+type DkFields = M.Map L.ByteString Bool -- Key Bool++{-|+  Abstract type for DomainKey-Signature:+-}++data DK = DK {+    dkAlgorithm :: DkAlgorithm+  , dkSignature :: L.ByteString+  , dkCanonAlgo :: DkCanonAlgo+  , dkDomain0   :: L.ByteString+  , dkFields    :: Maybe DkFields+--  , dkQuery     :: Maybe DkQuery -- gmail does not provide, sigh+  , dkSelector0 :: L.ByteString+  } deriving (Eq,Show)++{-|+  Getting of the value of the \"d\" tag in DomainKey-Signature:.+-}+dkDomain :: DK -> Domain+dkDomain = L.unpack . dkDomain0++{-|+  Getting of the value of the \"s\" tag in DomainKey-Signature:.+-}+dkSelector :: DK -> String+dkSelector = L.unpack . dkSelector0
+ Network/DomainAuth/DK/Verify.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.DK.Verify (+    verifyDK, prepareDK+  ) where++import Codec.Crypto.RSA+import qualified Data.ByteString.Lazy.Char8 as L+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 -> L.ByteString+prepareDK dk mail = cmail+  where+    header' = canonDkHeader dk (mailHeader mail)+    body'   = canonDkBody (dkCanonAlgo dk) (mailBody mail)+    cmail   = if body' == "" then header' else header' `appendCRLF` body'++----------------------------------------------------------------++canonDkHeader :: DK -> Header -> L.ByteString+canonDkHeader dk hdr = concatCRLFWith (canonDkField calgo) flds+  where+    calgo = dkCanonAlgo dk+    hFields = dkFields dk+    flds = prepareDkHeader hFields hdr++canonDkField :: DkCanonAlgo -> Field -> L.ByteString+canonDkField DK_SIMPLE fld = fieldKey fld +++ ": " +++ fieldValueFolded fld+canonDkField DK_NOFWS  fld = fieldKey fld +++ ":" +++ removeFWS (fieldValueUnfolded fld)++prepareDkHeader :: Maybe DkFields -> Header -> Header+prepareDkHeader Nothing hdr = fieldsAfter dkFieldKey hdr+prepareDkHeader (Just hFields) hdr = filter isInHTag $ fieldsAfter dkFieldKey hdr+  where+    isInHTag fld = M.member (fieldSearchKey fld) hFields++----------------------------------------------------------------++canonDkBody :: DkCanonAlgo -> Body -> L.ByteString+canonDkBody DK_SIMPLE = fromBody . removeTrailingEmptyLine+canonDkBody DK_NOFWS  = fromBodyWith removeFWS . removeTrailingEmptyLine++----------------------------------------------------------------++verifyDK :: Mail -> DK -> PublicKey -> Bool+verifyDK mail dk pub = rsassa_pkcs1_v1_5_verify ha_SHA1 pub cmail sig+  where+    sig = B.decode (dkSignature dk)+    cmail = prepareDK dk mail
+ Network/DomainAuth/DKIM.hs view
@@ -0,0 +1,45 @@+{-|+  A library for DKIM (<http://www.ietf.org/rfc/rfc4071>).+  Currently, only receiver side is implemented.+-}++module Network.DomainAuth.DKIM (+  -- * Documentation+  -- ** Authentication with DKIM+    runDKIM, runDKIM'+  -- ** Parsing DKIM-Signature:+  , parseDKIM+  , DKIM, dkimDomain, dkimSelector+  -- ** Field key for DKIM-Signature:+  , dkimFieldKey+  ) where++import Control.Applicative+import Network.DNS as DNS (Resolver)+import Network.DomainAuth.DKIM.Parser+import Network.DomainAuth.DKIM.Types+import Network.DomainAuth.DKIM.Verify+import Network.DomainAuth.Mail+import Network.DomainAuth.Pubkey.RSAPub+import Network.DomainAuth.Types++{-|+  Verifying 'Mail' with DKIM.+-}+runDKIM :: Resolver -> Mail -> IO DAResult+runDKIM resolver mail = dkim1+  where+    dkim1       = maybe (return DANone)      dkim2 $ lookupField dkimFieldKey (mailHeader mail)+    dkim2 dkimv = maybe (return DAPermError) dkim3 $ parseDKIM (fieldValueUnfolded dkimv)+    dkim3       = runDKIM' resolver mail++{-|+  Verifying 'Mail' with DKIM. The value of DKIM-Signature:+  should be parsed beforehand.+-}+runDKIM' :: Resolver -> Mail -> DKIM -> IO DAResult+runDKIM' resolver mail dkim = maybe DATempError (verify mail dkim) <$> pub+  where+    pub = lookupPublicKey resolver dom+    dom = dkimSelector dkim ++ "._domainkey." ++ dkimDomain dkim+    verify m d p = if verifyDKIM m d p then DAPass else DAFail
+ Network/DomainAuth/DKIM/Btag.hs view
@@ -0,0 +1,24 @@+module Network.DomainAuth.DKIM.Btag where++import Control.Applicative+import Data.ByteString.Lazy.Char8+import Data.Maybe+import Text.Appar.LazyByteString++removeBtagValue :: ByteString -> ByteString+removeBtagValue = pack . fromMaybe "" . parse remBtagValue++remBtagValue :: Parser String+remBtagValue = (++) <$> inFix btag <*> many anyChar++inFix :: Parser String -> Parser String+inFix p = try p <|> (:) <$> anyChar <*> inFix p++btag :: Parser String+btag = do+    b <- string "b"+    w <- many $ oneOf " \t\r\n"+    e <- string "="+    some $ noneOf ";"+    s <- option "" (string ";")+    return $ b ++ w ++ e ++ s
+ Network/DomainAuth/DKIM/Parser.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.DKIM.Parser where++import Control.Applicative+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe+import Network.DomainAuth.DKIM.Types+import Network.DomainAuth.Mail+import Prelude hiding (catch)++{-|+  Parsing DKIM-Signature:.+-}+parseDKIM :: RawFieldValue -> Maybe DKIM+parseDKIM val = toDKIM domkey+  where+    (ts,vs) = unzip $ parseTaggedValue val+    fs = map tagToSetter ts+    tagToSetter tag = fromMaybe (\_ mdkim -> mdkim) $ lookup (L.unpack tag) dkimTagDB+    pfs = zipWith ($) fs vs+    domkey = foldr ($) initialMDKIM pfs+    toDKIM mdkim = do+        ver <- mdkimVersion     mdkim+        alg <- mdkimSigAlgo     mdkim+        sig <- mdkimSignature   mdkim+        bhs <- mdkimBodyHash    mdkim+        hca <- mdkimHeaderCanon mdkim+        bca <- mdkimBodyCanon   mdkim+        dom <- mdkimDomain      mdkim+        fld <- mdkimFields      mdkim+        sel <- mdkimSelector    mdkim+        return DKIM {+            dkimVersion     = ver+          , dkimSigAlgo     = alg+          , dkimSignature   = sig+          , dkimBodyHash    = bhs+          , dkimHeaderCanon = hca+          , dkimBodyCanon   = bca+          , dkimDomain0     = dom+          , dkimFields      = fld+          , dkimLength      = mdkimLength mdkim+          , dkimSelector0   = sel+          }++data MDKIM = MDKIM {+    mdkimVersion     :: Maybe L.ByteString+  , mdkimSigAlgo     :: Maybe DkimSigAlgo+  , mdkimSignature   :: Maybe L.ByteString+  , mdkimBodyHash    :: Maybe L.ByteString+  , mdkimHeaderCanon :: Maybe DkimCanonAlgo+  , mdkimBodyCanon   :: Maybe DkimCanonAlgo+  , mdkimDomain      :: Maybe L.ByteString+  , mdkimFields      :: Maybe [CanonFieldKey]+  , mdkimLength      :: Maybe Int+  , mdkimSelector    :: Maybe L.ByteString+  } deriving (Eq,Show)++initialMDKIM :: MDKIM+initialMDKIM = MDKIM {+    mdkimVersion     = Nothing+  , mdkimSigAlgo     = Nothing+  , mdkimSignature   = Nothing+  , mdkimBodyHash    = Nothing+  , mdkimHeaderCanon = Just DKIM_SIMPLE+  , mdkimBodyCanon   = Just DKIM_SIMPLE+  , mdkimDomain      = Nothing+  , mdkimFields      = Nothing+  , mdkimLength      = Nothing+  , mdkimSelector    = Nothing+  }++type DKIMSetter = L.ByteString -> MDKIM -> MDKIM++dkimTagDB :: [(String,DKIMSetter)]+dkimTagDB = [+    ("v",setDkimVersion)+  , ("a",setDkimSigAlgo)+  , ("b",setDkimSignature)+  , ("bh",setDkimBodyHash)+  , ("c",setDkimCanonAlgo)+  , ("d",setDkimDomain)+  , ("h",setDkimFields)+  , ("l",setDkimLength)+  , ("s",setDkimSelector)+  ]++setDkimVersion :: DKIMSetter+setDkimVersion ver dkim = dkim { mdkimVersion = Just ver }++setDkimSigAlgo :: DKIMSetter+setDkimSigAlgo "rsa-sha1" dkim = dkim { mdkimSigAlgo = Just RSA_SHA1 }+setDkimSigAlgo "rsa-sha256" dkim = dkim { mdkimSigAlgo = Just RSA_SHA256 }+setDkimSigAlgo _ _ = error "setDkimSigAlgo"++setDkimSignature :: DKIMSetter+setDkimSignature sig dkim = dkim { mdkimSignature = Just sig }++setDkimBodyHash :: DKIMSetter+setDkimBodyHash bh dkim = dkim { mdkimBodyHash = Just bh }++setDkimCanonAlgo :: DKIMSetter+setDkimCanonAlgo "relaxed" dkim = dkim {+    mdkimHeaderCanon = Just DKIM_RELAXED+  , mdkimBodyCanon   = Just DKIM_SIMPLE+  }+setDkimCanonAlgo "relaxed/relaxed" dkim = dkim {+    mdkimHeaderCanon = Just DKIM_RELAXED+  , mdkimBodyCanon   = Just DKIM_RELAXED+  }+setDkimCanonAlgo "relaxed/simple" dkim = dkim {+    mdkimHeaderCanon = Just DKIM_RELAXED+  , mdkimBodyCanon   = Just DKIM_SIMPLE+  }+setDkimCanonAlgo "simple/relaxed" dkim = dkim {+    mdkimHeaderCanon = Just DKIM_SIMPLE+  , mdkimBodyCanon   = Just DKIM_RELAXED+  }+setDkimCanonAlgo "simple/simple" dkim = dkim {+    mdkimHeaderCanon = Just DKIM_SIMPLE+  , mdkimBodyCanon   = Just DKIM_SIMPLE+  }+setDkimCanonAlgo _ _ = error "setDkimCanonAlgo"++setDkimDomain :: DKIMSetter+setDkimDomain dom dkim = dkim { mdkimDomain = Just dom }++setDkimFields :: DKIMSetter+setDkimFields keys dkim = dkim { mdkimFields = Just flds }+  where+    flds = map canonicalizeKey $ L.split ':' keys++setDkimLength :: DKIMSetter+setDkimLength len dkim = dkim { mdkimLength = fst <$> L.readInt len }++setDkimSelector :: DKIMSetter+setDkimSelector sel dkim = dkim { mdkimSelector = Just sel }
+ Network/DomainAuth/DKIM/Types.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.DKIM.Types where++import qualified Data.ByteString.Lazy.Char8 as L+import Network.DNS+import Network.DomainAuth.Mail++----------------------------------------------------------------++{-|+  Canonicalized key for DKIM-Signature:.+-}+dkimFieldKey :: CanonFieldKey+dkimFieldKey = "dkim-signature"++----------------------------------------------------------------++data DkimSigAlgo = RSA_SHA1 | RSA_SHA256 deriving (Eq,Show)+data DkimCanonAlgo = DKIM_SIMPLE | DKIM_RELAXED deriving (Eq,Show)++data DKIM = DKIM {+    dkimVersion     :: L.ByteString+  , dkimSigAlgo     :: DkimSigAlgo+  , dkimSignature   :: L.ByteString+  , dkimBodyHash    :: L.ByteString+  , dkimHeaderCanon :: DkimCanonAlgo+  , dkimBodyCanon   :: DkimCanonAlgo+  , dkimDomain0     :: L.ByteString+  , dkimFields      :: [CanonFieldKey]+  , dkimLength      :: Maybe Int+  , dkimSelector0   :: L.ByteString+  } deriving (Eq,Show)++{-|+  Getting of the value of the \"d\" tag in DKIM-Signature:.+-}+dkimDomain :: DKIM -> Domain+dkimDomain = L.unpack . dkimDomain0++{-|+  Getting of the value of the \"s\" tag in DKIM-Signature:.+-}+dkimSelector :: DKIM -> String+dkimSelector = L.unpack . dkimSelector0
+ Network/DomainAuth/DKIM/Verify.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.DKIM.Verify (+    verifyDKIM, prepareDKIM+  ) where++import Codec.Crypto.RSA+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.Digest.Pure.SHA+import Network.DomainAuth.DKIM.Btag+import Network.DomainAuth.DKIM.Types+import Network.DomainAuth.Mail+import qualified Network.DomainAuth.Pubkey.Base64 as B+import Network.DomainAuth.Utils++----------------------------------------------------------------++prepareDKIM :: DKIM -> Mail -> L.ByteString+prepareDKIM dkim mail = header+  where+    dkimField:fields = fieldsFrom dkimFieldKey (mailHeader mail)+    hCanon = canonDkimField (dkimHeaderCanon dkim)+    canon = removeBtagValue . hCanon+    targets = fieldsWith (dkimFields dkim) fields+    header = concatCRLFWith hCanon targets +++ canon dkimField++----------------------------------------------------------------++canonDkimField :: DkimCanonAlgo -> Field -> L.ByteString+canonDkimField DKIM_SIMPLE fld  = fieldKey fld +++ ": " +++ fieldValueFolded fld+canonDkimField DKIM_RELAXED fld = fieldSearchKey fld +++ ":" +++ canon fld+  where+    canon = L.dropWhile isSpace . removeTrailingWSP . reduceWSP . L.concat . fieldValue++----------------------------------------------------------------++canonDkimBody :: DkimCanonAlgo -> Body -> L.ByteString+canonDkimBody DKIM_SIMPLE  = fromBody . removeTrailingEmptyLine+canonDkimBody DKIM_RELAXED = fromBodyWith relax . removeTrailingEmptyLine+  where+    relax = removeTrailingWSP . reduceWSP++----------------------------------------------------------------++verifyDKIM :: Mail -> DKIM -> PublicKey -> Bool+verifyDKIM mail dkim pub = bodyHash1 mail == bodyHash2 dkim &&+                           rsassa_pkcs1_v1_5_verify hashfunc pub cmail sig+  where+    hashfunc = hashAlgo1 (dkimSigAlgo dkim)+    hashfunc2 = hashAlgo2 (dkimSigAlgo dkim)+    sig = B.decode (dkimSignature dkim)+    cmail = prepareDKIM dkim mail+    bodyHash1 = bytestringDigest . hashfunc2 . canonDkimBody (dkimBodyCanon dkim) . mailBody+    bodyHash2 = B.decode . dkimBodyHash++hashAlgo1 :: DkimSigAlgo -> HashInfo+hashAlgo1 RSA_SHA1   = ha_SHA1+hashAlgo1 RSA_SHA256 = ha_SHA256++hashAlgo2 :: DkimSigAlgo -> L.ByteString -> Digest+hashAlgo2 RSA_SHA1   = sha1+hashAlgo2 RSA_SHA256 = sha256++
+ Network/DomainAuth/Mail.hs view
@@ -0,0 +1,40 @@+{-|+  A library to parse e-mail messages both from a file and Milter(<https://www.milter.org/>).+-}++module Network.DomainAuth.Mail (+  -- * Documentation+  -- ** Types for raw e-mail message+    RawMail+  , RawFieldKey+  , RawFieldValue+  , RawBodyChunk+  -- ** Types for parsed e-mail message+  , Mail(..), Header, Field(..), CanonFieldKey, FieldKey, FieldValue, Body+  , canonicalizeKey+  -- ** Obtaining 'Mail'+  , readMail, getMail+  -- ** Obtaining 'Mail' incrementally.+  , XMail(..)+  , initialXMail+  , pushField, pushBody, finalizeMail+  -- ** Functions to manipulate 'Header'+  , lookupField+  , fieldsFrom+  , fieldsAfter+  , fieldsWith+  -- ** Functions to manipulate 'Field'+  , fieldValueFolded+  , fieldValueUnfolded+  -- ** Functions to manipulate 'Body'+  , fromBody+  , fromBodyWith+  , removeTrailingEmptyLine+  -- ** Special function for DomainKeys and DKIM+  , parseTaggedValue+  ) where++import Network.DomainAuth.Mail.Mail+import Network.DomainAuth.Mail.Parser+import Network.DomainAuth.Mail.Types+import Network.DomainAuth.Mail.XMail
+ Network/DomainAuth/Mail/Mail.hs view
@@ -0,0 +1,86 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.Mail.Mail where++import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.Foldable as F (foldr)+import Data.List+import Data.Sequence (Seq, viewr, ViewR(..), empty)+import Network.DomainAuth.Mail.Types+import Network.DomainAuth.Utils++----------------------------------------------------------------++-- | Looking up 'Field' from 'Header' with 'FieldKey'.+lookupField :: FieldKey -> Header -> Maybe Field+lookupField key hdr = find (ckey `isKeyOf`) hdr+  where+    ckey = canonicalizeKey key++-- | Obtaining the 'Field' of 'FieldKey' and all fields under 'FieldKey'.+fieldsFrom :: FieldKey -> Header -> Header+fieldsFrom key = dropWhile (ckey `isNotKeyOf`)+  where+    ckey = canonicalizeKey key++-- | Obtaining all fields under 'FieldKey'.+fieldsAfter :: FieldKey -> Header -> Header+fieldsAfter key = safeTail . fieldsFrom key+  where+    safeTail [] = []+    safeTail xs = tail xs++{-+  RFC 4871 is ambiguous, so implement only normal case.+-}+-- | Obtaining all fields with DKIM algorithm.+fieldsWith :: [CanonFieldKey] -> Header -> Header+fieldsWith [] _ = []+fieldsWith _ [] = []+fieldsWith (k:ks) is+  | fs == []  = fieldsWith (k:ks) (tail is')+  | otherwise = take len (reverse fs) ++ fieldsWith ks' is'+  where+    (fs,is') = span (\fld -> fieldSearchKey fld == k) is+    (kx,ks') = span (==k) ks+    len = length kx + 1 -- including k++----------------------------------------------------------------++isKeyOf :: CanonFieldKey -> Field -> Bool+isKeyOf key fld = fieldSearchKey fld == key++isNotKeyOf :: CanonFieldKey -> Field -> Bool+isNotKeyOf key fld = fieldSearchKey fld /= key++----------------------------------------------------------------++-- | Obtaining folded (raw) field value.+fieldValueFolded :: Field -> RawFieldValue+fieldValueFolded = concatCRLF . fieldValue++-- | Obtaining unfolded (removing CRLF) field value.+fieldValueUnfolded :: Field -> RawFieldValue+fieldValueUnfolded = L.concat . fieldValue++----------------------------------------------------------------++-- | Obtaining body.+fromBody :: Body -> L.ByteString+fromBody = fromBodyWith id++-- | Obtaining body with a canonicalization function.+fromBodyWith :: (L.ByteString -> L.ByteString) -> Body -> L.ByteString+fromBodyWith modify = F.foldr (appendCRLFWith modify) ""++-- | Removing trailing empty lines.+removeTrailingEmptyLine :: Body -> Body+removeTrailingEmptyLine = dropWhileR (=="")++-- dropWhileR is buggy, sigh.+dropWhileR :: (a -> Bool) -> Seq a -> Seq a+dropWhileR p xs = case viewr xs of+    EmptyR        -> empty+    xs' :> x+      | p x       -> dropWhileR p xs'+      | otherwise -> xs
+ Network/DomainAuth/Mail/Parser.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.Mail.Parser where++import Control.Applicative+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.Int+import Network.DomainAuth.Mail.Types+import Network.DomainAuth.Mail.XMail+import Network.DomainAuth.Utils++----------------------------------------------------------------++-- | Obtain 'Mail' from a file.+readMail :: FilePath -> IO Mail+readMail file = getMail <$> L.readFile file++----------------------------------------------------------------++-- | Obtain 'Mail' from 'RawMail'.+getMail :: RawMail -> Mail+getMail bs = finalizeMail $ pushBody rbdy xmail+  where+    (rhdr,rbdy) = splitHeaderBody bs+    rflds = splitFields rhdr+    xmail = foldl push initialXMail rflds+    push m fld = let (k,v) = parseField fld+                 in pushField k v m++----------------------------------------------------------------++splitHeaderBody :: RawMail -> (RawHeader,RawBody)+splitHeaderBody bs = case mcnt of+    Nothing  -> (bs,"")+    Just cnt -> check (L.splitAt cnt bs)+  where+    mcnt = findEOH bs 0+    check (hdr,bdy) = (hdr, dropSep bdy)+    dropSep bdy+      | len == 0 = ""+      | len == 1 = ""+      | otherwise = if b1 == '\r' then bdy3 else bdy2+      where+        len = L.length bdy+        b1 = L.head bdy+        bdy2 = L.tail bdy+        bdy3 = L.tail bdy2++findEOH :: RawMail -> Int64 -> Maybe Int64+findEOH "" _ = Nothing+findEOH bs cnt+  | b0 == '\n' && bs1 /= "" && b1 == '\n' = Just (cnt + 1)+  | b0 == '\n' && bs1 /= "" && b1 == '\r'+               && bs2 /= "" && b2 == '\n' = Just (cnt + 1)+  | otherwise                             = findEOH bs1 (cnt + 1)+  where+    b0  = L.head bs+    bs1 = L.tail bs+    b1  = L.head bs1+    bs2 = L.tail bs1+    b2  = L.head bs2++----------------------------------------------------------------++splitFields :: RawHeader -> [RawField]+splitFields "" = []+splitFields bs = fld : splitFields bs''+  where+    -- split before '\n' for efficiency+    (fld,bs') = L.splitAt (findFieldEnd bs 0 - 1) bs+    bs'' = L.tail bs'++findFieldEnd :: RawMail -> Int64 -> Int64+findFieldEnd bs cnt+    | bs == ""   = cnt+    | b  == '\n' = begOfLine bs' (cnt + 1)+    | otherwise  = findFieldEnd bs' (cnt + 1)+  where+    b   = L.head bs+    bs' = L.tail bs++begOfLine :: RawMail -> Int64 -> Int64+begOfLine bs cnt+    | bs == ""      = cnt+    | isContinued b = findFieldEnd bs' (cnt + 1)+    | otherwise     = cnt+  where+    b   = L.head bs+    bs' = L.tail bs++isContinued :: Char -> Bool+isContinued c = c `elem` " \t"++----------------------------------------------------------------++parseField :: RawField -> (RawFieldKey,RawFieldValue)+parseField bs = (k,v')+  where+    (k,v) = break' ':' bs+    -- Sendmail drops ' ' after ':'.+    v' = if v /= "" && L.head v == ' '+         then L.tail v+         else v++----------------------------------------------------------------++{-|+  Parsing field value of tag=value.+-}+-- This breaks spaces in the note tag.+parseTaggedValue :: RawFieldValue -> [(L.ByteString,L.ByteString)]+parseTaggedValue xs = vss+  where+    v = L.filter (not.isSpace) xs+    vs = filter (/= "") $ L.split ';' v+    vss = map (break' '=') vs
+ Network/DomainAuth/Mail/Types.hs view
@@ -0,0 +1,57 @@+module Network.DomainAuth.Mail.Types where++import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.Sequence++----------------------------------------------------------------+-- | Type for raw e-mail message.+type RawMail = L.ByteString+type RawHeader = L.ByteString+type RawBody = L.ByteString+type RawField = L.ByteString+-- | Field key for raw e-mail message.+type RawFieldKey = L.ByteString+-- | Field value for raw e-mail message.+type RawFieldValue = L.ByteString+-- | Body chunk for raw e-mail message.+type RawBodyChunk = L.ByteString++----------------------------------------------------------------++{-|+  Type for parsed e-mail message.+-}+data Mail = Mail {+    mailHeader :: Header+  , mailBody :: Body+  } deriving (Eq,Show)++{-|+  Header type for parsed e-mail message.+-}+type Header = [Field]++{-|+  Field type for parsed e-mail message.+-}+data Field = Field {+    fieldSearchKey :: CanonFieldKey+  , fieldKey       :: FieldKey+  , fieldValue     :: FieldValue+  } deriving (Eq,Show)++-- | Type for canonicalized field key of parsed e-mail message.+type CanonFieldKey = L.ByteString+-- | Type for field key of parsed e-mail message.+type FieldKey = L.ByteString+-- | Type for field value of parsed e-mail message.+type FieldValue = [L.ByteString]+-- | Type for body of parsed e-mail message.+type Body = Seq L.ByteString++----------------------------------------------------------------++-- | Canonicalizing 'FieldKey' for search.+canonicalizeKey :: FieldKey -> CanonFieldKey+canonicalizeKey = L.map toLower
+ Network/DomainAuth/Mail/XMail.hs view
@@ -0,0 +1,40 @@+module Network.DomainAuth.Mail.XMail where++import qualified Data.ByteString.Lazy.Char8 as L+import Data.Sequence (fromList)+import Network.DomainAuth.Mail.Types+import Network.DomainAuth.Utils++----------------------------------------------------------------++-- | Type for temporary data to parse e-mail message.+data XMail = XMail {+    xmailHeader :: Header+  , xmailBody :: [RawBodyChunk]+  } deriving (Eq,Show)++-- | Initial value for 'XMail'.+initialXMail :: XMail+initialXMail = XMail [] []++-- | Storing field key and field value to the temporary data.+pushField :: RawFieldKey -> RawFieldValue -> XMail -> XMail+pushField key val xmail = xmail {+    xmailHeader = fld : xmailHeader xmail+  }+  where+    fld = Field ckey key (blines val)+    ckey = canonicalizeKey key++-- | Storing body chunk to the temporary data.+pushBody :: RawBodyChunk -> XMail -> XMail+pushBody bc xmail = xmail {+    xmailBody = bc : xmailBody xmail+  }++-- | Converting 'XMail' to 'Mail'.+finalizeMail :: XMail -> Mail+finalizeMail xmail = Mail {+    mailHeader = reverse . xmailHeader $ xmail+  , mailBody = fromList . blines . L.concat . reverse . xmailBody $ xmail+  }
+ Network/DomainAuth/PRD.hs view
@@ -0,0 +1,12 @@+{-|+  Utilities to decide Purported Responsible Domain (<http://www.ietf.org/rfc/rfc4407>).+-}++module Network.DomainAuth.PRD (+    module Network.DomainAuth.PRD.PRD+  , module Network.DomainAuth.PRD.Domain+  ) where++import Network.DomainAuth.PRD.PRD+import Network.DomainAuth.PRD.Domain+
+ Network/DomainAuth/PRD/Domain.hs view
@@ -0,0 +1,17 @@+module Network.DomainAuth.PRD.Domain (extractDomain) where++import Network.DNS (Domain)+import Network.DomainAuth.Mail+import Network.DomainAuth.PRD.Lexer+import Text.Appar.LazyByteString++{-|+  Extract a domain from a value of a header field.+-}++extractDomain :: RawFieldValue -> Maybe Domain+extractDomain bs = parse structured bs >>= takeDomain+    where+      takeDomain = dropTail . dropWhile (/="@")+      dropTail [] = Nothing+      dropTail xs = (Just . concat . takeWhile (/=">") . tail) xs
+ Network/DomainAuth/PRD/Lexer.hs view
@@ -0,0 +1,100 @@+module Network.DomainAuth.PRD.Lexer (+    structured+  ) where++import Control.Applicative+import Text.Appar.LazyByteString++----------------------------------------------------------------++concatSpace :: [String] -> String+concatSpace = unwords++----------------------------------------------------------------++skipChar :: Char -> Parser ()+skipChar c = () <$ char c++wsp :: Parser Char+wsp = oneOf " \t\n"++----------------------------------------------------------------++structured :: Parser [String]+structured = removeComments <$> many (choice choices)+  where+    removeComments = filter (/="")+    choices = [specials,quotedString,domainLiteral,atom,comment]++specials :: Parser String+specials = toStr <$> (specialChar <* skipMany wsp)+  where+    -- removing "()[]\\\""+    specialChar = oneOf "<>:;@=,."+    toStr c = [c]++----------------------------------------------------------------++atext :: Parser Char+atext = alphaNum <|> oneOf "!#$%&'*+-/=?^_`{|}~"++atom :: Parser String+atom = some atext <* skipMany wsp++----------------------------------------------------------------++dtext :: Parser Char+dtext = oneOf $ ['!' .. 'Z'] ++ ['^' .. '~']++domainLiteral :: Parser String+domainLiteral = do+    skipChar '['+    ds <- many (some dtext <* skipMany wsp)+    skipChar ']'+    skipMany wsp+    return (concatSpace ds)++----------------------------------------------------------------++qtext :: Parser Char+qtext = oneOf $ "!" ++ ['#' .. '['] ++ [']' .. '~']++qcontent :: Parser Char+qcontent = qtext <|> quoted_pair++quotedString :: Parser String+quotedString = do+    skipChar '"'+    skipMany wsp+    qs <- many (some qcontent <* skipMany wsp)+    skipChar '"'+    skipMany wsp+    return (concatSpace qs)++----------------------------------------------------------------++vchar :: Parser Char+vchar = oneOf ['!'..'~']++quoted_pair :: Parser Char+quoted_pair = skipChar '\\' >> (vchar <|> wsp)++----------------------------------------------------------------++ctext :: Parser Char+ctext = oneOf $ ['!' .. '\''] ++ ['*' .. '['] ++ [']' .. '~']++ccontent :: Parser String+ccontent = some (ctext <|> quoted_pair)++comment' :: Parser String+comment' = do+    skipChar '('+    skipMany wsp+    cs <- many ((ccontent <|> comment') <* skipMany wsp)+    skipChar ')'+    skipMany wsp+    return (concatSpace cs)++comment :: Parser String+comment = "" <$ comment'
+ Network/DomainAuth/PRD/PRD.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE OverloadedStrings #-}++{-|+  Purported Responsible Domain, RFC 4407.+-}++module Network.DomainAuth.PRD.PRD (+    PRD+  , initialPRD, pushPRD+  , decidePRD, decideFrom+  ) where++import Control.Monad+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.List (foldl')+import Network.DNS (Domain)+import Network.DomainAuth.Mail+import Network.DomainAuth.PRD.Domain++----------------------------------------------------------------++type HD = [(CanonFieldKey,RawFieldValue)]++data DST = DST_Zero | DST_Invalid | DST_Valid Domain deriving (Eq, Show)++{-|+  Abstract type for context to decide PRD(purported responsible domain)+  according to RFC 4407.+-}+data PRD = PRD {+    praFrom         :: DST+  , praSender       :: DST+  , praResentFrom   :: DST+  , praResentSender :: DST+  , praHeader       :: HD+  } deriving Show++{-|+  Initial context of PRD.+-}+initialPRD :: PRD+initialPRD = PRD {+    praFrom         = DST_Zero+  , praSender       = DST_Zero+  , praResentFrom   = DST_Zero+  , praResentSender = DST_Zero+  , praHeader       = []+  }++----------------------------------------------------------------++{-|+  Pushing a field key and its value in to the PRD context.+-}+pushPRD :: RawFieldKey -> RawFieldValue -> PRD -> PRD+pushPRD key val ctx = case ckey of+    "from"          -> pushFrom ctx' jdom+    "sender"        -> pushSender ctx' jdom+    "resent-from"   -> pushResentFrom ctx' jdom+    "resent-sender" -> pushResentSender ctx' jdom+    _               -> ctx'+  where+    ckey = L.map toLower key+    jdom = extractDomain val+    ctx' = ctx { praHeader = (ckey,val) : praHeader ctx }++{-|+  Deciding PRD from the RPD context.+-}+decidePRD :: PRD -> Maybe Domain+decidePRD ctx =+    let jds = [ praResentSender ctx+              , praResentFrom ctx+              , praSender ctx+              , praFrom ctx+              ]+    in foldl' mplus mzero $ map toMaybe jds+{-|+  Taking the value of From: from the RPD context.+-}+decideFrom :: PRD -> Maybe Domain+decideFrom = toMaybe . praFrom++toMaybe :: DST -> Maybe String+toMaybe (DST_Valid d) = Just d+toMaybe _             = Nothing++----------------------------------------------------------------++pushFrom :: PRD -> Maybe Domain -> PRD+pushFrom ctx Nothing    = ctx { praFrom = DST_Invalid }+pushFrom ctx (Just dom) = ctx { praFrom = from }+  where+    from = case praFrom ctx of+        DST_Zero -> DST_Valid dom+        _        -> DST_Invalid++pushSender :: PRD -> Maybe Domain -> PRD+pushSender ctx Nothing    = ctx { praSender = DST_Invalid }+pushSender ctx (Just dom) = ctx { praSender = sender }+  where+    sender = case praSender ctx of+        DST_Zero -> DST_Valid dom+        _        -> DST_Invalid++pushResentFrom :: PRD -> Maybe Domain -> PRD+pushResentFrom ctx Nothing    = ctx { praResentFrom = DST_Invalid }+pushResentFrom ctx (Just dom) = ctx { praResentFrom = rfrom }+  where+    rfrom = case praResentFrom ctx of+        DST_Zero    -> DST_Valid dom+        DST_Valid d -> DST_Valid d+        DST_Invalid -> DST_Invalid++pushResentSender :: PRD -> Maybe Domain -> PRD+pushResentSender ctx Nothing        = ctx { praResentSender = DST_Invalid }+pushResentSender ctx (Just dom)+    | praResentFrom ctx == DST_Zero = ctx { praResentSender = rsender }+    | isFirstBlock (praHeader ctx)  = ctx { praResentSender = DST_Valid dom }+    | otherwise                     = ctx { praResentSender = DST_Invalid }+  where+    rsender = case praResentSender ctx of+        DST_Zero    -> DST_Valid dom+        DST_Valid d -> DST_Valid d+        DST_Invalid -> DST_Invalid++isFirstBlock :: HD -> Bool+isFirstBlock hdr = all rr . takeWhile end $ hdr+  where+    end = (/= "resent-from") . fst+    rr  = (`notElem` ["received", "return-path"]) . fst
+ Network/DomainAuth/Pubkey/Base64.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.Pubkey.Base64 where++import Data.Bits (shiftL, shiftR, (.&.), (.|.))+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char (ord, chr, isAscii, isAlphaNum, isUpper, isLower, isDigit)+import Network.DomainAuth.Utils++decode :: L.ByteString -> L.ByteString+decode = dec . L.filter valid+  where+    valid c = isAscii c+              && (isAlphaNum c || (c `elem` "+/="))++dec :: L.ByteString -> L.ByteString+dec bs+    | L.null bs             = ""+    | len == 4 && c3 == '=' = L.take 1 (dec' x1 x2  0  0)+    | len == 4 && c4 == '=' = L.take 2 (dec' x1 x2 x3  0)+    | len >= 4              =           dec' x1 x2 x3 x4  +++ dec bs'+    | otherwise             = error "dec"+  where+    len = L.length bs+    c1 = bs !!! 0+    c2 = bs !!! 1+    c3 = bs !!! 2+    c4 = bs !!! 3+    x1 = fromChar c1+    x2 = fromChar c2+    x3 = fromChar c3+    x4 = fromChar c4+    bs' = L.drop 4 bs++dec' :: Int -> Int -> Int -> Int -> L.ByteString+dec' x1 x2 x3 x4 = L.pack [d1,d2,d3]+  where+    d1 = chr  ((x1 `shiftL` 2)           .|. (x2 `shiftR` 4))+    d2 = chr (((x2 `shiftL` 4) .&. 0xF0) .|. (x3 `shiftR` 2))+    d3 = chr (((x3 `shiftL` 6) .&. 0xC0) .|. x4)++fromChar :: Char -> Int+fromChar c+ | isUpper c = ord c - ord 'A'+ | isLower c = ord c - ord 'a' + 26+ | isDigit c = ord c - ord '0' + 52+ | c == '+'  = 62+ | c == '/'  = 63+ | otherwise = error ("fromChar: Can't happen: Bad input: " ++ show c)++splits :: Int -> [a] -> [[a]]+splits _ [] = []+splits n xs = case splitAt n xs of+                  (ys, zs) -> ys:splits n zs
+ Network/DomainAuth/Pubkey/Der.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.Pubkey.Der (+    decode+  , Class (..)+  , TLV (..)+  ) where++import Control.Applicative hiding (many)+import Control.Monad+import Data.Binary.Get+import Data.Bits+import qualified Data.ByteString.Lazy.Char8 as L++----------------------------------------------------------------++data TLV = Term+         | Prim { cls :: Class+                , tag :: Tag+                , siz :: Size+                , cnt :: L.ByteString+                }+         | Cons { cls :: Class+                , tag :: Tag+                , siz :: Size+                , tlv :: [TLV]+                }+         deriving Show++data Class = Univ | Appl | Cont | Priv deriving (Show, Eq, Enum)+type Tag  = Int+type Size = Int++----------------------------------------------------------------++decode :: L.ByteString -> TLV+decode = runGet der++----------------------------------------------------------------++der :: Get TLV+der = do+    first <- nonZero+    let clss = getClass first+        cons = getConstructor first+    tg <- getTag first+    len <- singleLength+    if cons+       then construct clss tg len+       else primitive clss tg len++primitive :: Class -> Tag -> Int -> Get TLV+primitive clss tg len = Prim clss tg len <$> getLazyByteString (fromIntegral len)++construct :: Class -> Tag -> Int -> Get TLV+construct = definite+    {-+    if len == indefiniteMark+    then indefinite clss tg len+    else definite clss tg len+    -}++definite :: Class -> Tag -> Int -> Get TLV+definite clss tg len = do+    start <- fromIntegral <$> bytesRead+    let end = start + len+    Cons clss tg len <$> withinLimit end []+  where+    withinLimit end ps = do+        p <- der+        end2 <- fromIntegral <$> bytesRead -- xxx+        if end2 == end+           then return (ps ++ [p])+           else withinLimit end (ps ++ [p])++{-+terminate :: Get TLV+terminate = Term <$ (zer0 >> zer0)++indefinite :: Class -> Tag -> Int -> Get TLV+indefinite clss tg len = Cons clss tg len <$> (many der <* terminate)+-}++getClass :: Int -> Class+getClass first = toEnum (shift (first .&. classMask) (- classShift)) :: Class++getConstructor :: Int -> Bool+getConstructor first = first .&. consFlag == consFlag++getTag :: Int -> Get Int+getTag first = if tg == tagMask+               then multiTag 0+               else return tg+  where+    tg = first .&. tagMask++multiTag :: Int -> Get Int+multiTag len = do+    i <- anyInt+    if (i .&. tagEnd) == 0+       then return (incTag len i)+       else multiTag (incTag len i)++incTag :: Int -> Int -> Int+incTag len i = len * 128 + (i .&. tagLenMask)++singleLength :: Get Int+singleLength = do+    second <- anyInt+    let multi = getMulti second+        len = getLen second+    if multi+       then definiteLength len+       else return len++getMulti :: Int -> Bool+getMulti second = second .&. lenFlag == lenFlag++getLen :: Int -> Int+getLen second = second .&. lenMask++definiteLength :: Int -> Get Int+definiteLength bytes = if bytes == 0+                       then return indefiniteMark+                       else multiLength 0 bytes++multiLength :: Int -> Int -> Get Int+multiLength len bytes = do+    i <- anyInt+    if bytes == 1+       then return (incLen len i)+       else multiLength (incLen len i) (bytes - 1)++incLen :: Int -> Int -> Int+incLen len i = len * 256 + i++----------------------------------------------------------------++anyInt :: Get Int+anyInt = fromIntegral <$> getWord8++nonZero :: Get Int+nonZero = do+    n <- anyInt+    when (n == 0) (error "nonZero")+    return n++{-+zer0 :: Get Int+zer0 = do+    n <- anyInt+    when (n /= 0) (error "zer0")+    return n+-}++----------------------------------------------------------------++classMask :: Int+classMask  = 0xc0+classShift :: Int+classShift = 6+consFlag :: Int+consFlag   = 0x20++tagMask :: Int+tagMask    = 0x1f+tagEnd :: Int+tagEnd     = 0x80+tagLenMask :: Int+tagLenMask = 0x7f++lenFlag :: Int+lenFlag    = 0x80+lenMask :: Int+lenMask    = 0x7f++indefiniteMark :: Int+indefiniteMark = -1 -- xxx
+ Network/DomainAuth/Pubkey/RSAPub.hs view
@@ -0,0 +1,37 @@+module Network.DomainAuth.Pubkey.RSAPub where++import Codec.Crypto.RSA+import Control.Applicative+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as LC (pack)+import Network.DNS (Domain)+import qualified Network.DNS as DNS hiding (Domain)+import Network.DomainAuth.Mail+import qualified Network.DomainAuth.Pubkey.Base64 as B+import qualified Network.DomainAuth.Pubkey.Der as D++lookupPublicKey :: DNS.Resolver -> Domain -> IO (Maybe PublicKey)+lookupPublicKey resolver domain = decode <$> lookupPublicKey' resolver domain+  where+    decode = (>>= return . decodeRSAPublicyKey)++lookupPublicKey' :: DNS.Resolver -> String -> IO (Maybe L.ByteString)+lookupPublicKey' resolver domain = extractPub <$> DNS.lookupTXT resolver domain++extractPub :: Maybe [L.ByteString] -> Maybe L.ByteString+extractPub = (>>= lookup (LC.pack "p") . parseTaggedValue . head)++decodeRSAPublicyKey :: L.ByteString -> PublicKey+decodeRSAPublicyKey bs = PublicKey size n e+  where+    subjectPublicKeyInfo = D.decode . B.decode $ bs+    [_, subjectPublicKey] = D.tlv subjectPublicKeyInfo+    rsaPublicKey = D.decode . bitString . D.cnt $ subjectPublicKey+    [bn',be'] = D.tlv rsaPublicKey+    bn = L.dropWhile (== 0) $ D.cnt bn'+    be = D.cnt be'+    n = toNum bn+    e = toNum be+    size = fromIntegral . L.length $ bn+    toNum = L.foldl' (\x y -> x*256 + fromIntegral y) 0+    bitString = L.tail
+ Network/DomainAuth/SPF.hs view
@@ -0,0 +1,33 @@+{-|+ A library for SPF(<http://www.ietf.org/rfc/rfc4408>)+ and Sender-ID(<http://www.ietf.org/rfc/rfc4406>).+-}+module Network.DomainAuth.SPF (+    runSPF+  , Limit(..)+  , defaultLimit+  ) where++import Data.IP+import Network.DNS (Domain, Resolver)+import Network.DomainAuth.Types+import Network.DomainAuth.SPF.Eval+import Network.DomainAuth.SPF.Resolver+import System.IO.Error++{-|+  Process SPF authentication. 'IP' is an IP address of an SMTP peer.+  If 'Domain' is specified from SMTP MAIL FROM, authentication is+  based on SPF. If 'Domain' is specified from the From field of mail+  header, authentication is based on SenderID. If condition reaches+  'Limit', 'SpfPermError' is returned.+-}+runSPF :: Limit -> Resolver -> Domain -> IP -> IO DAResult+runSPF lim resolver dom ip =+    (resolveSPF resolver dom ip >>= evalSPF lim ip) `catch` spfErrorHandle++spfErrorHandle :: IOError -> IO DAResult+spfErrorHandle e = case ioeGetErrorString e of+                     "TempError" -> return DATempError+                     "PermError" -> return DAPermError+                     _           -> return DANone
+ Network/DomainAuth/SPF/Eval.hs view
@@ -0,0 +1,101 @@+module Network.DomainAuth.SPF.Eval (evalSPF, Limit(..), defaultLimit) where++import Control.Applicative+import Data.IORef+import Data.IP+import Data.Maybe+import Network.DomainAuth.SPF.Types+import Network.DomainAuth.Types++{-|+  Limit for SPF authentication.+-}+data Limit = Limit {+    -- | How many \"redirect\"/\"include\" should be followed.+    limit :: Int+    -- | Ignoring IPv4 range whose mask length is shorter than this.+  , ipv4_masklen :: Int+    -- | Ignoring IPv6 range whose mask length is shorter than this.+  , ipv6_masklen :: Int+    -- | Whether or not \"+all\" is rejected.+  , reject_plus_all :: Bool+  }++{-|+  Default 'Limit'. 'limit' is 10. 'ipv4_masklen' is 16.+  'ipv6_masklen' is 48. 'reject_plus_all' is 'True'.+-}+defaultLimit :: Limit+defaultLimit = Limit {+    limit = 10+  , ipv4_masklen = 16+  , ipv6_masklen = 48+  , reject_plus_all = True+  }++----------------------------------------------------------------++evalSPF :: Limit -> IP -> [IO SpfSeq] -> IO DAResult+evalSPF lim ip ss = do+    ref <- newIORef (0 :: Int)+    fromJust <$> evalspf ref lim ip ss++----------------------------------------------------------------++evalspf :: IORef Int -> Limit -> IP -> [IO SpfSeq] -> IO (Maybe DAResult)+evalspf _ _ _ [] = return (Just DANeutral) -- default result+evalspf ref lim ip (s:ss) = do+    cnt <- readIORef ref+    if cnt > limit lim+       then return (Just DAPermError) -- reached the limit+       else do+           mres <- eval ref lim ip s+           case mres of+               Nothing  -> evalspf ref lim ip ss+               res      -> return res++----------------------------------------------------------------+{-+Follow N of redirect/include. But the last one is not+evaluated.+-}++eval :: IORef Int -> Limit -> IP -> IO SpfSeq -> IO (Maybe DAResult)+eval ref lim ip is = do+    cnt <- readIORef ref+    s <- is+    case s of+      SS_All q -> if q == Q_Pass && reject_plus_all lim+                  then result DAPermError+                  else ret q+      SS_IPv4Range q ipr+           | nastyMask4 lim ipr        -> result DAPermError+           | ipv4 ip `isMatchedTo` ipr -> ret q+           | otherwise                 -> continue+      SS_IPv4Ranges q iprs+           | any (nastyMask4 lim) iprs        -> result DAPermError+           | any (ipv4 ip `isMatchedTo`) iprs -> ret q+           | otherwise                        -> continue+      SS_IPv6Range q ipr+           | nastyMask6 lim ipr        -> result DAPermError+           | ipv6 ip `isMatchedTo` ipr -> ret q+           | otherwise                 -> continue+      SS_IPv6Ranges q iprs+           | any (nastyMask6 lim) iprs        -> result DAPermError+           | any (ipv6 ip `isMatchedTo`) iprs -> ret q+           | otherwise                        -> continue+      SS_IF_Pass q ss -> do+          writeIORef ref (cnt + 1)+          r <- evalspf ref lim ip ss+          if r == Just DAPass+            then ret q+            else continue+      SS_SpfSeq ss -> do+          writeIORef ref (cnt + 1)+          evalspf ref lim ip ss+  where+    ret = return . Just . toEnum . fromEnum+    result = return . Just+    continue = return Nothing+    nastyMask4 st ipr = mlen ipr < ipv4_masklen st+    nastyMask6 st ipr = mlen ipr < ipv6_masklen st
+ Network/DomainAuth/SPF/Parser.hs view
@@ -0,0 +1,97 @@+module Network.DomainAuth.SPF.Parser (parseSPF) where++import Control.Applicative+import qualified Data.ByteString.Lazy.Char8 as L+import Network.DNS (Domain)+import Network.DomainAuth.SPF.Types+import Prelude hiding (all)+import Text.Appar.LazyByteString++----------------------------------------------------------------++parseSPF :: L.ByteString  -> Maybe [SPF]+parseSPF = parse spf++----------------------------------------------------------------++spaces1 :: Parser ()+spaces1 = skipSome space++----------------------------------------------------------------++spf :: Parser [SPF]+spf = do spfPrefix+         some $ do spaces1+                    -- modifier should be first since + is optional+                   modifier <|> directive++spfPrefix :: Parser ()+spfPrefix = () <$ string "v=spf1"++----------------------------------------------------------------++modifier :: Parser SPF+modifier = SPF_Redirect <$> (string "redirect=" *> domain)++directive :: Parser SPF+directive = qualifier >>= mechanism++----------------------------------------------------------------++qualifier :: Parser Qualifier+qualifier = option Q_Pass (choice quals)+    where+      func sym res = res <$ char sym+      quals = zipWith func qualifierSymbol [minBound..maxBound]++----------------------------------------------------------------++type Directive = Qualifier -> Parser SPF++mechanism :: Directive+mechanism q = choice $ map ($ q) [ip4,ip6,all,address,mx,include]++ip4 :: Directive+ip4 q = try $ SPF_IPv4Range q . read <$> (string "ip4:" *> some (noneOf " "))++ip6 :: Directive+ip6 q = try $ SPF_IPv6Range q . read <$> (string "ip6:" *> some (noneOf " "))++all :: Directive+all q = try $ SPF_All q <$ string "all"++address :: Directive+address q = SPF_Address q <$> (string "a" *> optionalDomain)+                          <*> optionalMask++mx :: Directive+mx q = SPF_MX q <$> (string "mx" *> optionalDomain)+                <*> optionalMask++include :: Directive+include q = SPF_Include q <$> (string "include:" *> domain)++----------------------------------------------------------------++domain :: Parser String+domain = some (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_-.")++optionalDomain :: Parser (Maybe Domain)+optionalDomain = option Nothing (Just <$> (char ':' *> domain))++mask :: Parser Int+mask = read <$> (some . oneOf $ ['0'..'9'])++optionalMask :: Parser (Int,Int)+optionalMask = try both <|> try v4 <|> try v6 <|> none+  where+    both = (,) <$> ipv4Mask <*> ipv6Mask+    v4   = ipv4Mask >>= \l4 -> return (l4,128)+    v6   = ipv6Mask >>= \l6 -> return (32,l6)+    none = return (32,128)++ipv4Mask :: Parser Int+ipv4Mask = char '/' *> mask++ipv6Mask :: Parser Int+ipv6Mask = string "//" *> mask
+ Network/DomainAuth/SPF/Resolver.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.SPF.Resolver (resolveSPF) where++import Control.Applicative+import Control.Monad+import Data.IP+import qualified Data.ByteString.Lazy.Char8 as L+import Data.Maybe+import Network.DNS+import Network.DomainAuth.SPF.Parser+import Network.DomainAuth.SPF.Types++----------------------------------------------------------------++resolveSPF :: Resolver -> Domain -> IP -> IO [IO SpfSeq]+resolveSPF resolver dom ip = do+    jrc <- lookupTXT resolver dom+    checkDNS jrc "TempError"+    let rr = getSPFRR jrc+    checkExistence rr "None"+    let jrs = parseSPF rr+    checkSyntax jrs "PermError"+    let is = filterSPFWithIP ip (fromJust jrs)+    return $ map (toSpfSeq resolver dom ip) is+  where+    getSPFRR jrc = let ts = filter ("v=spf1" `L.isPrefixOf`) (fromJust jrc)+                   in if null ts then "" else head ts+    checkSyntax rs estr = when (isNothing rs) (fail estr)+    checkExistence rr estr = when (L.null rr) (fail estr)++----------------------------------------------------------------++filterSPFWithIP :: IP -> [SPF] -> [SPF]+filterSPFWithIP (IPv4 _) spfs = filter exceptIPv4 spfs+filterSPFWithIP (IPv6 _) spfs = filter exceptIPv6 spfs++exceptIPv4 :: SPF -> Bool+exceptIPv4 (SPF_IPv6Range _ _) = False+exceptIPv4 _                   = True++exceptIPv6 :: SPF -> Bool+exceptIPv6 (SPF_IPv4Range _ _) = False+exceptIPv6 _                   = True++----------------------------------------------------------------++toSpfSeq :: Resolver -> Domain -> IP -> SPF -> IO SpfSeq+toSpfSeq _ _ _  (SPF_IPv4Range q ipr) = return $ SS_IPv4Range q ipr+toSpfSeq _ _ _  (SPF_IPv6Range q ipr) = return $ SS_IPv6Range q ipr+toSpfSeq _ _ _  (SPF_All       q)     = return $ SS_All q+toSpfSeq r _ ip (SPF_Include   q dom) = SS_IF_Pass q <$> resolveSPF r dom ip+toSpfSeq r _ ip (SPF_Redirect dom)    = SS_SpfSeq <$> resolveSPF r dom ip++toSpfSeq r dom (IPv4 _) (SPF_MX q Nothing (l4,_))+    = lookupAviaMX r dom    >>= doit4 q l4+toSpfSeq r dom (IPv6 _) (SPF_MX q Nothing (_,l6))+    = lookupAAAAviaMX r dom >>= doit6 q l6+toSpfSeq r _   (IPv4 _) (SPF_MX q (Just dom) (l4,_))+    = lookupAviaMX r dom    >>= doit4 q l4+toSpfSeq r _   (IPv6 _) (SPF_MX q (Just dom) (_,l6))+    = lookupAAAAviaMX r dom >>= doit6 q l6+toSpfSeq r dom (IPv4 _) (SPF_Address q Nothing (l4,_))+    = lookupA r dom    >>= doit4 q l4+toSpfSeq r dom (IPv6 _) (SPF_Address q Nothing (_,l6))+    = lookupAAAA r dom >>= doit6 q l6+toSpfSeq r _   (IPv4 _) (SPF_Address q (Just dom) (l4,_))+    = lookupA r dom    >>= doit4 q l4+toSpfSeq r _   (IPv6 _) (SPF_Address q (Just dom) (_,l6))+    = lookupAAAA r dom >>= doit6 q l6++doit4 :: Qualifier -> Int -> Maybe [IPv4] -> IO SpfSeq+doit4 q l4 is = do+    checkDNS is "TempError"+    return $ SS_IPv4Ranges q $ map (mkr l4) $ fromJust is+  where+    mkr = flip makeAddrRange++doit6 :: Qualifier -> Int -> Maybe [IPv6] -> IO SpfSeq+doit6 q l6 is = do+    checkDNS is "TempError"+    return $ SS_IPv6Ranges q $ map (mkr l6) $ fromJust is+  where+    mkr = flip makeAddrRange++----------------------------------------------------------------++checkDNS :: Maybe a -> String -> IO ()+checkDNS jrc estr = when (isNothing jrc) (fail estr)
+ Network/DomainAuth/SPF/Types.hs view
@@ -0,0 +1,33 @@+module Network.DomainAuth.SPF.Types where++import Data.IP+import Network.DNS (Domain)++----------------------------------------------------------------++-- See DAResult in Network.DomainAuth.Types+data Qualifier = Q_Pass | Q_HardFail | Q_Softfail | Q_Neutral+                 deriving (Eq,Enum,Bounded,Show)++-- Depends on Qualifier+qualifierSymbol :: String+qualifierSymbol = "+-~?"++data SPF = SPF_IPv4Range Qualifier (AddrRange IPv4)+         | SPF_IPv6Range Qualifier (AddrRange IPv6)+         | SPF_Address   Qualifier (Maybe Domain) (Int,Int)+         | SPF_MX        Qualifier (Maybe Domain) (Int,Int)+         | SPF_Include   Qualifier Domain+         | SPF_All       Qualifier+         | SPF_Redirect            Domain+           deriving Show++----------------------------------------------------------------++data SpfSeq = SS_All        Qualifier+            | SS_IPv4Range  Qualifier (AddrRange IPv4)+            | SS_IPv6Range  Qualifier (AddrRange IPv6)+            | SS_IPv4Ranges Qualifier [AddrRange IPv4]+            | SS_IPv6Ranges Qualifier [AddrRange IPv6]+            | SS_IF_Pass    Qualifier [IO SpfSeq]+            | SS_SpfSeq               [IO SpfSeq]
+ Network/DomainAuth/Types.hs view
@@ -0,0 +1,40 @@+{-|+  Type for Message Authentication Status (<http://www.ietf.org/rfc/rfc5451.txt>).+-}++module Network.DomainAuth.Types where++----------------------------------------------------------------++{-|+  The result of domain authentication. For more information, see+  <http://www.ietf.org/rfc/rfc5451.txt>.+-}+-- See Qualifier in Network.DomainAuth.SPF.Types+data DAResult = DAPass+              | DAHardFail+              | DASoftFail+              | DANeutral+              | DAFail+              | DATempError+              | DAPermError+              | DANone+              | DAPolicy+              | DANxDomain+              | DADiscard+              | DAUnknown+              deriving (Eq,Enum,Bounded)++instance Show DAResult where+    show DAPass       = "pass"+    show DAHardFail   = "hardfail"+    show DASoftFail   = "fail"+    show DANeutral    = "neutral"+    show DAFail       = "fail"+    show DATempError  = "temperror"+    show DAPermError  = "permerror"+    show DANone       = "none"+    show DAPolicy     = "policy"+    show DANxDomain   = "nxdomain"+    show DADiscard    = "discard"+    show DAUnknown    = "unknown"
+ Network/DomainAuth/Utils.hs view
@@ -0,0 +1,100 @@+{-# LANGUAGE OverloadedStrings #-}++module Network.DomainAuth.Utils where++import qualified Data.ByteString.Lazy.Char8 as L+import Data.Char+import Data.Int++crlf :: L.ByteString+crlf = "\r\n"++(+++) :: L.ByteString -> L.ByteString -> L.ByteString+(+++) = L.append++(!!!) :: L.ByteString -> Int64 -> Char+(!!!) = L.index++----------------------------------------------------------------++appendCRLF :: L.ByteString -> L.ByteString -> L.ByteString+appendCRLF x y = x +++ crlf +++ y++appendCRLFWith :: (a -> L.ByteString) -> a -> L.ByteString -> L.ByteString+appendCRLFWith modify x y = modify x +++ crlf +++ y++concatCRLF :: [L.ByteString] -> L.ByteString+concatCRLF = foldr appendCRLF ""++concatCRLFWith :: (a -> L.ByteString) -> [a] -> L.ByteString+concatCRLFWith modify = foldr (appendCRLFWith modify) ""++----------------------------------------------------------------++{-|+  Replaces multiple WPSs to a single SP.+-}+reduceWSP :: Cook+reduceWSP "" = ""+reduceWSP bs+  | isSpace (L.head bs) = inSP bs+  | otherwise           = outSP bs++inSP :: Cook+inSP "" = ""+inSP bs = " " +++ outSP bs'+  where+    (_,bs') = L.span isSpace bs++outSP :: Cook+outSP "" = ""+outSP bs = nonSP +++ inSP bs'+  where+    (nonSP,bs') = L.break isSpace bs++----------------------------------------------------------------++type FWSRemover = L.ByteString -> L.ByteString++removeFWS :: FWSRemover+removeFWS = L.filter (not.isSpace)++----------------------------------------------------------------++type Cook = L.ByteString -> L.ByteString++removeTrailingWSP :: Cook+removeTrailingWSP bs+  | slowPath  = L.reverse . L.dropWhile isSpace . L.reverse $ bs  -- xxx+  | otherwise = bs+  where+    slowPath = hasTrailingWSP bs++hasTrailingWSP :: L.ByteString -> Bool+hasTrailingWSP bs+    | len == 0  = False+    | otherwise = isSpace lastChar+  where+    len = L.length bs+    lastChar = bs !!! (len - 1)++----------------------------------------------------------------++chop :: L.ByteString -> L.ByteString+chop "" = ""+chop bs+  | L.last bs == '\r' = L.init bs+  | otherwise         = bs++blines :: L.ByteString -> [L.ByteString]+blines = map chop . L.lines++----------------------------------------------------------------++break' :: Char -> L.ByteString -> (L.ByteString,L.ByteString)+break' c bs = (f,s)+  where+    (f,s') = L.break (==c) bs+    s = if s' == ""+        then ""+        else L.tail s'
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ domain-auth.cabal view
@@ -0,0 +1,53 @@+Name:                   domain-auth+Version:                0.1.0+Author:                 Kazu Yamamoto <kazu@iij.ad.jp>+Maintainer:             Kazu Yamamoto <kazu@iij.ad.jp>+License:                BSD3+License-File:           LICENSE+Synopsis:               Domain authentication library+Description:            Library for Sender Policy Framework, SenderID,+                        DomainKeys and DKIM.+Category:               Network+Cabal-Version:          >= 1.6+Build-Type:             Simple+library+  if impl(ghc >= 6.12)+    GHC-Options:        -Wall -fno-warn-unused-do-bind+  else+    GHC-Options:        -Wall+  Exposed-Modules:      Network.DomainAuth+                        Network.DomainAuth.Mail+                        Network.DomainAuth.DK+                        Network.DomainAuth.DKIM+                        Network.DomainAuth.SPF+                        Network.DomainAuth.PRD+                        Network.DomainAuth.Types+  Other-Modules:        Network.DomainAuth.Utils+                        Network.DomainAuth.Mail.Mail+                        Network.DomainAuth.Mail.Parser+                        Network.DomainAuth.Mail.Types+                        Network.DomainAuth.Mail.XMail+                        Network.DomainAuth.DK.Parser+                        Network.DomainAuth.DK.Types+                        Network.DomainAuth.DK.Verify+                        Network.DomainAuth.DKIM.Btag+                        Network.DomainAuth.DKIM.Parser+                        Network.DomainAuth.DKIM.Types+                        Network.DomainAuth.DKIM.Verify+                        Network.DomainAuth.Pubkey.Base64+                        Network.DomainAuth.Pubkey.Der+                        Network.DomainAuth.Pubkey.RSAPub+                        Network.DomainAuth.PRD.Domain+                        Network.DomainAuth.PRD.Lexer+                        Network.DomainAuth.PRD.PRD+                        Network.DomainAuth.SPF.Eval+                        Network.DomainAuth.SPF.Parser+                        Network.DomainAuth.SPF.Resolver+                        Network.DomainAuth.SPF.Types+  Build-Depends:        base >= 4 && < 5, appar, dns, iproute,+                        network, bytestring, RSA, binary,+                        containers, SHA+Source-Repository head+  Type:                 git+  Location:             git://github.com/kazu-yamamoto/domain-auth.git+