diff --git a/Network/DomainAuth/DK.hs b/Network/DomainAuth/DK.hs --- a/Network/DomainAuth/DK.hs +++ b/Network/DomainAuth/DK.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {-| A library for DomainKeys (). 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 diff --git a/Network/DomainAuth/DK/Parser.hs b/Network/DomainAuth/DK/Parser.hs --- a/Network/DomainAuth/DK/Parser.hs +++ b/Network/DomainAuth/DK/Parser.hs @@ -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 diff --git a/Network/DomainAuth/DK/Types.hs b/Network/DomainAuth/DK/Types.hs --- a/Network/DomainAuth/DK/Types.hs +++ b/Network/DomainAuth/DK/Types.hs @@ -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 diff --git a/Network/DomainAuth/DK/Verify.hs b/Network/DomainAuth/DK/Verify.hs --- a/Network/DomainAuth/DK/Verify.hs +++ b/Network/DomainAuth/DK/Verify.hs @@ -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) diff --git a/Network/DomainAuth/DKIM.hs b/Network/DomainAuth/DKIM.hs --- a/Network/DomainAuth/DKIM.hs +++ b/Network/DomainAuth/DKIM.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE OverloadedStrings #-} + {-| A library for DKIM (). 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 diff --git a/Network/DomainAuth/DKIM/Btag.hs b/Network/DomainAuth/DKIM/Btag.hs --- a/Network/DomainAuth/DKIM/Btag.hs +++ b/Network/DomainAuth/DKIM/Btag.hs @@ -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 diff --git a/Network/DomainAuth/DKIM/Parser.hs b/Network/DomainAuth/DKIM/Parser.hs --- a/Network/DomainAuth/DKIM/Parser.hs +++ b/Network/DomainAuth/DKIM/Parser.hs @@ -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 } diff --git a/Network/DomainAuth/DKIM/Types.hs b/Network/DomainAuth/DKIM/Types.hs --- a/Network/DomainAuth/DKIM/Types.hs +++ b/Network/DomainAuth/DKIM/Types.hs @@ -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 diff --git a/Network/DomainAuth/DKIM/Verify.hs b/Network/DomainAuth/DKIM/Verify.hs --- a/Network/DomainAuth/DKIM/Verify.hs +++ b/Network/DomainAuth/DKIM/Verify.hs @@ -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 - - diff --git a/Network/DomainAuth/Mail.hs b/Network/DomainAuth/Mail.hs --- a/Network/DomainAuth/Mail.hs +++ b/Network/DomainAuth/Mail.hs @@ -27,6 +27,7 @@ , fieldValueFolded , fieldValueUnfolded -- ** Functions to manipulate 'Body' + , isEmpty , fromBody , fromBodyWith , removeTrailingEmptyLine diff --git a/Network/DomainAuth/Mail/Mail.hs b/Network/DomainAuth/Mail/Mail.hs --- a/Network/DomainAuth/Mail/Mail.hs +++ b/Network/DomainAuth/Mail/Mail.hs @@ -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 diff --git a/Network/DomainAuth/Mail/Parser.hs b/Network/DomainAuth/Mail/Parser.hs --- a/Network/DomainAuth/Mail/Parser.hs +++ b/Network/DomainAuth/Mail/Parser.hs @@ -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 diff --git a/Network/DomainAuth/Mail/Types.hs b/Network/DomainAuth/Mail/Types.hs --- a/Network/DomainAuth/Mail/Types.hs +++ b/Network/DomainAuth/Mail/Types.hs @@ -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 diff --git a/Network/DomainAuth/Mail/XMail.hs b/Network/DomainAuth/Mail/XMail.hs --- a/Network/DomainAuth/Mail/XMail.hs +++ b/Network/DomainAuth/Mail/XMail.hs @@ -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 } diff --git a/Network/DomainAuth/PRD/Domain.hs b/Network/DomainAuth/PRD/Domain.hs --- a/Network/DomainAuth/PRD/Domain.hs +++ b/Network/DomainAuth/PRD/Domain.hs @@ -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 diff --git a/Network/DomainAuth/PRD/Lexer.hs b/Network/DomainAuth/PRD/Lexer.hs --- a/Network/DomainAuth/PRD/Lexer.hs +++ b/Network/DomainAuth/PRD/Lexer.hs @@ -2,7 +2,7 @@ structured ) where -import Text.Appar.LazyByteString +import Text.Appar.ByteString ---------------------------------------------------------------- diff --git a/Network/DomainAuth/PRD/PRD.hs b/Network/DomainAuth/PRD/PRD.hs --- a/Network/DomainAuth/PRD/PRD.hs +++ b/Network/DomainAuth/PRD/PRD.hs @@ -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 diff --git a/Network/DomainAuth/Pubkey/Base64.hs b/Network/DomainAuth/Pubkey/Base64.hs --- a/Network/DomainAuth/Pubkey/Base64.hs +++ b/Network/DomainAuth/Pubkey/Base64.hs @@ -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]] diff --git a/Network/DomainAuth/Pubkey/Der.hs b/Network/DomainAuth/Pubkey/Der.hs --- a/Network/DomainAuth/Pubkey/Der.hs +++ b/Network/DomainAuth/Pubkey/Der.hs @@ -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 diff --git a/Network/DomainAuth/Pubkey/RSAPub.hs b/Network/DomainAuth/Pubkey/RSAPub.hs --- a/Network/DomainAuth/Pubkey/RSAPub.hs +++ b/Network/DomainAuth/Pubkey/RSAPub.hs @@ -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] diff --git a/Network/DomainAuth/SPF/Parser.hs b/Network/DomainAuth/SPF/Parser.hs --- a/Network/DomainAuth/SPF/Parser.hs +++ b/Network/DomainAuth/SPF/Parser.hs @@ -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)) diff --git a/Network/DomainAuth/SPF/Resolver.hs b/Network/DomainAuth/SPF/Resolver.hs --- a/Network/DomainAuth/SPF/Resolver.hs +++ b/Network/DomainAuth/SPF/Resolver.hs @@ -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) ---------------------------------------------------------------- diff --git a/Network/DomainAuth/Utils.hs b/Network/DomainAuth/Utils.hs --- a/Network/DomainAuth/Utils.hs +++ b/Network/DomainAuth/Utils.hs @@ -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 diff --git a/domain-auth.cabal b/domain-auth.cabal --- a/domain-auth.cabal +++ b/domain-auth.cabal @@ -1,5 +1,5 @@ Name: domain-auth -Version: 0.1.1 +Version: 0.2.0 Author: Kazu Yamamoto Maintainer: Kazu Yamamoto 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