diff --git a/Network/DomainAuth/DKIM.hs b/Network/DomainAuth/DKIM.hs --- a/Network/DomainAuth/DKIM.hs +++ b/Network/DomainAuth/DKIM.hs @@ -32,26 +32,25 @@ -- >>> rs <- makeResolvSeed defaultResolvConf -- >>> :{ -- let lst = ["DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed;" --- ," d=gmail.com; s=20161025;" --- ," h=mime-version:from:date:message-id:subject:to;" --- ," bh=IQB23UrpTWE7dPV0Ebeqy3ZJyCILT/tw2Ixhmh83FJ0=;" --- ," b=BCZrZwEnJfrdbbNqM+bWHeDrdHKvc6DvjafGCDndUUkHPbfVvvx2RTYfkC3LT1uCZC" --- ," 7vzKmucESLK5PVh4mAGNQjHDmdvhq7GIubOVK8Uoq+MpjZ321SwNI7rck/uLq512bfvO" --- ," NU9nYcUGNIKh+rho6V8XHX/REsfE+a8jGUvywZgV5IoORfTvejEluuy360PN0rAjSmi3" --- ," j5WRFV7XR5pCzAN78hmsUaTzf8zdwQwIlSsnUylnlRmc97xU5Ou3VBzxBV+ScXZsX5jI" --- ," TNv+ujuZcoO0fS0zm7UwmcOzXb01cQpBDqHK8cBvEdQ4+8LSx/Nf1UaOBrecw6GiwN23" --- ," BFBg==" --- ,"MIME-Version: 1.0" --- ,"Received: by 10.37.15.133 with HTTP; Wed, 20 Sep 2017 01:19:02 -0700 (PDT)" +-- ," d=gmail.com; s=20221208; t=1692239637; x=1692844437;" +-- ," h=to:subject:message-id:date:from:mime-version:from:to:cc:subject" +-- ," :date:message-id:reply-to;" +-- ," bh=g3zLYH4xKxcPrHOD18z9YfpQcnk/GaJedfustWU5uGs=;" +-- ," b=ceWXhAaIcvcQCkqTELkw1Bk7v+0pwT8VjmmE49M2nNhXQqA/DXR/aRljXAxGFIm2eU" +-- ," qhHFwQBh9JHbDWXUpltPWisIEDVI+rgOZFRQ7s9OrhJ4Vfmi+Y9Tu3LqmrzvacjdRM2Z" +-- ," 9RNfk4Wv1xk4jGas+JU0T296Z2BYOR5qxB5X/rmMhPNanKeZDmrhUOk+DWrbC+uJ0wcn" +-- ," P/jb76YBwTKBN1ySRrB0SdbruOIm0kYHYZoNMW/QWsR8f9PGthbAedCZrdjyixb7uXkz" +-- ," YmmGi6+XlLL3czZrj+RRrQlFn/xANIrE7sc0YYkhnehvBM6zZtgqesPflVbTlVEMMQg2" +-- ," N22A==" +-- ,"To: kazu@iij.ad.jp" +-- ,"Subject: test" +-- ,"Message-ID: " +-- ,"Date: Thu, 17 Aug 2023 11:33:46 +0900" -- ,"From: Kazu Yamamoto " --- ,"Date: Wed, 20 Sep 2017 17:19:02 +0900" --- ,"Message-ID: " --- ,"Subject: test for DKIM" --- ,"To: Kazu Yamamoto " +-- ,"MIME-Version: 1.0" -- ,"Content-Type: text/plain; charset=\"UTF-8\"" -- ,"" --- ,"this is test." --- ,"" +-- ,"test" -- ] -- mail = getMail $ BS8.intercalate "\r\n" lst -- in withResolver rs $ \rslv -> runDKIM rslv mail 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 @@ -8,13 +8,10 @@ import Control.Monad import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as P -import qualified Data.Attoparsec.Combinator as P (option) import Data.ByteString as BS import Data.ByteString.Builder (Builder) -import Data.ByteString.Lazy (toStrict) import qualified Data.ByteString.Builder as B import Data.ByteString.Char8 () -import Data.Monoid import Data.Word8 -- | 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 @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Network.DomainAuth.DKIM.Verify ( verifyDKIM, prepareDKIM 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 @@ -19,11 +19,16 @@ import qualified Data.ByteString.Lazy as BL import qualified Data.Foldable as F (foldr) import Data.List +import Data.Maybe (catMaybes) import Data.Sequence (Seq, viewr, ViewR(..), empty) import Network.DomainAuth.Mail.Types import qualified Network.DomainAuth.Utils as B (empty) import Network.DomainAuth.Utils hiding (empty) +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import Data.ByteString.Char8 + ---------------------------------------------------------------- -- | Looking up 'Field' from 'Header' with 'FieldKey'. @@ -48,16 +53,63 @@ -- RFC 4871 is ambiguous, so implement only normal case. -- | Obtaining all fields with DKIM algorithm. +-- +-- >>> fieldsWith ["from","to","subject","date","message-id"] [Field "from" "From" ["foo"],Field "to" "To" ["bar"],Field "subject" "Subject" ["baz"],Field "date" "Date" ["qux"],Field "message-id" "Message-Id" ["quux"], Field "received" "Received" ["fiz"], Field "filtered-out" "Filtered-Out" ["buzz"], Field "not-needed" "Not-Needed" ["fizz"]] +-- [Field {fieldSearchKey = "from", fieldKey = "From", fieldValue = ["foo"]},Field {fieldSearchKey = "to", fieldKey = "To", fieldValue = ["bar"]},Field {fieldSearchKey = "subject", fieldKey = "Subject", fieldValue = ["baz"]},Field {fieldSearchKey = "date", fieldKey = "Date", fieldValue = ["qux"]},Field {fieldSearchKey = "message-id", fieldKey = "Message-Id", fieldValue = ["quux"]}] 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 +fieldsWith kx hx = catMaybes $ enm kx hx (\k h -> k == fieldSearchKey h) + +-- | RFC 6376 says: +-- Signers MAY claim to have signed header fields that do not exist +-- (that is, Signers MAY include the header field name in the "h=" tag +-- even if that header field does not exist in the message). When +-- computing the signature, the nonexisting header field MUST be treated +-- as the null string (including the header field name, header field +-- value, all punctuation, and the trailing CRLF). +-- +-- INFORMATIVE RATIONALE: This allows Signers to explicitly assert +-- the absence of a header field; if that header field is added +-- later, the signature will fail. +-- +-- INFORMATIVE NOTE: A header field name need only be listed once +-- more than the actual number of that header field in a message at +-- the time of signing in order to prevent any further additions. +-- For example, if there is a single Comments header field at the +-- time of signing, listing Comments twice in the "h=" tag is +-- sufficient to prevent any number of Comments header fields from +-- being appended; it is not necessary (but is legal) to list +-- Comments three or more times in the "h=" tag. +-- +-- 'Notihng' represents the null above. +-- +-- >>> enm [1,2,3] [1,1,2,2,2,3,4,5] (==) +-- [Just 1,Just 2,Just 3] +-- >>> enm [1,1,2,3] [1,1,2,2,2,3,4,5] (==) +-- [Just 1,Just 1,Just 2,Just 3] +-- >>> enm [1,1,1,2,3] [1,1,2,2,2,3,4,5] (==) +-- [Just 1,Just 1,Nothing,Just 2,Just 3] +enm :: [a] -> [b] -> (a -> b -> Bool) -> [Maybe b] +enm [] _ _ = [] +enm _ [] _ = [] +enm (k:kx) hs0 eq = case fnd (eq k) hs0 of + Nothing -> Nothing : enm kx hs0 eq + Just (x,hs) -> Just x : enm kx hs eq + +-- >>> fnd (== 1) [1,2,3] +-- Just (1,[2,3]) +-- >>> fnd (== 2) [1,2,3] +-- Just (2,[1,3]) +-- >>> fnd (== 3) [1,2,3] +-- Just (3,[1,2]) +-- >>> fnd (== 4) [1,2,3] +-- Nothing +fnd :: (a -> Bool) -> [a] -> Maybe (a,[a]) +fnd _ [] = Nothing +fnd p (x:xs) + | p x = Just (x, xs) + | otherwise = case fnd p xs of + Nothing -> Nothing + Just (y,ys) -> Just (y, x:ys) ---------------------------------------------------------------- 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 @@ -7,7 +7,6 @@ import Control.Applicative import Data.Attoparsec.ByteString (Parser) import qualified Data.Attoparsec.ByteString as P -import qualified Data.Attoparsec.Combinator as P (choice) import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Char8 () 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 @@ -11,7 +11,6 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Builder as BB import qualified Data.ByteString.Lazy as BL -import Data.Monoid ((<>)) import Data.Word import Network.DomainAuth.Utils 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 @@ -24,8 +24,8 @@ -- >>> rs <- DNS.makeResolvSeed DNS.defaultResolvConf -- >>> withResolver rs $ \rslv -> lookupPublicKey rslv "dk200510._domainkey.yahoo.co.jp" -- Just (PublicKey {public_size = 128, public_n = 124495277115430906234131617223399742059624761592171426860362133400468320289284068350453787798555522712914036293436636386707903510390018044090096883314714401752103035965668114514933570840775088208966674120428191313530595210688523478828022953238411688594634270571841869051696953556782155414877029327479844990933, public_e = 65537}) --- >>> withResolver rs $ \rslv -> lookupPublicKey rslv "20161025._domainkey.gmail.com" --- Just (PublicKey {public_size = 256, public_n = 24002918530496096406691035681124918576525139397315303508411989678485471042094243709057313703002506577481962009015943359911855470236184740304869372300375695346466126498491672986773463137306714366250125164042667360646066116764211863426455899157774209331432246892273100824803003088472583507901403747123280231573655315087668569169140244507741538460717772392364103610973022227332742456151275783849571119048507254523999452581754451573432729267867937880516609319975372273089173378196646435625090021348583100824870283641053888848697729241628460935831026221013673635926904278136940569963717548356154570137751386534390787055991, public_e = 65537}) +-- >>> withResolver rs $ \rslv -> lookupPublicKey rslv "20221208._domainkey.gmail.com" +-- Just (PublicKey {public_size = 256, public_n = 22678151869562939359899136428859256198402569240680475393086048829021713182010490409724483359945551283969506235489826762257419985891230334120904178414351809046671461143996599803281758436654811035615578092428632166371331342907633917876752170113620966009358291594609542956251740141784694619901495773614035042135465203364073740861194611021551592336450807473519143746970021740067888325723330796836146546417386918505126721680365151889317110944800331756379997471380657912089911948147086686452887197011845657708078311037666769039161141500897109834073427400667740315220146696437513966171590587213846521825862509466370365529359, public_e = 65537}) lookupPublicKey :: DNS.Resolver -> Domain -> IO (Maybe PublicKey) lookupPublicKey resolver domain = do mpub <- lookupPublicKey' resolver domain @@ -47,5 +47,8 @@ decodeRSAPublicyKey b64 = pub where der = B.decode b64 - Right ans1 = decodeASN1' (undefined :: DER) der - Right (PubKeyRSA pub,[]) = fromASN1 ans1 + pub = case decodeASN1' (undefined :: DER) der of + Left _ -> error "decodeRSAPublicyKey (1)" + Right ans1 -> case fromASN1 ans1 of + Right (PubKeyRSA p,[]) -> p + _ -> error "decodeRSAPublicyKey (2)" diff --git a/Network/DomainAuth/SPF.hs b/Network/DomainAuth/SPF.hs --- a/Network/DomainAuth/SPF.hs +++ b/Network/DomainAuth/SPF.hs @@ -28,9 +28,9 @@ -- -- pass (IPv4 & IPv6): -- --- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "mew.org" "210.130.207.72" +-- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "mew.org" "202.238.220.92" -- pass --- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "iij.ad.jp" "2001:240:bb42:8010::1:126" +-- >>> withResolver rs $ \rslv -> runSPF defaultLimit rslv "iij.ad.jp" "2001:240:bb5f:86c::1:41" -- pass -- -- hardfail: @@ -50,9 +50,6 @@ -- >>> let limit1 = defaultLimit { ipv4_masklen = 24 } -- >>> withResolver rs $ \rslv -> runSPF limit1 rslv "gmail.com" "72.14.192.1" -- softfail --- >>> let limit2 = defaultLimit { limit = 2 } --- >>> withResolver rs $ \rslv -> runSPF limit2 rslv "nifty.com" "202.248.88.1" --- permerror runSPF :: Limit -> Resolver -> Domain -> IP -> IO DAResult runSPF lim resolver dom ip = diff --git a/domain-auth.cabal b/domain-auth.cabal --- a/domain-auth.cabal +++ b/domain-auth.cabal @@ -1,71 +1,79 @@ -Name: domain-auth -Version: 0.2.2 -Author: Kazu Yamamoto -Maintainer: Kazu Yamamoto -License: BSD3 -License-File: LICENSE -Synopsis: Domain authentication library -Description: Library for Sender Policy Framework, SenderID, - DomainKeys and DKIM. -Category: Network -Cabal-Version: >= 1.10 -Build-Type: Simple +cabal-version: >=1.10 +name: domain-auth +version: 0.2.3 +license: BSD3 +license-file: LICENSE +maintainer: Kazu Yamamoto +author: Kazu Yamamoto +synopsis: Domain authentication library +description: + Library for Sender Policy Framework, SenderID, + DomainKeys and DKIM. +category: Network +build-type: Simple + +source-repository head + type: git + location: https://github.com/kazu-yamamoto/domain-auth + library - Default-Language: Haskell2010 - 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.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 - , attoparsec - , asn1-encoding - , asn1-types - , bytestring - , containers - , cryptonite - , dns >= 1.0 - , iproute - , memory - , network - , x509 - , word8 + exposed-modules: + Network.DomainAuth + Network.DomainAuth.Mail + Network.DomainAuth.DK + Network.DomainAuth.DKIM + Network.DomainAuth.SPF + Network.DomainAuth.PRD + Network.DomainAuth.Types -Test-Suite doctest - Type: exitcode-stdio-1.0 - Default-Language: Haskell2010 - HS-Source-Dirs: test - Ghc-Options: -Wall - Main-Is: doctests.hs - Build-Depends: base >= 4 && < 5 - , doctest >= 0.9.3 - , pretty-simple + 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.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 -Source-Repository head - Type: git - Location: git://github.com/kazu-yamamoto/domain-auth.git + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4 && <5, + attoparsec, + asn1-encoding, + asn1-types, + bytestring, + containers, + crypton, + dns >=1.0, + iproute, + memory, + network, + crypton-x509, + word8 + +test-suite doctest + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4 && <5, + doctest >=0.9.3, + pretty-simple