domain-auth 0.1.1 → 0.2.0
raw patch · 24 files changed
+289/−210 lines, 24 filesdep +blaze-builderPVP ok
version bump matches the API change (PVP)
Dependencies added: blaze-builder
API changes (from Hackage documentation)
+ Network.DomainAuth.Mail: isEmpty :: Body -> Bool
- Network.DomainAuth.DK: dkSelector :: DK -> String
+ Network.DomainAuth.DK: dkSelector :: DK -> ByteString
- Network.DomainAuth.DKIM: dkimSelector :: DKIM -> String
+ Network.DomainAuth.DKIM: dkimSelector :: DKIM -> ByteString
- Network.DomainAuth.Mail: fromBody :: Body -> ByteString
+ Network.DomainAuth.Mail: fromBody :: Body -> Builder
- Network.DomainAuth.Mail: fromBodyWith :: (ByteString -> ByteString) -> Body -> ByteString
+ Network.DomainAuth.Mail: fromBodyWith :: (ByteString -> ByteString) -> Body -> Builder
Files
- Network/DomainAuth/DK.hs +5/−1
- Network/DomainAuth/DK/Parser.hs +8/−7
- Network/DomainAuth/DK/Types.hs +8/−8
- Network/DomainAuth/DK/Verify.hs +12/−8
- Network/DomainAuth/DKIM.hs +5/−1
- Network/DomainAuth/DKIM/Btag.hs +2/−2
- Network/DomainAuth/DKIM/Parser.hs +11/−10
- Network/DomainAuth/DKIM/Types.hs +9/−9
- Network/DomainAuth/DKIM/Verify.hs +13/−13
- Network/DomainAuth/Mail.hs +1/−0
- Network/DomainAuth/Mail/Mail.hs +10/−7
- Network/DomainAuth/Mail/Parser.hs +38/−39
- Network/DomainAuth/Mail/Types.hs +17/−13
- Network/DomainAuth/Mail/XMail.hs +2/−2
- Network/DomainAuth/PRD/Domain.hs +3/−2
- Network/DomainAuth/PRD/Lexer.hs +1/−1
- Network/DomainAuth/PRD/PRD.hs +3/−3
- Network/DomainAuth/Pubkey/Base64.hs +40/−26
- Network/DomainAuth/Pubkey/Der.hs +5/−4
- Network/DomainAuth/Pubkey/RSAPub.hs +16/−11
- Network/DomainAuth/SPF/Parser.hs +6/−5
- Network/DomainAuth/SPF/Resolver.hs +3/−3
- Network/DomainAuth/Utils.hs +69/−33
- domain-auth.cabal +2/−2
Network/DomainAuth/DK.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ {-| A library for DomainKeys (<http://www.ietf.org/rfc/rfc4070>). Currently, only receiver side is implemented.@@ -22,6 +24,7 @@ import Network.DomainAuth.Mail import Network.DomainAuth.Pubkey.RSAPub import Network.DomainAuth.Types+import qualified Data.ByteString as BS (append) {-| Verifying 'Mail' with DomainKeys.@@ -41,5 +44,6 @@ runDK' resolver mail dk = maybe DATempError (verify mail dk) <$> pub where pub = lookupPublicKey resolver dom- dom = dkSelector dk ++ "._domainkey." ++ dkDomain dk+ dom = dkSelector dk +++ "._domainkey." +++ dkDomain dk verify m d p = if verifyDK m d p then DAPass else DAFail+ (+++) = BS.append
Network/DomainAuth/DK/Parser.hs view
@@ -2,7 +2,8 @@ module Network.DomainAuth.DK.Parser where -import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS import Data.List import qualified Data.Map as M import Data.Maybe@@ -18,7 +19,7 @@ where (ts,vs) = unzip $ parseTaggedValue val fs = map tagToSetter ts- tagToSetter tag = fromMaybe (\_ mdk -> mdk) $ lookup (L.head tag) dkTagDB+ tagToSetter tag = fromMaybe (\_ mdk -> mdk) $ lookup (BS.head tag) dkTagDB pfs = zipWith ($) fs vs domkey = foldr ($) initialMDK pfs toDK mdk = do@@ -38,11 +39,11 @@ data MDK = MDK { mdkAlgorithm :: Maybe DkAlgorithm- , mdkSignature :: Maybe L.ByteString+ , mdkSignature :: Maybe ByteString , mdkCanonAlgo :: Maybe DkCanonAlgo- , mdkDomain :: Maybe L.ByteString+ , mdkDomain :: Maybe ByteString , mdkFields :: Maybe DkFields- , mdkSelector :: Maybe L.ByteString+ , mdkSelector :: Maybe ByteString } deriving (Eq,Show) initialMDK :: MDK@@ -55,7 +56,7 @@ , mdkSelector = Nothing } -type DKSetter = L.ByteString -> MDK -> MDK+type DKSetter = ByteString -> MDK -> MDK dkTagDB :: [(Char,DKSetter)] dkTagDB = [@@ -86,7 +87,7 @@ setDkFields :: DKSetter setDkFields keys dk = dk { mdkFields = Just mx } where- flds = L.split ':' keys+ flds = BS.split ':' keys mx = foldl' func M.empty flds func m fld = M.insert fld True m
Network/DomainAuth/DK/Types.hs view
@@ -2,7 +2,7 @@ module Network.DomainAuth.DK.Types where -import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString) import qualified Data.Map as M import Network.DNS import Network.DomainAuth.Mail@@ -20,7 +20,7 @@ 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+type DkFields = M.Map ByteString Bool -- Key Bool {-| Abstract type for DomainKey-Signature:@@ -28,22 +28,22 @@ data DK = DK { dkAlgorithm :: DkAlgorithm- , dkSignature :: L.ByteString+ , dkSignature :: ByteString , dkCanonAlgo :: DkCanonAlgo- , dkDomain0 :: L.ByteString+ , dkDomain0 :: ByteString , dkFields :: Maybe DkFields -- , dkQuery :: Maybe DkQuery -- gmail does not provide, sigh- , dkSelector0 :: L.ByteString+ , dkSelector0 :: ByteString } deriving (Eq,Show) {-| Getting of the value of the \"d\" tag in DomainKey-Signature:. -} dkDomain :: DK -> Domain-dkDomain = L.unpack . dkDomain0+dkDomain = dkDomain0 {-| Getting of the value of the \"s\" tag in DomainKey-Signature:. -}-dkSelector :: DK -> String-dkSelector = L.unpack . dkSelector0+dkSelector :: DK -> ByteString+dkSelector = dkSelector0
Network/DomainAuth/DK/Verify.hs view
@@ -4,8 +4,9 @@ verifyDK, prepareDK ) where +import Blaze.ByteString.Builder import Codec.Crypto.RSA-import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString) import qualified Data.Map as M import Network.DomainAuth.DK.Types import Network.DomainAuth.Mail@@ -14,23 +15,26 @@ ---------------------------------------------------------------- -prepareDK :: DK -> Mail -> L.ByteString+prepareDK :: DK -> Mail -> Builder 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'+ cmail = if isEmpty (mailBody mail) then+ header'+ else+ header' `appendCRLF` body' ---------------------------------------------------------------- -canonDkHeader :: DK -> Header -> L.ByteString+canonDkHeader :: DK -> Header -> Builder canonDkHeader dk hdr = concatCRLFWith (canonDkField calgo) flds where calgo = dkCanonAlgo dk hFields = dkFields dk flds = prepareDkHeader hFields hdr -canonDkField :: DkCanonAlgo -> Field -> L.ByteString+canonDkField :: DkCanonAlgo -> Field -> ByteString canonDkField DK_SIMPLE fld = fieldKey fld +++ ": " +++ fieldValueFolded fld canonDkField DK_NOFWS fld = fieldKey fld +++ ":" +++ removeFWS (fieldValueUnfolded fld) @@ -42,7 +46,7 @@ ---------------------------------------------------------------- -canonDkBody :: DkCanonAlgo -> Body -> L.ByteString+canonDkBody :: DkCanonAlgo -> Body -> Builder canonDkBody DK_SIMPLE = fromBody . removeTrailingEmptyLine canonDkBody DK_NOFWS = fromBodyWith removeFWS . removeTrailingEmptyLine @@ -51,5 +55,5 @@ 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+ sig = B.decode . dkSignature $ dk+ cmail = toLazyByteString (prepareDK dk mail)
Network/DomainAuth/DKIM.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ {-| A library for DKIM (<http://www.ietf.org/rfc/rfc4071>). Currently, only receiver side is implemented.@@ -14,6 +16,7 @@ , dkimFieldKey ) where +import qualified Data.ByteString as BS import Control.Applicative import Network.DNS as DNS (Resolver) import Network.DomainAuth.DKIM.Parser@@ -41,5 +44,6 @@ runDKIM' resolver mail dkim = maybe DATempError (verify mail dkim) <$> pub where pub = lookupPublicKey resolver dom- dom = dkimSelector dkim ++ "._domainkey." ++ dkimDomain dkim+ dom = dkimSelector dkim +++ "._domainkey." +++ dkimDomain dkim verify m d p = if verifyDKIM m d p then DAPass else DAFail+ (+++) = BS.append
Network/DomainAuth/DKIM/Btag.hs view
@@ -1,8 +1,8 @@ module Network.DomainAuth.DKIM.Btag where -import Data.ByteString.Lazy.Char8+import Data.ByteString.Char8 import Data.Maybe-import Text.Appar.LazyByteString+import Text.Appar.ByteString removeBtagValue :: ByteString -> ByteString removeBtagValue = pack . fromMaybe "" . parse remBtagValue
Network/DomainAuth/DKIM/Parser.hs view
@@ -3,7 +3,8 @@ module Network.DomainAuth.DKIM.Parser where import Control.Applicative-import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS import Data.Maybe import Network.DomainAuth.DKIM.Types import Network.DomainAuth.Mail@@ -17,7 +18,7 @@ where (ts,vs) = unzip $ parseTaggedValue val fs = map tagToSetter ts- tagToSetter tag = fromMaybe (\_ mdkim -> mdkim) $ lookup (L.unpack tag) dkimTagDB+ tagToSetter tag = fromMaybe (\_ mdkim -> mdkim) $ lookup (BS.unpack tag) dkimTagDB pfs = zipWith ($) fs vs domkey = foldr ($) initialMDKIM pfs toDKIM mdkim = do@@ -44,16 +45,16 @@ } data MDKIM = MDKIM {- mdkimVersion :: Maybe L.ByteString+ mdkimVersion :: Maybe ByteString , mdkimSigAlgo :: Maybe DkimSigAlgo- , mdkimSignature :: Maybe L.ByteString- , mdkimBodyHash :: Maybe L.ByteString+ , mdkimSignature :: Maybe ByteString+ , mdkimBodyHash :: Maybe ByteString , mdkimHeaderCanon :: Maybe DkimCanonAlgo , mdkimBodyCanon :: Maybe DkimCanonAlgo- , mdkimDomain :: Maybe L.ByteString+ , mdkimDomain :: Maybe ByteString , mdkimFields :: Maybe [CanonFieldKey] , mdkimLength :: Maybe Int- , mdkimSelector :: Maybe L.ByteString+ , mdkimSelector :: Maybe ByteString } deriving (Eq,Show) initialMDKIM :: MDKIM@@ -70,7 +71,7 @@ , mdkimSelector = Nothing } -type DKIMSetter = L.ByteString -> MDKIM -> MDKIM+type DKIMSetter = ByteString -> MDKIM -> MDKIM dkimTagDB :: [(String,DKIMSetter)] dkimTagDB = [@@ -128,10 +129,10 @@ setDkimFields :: DKIMSetter setDkimFields keys dkim = dkim { mdkimFields = Just flds } where- flds = map canonicalizeKey $ L.split ':' keys+ flds = map canonicalizeKey $ BS.split ':' keys setDkimLength :: DKIMSetter-setDkimLength len dkim = dkim { mdkimLength = fst <$> L.readInt len }+setDkimLength len dkim = dkim { mdkimLength = fst <$> BS.readInt len } setDkimSelector :: DKIMSetter setDkimSelector sel dkim = dkim { mdkimSelector = Just sel }
Network/DomainAuth/DKIM/Types.hs view
@@ -2,7 +2,7 @@ module Network.DomainAuth.DKIM.Types where -import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString) import Network.DNS import Network.DomainAuth.Mail @@ -20,26 +20,26 @@ data DkimCanonAlgo = DKIM_SIMPLE | DKIM_RELAXED deriving (Eq,Show) data DKIM = DKIM {- dkimVersion :: L.ByteString+ dkimVersion :: ByteString , dkimSigAlgo :: DkimSigAlgo- , dkimSignature :: L.ByteString- , dkimBodyHash :: L.ByteString+ , dkimSignature :: ByteString+ , dkimBodyHash :: ByteString , dkimHeaderCanon :: DkimCanonAlgo , dkimBodyCanon :: DkimCanonAlgo- , dkimDomain0 :: L.ByteString+ , dkimDomain0 :: ByteString , dkimFields :: [CanonFieldKey] , dkimLength :: Maybe Int- , dkimSelector0 :: L.ByteString+ , dkimSelector0 :: ByteString } deriving (Eq,Show) {-| Getting of the value of the \"d\" tag in DKIM-Signature:. -} dkimDomain :: DKIM -> Domain-dkimDomain = L.unpack . dkimDomain0+dkimDomain = dkimDomain0 {-| Getting of the value of the \"s\" tag in DKIM-Signature:. -}-dkimSelector :: DKIM -> String-dkimSelector = L.unpack . dkimSelector0+dkimSelector :: DKIM -> ByteString+dkimSelector = dkimSelector0
Network/DomainAuth/DKIM/Verify.hs view
@@ -4,9 +4,11 @@ verifyDKIM, prepareDKIM ) where +import Blaze.ByteString.Builder import Codec.Crypto.RSA-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL import Data.Digest.Pure.SHA import Network.DomainAuth.DKIM.Btag import Network.DomainAuth.DKIM.Types@@ -16,26 +18,26 @@ ---------------------------------------------------------------- -prepareDKIM :: DKIM -> Mail -> L.ByteString+prepareDKIM :: DKIM -> Mail -> Builder prepareDKIM dkim mail = header where dkimField:fields = fieldsFrom dkimFieldKey (mailHeader mail) hCanon = canonDkimField (dkimHeaderCanon dkim)- canon = removeBtagValue . hCanon+ canon = fromByteString . removeBtagValue . hCanon targets = fieldsWith (dkimFields dkim) fields header = concatCRLFWith hCanon targets +++ canon dkimField ---------------------------------------------------------------- -canonDkimField :: DkimCanonAlgo -> Field -> L.ByteString+canonDkimField :: DkimCanonAlgo -> Field -> 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+ canon = BS.dropWhile isSpace . removeTrailingWSP . reduceWSP . BS.concat . fieldValue ---------------------------------------------------------------- -canonDkimBody :: DkimCanonAlgo -> Body -> L.ByteString+canonDkimBody :: DkimCanonAlgo -> Body -> Builder canonDkimBody DKIM_SIMPLE = fromBody . removeTrailingEmptyLine canonDkimBody DKIM_RELAXED = fromBodyWith relax . removeTrailingEmptyLine where@@ -49,17 +51,15 @@ where hashfunc = hashAlgo1 (dkimSigAlgo dkim) hashfunc2 = hashAlgo2 (dkimSigAlgo dkim)- sig = B.decode (dkimSignature dkim)- cmail = prepareDKIM dkim mail- bodyHash1 = hashfunc2 . canonDkimBody (dkimBodyCanon dkim) . mailBody+ sig = B.decode . dkimSignature $ dkim+ cmail = toLazyByteString (prepareDKIM dkim mail)+ bodyHash1 = hashfunc2 . toLazyByteString . 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 -> L.ByteString+hashAlgo2 :: DkimSigAlgo -> BL.ByteString -> BL.ByteString hashAlgo2 RSA_SHA1 = bytestringDigest . sha1 hashAlgo2 RSA_SHA256 = bytestringDigest . sha256--
Network/DomainAuth/Mail.hs view
@@ -27,6 +27,7 @@ , fieldValueFolded , fieldValueUnfolded -- ** Functions to manipulate 'Body'+ , isEmpty , fromBody , fromBodyWith , removeTrailingEmptyLine
Network/DomainAuth/Mail/Mail.hs view
@@ -2,12 +2,15 @@ module Network.DomainAuth.Mail.Mail where -import qualified Data.ByteString.Lazy.Char8 as L+import Blaze.ByteString.Builder+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS 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+import Network.DomainAuth.Utils hiding (empty)+import qualified Network.DomainAuth.Utils as B (empty) ---------------------------------------------------------------- @@ -57,21 +60,21 @@ -- | Obtaining folded (raw) field value. fieldValueFolded :: Field -> RawFieldValue-fieldValueFolded = concatCRLF . fieldValue+fieldValueFolded = toByteString . concatCRLF . fieldValue -- | Obtaining unfolded (removing CRLF) field value. fieldValueUnfolded :: Field -> RawFieldValue-fieldValueUnfolded = L.concat . fieldValue+fieldValueUnfolded = BS.concat . fieldValue ---------------------------------------------------------------- -- | Obtaining body.-fromBody :: Body -> L.ByteString+fromBody :: Body -> Builder fromBody = fromBodyWith id -- | Obtaining body with a canonicalization function.-fromBodyWith :: (L.ByteString -> L.ByteString) -> Body -> L.ByteString-fromBodyWith modify = F.foldr (appendCRLFWith modify) ""+fromBodyWith :: (ByteString -> ByteString) -> Body -> Builder+fromBodyWith modify = F.foldr (appendCRLFWith modify) B.empty -- | Removing trailing empty lines. removeTrailingEmptyLine :: Body -> Body
Network/DomainAuth/Mail/Parser.hs view
@@ -3,9 +3,8 @@ module Network.DomainAuth.Mail.Parser where import Control.Applicative-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char-import Data.Int+import qualified Data.ByteString as BS+import Data.Word import Network.DomainAuth.Mail.Types import Network.DomainAuth.Mail.XMail import Network.DomainAuth.Utils@@ -14,7 +13,7 @@ -- | Obtain 'Mail' from a file. readMail :: FilePath -> IO Mail-readMail file = getMail <$> L.readFile file+readMail file = getMail <$> BS.readFile file ---------------------------------------------------------------- @@ -33,33 +32,33 @@ splitHeaderBody :: RawMail -> (RawHeader,RawBody) splitHeaderBody bs = case mcnt of Nothing -> (bs,"")- Just cnt -> check (L.splitAt cnt bs)+ Just cnt -> check (BS.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+ | otherwise = if b1 == cCR then bdy3 else bdy2 where- len = L.length bdy- b1 = L.head bdy- bdy2 = L.tail bdy- bdy3 = L.tail bdy2+ len = BS.length bdy+ b1 = BS.head bdy+ bdy2 = BS.tail bdy+ bdy3 = BS.tail bdy2 -findEOH :: RawMail -> Int64 -> Maybe Int64+findEOH :: RawMail -> Int -> Maybe Int 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)+ | b0 == cLF && bs1 /= "" && b1 == cLF = Just (cnt + 1)+ | b0 == cLF && bs1 /= "" && b1 == cCR+ && bs2 /= "" && b2 == cLF = 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+ b0 = BS.head bs+ bs1 = BS.tail bs+ b1 = BS.head bs1+ bs2 = BS.tail bs1+ b2 = BS.head bs2 ---------------------------------------------------------------- @@ -67,40 +66,40 @@ 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'+ -- split before cLF for efficiency+ (fld,bs') = BS.splitAt (findFieldEnd bs 0 - 1) bs+ bs'' = BS.tail bs' -findFieldEnd :: RawMail -> Int64 -> Int64+findFieldEnd :: RawMail -> Int -> Int findFieldEnd bs cnt | bs == "" = cnt- | b == '\n' = begOfLine bs' (cnt + 1)+ | b == cLF = begOfLine bs' (cnt + 1) | otherwise = findFieldEnd bs' (cnt + 1) where- b = L.head bs- bs' = L.tail bs+ b = BS.head bs+ bs' = BS.tail bs -begOfLine :: RawMail -> Int64 -> Int64+begOfLine :: RawMail -> Int -> Int begOfLine bs cnt | bs == "" = cnt | isContinued b = findFieldEnd bs' (cnt + 1) | otherwise = cnt where- b = L.head bs- bs' = L.tail bs+ b = BS.head bs+ bs' = BS.tail bs -isContinued :: Char -> Bool-isContinued c = c `elem` " \t"+isContinued :: Word8 -> Bool+isContinued = isSpace ---------------------------------------------------------------- parseField :: RawField -> (RawFieldKey,RawFieldValue) parseField bs = (k,v') where- (k,v) = break' ':' bs+ (k,v) = break' cColon bs -- Sendmail drops ' ' after ':'.- v' = if v /= "" && L.head v == ' '- then L.tail v+ v' = if v /= "" && BS.head v == cSP+ then BS.tail v else v ----------------------------------------------------------------@@ -109,9 +108,9 @@ Parsing field value of tag=value. -} -- This breaks spaces in the note tag.-parseTaggedValue :: RawFieldValue -> [(L.ByteString,L.ByteString)]+parseTaggedValue :: RawFieldValue -> [(BS.ByteString,BS.ByteString)] parseTaggedValue xs = vss where- v = L.filter (not.isSpace) xs- vs = filter (/= "") $ L.split ';' v- vss = map (break' '=') vs+ v = BS.filter (not.isSpace) xs+ vs = filter (/= "") $ BS.split cSemiColon v+ vss = map (break' cEqual) vs
Network/DomainAuth/Mail/Types.hs view
@@ -1,21 +1,22 @@ module Network.DomainAuth.Mail.Types where -import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as BS 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+type RawMail = ByteString+type RawHeader = ByteString+type RawBody = ByteString+type RawField = ByteString -- | Field key for raw e-mail message.-type RawFieldKey = L.ByteString+type RawFieldKey = ByteString -- | Field value for raw e-mail message.-type RawFieldValue = L.ByteString+type RawFieldValue = ByteString -- | Body chunk for raw e-mail message.-type RawBodyChunk = L.ByteString+type RawBodyChunk = ByteString ---------------------------------------------------------------- @@ -27,6 +28,9 @@ , mailBody :: Body } deriving (Eq,Show) +isEmpty :: Body -> Bool+isEmpty = (== empty)+ {-| Header type for parsed e-mail message. -}@@ -42,16 +46,16 @@ } deriving (Eq,Show) -- | Type for canonicalized field key of parsed e-mail message.-type CanonFieldKey = L.ByteString+type CanonFieldKey = ByteString -- | Type for field key of parsed e-mail message.-type FieldKey = L.ByteString+type FieldKey = ByteString -- | Type for field value of parsed e-mail message.-type FieldValue = [L.ByteString]+type FieldValue = [ByteString] -- | Type for body of parsed e-mail message.-type Body = Seq L.ByteString+type Body = Seq ByteString ---------------------------------------------------------------- -- | Canonicalizing 'FieldKey' for search. canonicalizeKey :: FieldKey -> CanonFieldKey-canonicalizeKey = L.map toLower+canonicalizeKey = BS.map toLower
Network/DomainAuth/Mail/XMail.hs view
@@ -1,6 +1,6 @@ module Network.DomainAuth.Mail.XMail where -import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as BS import Data.Sequence (fromList) import Network.DomainAuth.Mail.Types import Network.DomainAuth.Utils@@ -36,5 +36,5 @@ finalizeMail :: XMail -> Mail finalizeMail xmail = Mail { mailHeader = reverse . xmailHeader $ xmail- , mailBody = fromList . blines . L.concat . reverse . xmailBody $ xmail+ , mailBody = fromList . blines . BS.concat . reverse . xmailBody $ xmail }
Network/DomainAuth/PRD/Domain.hs view
@@ -3,7 +3,8 @@ import Network.DNS (Domain) import Network.DomainAuth.Mail import Network.DomainAuth.PRD.Lexer-import Text.Appar.LazyByteString+import Text.Appar.ByteString+import qualified Data.ByteString.Char8 as BS {-| Extract a domain from a value of a header field.@@ -14,4 +15,4 @@ where takeDomain = dropTail . dropWhile (/="@") dropTail [] = Nothing- dropTail xs = (Just . concat . takeWhile (/=">") . tail) xs+ dropTail xs = (Just . BS.pack . concat . takeWhile (/=">") . tail) xs
Network/DomainAuth/PRD/Lexer.hs view
@@ -2,7 +2,7 @@ structured ) where -import Text.Appar.LazyByteString+import Text.Appar.ByteString ----------------------------------------------------------------
Network/DomainAuth/PRD/PRD.hs view
@@ -11,7 +11,7 @@ ) where import Control.Monad-import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as BS import Data.Char import Data.List (foldl') import Network.DNS (Domain)@@ -61,7 +61,7 @@ "resent-sender" -> pushResentSender ctx' jdom _ -> ctx' where- ckey = L.map toLower key+ ckey = BS.map toLower key jdom = extractDomain val ctx' = ctx { praHeader = (ckey,val) : praHeader ctx } @@ -82,7 +82,7 @@ decideFrom :: PRD -> Maybe Domain decideFrom = toMaybe . praFrom -toMaybe :: DST -> Maybe String+toMaybe :: DST -> Maybe Domain toMaybe (DST_Valid d) = Just d toMaybe _ = Nothing
Network/DomainAuth/Pubkey/Base64.hs view
@@ -2,26 +2,29 @@ module Network.DomainAuth.Pubkey.Base64 where +import Blaze.ByteString.Builder import Data.Bits (shiftL, shiftR, (.&.), (.|.))-import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char (ord, chr, isAscii, isAlphaNum, isUpper, isLower, isDigit)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BL+import Data.Word import Network.DomainAuth.Utils -decode :: L.ByteString -> L.ByteString-decode = dec . L.filter valid- where- valid c = isAscii c- && (isAlphaNum c || (c `elem` "+/="))+isBase64 :: Word8 -> Bool+isBase64 c = isAlphaNum c || (c `elem` [cPlus,cSlash,cEqual]) -dec :: L.ByteString -> L.ByteString+decode :: ByteString -> BL.ByteString+decode = toLazyByteString . dec . BS.filter isBase64++dec :: ByteString -> Builder 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"+ | BS.null bs = empty+ | len == 4 && c3 == cEqual = dec1' x1 x2+ | len == 4 && c4 == cEqual = dec2' x1 x2 x3+ | len >= 4 = dec' x1 x2 x3 x4 +++ dec bs'+ | otherwise = error "dec" where- len = L.length bs+ len = BS.length bs c1 = bs !!! 0 c2 = bs !!! 1 c3 = bs !!! 2@@ -30,22 +33,33 @@ x2 = fromChar c2 x3 = fromChar c3 x4 = fromChar c4- bs' = L.drop 4 bs+ bs' = BS.drop 4 bs -dec' :: Int -> Int -> Int -> Int -> L.ByteString-dec' x1 x2 x3 x4 = L.pack [d1,d2,d3]+dec' :: Word8 -> Word8 -> Word8 -> Word8 -> Builder+dec' x1 x2 x3 x4 = fromWord8s [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)+ d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4)+ d2 = ((x2 `shiftL` 4) .&. 0xF0) .|. (x3 `shiftR` 2)+ d3 = ((x3 `shiftL` 6) .&. 0xC0) .|. x4 -fromChar :: Char -> Int+dec1' :: Word8 -> Word8 -> Builder+dec1' x1 x2 = fromWord8 d1+ where+ d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4)++dec2' :: Word8 -> Word8 -> Word8 -> Builder+dec2' x1 x2 x3 = fromWord8s [d1,d2]+ where+ d1 = (x1 `shiftL` 2) .|. (x2 `shiftR` 4)+ d2 = ((x2 `shiftL` 4) .&. 0xF0) .|. (x3 `shiftR` 2)++fromChar :: Word8 -> Word8 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+ | isUpper c = c - cA+ | isLower c = c - cSmallA + 26+ | isDigit c = c - cZero + 52+ | c == cPlus = 62+ | c == cSlash = 63 | otherwise = error ("fromChar: Can't happen: Bad input: " ++ show c) splits :: Int -> [a] -> [[a]]
Network/DomainAuth/Pubkey/Der.hs view
@@ -10,7 +10,8 @@ import Control.Monad import Data.Binary.Get import Data.Bits-import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BL ---------------------------------------------------------------- @@ -18,7 +19,7 @@ | Prim { cls :: Class , tag :: Tag , siz :: Size- , cnt :: L.ByteString+ , cnt :: ByteString } | Cons { cls :: Class , tag :: Tag@@ -33,7 +34,7 @@ ---------------------------------------------------------------- -decode :: L.ByteString -> TLV+decode :: BL.ByteString -> TLV decode = runGet der ----------------------------------------------------------------@@ -50,7 +51,7 @@ else primitive clss tg len primitive :: Class -> Tag -> Int -> Get TLV-primitive clss tg len = Prim clss tg len <$> getLazyByteString (fromIntegral len)+primitive clss tg len = Prim clss tg len <$> getByteString (fromIntegral len) construct :: Class -> Tag -> Int -> Get TLV construct = definite
Network/DomainAuth/Pubkey/RSAPub.hs view
@@ -1,9 +1,13 @@+{-# LANGUAGE OverloadedStrings #-}+ 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 Data.ByteString (ByteString)+import qualified Data.ByteString as BS (foldl', dropWhile, length, tail)+import qualified Data.ByteString.Char8 as BS ()+import qualified Data.ByteString.Lazy as BL import Network.DNS (Domain) import qualified Network.DNS as DNS hiding (Domain) import Network.DomainAuth.Mail@@ -15,23 +19,24 @@ where decode = (>>= return . decodeRSAPublicyKey) -lookupPublicKey' :: DNS.Resolver -> String -> IO (Maybe L.ByteString)+lookupPublicKey' :: DNS.Resolver -> Domain -> IO (Maybe ByteString) lookupPublicKey' resolver domain = extractPub <$> DNS.lookupTXT resolver domain -extractPub :: Maybe [L.ByteString] -> Maybe L.ByteString-extractPub = (>>= lookup (LC.pack "p") . parseTaggedValue . head)+extractPub :: Maybe [ByteString] -> Maybe ByteString+extractPub = (>>= lookup "p" . parseTaggedValue . head) -decodeRSAPublicyKey :: L.ByteString -> PublicKey+decodeRSAPublicyKey :: 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+ rsaPublicKey = D.decode . toLazy . bitString . D.cnt $ subjectPublicKey [bn',be'] = D.tlv rsaPublicKey- bn = L.dropWhile (== 0) $ D.cnt bn'+ bn = BS.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+ size = fromIntegral . BS.length $ bn+ toNum = BS.foldl' (\x y -> x*256 + fromIntegral y) 0+ bitString = BS.tail+ toLazy x = BL.fromChunks [x]
Network/DomainAuth/SPF/Parser.hs view
@@ -1,14 +1,15 @@ module Network.DomainAuth.SPF.Parser (parseSPF) where -import qualified Data.ByteString.Lazy.Char8 as L+import Data.ByteString (ByteString)+import Data.ByteString.Char8 as BS (pack) import Network.DNS (Domain) import Network.DomainAuth.SPF.Types import Prelude hiding (all)-import Text.Appar.LazyByteString+import Text.Appar.ByteString ---------------------------------------------------------------- -parseSPF :: L.ByteString -> Maybe [SPF]+parseSPF :: ByteString -> Maybe [SPF] parseSPF = parse spf ----------------------------------------------------------------@@ -72,8 +73,8 @@ ---------------------------------------------------------------- -domain :: Parser String-domain = some (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_-.")+domain :: Parser Domain+domain = BS.pack <$> some (oneOf $ ['a'..'z'] ++ ['A'..'Z'] ++ ['0'..'9'] ++ "_-.") optionalDomain :: Parser (Maybe Domain) optionalDomain = option Nothing (Just <$> (char ':' *> domain))
Network/DomainAuth/SPF/Resolver.hs view
@@ -5,7 +5,7 @@ import Control.Applicative import Control.Monad import Data.IP-import qualified Data.ByteString.Lazy.Char8 as L+import qualified Data.ByteString.Char8 as BS import Data.Maybe import Network.DNS import Network.DomainAuth.SPF.Parser@@ -24,10 +24,10 @@ 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)+ getSPFRR jrc = let ts = filter ("v=spf1" `BS.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)+ checkExistence rr estr = when (BS.null rr) (fail estr) ----------------------------------------------------------------
Network/DomainAuth/Utils.hs view
@@ -2,33 +2,42 @@ module Network.DomainAuth.Utils where -import qualified Data.ByteString.Lazy.Char8 as L-import Data.Char-import Data.Int+import Blaze.ByteString.Builder+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS (lines)+import Data.Monoid+import Data.Word -crlf :: L.ByteString-crlf = "\r\n"+crlf :: Builder+crlf = fromByteString "\r\n" -(+++) :: L.ByteString -> L.ByteString -> L.ByteString-(+++) = L.append+(+++) :: Monoid a => a -> a -> a+(+++) = mappend -(!!!) :: L.ByteString -> Int64 -> Char-(!!!) = L.index+empty :: Monoid a => a+empty = mempty +(!!!) :: ByteString -> Int -> Word8+(!!!) = BS.index+ ---------------------------------------------------------------- -appendCRLF :: L.ByteString -> L.ByteString -> L.ByteString+appendCRLF :: Builder -> Builder -> Builder appendCRLF x y = x +++ crlf +++ y -appendCRLFWith :: (a -> L.ByteString) -> a -> L.ByteString -> L.ByteString-appendCRLFWith modify x y = modify x +++ crlf +++ y+appendCRLF' :: ByteString -> Builder -> Builder+appendCRLF' x = appendCRLF (fromByteString x) -concatCRLF :: [L.ByteString] -> L.ByteString-concatCRLF = foldr appendCRLF ""+appendCRLFWith :: (a -> ByteString) -> a -> Builder -> Builder+appendCRLFWith modify x y = fromByteString (modify x) +++ crlf +++ y -concatCRLFWith :: (a -> L.ByteString) -> [a] -> L.ByteString-concatCRLFWith modify = foldr (appendCRLFWith modify) ""+concatCRLF :: [ByteString] -> Builder+concatCRLF = foldr appendCRLF' empty +concatCRLFWith :: (a -> ByteString) -> [a] -> Builder+concatCRLFWith modify = foldr (appendCRLFWith modify) empty+ ---------------------------------------------------------------- {-|@@ -37,64 +46,91 @@ reduceWSP :: Cook reduceWSP "" = "" reduceWSP bs- | isSpace (L.head bs) = inSP bs+ | isSpace (BS.head bs) = inSP bs | otherwise = outSP bs inSP :: Cook inSP "" = "" inSP bs = " " +++ outSP bs' where- (_,bs') = L.span isSpace bs+ (_,bs') = BS.span isSpace bs outSP :: Cook outSP "" = "" outSP bs = nonSP +++ inSP bs' where- (nonSP,bs') = L.break isSpace bs+ (nonSP,bs') = BS.break isSpace bs ---------------------------------------------------------------- -type FWSRemover = L.ByteString -> L.ByteString+type FWSRemover = ByteString -> ByteString removeFWS :: FWSRemover-removeFWS = L.filter (not.isSpace)+removeFWS = BS.filter (not.isSpace) ---------------------------------------------------------------- -type Cook = L.ByteString -> L.ByteString+type Cook = ByteString -> ByteString removeTrailingWSP :: Cook removeTrailingWSP bs- | slowPath = L.reverse . L.dropWhile isSpace . L.reverse $ bs -- xxx+ | slowPath = BS.reverse . BS.dropWhile isSpace . BS.reverse $ bs -- xxx | otherwise = bs where slowPath = hasTrailingWSP bs -hasTrailingWSP :: L.ByteString -> Bool+hasTrailingWSP :: ByteString -> Bool hasTrailingWSP bs | len == 0 = False | otherwise = isSpace lastChar where- len = L.length bs+ len = BS.length bs lastChar = bs !!! (len - 1) ---------------------------------------------------------------- -chop :: L.ByteString -> L.ByteString+chop :: ByteString -> ByteString chop "" = "" chop bs- | L.last bs == '\r' = L.init bs- | otherwise = bs+ | BS.last bs == 13 = BS.init bs -- 13 == '\r'+ | otherwise = bs -blines :: L.ByteString -> [L.ByteString]-blines = map chop . L.lines+blines :: ByteString -> [ByteString]+blines = map chop . BS.lines ---------------------------------------------------------------- -break' :: Char -> L.ByteString -> (L.ByteString,L.ByteString)+break' :: Word8 -> ByteString -> (ByteString,ByteString) break' c bs = (f,s) where- (f,s') = L.break (==c) bs+ (f,s') = BS.break (==c) bs s = if s' == "" then ""- else L.tail s'+ else BS.tail s'++----------------------------------------------------------------++isAlphaNum, isUpper, isLower, isDigit, isSpace :: Word8 -> Bool+isAlphaNum c = isUpper c || isLower c || isDigit c+isDigit c = 48 <= c && c <= 57+isUpper c = 65 <= c && c <= 90+isLower c = 97 <= c && c <= 122+isSpace c = c `elem` [cSP,cTB,cLF,cCR]++cCR, cLF, cSP, cTB :: Word8+cCR = 13+cLF = 10+cSP = 32+cTB = 9++cPlus,cSlash,cEqual,cSmallA,cA,cZero :: Word8+cPlus = 43+cSlash = 47+cEqual = 61+cSmallA = 97+cA = 65+cZero = 48++cColon,cSemiColon :: Word8+cColon = 58+cSemiColon = 59
domain-auth.cabal view
@@ -1,5 +1,5 @@ Name: domain-auth-Version: 0.1.1+Version: 0.2.0 Author: Kazu Yamamoto <kazu@iij.ad.jp> Maintainer: Kazu Yamamoto <kazu@iij.ad.jp> License: BSD3@@ -46,7 +46,7 @@ Network.DomainAuth.SPF.Types Build-Depends: base >= 4 && < 5, appar, dns, iproute, network, bytestring, RSA, binary,- containers, SHA+ containers, SHA, blaze-builder Source-Repository head Type: git Location: git://github.com/kazu-yamamoto/domain-auth.git