mail-reports 0.1.0.0 → 0.2.0.0
raw patch · 4 files changed
+322/−6 lines, 4 filesdep +aeson
Dependencies added: aeson
Files
- CHANGELOG.md +4/−0
- mail-reports.cabal +7/−5
- src/Data/Mail/DMARC/Reports.hs +3/−1
- src/Data/Mail/TLSRPT/Reports.hs +308/−0
CHANGELOG.md view
@@ -1,5 +1,9 @@ # Revision history for mail-reports +## 0.2.0.0 -- 2020-12-21++Also parse SMTP-TLSRPT aggregated reports.+ ## 0.1.0.0 -- 2020-12-19 First version, parsing DMARC aggregated reports.
mail-reports.cabal view
@@ -3,9 +3,9 @@ -- For further documentation, see http://haskell.org/cabal/users-guide/ name: mail-reports-version: 0.1.0.0-synopsis: A parser library for DMARC reports-description: This library is meant to parse DMARC aggregated reports from bytestrings, XML documents or streaming bytestrings.+version: 0.2.0.0+synopsis: A parser library for DMARC and SMTP TLS reports+description: This library is meant to parse DMARC and TLSRPT aggregated reports from bytestrings, XML documents or streaming bytestrings. -- bug-reports: license: AGPL-3 license-file: LICENSE@@ -22,9 +22,10 @@ library exposed-modules: Data.Mail.DMARC.Reports+ Data.Mail.TLSRPT.Reports -- other-modules: -- other-extensions:- build-depends: base >=4.13 && <4.14,+ build-depends: base >=4.13 && <5, streaming-bytestring, zip-archive, streaming-utils,@@ -34,7 +35,8 @@ resourcet, text, time,- mtl+ mtl,+ aeson hs-source-dirs: src default-language: Haskell2010
src/Data/Mail/DMARC/Reports.hs view
@@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings, FlexibleContexts, RecordWildCards #-} --- | Utilities for parsing a DMARC aggregated report, following RFC 7489+-- | Utilities for parsing a DMARC aggregated report, following RFC 7489. These functions also handle decompression (gzip or pkzip) module Data.Mail.DMARC.Reports ( -- * Parsers@@ -170,6 +170,7 @@ fbRecords :: [Record] } deriving (Eq,Show,Read) +-- | Gets an XML document root from a streaming bytestring xmlFromStream :: (MonadFail m, MonadIO m) => Q.ByteStream m r -> m (Maybe Element) xmlFromStream stream = do let stream' = uncompressStream stream@@ -202,6 +203,7 @@ -- | Parse a DMARC report from an XML document dmarcFeedbackFromXml = processXml +-- | Parse a DMARC report from an XML document (also: 'dmarcFeedbackFromXml') processXml :: Element -> Maybe Feedback processXml root = let strContent' = T.pack . strContent
+ src/Data/Mail/TLSRPT/Reports.hs view
@@ -0,0 +1,308 @@+{-# LANGUAGE OverloadedStrings, FlexibleContexts, RecordWildCards #-}++-- | Utilities for parsing an SMTP-TLRPT aggregated report, following RFC 8460. These functions also handle decompression (gzip or pkzip)++module Data.Mail.TLSRPT.Reports (+ -- * Parsers+ tlsReportFromStrict,+ tlsReportFromLazy,+ tlsReportFromStream,+ tlsReportFromJson,+ -- * Data types+ Report(..),+ Policy(..),+ PolicyDesc(..),+ FailureDetails(..),+ IpAddress,+ PolicySummary(..),+ PolicyType(..),+ ResultType(..)+ ) where++import Data.Mail.DMARC.Reports (uncompressStream)+import Streaming+import qualified Streaming.Prelude as S+import Data.Aeson+import Data.Aeson.Types+import Data.Time.Clock+import Data.Time.Format+import qualified Data.Text as T+import Text.Read (readMaybe)+import Data.Aeson.Encoding (string)+import qualified Streaming.ByteString as Q+import Control.Monad.Trans.Resource+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as L+import System.IO.Unsafe++type IpAddress = String++data PolicyType = NoPolicyFound -- ^ neither MTA-STS nor DANE+ | TlsaPolicy -- ^ DANE policy (TLSA record)+ | StsPolicy -- ^ MTA-STS policy+ deriving (Eq)++instance Show PolicyType where+ show NoPolicyFound = "no-policy-found"+ show TlsaPolicy = "tlsa"+ show StsPolicy = "sts"++instance Read PolicyType where+ readsPrec _ r =+ [(NoPolicyFound,s) | ("no-policy-found",s) <- lex' r]+ ++[(TlsaPolicy,s) | ("tlsa",s) <- lex' r]+ ++[(StsPolicy,s) | ("sts",s) <- lex' r]++instance ToJSON PolicyType where+ toJSON = toJSONShow+ toEncoding = toEncodingShow++toJSONShow :: Show a => a -> Value+toJSONShow = String . T.pack . show++toEncodingShow :: Show a => a -> Encoding+toEncodingShow = string . show++instance FromJSON PolicyType where+ parseJSON = parseJSONRead "PolicyType"++parseJSONRead :: Read a => String -> Value -> Parser a+parseJSONRead desc = withText desc $ \t ->+ case readMaybe (T.unpack t) of+ Nothing -> typeMismatch desc (String t)+ Just a -> return a++-- | Description of the evaluated policy+data PolicyDesc = PolicyDesc {+ -- | Policy type (DANE or MTA-STS)+ pdPolicyType :: PolicyType,+ -- | Applied policy as strings+ pdPolicyString :: [T.Text],+ -- | domain (if punycode: A-labels, not U-labels)+ pdPolicyDomain :: T.Text,+ -- | if MTA-STS, then this is a list of mx host patterns+ pdMxHost :: [T.Text]+ } deriving (Eq, Show, Read)++instance ToJSON PolicyDesc where+ toJSON PolicyDesc{..} =+ object ["policy-type" .= pdPolicyType,+ "policy-string" .= pdPolicyString,+ "policy-domain" .= pdPolicyDomain,+ "mx-host" .= pdMxHost]+ toEncoding PolicyDesc{..} =+ pairs ("policy-type" .= pdPolicyType <>+ "policy-string" .= pdPolicyString <>+ "policy-domain" .= pdPolicyDomain <>+ "mx-host" .= pdMxHost)++instance FromJSON PolicyDesc where+ parseJSON = withObject "PolicyDesc" $+ \o -> PolicyDesc+ <$> o .: "policy-type"+ <*> o .:? "policy-string" .!= []+ <*> o .: "policy-domain"+ <*> o .:? "mx-host" .!= []++-- | Summary of policy evaluation+data PolicySummary = PolicySummary {+ -- | Successful sessions+ psTotalSuccessfulSessionCount :: Int,+ -- | Failed sessions+ psTotalFailureSessionCount :: Int+ } deriving (Eq, Show, Read)++instance ToJSON PolicySummary where+ toJSON PolicySummary{..} =+ object ["total-successful-session-count" .= psTotalSuccessfulSessionCount,+ "total-failure-session-count" .= psTotalFailureSessionCount]+ toEncoding PolicySummary{..} =+ pairs ("total-successful-session-count" .= psTotalSuccessfulSessionCount <>+ "total-failure-session-count" .= psTotalFailureSessionCount)++instance FromJSON PolicySummary where+ parseJSON = withObject "PolicySummary" $+ \o -> PolicySummary+ <$> o .: "total-successful-session-count"+ <*> o .: "total-failure-session-count"++-- | Failure types+data ResultType = StarttlsNotSupported -- ^ recipient MX did not support STARTTLS+ | CertificateHostMismatch -- ^ MX hostname does not match any of the subject alternative names in the certificate+ | CertificateExpired -- ^ certificate has expired+ | CertificateNotTrusted -- ^ certificate is not signed by any trusted CA+ | ValidationFailure -- ^ general negotiation failure (other)+ | TlsaInvalid -- ^ validation error in the TLSA record+ | DnssecInvalid -- ^ no valid records were returned from the recursive resolver+ | DaneRequired -- ^ sending system is configured to require DANE TLSA records for all the MX hosts of the destination domain, but no DNSSEC-validated TLSA records were present for the MX host+ | StsPolicyFetchError -- ^ failure to retrieve an MTA-STS policy (e.g. host unreachable)+ | StsPolicyInvalid -- ^ validation error for the overall MTA-STS policy+ | StsWebpkiInvalid -- ^ MTA-STS policy could not be authenticated using PKIX validation+ deriving (Eq)++instance Show ResultType where+ show StarttlsNotSupported = "starttls-not-supported"+ show CertificateHostMismatch = "certificate-host-mismatch"+ show CertificateExpired = "certificate-expired"+ show CertificateNotTrusted = "certificate-not-trusted"+ show ValidationFailure = "validation-failure"+ show TlsaInvalid = "tlsa-invalid"+ show DnssecInvalid = "dnssec-invalid"+ show DaneRequired = "dane-required"+ show StsPolicyFetchError = "sts-policy-fetch-error"+ show StsPolicyInvalid = "sts-policy-invalid"+ show StsWebpkiInvalid = "sts-webpki-invalid"++instance Read ResultType where+ readsPrec _ r =+ [(rt,s)+ | (w,s) <- lex' r,+ let rt = case w of+ "starttls-not-supported" -> StarttlsNotSupported+ "certificate-host-mismatch" -> CertificateHostMismatch+ "certificate-expired" -> CertificateExpired+ "certificate-not-trusted" -> CertificateNotTrusted+ "validation-failure" -> ValidationFailure+ "tlsa-invalid" -> TlsaInvalid+ "dnssec-invalid" -> DnssecInvalid+ "dane-required" -> DaneRequired+ "sts-policy-fetch-error" -> StsPolicyFetchError+ "sts-policy-invalid" -> StsPolicyInvalid+ "sts-webpki-invalid" -> StsWebpkiInvalid]++lex' r = [span (\c -> c `elem` ('-':['a'..'z'])) r]+ +instance FromJSON ResultType where+ parseJSON = parseJSONRead "ResultType"++instance ToJSON ResultType where+ toJSON = toJSONShow+ toEncoding = toEncodingShow++data FailureDetails = FailureDetails {+ fdResultType :: ResultType, -- ^ failure type+ fdSendingMtaIp :: IpAddress, -- ^ address of the sending MTA+ fdReceivingMxHostname :: T.Text, -- ^ hostname of the receiving MTA MX record+ fdReceivingMxHelo :: Maybe T.Text, -- ^ the HELO or EHLO string from thte banner announced during the reported session+ fdReceivingIp :: IpAddress, -- ^ destination IP address+ fdFailedSessionCount :: Int, -- ^ number of attempted sessions that match the result type+ fdAdditionalInformation :: Maybe T.Text,-- ^ URI that points to additional information+ fdFailureReasonCode :: Maybe T.Text -- ^ failure code, esp. useful if result type is validation-failure+ } deriving (Eq, Show, Read)++instance ToJSON FailureDetails where+ toJSON FailureDetails{..} =+ object (["result-type" .= fdResultType,+ "sending-mta-ip" .= fdSendingMtaIp,+ "receiving-mx-hostname" .= fdReceivingMxHostname,+ "receiving-ip" .= fdReceivingIp,+ "failed-session-count" .= fdFailedSessionCount]+ ++maybe [] (\h -> ["receiving-mx-helo" .= h]) fdReceivingMxHelo+ ++maybe [] (\h -> ["additional-information" .= h]) fdAdditionalInformation+ ++maybe [] (\h -> ["failure-reason-code" .= h]) fdFailureReasonCode)++instance FromJSON FailureDetails where+ parseJSON = withObject "FailureDetails" $+ \o -> FailureDetails+ <$> o .: "result-type"+ <*> o .: "sending-mta-ip"+ <*> o .: "receiving-mx-hostname"+ <*> o .:? "receiving-mx-helo"+ <*> o .: "receiving-ip"+ <*> o .: "failed-session-count"+ <*> o .:? "additional-information"+ <*> o .:? "failure-reason-code"++data Policy = Policy {+ -- | description of the evaluated policy+ pcPolicy :: PolicyDesc,+ -- | failure/success summary+ pcSummary :: PolicySummary,+ -- | details about failure types+ pcFailureDetails :: [FailureDetails]+ } deriving (Eq, Show, Read)++instance ToJSON Policy where+ toJSON Policy{..} =+ object ["policy" .= pcPolicy,+ "summary" .= pcSummary,+ "failure-details" .= pcFailureDetails]++instance FromJSON Policy where+ parseJSON = withObject "Policy" $+ \o -> Policy+ <$> o .: "policy"+ <*> o .: "summary"+ <*> o .:? "failure-details" .!= []++-- | The entire SMTP-TLSRPT report+data Report = Report {+ -- | organization responsible for the report+ rpOrganizationName :: T.Text,+ -- | start and end times for the report range+ rpDateRange :: (UTCTime, UTCTime),+ -- | e-mail address of the party responsible for the report+ rpContactInfo :: T.Text,+ -- | unique identifier+ rpReportId :: T.Text,+ -- | results for each policy+ rpPolicies :: [Policy]+ } deriving (Eq, Show, Read)++instance ToJSON Report where+ toJSON Report{..} =+ object ["organization-name" .= rpOrganizationName,+ "date-range" .= object+ ["start-datetime" .= fmt (fst rpDateRange),+ "end-datetime" .= fmt (snd rpDateRange)],+ "contact-info" .= rpContactInfo,+ "report-id" .= rpReportId,+ "policies" .= rpPolicies]+ where fmt = formatTime defaultTimeLocale "%FT%X%Z"+ +instance FromJSON Report where+ parseJSON = withObject "Report" $+ \o -> Report+ <$> o .: "organization-name"+ <*> mtime o+ <*> o .: "contact-info"+ <*> o .: "report-id"+ <*> o .: "policies"+ where mtime o = do+ range <- o .: "date-range"+ start <- range .: "start-datetime"+ end <- range .: "end-datetime"+ start' <- parseTimeM True defaultTimeLocale "%FT%X%Z" start+ end' <- parseTimeM True defaultTimeLocale "%FT%X%Z" end+ return (start', end')++-- | Parse a TLSRPT report from a JSON 'Value'+tlsReportFromJson :: Value -> Either String Report+tlsReportFromJson v =+ case fromJSON v of+ Error s -> Left s+ Success r -> Right r++-- | Parse a TLSRPT report from a strict 'B.ByteString'+tlsReportFromStrict :: B.ByteString -> Either String Report+tlsReportFromStrict = unsafePerformIO . tlsReportFromStream . Q.fromStrict++-- | Parse a TLSRPT report from a lazy 'L.ByteString'+tlsReportFromLazy :: L.ByteString -> Either String Report+tlsReportFromLazy = unsafePerformIO . tlsReportFromStream . Q.fromLazy++-- | Parse a TLSRPT report from a 'Q.ByteStream'+tlsReportFromStream :: (MonadFail m, MonadIO m) => Q.ByteStream m r -> m (Either String Report)+tlsReportFromStream stream = do+ let stream' = uncompressStream stream+ lbs <- Q.toLazy_ stream'+ return $ eitherDecode lbs++test :: IO ()+test = do+ let filename = "../google.com!enumeration.eu!1607990400!1608076799!001.json.gz"+ runResourceT $ do+ erpt <- tlsReportFromStream $ Q.readFile filename+ case erpt of+ Left e -> liftIO $ putStrLn e+ Right x -> liftIO $ putStrLn $ show x