diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -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. diff --git a/mail-reports.cabal b/mail-reports.cabal --- a/mail-reports.cabal +++ b/mail-reports.cabal @@ -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 diff --git a/src/Data/Mail/DMARC/Reports.hs b/src/Data/Mail/DMARC/Reports.hs --- a/src/Data/Mail/DMARC/Reports.hs +++ b/src/Data/Mail/DMARC/Reports.hs @@ -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 diff --git a/src/Data/Mail/TLSRPT/Reports.hs b/src/Data/Mail/TLSRPT/Reports.hs new file mode 100644 --- /dev/null +++ b/src/Data/Mail/TLSRPT/Reports.hs @@ -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