diff --git a/Dane/Scanner/DNS/Dane.hs b/Dane/Scanner/DNS/Dane.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/DNS/Dane.hs @@ -0,0 +1,290 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TemplateHaskell #-} + +module Dane.Scanner.DNS.Dane (daneCheck) where + +import qualified Data.Text as T +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Except (runExceptT) +import Control.Monad.Trans.State.Strict (gets) +import Data.List (nub, sortOn) + +import Data.IP (IP(IPv4, IPv6)) +import Net.DNSBase ( Domain(RootDomain) + , T_a(T_A), T_aaaa(T_AAAA) + , T_dnskey, T_ds, T_mx(..), T_soa, T_tlsa + , RRTYPE(SOA) + , appendDomain, dnLit8, shortBytes + ) +import Net.DNSBase.Present (putBuilder) +import Net.DNSBase.Resolver (withResolver) + +import qualified Text.IDNA2008 as I +import qualified Text.IDNA2008.Wire as IW + +import qualified Dane.Scanner.Opts as Opts +import Dane.Scanner.State +import Dane.Scanner.Util +import Dane.Scanner.DNS.Lookup +import Dane.Scanner.DNS.Reply +import Dane.Scanner.DNS.Toascii +import Dane.Scanner.SMTP.Chain + + +-- | Prefix prepended to a TLSA base domain to form the TLSA +-- query name (e.g. @_25._tcp.mx1.example.com@). Built once at +-- compile-time via 'DNS.dnLit8'; combined with the per-host base +-- via 'DNS.appendDomain', which returns 'Nothing' when the +-- result would overflow the 255-octet wire-form name limit. +tlsaPrefix :: Domain +tlsaPrefix = $$(dnLit8 "_25._tcp.") + + +-- | Skip hosts that securely don't exist. +skipHost :: RC -> Bool +skipHost NXDomainRC = True +skipHost _ = False + + +-- | Label-form set acceptable for an MX hostname received from +-- DNS: LDH + ALABEL + RLDH + FAKEA. Excludes ATTRLEAF +-- (leading-underscore service labels are not MX exchanger +-- names), ULABEL (wire form is never UTF-8 here), WILDLABEL, +-- OCTET, BLANK, LAXULABEL. xn-- labels are accepted whether or +-- not they decode as valid Punycode — FAKEA admission means we +-- don't reject names whose Punycode happens not to decode. +mxHostForms :: I.LabelFormSet +mxHostForms = mempty I.<+> I.LDH I.<+> I.ALABEL I.<+> I.RLDH I.<+> I.FAKEA + +-- | Validate an MX hostname's label shape. Classifies the +-- wire-form bytes directly via 'IW.unparseOpts' (no 'Text' +-- round-trip) against 'mxHostForms'. Flags are 'mempty' — +-- pure shape classification, with ALABELCHECK / NFCCHECK / +-- BIDICHECK / character mappings all off, since none of them +-- are meaningful constraints on data received off the wire. +validMXHost :: Domain -> Bool +validMXHost dom = + case IW.unparseOpts mxHostForms mempty (shortBytes dom) of + Right _ -> True + Left _ -> False + + +-- | Given a non-empty A or AAAA response, try to find TLSA +-- records at the CNAME-expanded name if the entire chain is +-- secure. If no TLSA records are found there, and the CNAME +-- chain is non-empty, try at the initial name if secure. +-- +getTLSA :: Reply a -- ^ MX-host address reply + -> Scanner (Maybe (Domain, Reply T_tlsa)) +getTLSA a = case repValidity a of + Secure -> do + cnamebt <- baseTLSA (repOwner a) + case cnamebt of + Just (_, t) | done t -> return cnamebt + _ -> baseTLSA (repQname a) + Insecure + | repCnAD a + , nonempty (repRD a) + , nonempty (repCnames a) -> baseTLSA (repQname a) + _ -> return Nothing + where + -- Is the initial qname a candidate base domain? + done :: Reply T_tlsa -> Bool + done t = case repValidity t of + Indeterminate -> True + Secure -> True + _ | not (repCnAD a) -> True + | null (repCnames a) -> True + | otherwise -> False + + baseTLSA :: Domain -> Scanner (Maybe (Domain, Reply T_tlsa)) + baseTLSA b = case appendDomain tlsaPrefix b of + Nothing -> return Nothing -- host name too long for TLSA prefix + Just q -> do + rv <- gets scannerResolver + t <- liftIO $ rawReply T_tlsa rv q + return (Just (b, t)) + + +-- | For each MX host display the corresponding per-host +-- information. This includes the A\/AAAA records and, when +-- DNSSEC-secure, the TLSA records and per-IP SMTP chain probes. +doMXHost :: Domain -- ^ Qname of MX RRset + -> Domain -- ^ MX RRset owner + -> Domain -- ^ MX host to process + -> Scanner () +doMXHost qname owner mx + | Just _ <- rootOrTLD mx + = displayFailA (noReply TldMX False mx) + | not (validMXHost mx) + = displayFailA (noReply BadName False mx) + | otherwise = do + rv <- gets scannerResolver + a <- liftIO $ rawReply T_a rv mx + noteInsecure a + if skipHost (repRC a) + then liftIO $ putBuilder $ putReplyA a mempty + else do + aaaa <- liftIO $ rawReply T_aaaa rv mx + noteInsecure aaaa + opts <- gets scannerOpts + let doV4 = Opts.enableV4 opts + doV6 = Opts.enableV6 opts + v4addrs = if_ doV4 [ IPv4 ip | T_A ip <- repRD a ] [] + v6addrs = if_ doV6 [ IPv6 ip | T_AAAA ip <- repRD aaaa ] [] + connaddrs = v4addrs ++ v6addrs + bt <- getTLSA a + case bt of + Just (b, t) -> renderHost a aaaa (Just (b, t)) connaddrs + Nothing -> do + bt' <- getTLSA aaaa + case bt' of + Just (b, t) -> renderHost a aaaa (Just (b, t)) connaddrs + Nothing + | Opts.useAll opts -> do + let synth = case appendDomain tlsaPrefix mx of + Just n -> noReply NoErrorRC False n + Nothing -> noReply NoErrorRC False mx + renderHost a aaaa (Just (mx, synth)) connaddrs + | otherwise -> do + displayFailA a + displayFailAaaa aaaa + where + noteInsecure r = case repRC r of + NoErrorRC | repCnAD r -> return () + NXDomainRC | repCnAD r -> return () + _ -> scannerFail () + + displayFailA r = do + liftIO $ putBuilder $ putReplyA r mempty + scannerFail () + + displayFailAaaa r = do + liftIO $ putBuilder $ putReplyAaaa Nothing [] r mempty + scannerFail () + + renderHost :: Reply T_a -> Reply T_aaaa + -> Maybe (Domain, Reply T_tlsa) + -> [IP] + -> Scanner () + renderHost a aaaa (Just (b, t)) connaddrs = do + chains <- getchains t b connaddrs + let tlsa = TlsaInfo { tlsaBase = b, tlsaRRset = t } + liftIO $ putBuilder $ + putReplyA a . putReplyAaaa (Just tlsa) chains aaaa $ mempty + renderHost a aaaa Nothing _ = + liftIO $ putBuilder $ + putReplyA a . putReplyAaaa Nothing [] aaaa $ mempty + + getchains :: Reply T_tlsa -> Domain -> [IP] -> Scanner [AddrChain] + getchains tlsa base addrs = case repValidity tlsa of + Secure -> + let refnames = nub [base, qname, owner] + in getAddrChains mx base refnames (repRD tlsa) addrs + _ -> gets scannerOpts >>= \opts -> + if Opts.useAll opts + then scannerFail () >> getAddrChains mx base [] [] addrs + else scannerFail [] + + +-- | If the MX RRset is secure (AD==True), for each MX host +-- perform A\/AAAA lookups and then TLSA lookups if those are in +-- turn secure. +chaseMX :: Reply T_mx -> Scanner () +chaseMX m = case repAD m of + False -> return () + True + | NoErrorRC <- repRC m, null (repRD m) + -> doMXHost (repQname m) (repOwner m) (repOwner m) + | otherwise + -> mapM_ (doMXHost (repQname m) (repOwner m)) (gethosts (repRD m)) + where + gethosts mxs = nub [ exch | T_MX _ exch <- sortOn mxPref mxs + , exch /= RootDomain ] + + +-- | For sub-domains, check DS, DNSKEY, MX and then recurse over +-- the MX hosts for A\/AAAA and TLSA. +checkDomain :: Domain -> Scanner Bool +checkDomain dom = do + rv <- gets scannerResolver + ds <- liftIO $ rawReply T_ds rv dom + liftIO $ putBuilder $ putReplyDs ds mempty + if not (repValidated ds) + then return False + else do + dk <- liftIO $ rawReply T_dnskey rv dom + liftIO $ putBuilder $ putReplyDnskey dk mempty + if not (repValidated dk) + then return False + else do + m <- liftIO $ rawReply T_mx rv dom + liftIO $ putBuilder $ putReplyMx m mempty + when (not (repValidated m)) (scannerFail ()) + chaseMX m + gets scannerOK + + +-- | For the root and TLDs, check DS (if applicable), DNSKEY, and +-- SOA in turn. Each step requires a secure validated answer; the +-- first failure stops the chain. DS is skipped at the root, which +-- has no parent zone and therefore no DS RRset to look up. +checkTld :: Domain -> Scanner Bool +checkTld tld = do + rv <- gets scannerResolver + dsOK <- case tld of + RootDomain -> return True + _ -> do + ds <- liftIO $ rawReply T_ds rv tld + liftIO $ putBuilder $ putReplyDs ds mempty + return (repValidity ds == Secure) + if not dsOK + then return False + else do + dk <- liftIO $ rawReply T_dnskey rv tld + liftIO $ putBuilder $ putReplyDnskey dk mempty + if repValidity dk /= Secure + then return False + else do + soa <- liftIO $ rawReply T_soa rv tld + liftIO $ putBuilder $ putReplyAny SOA soa mempty + return (repValidity soa == Secure) + + +-- | For the root domain and TLDs simply check for working +-- DNSSEC. For sub-domains attempt to verify MX host DANE TLSA. +check :: String -> Scanner Bool +check domain = case todomain forms flags (T.pack domain) of + Just dom + | Just _ <- rootOrTLD dom -> checkTld dom + | otherwise -> checkDomain dom + Nothing -> do + liftIO $ putStrLn $ domain ++ " IN MX ? ; Invalid AD=0" + return False + where + -- Hostname-shaped label set: LDH + ALABEL + ULABEL + RLDH + + -- FAKEA. Excludes ATTRLEAF (leading-underscore service + -- labels like @_dmarc@, @_25@), WILDLABEL, OCTET, BLANK, + -- LAXULABEL — none of which a user-typed mail domain has + -- any legitimate use for. Tighter than the pre-port + -- Toascii.hs, which short-circuited any all-ASCII input + -- through without validation and accepted ATTRLEAF and + -- worse by accident. + forms = I.hostnameLabelForms + flags = I.defaultIdnaFlags <> I.allIdnaMappings + + +-- | Scan the requested domain after seeding the DNS resolver. +daneCheck :: Opts.Opts -> IO Bool +daneCheck opts = do + seedRes <- runExceptT (dnsConf opts) + case seedRes of + Left e -> do + putStrLn $ "Resolver configuration error: " ++ show e + return False + Right seed -> withResolver seed $ \rv -> + evalScanner (check (Opts.dnsDomain opts)) + ScannerSt { scannerOpts = opts + , scannerResolver = rv + , scannerOK = True } diff --git a/Dane/Scanner/DNS/Lookup.hs b/Dane/Scanner/DNS/Lookup.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/DNS/Lookup.hs @@ -0,0 +1,255 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE RequiredTypeArguments #-} + +-- | +-- Module : Dane.Scanner.DNS.Lookup +-- Description : DNS lookup layer for the scanner. +-- +-- Issues a DNS query at the slot's RR type (derived from the +-- caller's type parameter via 'rdType') and packages the result +-- as a typed 'Reply a' carrying the answer RRset narrowed to +-- @[a]@, the AD bit, and any CNAME or DNAME chain provenance +-- that led to the final owner. 'rawReply' \/ 'rawReplyCD' are +-- the two public entry points; both share an implementation +-- parameterised over 'QueryControls'. +-- +-- The CNAME walk uses 'Net.DNSBase.RRSet.rrSetsFromList' to group +-- the answer section by RRset and 'Data.Map.Strict' to look up +-- the chain; 'M.alterF (, Just []) (CNAME, owner)' fetches the +-- CNAME RRset and replaces it with @[]@ in a single pass, so a +-- malicious CNAME loop cannot be traversed twice. When the chain +-- as a whole is not secure and the query is for A/AAAA, +-- 'cnameAdProbe' issues a separate CNAME query to recover the +-- source-zone signedness (see RFC 7672, section 2.1.3). +-- +module Dane.Scanner.DNS.Lookup + ( dnsConf + , rawReply + , rawReplyCD + ) where + +import qualified Data.Map.Strict as M +import Control.Monad.Trans.Except (ExceptT(ExceptT)) +import Data.List (partition, sort) +import Data.List.NonEmpty (NonEmpty(..)) +import Data.Maybe (mapMaybe) + +import qualified Net.DNSBase as DNS +import Net.DNSBase ( Domain, DNSFlags(..), KnownRData, QueryControls + , RR(..), RRTYPE(..), RRCLASS(..) + , T_dname(..), X_domain(..) + , canonicalise, rdType, rrDataCast ) +import Net.DNSBase.Lookup (lookupRawCtl) +import Net.DNSBase.RRSet (RRSet(..), rrSetsFromList) +import Net.DNSBase.Resolver (DNSIO, Resolver, ResolvSeed) + +import qualified Dane.Scanner.Opts as Opts +import Dane.Scanner.DNS.Reply + + +-- | Single low-level DNS query. CD-bit selection is via the +-- 'QueryControls' argument; see 'rawReply' / 'rawReplyCD'. +rawDnsLookup :: Resolver + -> QueryControls + -> Domain + -> RRTYPE + -> IO (RC, AD, [RR]) +rawDnsLookup rv qctls qname typ = do + reply <- lookupRawCtl rv qctls qname IN typ + pure $ case reply of + Left (DNS.NetworkError n) + | DNS.TimeoutExpired <- n -> (DnsTimeout, False, []) + | DNS.RetryLimitExceeded <- n -> (DnsTimeout, False, []) + | DNS.NetworkFailure e <- n -> (DnsXprtErr (showXprtErr e), False, []) + Left e -> (ErrRC (show e), False, []) + Right msg -> let !fl = DNS.dnsMsgFl msg + !ad = DNS.maskDNSFlags fl ADflag /= mempty + !rc = DNS.dnsMsgRC msg + !an = DNS.dnsMsgAn msg + in (DnsRC rc, ad, an) + + +-- | Probe the source-zone signedness of a CNAMEd MX host name +-- (RFC 7672, section 2.1.3). +-- +-- When an A/AAAA reply is reached via a CNAME and the answer +-- chain as a whole is not secure, the A/AAAA RRsets sit on the +-- /target/ side of the CNAME and so reflect the target zone's +-- signedness; they say nothing about whether the source zone +-- (the MX host's own zone) is signed. The source zone may still +-- publish authentic TLSA records at @_25._tcp.\@ even +-- when the target zone is unsigned. Querying TLSA directly is +-- unsafe in that case because out-of-spec name servers serving +-- the target may @SERVFAIL@\/@NOTIMP@ on TLSA, so we issue this +-- CNAME query at the MX host name and consult only the AD bit +-- of the result. +cnameAdProbe :: Resolver -> Domain -> IO (RC, AD) +cnameAdProbe rv qname = do + (rc, ad, _) <- rawDnsLookup rv mempty qname CNAME + pure (rc, ad) + + +-- | Issue a DNS query at the slot's RR type and return the typed +-- 'Reply a' directly. The RR type is supplied as a required +-- visible type argument (no @\@@ needed at the call site). The +-- CnAD probe for A\/AAAA replies that arrive over an insecure +-- CNAME chain happens inside 'buildReply'. +rawReply :: forall a -> KnownRData a => Resolver -> Domain -> IO (Reply a) +rawReply a = rawReply' a mempty +{-# INLINE rawReply #-} + +-- | 'rawReply' with the CD bit set. Used to probe a name that +-- returned bogus / SERVFAIL: if the same query with the CD bit +-- set succeeds, the upstream zone is signed but at least one +-- record is bogus. +rawReplyCD :: forall a -> KnownRData a => Resolver -> Domain -> IO (Reply a) +rawReplyCD a = rawReply' a (DNS.QctlFlags (DNS.setFlagBits CDflag)) +{-# INLINE rawReplyCD #-} + + +-- | Shared implementation of 'rawReply' / 'rawReplyCD'. +rawReply' :: forall a -> KnownRData a + => QueryControls -> Resolver -> Domain -> IO (Reply a) +rawReply' a qctls rv qname = do + let typ = rdType a + (rc, ad, an) <- rawDnsLookup rv qctls qname typ + case rc of + NoErrorRC -> buildReply rv rc ad qname typ an + NXDomainRC -> buildReply rv rc ad qname typ an + _ -> pure (noReply rc ad qname) + + +-- | Process the answer section of a NOERROR / NXDOMAIN response +-- into a typed 'Reply a'. Extracts DNAMEs separately +-- (informational), groups the CNAME and qtype RRs into an RRset +-- map keyed by @(RRTYPE, canonical-owner)@, then walks the CNAME +-- chain via 'M.alterF'-with-deletion so that pathological cycles +-- cannot be re-traversed. A multi-CNAME RRset at any owner +-- along the chain yields a 'Reply' with 'repRC' set to +-- 'CnameErr' carrying the offending targets; otherwise the chain +-- walk sets 'repOwner' and 'repChain' (when any CNAMEs or DNAMEs +-- were observed), and the answer-section RRset at the final +-- owner is narrowed to @[a]@ via 'rrDataCast' to populate +-- 'repRD'. +buildReply :: forall a. KnownRData a + => Resolver -> RC -> AD -> Domain -> RRTYPE -> [RR] + -> IO (Reply a) +buildReply rv rc ad qname typ rs = do + let -- DNAMEs are pulled out separately: they are informational + -- and not part of the CNAME walk. + (dnameRRs, others) = partition ((== DNAME) . DNS.rrType) rs + ds = [ Dname (rrOwner rr) target + | rr <- dnameRRs + , Just (T_DNAME target) <- [rrDataCast rr] + ] + -- Filter to IN-class records that can participate in the + -- chain walk: the CNAMEs that drive it and the qtype that + -- terminates it. Group into RRsets, then key the map by + -- (RRTYPE, canonical-owner) so that lookups don't depend + -- on the wire-form casing of owner names. + relevant = [ rr | rr <- others + , rrClass rr == IN + , let t = DNS.rrType rr + , t == typ || t == CNAME ] + sm0 :: M.Map (RRTYPE, Domain) [RR] + sm0 = M.fromList + [ ((rrSetType s, canonicalise (rrSetOwner s)), rrSetRecs s) + | s <- rrSetsFromList relevant + ] + case walkChain qname sm0 [] of + BadCNames bad -> + pure Reply + { repRC = CnameErr bad + , repAD = ad + , repChain = chainOf [] ds ad + , repOwner = qname + , repRD = [] + } + Walked owner aliases -> do + let ans :: [a] + ans = case M.lookup (typ, canonicalise owner) sm0 of + Nothing -> [] + Just rrs -> sort (mapMaybe rrDataCast rrs) + cnAD <- + if rc == NoErrorRC + && not ad + && typ `elem` [A, AAAA] + && not (null aliases) + then do + (rc', ad') <- cnameAdProbe rv qname + -- If the probe didn't return NoError, fall + -- back to the chain's AD bit (which is False + -- here). + pure $ case rc' of + NoErrorRC -> ad' + _ -> ad + else + pure ad + pure Reply + { repRC = rc + , repAD = ad + , repChain = chainOf aliases ds cnAD + , repOwner = owner + , repRD = ans + } + + +-- | Result of walking a CNAME chain. +data ChainResult + = BadCNames [Domain] + -- ^ Multi-CNAME RRset detected; the offending targets are + -- recorded for the 'CnameErr' RC. + | Walked !Domain ![Domain] + -- ^ Final owner reached, plus the alias list with @qname@ + -- at the head and the name whose CNAME terminated the walk + -- at the tail. Empty alias list means no chain was + -- followed. + + +-- | Walk a CNAME chain starting at @owner@. At each step at most +-- one CNAME may match the current owner; multiple matches abort +-- the walk via 'BadCNames'. The CNAME entry under each visited +-- owner is removed from the map as we traverse it +-- ('M.alterF (, Just []) (CNAME, owner)' fetches and replaces in +-- one pass), so a malicious CNAME loop cannot be walked twice. +walkChain :: Domain + -> M.Map (RRTYPE, Domain) [RR] + -> [Domain] -- ^ aliases accumulated so far, in reverse + -> ChainResult +walkChain owner sm acc = + let key = (CNAME, canonicalise owner) + (cnameRRs, sm') = M.alterF (, Just []) key sm + in case cnameRRs of + Just rrs + | length rrs > 1 -> + BadCNames + [ t | r <- rrs + , Just (T_CNAME t) <- [rrDataCast r] + ] + | [r] <- rrs + , Just (T_CNAME target) <- rrDataCast r -> + walkChain target sm' (owner : acc) + _ -> + -- No CNAME at this owner. Walk terminates; if we + -- accumulated aliases, the final 'repOwner' is + -- 'owner' and 'repCnames' is the reversed accumulator. + Walked owner (reverse acc) + + +-- | Seed the DNS resolver from dc-main's flat 'Opts.Opts'. AD +-- bit is requested by default; CD is selected per-query via the +-- 'QueryControls' argument on 'rawReplyCD'. +dnsConf :: Opts.Opts -> DNSIO ResolvSeed +dnsConf opts = ExceptT $ DNS.makeResolvSeed + $ DNS.setResolverConfRetries (Opts.dnsTries opts) + . DNS.setResolverConfTimeout (1000 * Opts.dnsTimeout opts) + . DNS.setResolverConfQueryControls qctls + . case Opts.dnsServer opts of + Nothing -> id + Just ns + | servers <- DNS.NameserverSpec ns Nothing :| [] + -> DNS.setResolverConfSource $ DNS.HostList servers + $ DNS.defaultResolvConf + where + qctls = DNS.QctlFlags (DNS.setFlagBits ADflag) + <> DNS.EdnsUdpSize (Opts.dnsUdpSize opts) diff --git a/Dane/Scanner/DNS/Reply.hs b/Dane/Scanner/DNS/Reply.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/DNS/Reply.hs @@ -0,0 +1,614 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | +-- Module : Dane.Scanner.DNS.Reply +-- Description : Typed DNS-reply data + per-RRtype printing +-- Copyright : (c) Viktor Dukhovni, 2018-2026 +-- License : BSD-3-Clause +-- Maintainer : ietf-dane@dukhovni.org +-- +-- The 'Reply a' type carries the per-RRtype query result: the +-- 'RC' rcode\/error, the AD bit, optional CNAME\/DNAME chain +-- bookkeeping, the final-owner name, and the answer RRset as a +-- typed @[a]@ list. Because @a@ is a concrete dnsbase RR data +-- type (e.g. 'T_a', 'T_dnskey', 'T_tlsa'), callers can pattern +-- match on record fields directly instead of unwrapping an +-- existential 'RData'. +-- +-- The 'put*' family produces continuation-style 'Builder' output +-- for streaming results to stdout as they become available +-- (danecheck prints each MX-host's results as soon as that host's +-- A\/AAAA\/TLSA\/chain probes are done). +-- +module Dane.Scanner.DNS.Reply + ( AD + , Dname(..) + , NameChain(..) + , RC( DnsRC, DnsTimeout, DnsXprtErr, TldMX, BadName, CnameErr, ErrRC + , NoErrorRC, NXDomainRC + ) + , Reply(..) + , TlsaInfo(..) + , Validity(..) + , chainOf + , noReply + , putReplyA + , putReplyAaaa + , putReplyAny + , putReplyDnskey + , putReplyDs + , putReplyMx + , repCnAD + , repCnames + , repQname + , repValidated + , repValidity + , showXprtErr + ) where + +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Short as SB +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import Control.Exception (IOException) +import Data.ByteString (ByteString) +import Data.Char (isControl, ord) +import Data.UnixTime (formatUnixTimeGMT, UnixTime(..)) +import Data.Word (Word8) +import Foreign.C.Types (CTime(..)) +import GHC.IO.Exception (ioe_description, ioe_filename, ioe_location) +import Text.Printf (printf) + +import Data.IP (IP(IPv4, IPv6)) +import Net.DNSBase ( Domain, RCODE(NOERROR, NXDOMAIN, SERVFAIL, FORMERR, NOTIMP, REFUSED) + , RRCLASS(IN) + , RRTYPE(A, AAAA, CNAME, DNAME, DS, DNSKEY, MX, TLSA) + , T_a(T_A), T_aaaa(T_AAAA) + , T_dnskey, T_ds, T_mx, T_tlsa, X_tlsa(..) + , toHost + ) +import Net.DNSBase.Present +import qualified Network.TLS as TLS + +import Dane.Scanner.Util +import Dane.Scanner.SMTP.Certs (CertInfo(..), CertHashes(..), cnOf, orgOf) +import Dane.Scanner.SMTP.Chain + ( AddrChain(..), PeerChain(..), PeerProbe(..), SmtpState(..) + ) + + +---------------------------------------------------------------------- +-- Validity and RC +---------------------------------------------------------------------- + +-- | DNSSEC validation status of a query response. A lookup might +-- fail, return insecure results, or return a secure NXDomain, +-- NODATA, or a regular answer. +data Validity + = Indeterminate -- ^ Lookup failed + | Insecure -- ^ Lookup done, insecure answer or DoE + | Nodomain -- ^ Lookup done, secure NXDomain + | Nodata -- ^ Lookup done, secure NODATA + | Secure -- ^ Lookup done, host secure + deriving (Eq) + +instance Show Validity where + show Indeterminate = "Indeterminate" + show Insecure = "Insecure" + show Nodomain = "NXDomain" + show Nodata = "NODATA" + show Secure = "NoError" + +instance Presentable Validity where + present v = present (show v :: String) + + +-- | DNS query response code or error condition. +data RC = DnsRC RCODE + | DnsTimeout + | DnsXprtErr String -- ^ Pre-rendered network/transport error + | TldMX -- ^ MX host is at TLD or root level + | BadName -- ^ MX hostname has a disallowed + -- label shape (e.g. ATTRLEAF, ULABEL, + -- WILDLABEL, OCTET) — kept in the + -- output but not looked up + | CnameErr [Domain] -- ^ Invalid multi-CNAME RRset; the targets + -- are recorded for display + | ErrRC String + deriving (Eq) + +pattern NoErrorRC :: RC +pattern NoErrorRC = DnsRC NOERROR + +pattern NXDomainRC :: RC +pattern NXDomainRC = DnsRC NXDOMAIN + +instance Show RC where + show NoErrorRC = "NoError" + show NXDomainRC = "NXDomain" + show (DnsRC SERVFAIL) = "ServFail" + show (DnsRC FORMERR) = "FormErr" + show (DnsRC NOTIMP) = "NotImp" + show (DnsRC REFUSED) = "Refused" + show (DnsRC rc) = presentString rc mempty + show DnsTimeout = "timeout" + show (DnsXprtErr s) = s + show TldMX = "TldMXHost" + show BadName = "Invalid MX hostname" + show (CnameErr _) = "CnameErr" + show (ErrRC err) = err + +instance Presentable RC where + present rc = present (show rc :: String) + + +-- | The DNS library sets the 'ioe_filename' field of network I/O +-- errors to the protocol (@UDP@ or @TCP@) and the 'ioe_location' +-- to the address and port of the peer nameserver. We render +-- those into a single string at error-capture time so 'RC' can +-- stay 'Eq'-derivable and survive any future serialisation. +showXprtErr :: IOException -> String +showXprtErr = (\a b c -> a ++ b ++ c) + <$> maybe "" (++ ": ") . ioe_filename + <*> ( ++ "; ") . ioe_location + <*> ioe_description + + +---------------------------------------------------------------------- +-- AD bit and chain bookkeeping +---------------------------------------------------------------------- + +-- | DNSSEC authentication-data bit from the response header. +type AD = Bool + +-- | DNAME source/target pair recorded during answer-section parsing. +data Dname = Dname + { dnameOwner :: Domain + , dnameTarget :: Domain + } + +-- | CNAME / DNAME chain bookkeeping. Present only when the answer +-- was reached via aliasing (or DNAMEs were observed); 'ncCnames' +-- is non-empty in the common chain case and starts with the qname, +-- followed by any intermediate aliases. +data NameChain = NameChain + { ncCnames :: [Domain] -- ^ qname : intermediates; empty if + -- only DNAMEs were seen + , ncDnames :: [Dname] -- ^ DNAME source/target pairs + , ncCnAD :: AD -- ^ AD bit of the initial CNAME RRset + } + + +---------------------------------------------------------------------- +-- Reply +---------------------------------------------------------------------- + +-- | Per-RRtype-specialized reply. Carries the typed answer RRset +-- @[a]@, the rcode, the AD bit, and optional chain provenance. +data Reply a = Reply + { repRC :: RC + , repAD :: AD + , repChain :: Maybe NameChain + , repOwner :: Domain + , repRD :: [a] + } + +-- | AD bit of the initial CNAME RRset, falling back to 'repAD' +-- when the response was reached without aliasing. +repCnAD :: Reply a -> AD +repCnAD r = maybe (repAD r) ncCnAD (repChain r) +{-# INLINE repCnAD #-} + +-- | Intermediate alias names from qname to (just before) the +-- final owner. Empty when the response was reached without +-- CNAMEs. +repCnames :: Reply a -> [Domain] +repCnames r = maybe [] ncCnames (repChain r) +{-# INLINE repCnames #-} + +-- | DNAME source/target pairs observed in the answer section. +repDnames :: Reply a -> [Dname] +repDnames r = maybe [] ncDnames (repChain r) +{-# INLINE repDnames #-} + +-- | Qname of the original query (first element of the CNAME +-- chain when present); falls back to the ultimate owner domain +-- when no aliasing was involved. +repQname :: Reply a -> Domain +repQname r = headDef (repOwner r) (repCnames r) +{-# INLINE repQname #-} + +-- | DNSSEC validation status of a query response. +repValidity :: Reply a -> Validity +repValidity Reply{..} = case repRC of + NoErrorRC | not repAD -> Insecure + | null repRD -> Nodata + | otherwise -> Secure + NXDomainRC | not repAD -> Insecure + | otherwise -> Nodomain + _ -> Indeterminate +{-# INLINE repValidity #-} + +-- | Is the response a DNSSEC-validated NoError response? +repValidated :: Reply a -> Bool +repValidated r = case repValidity r of + Secure -> True + Nodata -> True + _ -> False +{-# INLINE repValidated #-} + +-- | Build a 'Maybe NameChain' from possibly-empty alias and DNAME +-- lists. Returns 'Nothing' when neither list contributes anything. +chainOf :: [Domain] -> [Dname] -> AD -> Maybe NameChain +chainOf [] [] _ = Nothing +chainOf cs ds cnAD = Just NameChain + { ncCnames = cs + , ncDnames = ds + , ncCnAD = cnAD + } + +-- | Synthetic empty 'Reply'. The RR type is implicit in the type +-- parameter @a@. +noReply :: RC -> AD -> Domain -> Reply a +noReply rc ad owner = Reply + { repRC = rc + , repAD = ad + , repChain = Nothing + , repOwner = owner + , repRD = [] + } + + +---------------------------------------------------------------------- +-- TLSA bundle +---------------------------------------------------------------------- + +-- | Per-host DNS-side TLSA information. Holds the TLSA base +-- domain and the typed TLSA RRset reply. The cert-chain probes +-- (one 'AddrChain' per scanned IP) are passed separately to +-- 'putReplyAaaa' rather than packaged here, so the print-as-you-go +-- driver can attach them at the right moment without buffering +-- the chains alongside the TLSA bundle. +data TlsaInfo = TlsaInfo + { tlsaBase :: !Domain -- ^ TLSA base (host name, the prefix + -- @_25._tcp.@ is added at query time) + , tlsaRRset :: !(Reply T_tlsa) + } + + +---------------------------------------------------------------------- +-- Per-RRtype Builder rendering +---------------------------------------------------------------------- + +-- | Render a 'Reply' for any concrete RR-data type. The 'RRTYPE' +-- parameter pins down the slot's nominal type for the +-- owner\/IN\/type lines (and for the AD-suppression test on +-- validated DS\/DNSKEY answers). 'CnameErr' is dispatched at the +-- top: DNAMEs print as usual, then the offending CNAME targets +-- emit as failed CNAME records. All other RC values delegate to +-- 'putRespBody' for the CNAME-chain prefix + answer RRset. +putReplyAny :: Presentable a => RRTYPE -> Reply a -> Builder -> Builder +putReplyAny typ r@Reply{..} = case repRC of + CnameErr bad -> + putDnames repAD (repDnames r) + . putBadCNames (repCnAD r) repOwner bad + _ -> + putRespBody repRC repAD (repCnAD r) (repDnames r) (repCnames r) + repOwner typ repRD + +-- Per-slot renderers — wrap 'putReplyAny' with the slot's RR type. +putReplyDs :: Reply T_ds -> Builder -> Builder +putReplyDs = putReplyAny DS + +putReplyDnskey :: Reply T_dnskey -> Builder -> Builder +putReplyDnskey = putReplyAny DNSKEY + +putReplyMx :: Reply T_mx -> Builder -> Builder +putReplyMx = putReplyAny MX + +putReplyA :: Reply T_a -> Builder -> Builder +putReplyA = putReplyAny A + +-- | AAAA reply renderer; also emits the per-host TLSA bundle and +-- SMTP cert-chain output appended after the AAAA records. +putReplyAaaa :: Maybe TlsaInfo -> [AddrChain] -> Reply T_aaaa + -> Builder -> Builder +putReplyAaaa mtlsa chains r = putReplyAny AAAA r . putHostTlsa mtlsa chains + + +-- | Render an answer RRset to a CPS builder. Prepends any CNAME +-- RRs leading to the answer RRset, then all the answers. Even if +-- the final RRset carries an NXDOMAIN RCODE, any intermediate +-- CNAME values are necessarily NOERROR. +putRespBody :: Presentable a + => RC + -> AD -- AD of final answer + -> AD -- AD of first CNAME + -> [Dname] -- DNAME chain + -> [Domain] -- CNAME chain + -> Domain -- Final owner domain + -> RRTYPE + -> [a] + -> Builder + -> Builder + +-- No answer, e.g. NODATA, NXDOMAIN. +putRespBody (DnsRC NOERROR) ad _ [] [] owner typ [] = + putAns "NODATA" ad owner (presentSp typ . presentSp '?') +putRespBody rc ad _ [] [] owner typ [] = + putAns rc ad owner (presentSp typ . presentSp '?') + +-- One or more answers. Validated DS\/DNSKEY answer RRs are +-- suppressed (the rcode-comment line is sufficient context). +-- The RR-type label is emitted explicitly because the typed +-- 'T_*' 'Presentable' instances render only the record fields, +-- so the @owner IN TYPE rdata@ line shape needs the @TYPE@ +-- prepended here. +putRespBody rc ad _ [] [] owner typ rds = + if ad && typ `elem` [DS, DNSKEY] && nonempty rds + then id + else flip (foldr f) rds + where + f rd = putAns rc ad owner (presentSp typ . presentSp rd) + +-- Final valid CNAME. Consumes ad'; ad is used for subsequent RData. +putRespBody rc ad ad' [] (alias:[]) cname typ rds = + putAns NOERROR ad' alias (presentSp CNAME . presentSp cname) + . putRespBody rc ad ad [] [] cname typ rds + +-- Two or more valid CNAMEs. Only the first gets the ad' security tag. +putRespBody rc ad ad' [] (alias:aliases@(cname:_)) owner typ rds = + putAns NOERROR ad' alias (presentSp CNAME . presentSp cname) + . putRespBody rc ad ad [] aliases owner typ rds + +-- One or more DNAMEs. The security status of even the first DNAME +-- record cannot be reliably inferred from the first CNAME's, so +-- 'ad' is used for all of them. +putRespBody rc ad ad' (dname:dnames) aliases owner typ rds = + putAns NOERROR ad q (presentSp DNAME . presentSp d) + . putRespBody rc ad ad' dnames aliases owner typ rds + where + q = dnameOwner dname + d = dnameTarget dname + + +-- | Generic record-line emitter: @owner IN ; AD=@. +putAns :: Presentable rc + => rc -> AD -> Domain -> (Builder -> Builder) -> Builder -> Builder +putAns rc ad owner rdbuilder = + present owner + . presentSp IN + . rdbuilder + . presentSp ';' + . presentSp rc + . presentSpLn @String (if_ ad "AD=1" "AD=0") + +-- | Print the DNAME chain. The security status of even the first +-- DNAME record cannot be reliably inferred from the security +-- status of the first CNAME, so 'ad' applies to all of them. +putDnames :: AD -> [Dname] -> Builder -> Builder +putDnames ad = flip (foldr f) + where + f (Dname q d) = + putAns NOERROR ad q (presentSp DNAME . presentSp d) + +-- | Emit the targets of a multi-CNAME RRset as failed CNAME +-- records under a "CnameErr" rcode comment. +putBadCNames :: AD -> Domain -> [Domain] -> Builder -> Builder +putBadCNames ad' owner = flip (foldr f) + where + f rd = putAns "CnameErr" ad' owner b + where + b = presentSp CNAME . presentSp rd + + +---------------------------------------------------------------------- +-- TLSA + per-IP SMTP chain rendering +---------------------------------------------------------------------- + +-- | TLSA RRset display + per-IP SMTP chain output, appended after +-- the AAAA reply for an MX host. No-op when the host has no +-- TLSA bundle attached. +putHostTlsa :: Maybe TlsaInfo -> [AddrChain] -> Builder -> Builder +putHostTlsa Nothing _ k = k +putHostTlsa (Just t@TlsaInfo{..}) cs k = + putReplyAny TLSA tlsaRRset (foldr f k cs) + where + f AddrChain{..} = putChainInfo t peerAddr peerChain + + +-- | Per-IP chain info: TLSA-base header line, the 'AddrChain' +-- outcome, and (for the success case) the per-cert chain display. +putChainInfo :: TlsaInfo -> IP -> PeerChain -> Builder -> Builder +putChainInfo TlsaInfo{..} addr chain = + indent2 + . present (toHost tlsaBase) + . case addr of + IPv4 ip4 -> presentCharSep '[' (T_A ip4) + IPv6 ip6 -> presentCharSep '[' (T_AAAA ip6) + . present @String "]:" + . case chain of + ChainException msg + -> presentSpLn msg + SmtpError CONNECT (-1) _ + -> presentSpLn @String "address reserved" + SmtpError CONNECT 0 _ + -> presentSpLn @String "connection timeout" + SmtpError CONNECT _ _ + -> presentSpLn @String "connection refused" + SmtpError STARTTLS (-1) _ + -> presentSpLn @String "STARTTLS failure" + SmtpError STARTTLS 0 _ + -> presentSpLn @String "STARTTLS not offered" + SmtpError state code m + -> presentSp (show state :: String) + . presentSp code + . presentSpLn m + Probed PeerProbe{..} + -> let auth = case matchDepth of + Nothing -> show matchStatus + Just d | Just n <- matchName + -> "pass: TLSA match: depth = " ++ show d + ++ ", name = " ++ n + | otherwise + -> "pass: TLSA match: depth = " ++ show d + in presentSpLn auth + . putTLS peerTlsVersion peerTlsCipher peerTlsGroup peerCerts + . flip (foldr putName) peerNames + . flip (foldr putCert) peerCerts + where + putTLS v c g cs = + indent4 + . present @String "TLS =" + . presentSp (show v :: String) + . case g of + Nothing -> presentSp @String "with" + . presentSpLn (show c :: String) + Just grp -> presentSp @String "with" + . presentSp (show c :: String) + . present ',' + . present (show grp :: String) + . leafAlg v cs + . present '\n' + leafAlg :: TLS.Version -> [CertInfo] -> Builder -> Builder + leafAlg v (CertInfo{..}:_) | v > TLS.TLS12 = + present ',' . present (show _alg :: String) + leafAlg _ _ = id + + putName n = + indent4 + . present @String "name =" + . presentSp n + . present '\n' + + putCert ci@CertInfo{..} = + putDepth _depth + . maybe id (putDN "Issuer" "CommonName") (DnDisplay <$> cnOf _idn) + . maybe id (putDN "Issuer" "Organization") (DnDisplay <$> orgOf _idn) + . putLife _life + . maybe id (putDN "Subject" "CommonName") (DnDisplay <$> cnOf _sdn) + . maybe id (putDN "Subject" "Organization") (DnDisplay <$> orgOf _sdn) + . putHashes (if_ (_depth == 0) 3 2) ci + + putDepth depth = + indent4 + . present @String "depth =" + . presentSpLn depth + + putDN which what val = + indent6 + . present @String which + . presentSp @String what + . presentSp '=' + . presentSpLn val + + putLife (before, after) = + putTime "notBefore" before + . putTime "notAfter" after + + putTime n t = + indent6 + . present @String n + . presentSp '=' + . presentSpLn gmtime + where + gmtime = formatUnixTimeGMT (BC.pack "%FT%TZ") (UnixTime (CTime t) 0) + + -- Print policy: show all hashes that match a TLSA RR, show all + -- hashes whose (selector, matching-type) pair appears in the + -- RRset, and always show the SPKI SHA2-256 entry. Full(0) + -- payloads are truncated by 'shorthex'. + putHashes u ci = + putHash tlsaRRset "cert sha256" u 0 1 (_cert256 (_hashes ci)) + . putHash tlsaRRset "pkey sha256" u 1 1 (_spki256 (_hashes ci)) + . putHash tlsaRRset "cert sha512" u 0 2 (_cert512 (_hashes ci)) + . putHash tlsaRRset "pkey sha512" u 1 2 (_spki512 (_hashes ci)) + . putHash tlsaRRset "full cert" u 0 0 (_cert ci) + . putHash tlsaRRset "full spki" u 1 0 (_spki ci) + + putHash :: Reply T_tlsa + -> String -> Word8 -> Word8 -> Word8 -> ByteString + -> Builder -> Builder + putHash t l u s m hash + | matched || (s == 1 && m == 1) || wanted + = indent6 + . present l + . presentSp matchstr + . presentSp @String "<- " + . fmtHash + | otherwise = id + where + rd = repRD t + sbHash = SB.toShort hash + matched = T_TLSA u s m sbHash `elem` rd + wanted = any (\(T_TLSA _ s' m' _) -> s' == s && m' == m) rd + matchstr | matched = "[matched]" :: String + | otherwise = "[nomatch]" + fmtHash = + present u + . presentSp s + . presentSp m + . presentSpLn (shorthex hash) + + +indent2, indent4, indent6 :: Builder -> Builder +indent2 = present @String " " +indent4 = present @String " " +indent6 = present @String " " + + +-- | Wrapper for a certificate Distinguished-Name field +-- ('cnOf'\/'orgOf' result) that should be rendered as Unicode +-- display text rather than DNS wire-form bytes. Use at sites +-- that print human-readable cert fields: +-- +-- > presentSpLn (DnDisplay orgString) +-- +-- The 'Presentable' instance emits the UTF-8 bytes of the +-- underlying 'String' verbatim, matching the on-disk byte form +-- the certificate carried (for modern UTF8String certs). +-- Unicode control characters (Cc category — C0 + DEL + C1) are +-- escaped as @\\xNN@; everything else passes through. +-- +-- The output shape mirrors a (sufficiently recent) OpenSSL +-- @x509 -nameopt utf8,-esc_msb@ rendering. Distinct from the +-- byte-per-'Char' 'Presentable' 'String' instance dnsbase +-- provides (correct for DNS wire-form labels but wrong for +-- arbitrary Unicode text) and from 'Net.DNSBase.DnsUtf8Text' +-- (which escapes every non-printable byte as @\\NNN@ decimal). +newtype DnDisplay = DnDisplay String + +instance Presentable DnDisplay where + present (DnDisplay s) = present (utf8Bytes s) + where + -- Pre-encode the input as UTF-8 bytes carried in a + -- 'String' whose 'Char's all have code values < 256, then + -- feed it through the existing byte-per-'Char' 'String' + -- presentation path. + utf8Bytes :: String -> String + utf8Bytes = BC.unpack . E.encodeUtf8 . T.pack . concatMap escChar + + -- Escape control characters (Cc: C0 + DEL + C1) as the + -- DNS-style @\\DDD@ three-decimal-digit byte escape used + -- throughout the rest of the output for domain labels. + -- This is the safety-critical category: it includes LF, + -- CR, BS, ESC, etc., any of which could otherwise break + -- the per-record one-line shape, drive the terminal + -- off-screen, or smuggle ANSI escape sequences out of a + -- malicious certificate. The fixed three-digit width is + -- unambiguous regardless of what follows. The backslash + -- itself is escaped as @\\\\@ so a literal @\\DDD@ + -- sequence in a cert stays distinguishable from an + -- actually-escaped control byte. + escChar c | isControl c = printf "\\%03d" (ord c) + | c == '\\' = "\\\\" + | otherwise = [c] + +-- | Truncated in the middle hex encoding of all but the shortest +-- ByteStrings. +shorthex :: ByteString -> ByteString +shorthex b + | BC.length b < 65 = bs2hex b + | otherwise = bs2hex (BC.take 31 b) + <> BC.pack "..." + <> bs2hex (BC.drop (BC.length b - 31) b) diff --git a/Dane/Scanner/DNS/Toascii.hs b/Dane/Scanner/DNS/Toascii.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/DNS/Toascii.hs @@ -0,0 +1,27 @@ +-- | Module : Dane.Scanner.DNS.Toascii +-- Description : IDNA2008 input parser for a one-shot DANE check +-- Copyright : (c) Viktor Dukhovni, 2018 +-- License : BSD-3-Clause +-- Maintainer : ietf-dane@dukhovni.org +-- Stability : experimental +-- Portability : POSIX +-- +-- Convert input domains that may contain U-labels to A-label form. +-- Optionally allow leading underscores in labels. +-- +module Dane.Scanner.DNS.Toascii (todomain) where + +import qualified Text.IDNA2008 as I +import Data.Text (Text) +import Net.DNSBase (Domain, wireToDomain) + +-- | Attempt to convert all the labels of a 'Text' domainname to IDNA ASCII. +-- Returns 'Nothing' on failure. +-- +todomain :: I.LabelFormSet -- ^ Accepted label forms + -> I.IdnaFlags -- ^ IDNA parser options + -> Text -- ^ Input domain name + -> Maybe Domain +todomain forms opts name = case I.parseDomainOpts forms opts name of + Right (I.Domain sbs, _) -> wireToDomain sbs + Left _ -> Nothing diff --git a/Dane/Scanner/Main.hs b/Dane/Scanner/Main.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/Main.hs @@ -0,0 +1,15 @@ +module Main (main) where + +import System.Exit (ExitCode(ExitFailure), exitWith) +import Control.Monad (when) + +import Dane.Scanner.DNS.Dane +import qualified Dane.Scanner.Opts as Opts + + +-- | Parse JCL and check the requested domain +-- +main :: IO () +main = do + ok <- daneCheck =<< Opts.getOpts + when (not ok) $ exitWith $ ExitFailure 1 diff --git a/Dane/Scanner/Opts.hs b/Dane/Scanner/Opts.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/Opts.hs @@ -0,0 +1,246 @@ +{-# LANGUAGE ApplicativeDo #-} +{-# LANGUAGE RecordWildCards #-} + +module Dane.Scanner.Opts + ( Opts(..) + , SigAlgs(..) + , SigAlgGroup(..) + , getOpts + ) where + +import Options.Applicative +import Data.Char (isSpace, toLower) +import Data.List (intercalate) +import Data.Word (Word16) + +-- | Named signature-algorithm groups offered to the server. +-- Each group expands at TLS-config time to a list of +-- @(HashAlgorithm, SignatureAlgorithm)@ pairs covering the +-- common SHA-256\/384\/512 variants within the family. The +-- friendly group names give users a stable handle to refer to a +-- family without having to spell out (or remember) the individual +-- sig-alg codepoint names. Future post-quantum families (e.g. an +-- @mldsa@ group covering ML-DSA-44\/65\/87) would slot in here +-- as additional constructors. +data SigAlgGroup = SigEcdsa -- ^ ECDSA over P-256, P-384, P-521 + | SigRsa -- ^ RSA-PSS (TLS 1.3) + RSA-PKCS#1 (TLS 1.2) + | SigEdDsa -- ^ Ed25519 and Ed448 + deriving (Eq, Show) + +-- | An ordered list of 'SigAlgGroup's, expressing the relative +-- preference offered to the server. The empty list means \"use +-- the TLS library default\", i.e. no override. A non-empty list +-- both restricts the offered algorithms to the named groups and +-- pins their relative order. Hosts that publish certificates of +-- multiple kinds can therefore be probed independently by passing +-- a single group, or with a chosen preference order by passing +-- two or more groups. +newtype SigAlgs = SigAlgs { sigAlgsList :: [SigAlgGroup] } + deriving (Eq, Show) + +data Opts = Opts + { dnsServer :: !(Maybe String) + , dnsTimeout :: !Int + , dnsTries :: !Int + , dnsUdpSize :: !Word16 + , smtpHelo :: !(Maybe String) + , smtpTimeout :: !Int + , smtpLineLen :: !Int + , useReserved :: !Bool + , downMX :: !([String]) + , upsideDown :: !Bool + , enableV4 :: !Bool + , enableV6 :: !Bool + , useAll :: !Bool + , addDays :: !Int + , eeChecks :: !Bool + , sigAlgs :: !SigAlgs + , dnsDomain :: !String + } + +parseN :: Parser (Maybe String) +parseN = flag' Nothing + ( short 'N' + <> help "Use /etc/resolv.conf nameserver list" ) + +parsen :: Parser (Maybe String) +parsen = Just <$> strOption + ( long "nameserver" + <> short 'n' + <> value "127.0.0.1" + <> showDefault + <> metavar "ADDRESS" + <> help "Use nameserver at ADDRESS" ) + +parser :: Parser Opts +parser = do + dnsServer <- parseN <|> parsen + + dnsTimeout <- option auto + ( long "timeout" + <> short 't' + <> metavar "TIMEOUT" + <> value 5000 + <> showDefaultWith (\t -> show t ++ " ms") + <> help "DNS request TIMEOUT" ) + + dnsTries <- option auto + ( long "tries" + <> short 'r' + <> metavar "NUMTRIES" + <> value 3 + <> showDefault + <> help "at most NUMTRIES requests per lookup" ) + + dnsUdpSize <- option auto + ( long "udpsize" + <> short 'u' + <> metavar "SIZE" + <> value 1400 + <> showDefault + <> help "set EDNS UDP buffer SIZE" ) + + smtpHelo <- optional ( strOption + ( long "helo" + <> short 'H' + <> metavar "HELO" + <> help "send specified client HELO name" ) ) + + smtpTimeout <- option auto + ( long "smtptimeout" + <> short 's' + <> metavar "TIMEOUT" + <> value 30000 + <> showDefaultWith (\t -> show t ++ " ms") + <> help "SMTP TIMEOUT" ) + + smtpLineLen <- option auto + ( long "linelimit" + <> short 'l' + <> metavar "LENGTH" + <> value 4096 + <> showDefault + <> help "Maximum server SMTP response LENGTH" ) + + useReserved <- switch + ( long "reserved" + <> short 'R' + <> help "connect to reserved IP addresses" ) + + downMX <- many + ( (map toLower) <$> strOption + ( long "down" + <> short 'D' + <> metavar "HOSTNAME" + <> help "Specify one or more HOSTNAMEs that are down" ) ) + + upsideDown <- switch + ( long "down-only" + <> short 'U' + <> help "Limit connections to just the '-D' option hosts" ) + + enableV4 <- not <$> switch + ( long "noipv4" + <> short '4' + <> help "disable SMTP via IPv4" ) + + enableV6 <- not <$> switch + ( long "noipv6" + <> short '6' + <> help "disable SMTP via IPv6" ) + + useAll <- switch + ( long "all" + <> short 'A' + <> help "scan all MX hosts, not just those with TLSA RRs" ) + + addDays <- option auto + ( long "days" + <> short 'd' + <> metavar "DAYS" + <> value 0 + <> help "check validity at DAYS in the future" ) + + eeChecks <- switch + ( long "eechecks" + <> short 'e' + <> help "check end-entity (leaf) certificate dates and names" ) + + sigAlgs <- option (eitherReader parseSigAlgs) + ( long "sigalgs" + <> metavar "GROUPS" + <> value (SigAlgs []) + <> showDefaultWith showSigAlgs + <> help "Comma-separated ordered list of TLS signature-algorithm \ + \groups, drawn from 'rsa', 'ecdsa' and 'eddsa'; restricts \ + \the offered algorithms and pins their relative order. \ + \Use 'any' or the empty string for the TLS library \ + \defaults (the default)." ) + + dnsDomain <- strArgument + ( metavar "DOMAIN" + <> value "." + <> showDefault + <> help "check the specified DOMAIN" ) + + return Opts{..} + +-- | Parse the @--sigalgs@ argument: a comma-separated, case- +-- insensitive list of named groups, with whitespace tolerated. +-- The literal string @any@ (or an empty string) yields +-- @SigAlgs []@, meaning \"no override\". +parseSigAlgs :: String -> Either String SigAlgs +parseSigAlgs s + | null trimmed = Right (SigAlgs []) + | map toLower trimmed == "any" = Right (SigAlgs []) + | otherwise = SigAlgs <$> traverse parseOne (splitComma trimmed) + where + trimmed = dropWhile isSpace $ reverse $ dropWhile isSpace $ reverse s + splitComma xs = case break (== ',') xs of + (h, ',':t) -> trim h : splitComma t + (h, _) -> [trim h] + trim = dropWhile isSpace . reverse . dropWhile isSpace . reverse + parseOne g = case map toLower g of + "rsa" -> Right SigRsa + "ecdsa" -> Right SigEcdsa + "eddsa" -> Right SigEdDsa + "" -> Left "empty sig-alg group name" + _ -> Left $ "unknown sig-alg group: " ++ show g + ++ " (expected one of rsa, ecdsa, eddsa)" + +-- | Pretty-print a 'SigAlgs' value for the @--help@ default +-- display. +showSigAlgs :: SigAlgs -> String +showSigAlgs (SigAlgs []) = "any" +showSigAlgs (SigAlgs gs) = intercalate "," (map groupName gs) + where + groupName SigRsa = "rsa" + groupName SigEcdsa = "ecdsa" + groupName SigEdDsa = "eddsa" + +-- | Parse command-line switches +-- +getOpts :: IO Opts +getOpts = + execParser + $ info (helper <*> parser) + $ noIntersperse + <> fullDesc + <> header "danecheck - check for and validate SMTP TLSA records" + <> footer + ("When scanning the root domain, what's checked is secure retrieval of \ + \ the root DNSKEY and SOA RRSets. Similarly, when scanning a top-level \ + \ domain, what's checked is secure retrieval of its DS, DNSKEY and SOA \ + \ records. For all other domains, MX records, address records and TLSA \ + \ records are retrieved and must be DNSSEC signed. Each MX host is \ + \ expected to have TLSA records, an SMTP connection is made to each \ + \ address of each such MX host (with the '-A' option connections are \ + \ made to all MX hosts). A TLS handshake is performed to retrieve the \ + \ hosts's certificate chain which is verified against the DNS TLSA RRs \ + \ If anything is unavailable, insecure or wrong, a non-zero exit code \ + \ is returned. The '-D' option can be used multiple times to skip SMTP \ + \ connections to MX hosts that are expected to be down. The '-U' option\ + \ inverts the action of the '-D' option, and connects to only those MX \ + \ hosts that are specified via the '-D' option (none if no such hosts \ + \ are specified)." + ) diff --git a/Dane/Scanner/SMTP/Addr.hs b/Dane/Scanner/SMTP/Addr.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/Addr.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE RecordWildCards #-} + +module Dane.Scanner.SMTP.Addr ( ipConn ) where + +import Control.Exception (IOException, bracket, try) +import Data.IP (IP(IPv4, IPv6), toHostAddress, toHostAddress6) +import Network.Socket (SockAddr(..), AddrInfo(..), Socket, SocketType(Stream)) +import Network.Socket (Family(AF_INET, AF_INET6), defaultProtocol, PortNumber) +import Network.Socket (connect, close, socket) +import System.Timeout (timeout) + +import Dane.Scanner.SMTP.Internal + +connectIP :: Int + -> (Either IOException Socket -> IO a) + -> AddrInfo + -> IO a +connectIP tmout action ~(AddrInfo{..}) = + bracket (socket addrFamily addrSocketType addrProtocol) close \sock -> do + res <- timeout tmout $ try $ connect sock addrAddress + case res of + Just (Right _) -> action . Right $ sock + Just (Left e) -> action . Left $ ioErr "connect" e + Nothing -> action . Left $ timeErr "connect" + +-- | Connect to the specified peer on the given TCP port with the +-- given timeout (in microseconds). The callback receives either +-- a connected 'Socket' or the 'IOException' describing the +-- failure to connect; the socket is always closed when the +-- callback returns, regardless of how it returns. +ipConn :: IP + -> PortNumber + -> Int + -> (Either IOException Socket -> IO a) + -> IO a +ipConn (IPv4 ip4) port tmout action = connectIP tmout action AddrInfo + { addrFlags = [] + , addrFamily = AF_INET + , addrSocketType = Stream + , addrProtocol = defaultProtocol + , addrAddress = SockAddrInet port (toHostAddress ip4) + , addrCanonName = Nothing + } +ipConn (IPv6 ip6) port tmout action = connectIP tmout action AddrInfo + { addrFlags = [] + , addrFamily = AF_INET6 + , addrSocketType = Stream + , addrProtocol = defaultProtocol + , addrAddress = SockAddrInet6 port 0 (toHostAddress6 ip6) 0 + -- 0 for FlowInfo, ScopeID + , addrCanonName = Nothing + } diff --git a/Dane/Scanner/SMTP/Certs.hs b/Dane/Scanner/SMTP/Certs.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/Certs.hs @@ -0,0 +1,184 @@ +{-# LANGUAGE RecordWildCards #-} + +module Dane.Scanner.SMTP.Certs + ( cnOf + , orgOf + , encodeDER + , genChainInfo + , ChainInfo + , CertInfo(..) + , CertHashes(..) + , HostName + ) where + +import Crypto.Hash (hashWith) +import Crypto.Hash.Algorithms (SHA256(..), SHA512(..)) +import Data.ASN1.BinaryEncoding +import Data.ASN1.Encoding +import Data.ASN1.Types +import qualified Data.ByteArray as BA +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LB +import Data.Hourglass (timeConvert, DateTime) +import Data.IORef (IORef, writeIORef) +import Data.Int (Int64) +import Data.List (find) +import Data.Maybe (catMaybes) +import Data.X509 +import Data.X509.CertificateStore +import Data.X509.Validation +import Foreign.C.Types (CTime(..)) + +import Dane.Scanner.Util + +data CertHashes = + CertHashes + { _cert256, _spki256, _cert512, _spki512 :: ByteString } + +type Timestamp = Int64 + +type LifeSpan = (Timestamp, Timestamp) + +data CertInfo = CertInfo { _depth :: !Int -- chain depth + , _idn :: !DistinguishedName -- issuer + , _life :: !LifeSpan -- dates + , _sdn :: !DistinguishedName -- subject + , _hashes :: !CertHashes + , _cert :: !ByteString -- Cert as DER ByteString + , _spki :: !ByteString -- Cert as DER ByteString + , _alg :: !PubKeyALG + } + +cnOf :: DistinguishedName -> Maybe String +cnOf dn = getDnElement DnCommonName dn >>= asn1CharacterToString + +orgOf :: DistinguishedName -> Maybe String +orgOf dn = getDnElement DnOrganization dn >>= asn1CharacterToString + +type ChainInfo = ( [HostName] -- DNS-IDs or CN-ID from leaf cert + , [CertInfo] -- Constructed chain + , Int64 -- Time observed + ) + +genChainInfo :: IORef ChainInfo + -> CertificateStore + -> ValidationCache + -> ServiceID + -> CertificateChain + -> IO [FailedReason] +genChainInfo cref _ _ _ chain = do + now <- gettime + writeIORef cref $ buildChain now chain + return [] -- Always succeed + +buildChain :: Int64 -> CertificateChain -> ChainInfo +buildChain now (CertificateChain xs) = + case xs of + [] -> error "Empty certificate chain" + top:chain -> + let names = getNames top + topinfo = certInfo 0 top + (issuer, rest) = getIssuer 0 chain top + infos = maybe [topinfo] ((topinfo:). getChainInfo 1 rest) issuer + in (names, infos, now) + where + certInfo _depth scert = + let cert = getCertificate scert + _cert = encodeSignedObject scert + _spki = encodeDER $ certPubKey cert + _hashes = getHashes _cert _spki + _idn = certIssuerDN cert + _life = getDates cert + _sdn = certSubjectDN cert + _alg = pubkeyToAlg $ certPubKey cert + in CertInfo{..} + + getDates :: Certificate -> LifeSpan + getDates = toTimestampTuple . certValidity + where + toTimestampTuple :: (DateTime, DateTime) -> LifeSpan + toTimestampTuple = (,) <$> toTimestamp . fst <*> toTimestamp . snd + where + toTimestamp :: DateTime -> Timestamp + toTimestamp = (\(CTime x) -> x) . timeConvert + + getChainInfo :: Int + -> [SignedCertificate] + -> SignedCertificate + -> [CertInfo] + getChainInfo depth cc cert = + let info = certInfo depth cert + (issuer, rest) = getIssuer depth cc cert + in maybe [info] ((info:). getChainInfo (depth + 1) rest) issuer + +getIssuer :: Int + -> [SignedCertificate] + -> SignedCertificate + -> ( Maybe (SignedCertificate) + , [SignedCertificate] + ) +getIssuer dep cc cert = + let iss = (certIssuerDN . getCertificate $ cert) + isMatch = (==iss) . certSubjectDN . getCertificate + isCA c = case certVersion c of + 0 -> True + 2 -> checkV3CA dep c + _ -> False + isSigner = checkSignature cert + in nulled $ (\x -> (x, filter (/= x) cc)) <$> + find (\s -> isMatch s && isCA (getCertificate s) + && isSigner s) cc + where + nulled :: Maybe (a,[b]) -> (Maybe a, [b]) + nulled Nothing = (Nothing, []) + nulled (Just (x,ys)) = (Just x, ys) + +getHashes :: ByteString -> ByteString -> CertHashes +getHashes cert spki = + let _cert256 = BS.pack $ BA.unpack $ hashWith SHA256 cert + _spki256 = BS.pack $ BA.unpack $ hashWith SHA256 spki + _cert512 = BS.pack $ BA.unpack $ hashWith SHA512 cert + _spki512 = BS.pack $ BA.unpack $ hashWith SHA512 spki + in CertHashes{..} + +encodeDER :: ASN1Object a => a -> ByteString +encodeDER = LB.toStrict . encodeASN1 DER . flip toASN1 [] + +getNames :: SignedCertificate -> [HostName] +getNames scert = + let cert = getCertificate scert + sdn = certSubjectDN cert + altNames = maybe [] toAltName $ extensionGet $ certExtensions cert + in case altNames of + [] -> case cnOf sdn of + Just s -> [s] + Nothing -> [] + x -> x + where + unAltName :: AltName -> Maybe HostName + unAltName (AltNameDNS s) = Just s + unAltName _ = Nothing + + toAltName :: ExtSubjectAltName -> [HostName] + toAltName (ExtSubjectAltName names) = catMaybes $ map unAltName names + +checkV3CA :: Int -> Certificate -> Bool +checkV3CA level cert = allowedSign && allowedCA && allowedDepth + where extensions = certExtensions cert + allowedSign = case extensionGet extensions of + Just (ExtKeyUsage flags) -> KeyUsage_keyCertSign `elem` flags + Nothing -> True + (allowedCA,pathLen) = case extensionGet extensions of + Just (ExtBasicConstraints True pl) -> (True, pl) + _ -> (False, Nothing) + allowedDepth = case pathLen of + Nothing -> True + Just pl | fromIntegral pl >= level -> True + | otherwise -> False + +checkSignature :: SignedCertificate -> SignedCertificate -> Bool +checkSignature signedCert signingCert = + case verifySignedSignature signedCert (certPubKey $ getCertificate signingCert) of + SignaturePass -> True + SignatureFailed _ -> False diff --git a/Dane/Scanner/SMTP/Chain.hs b/Dane/Scanner/SMTP/Chain.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/Chain.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ViewPatterns #-} + +module Dane.Scanner.SMTP.Chain + ( getAddrChains + , AddrChain(..) + , PeerChain(..) + , PeerProbe(..) + , SmtpState(..) + ) + where + +import Control.Exception (displayException) +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.State.Strict (gets) + +import qualified Data.ByteString.Char8 as BC (unpack) +import qualified Data.ByteString.Short as SB +import Data.Char (toLower) +import Data.IORef (readIORef) +import Data.IP ( AddrRange, IP(IPv4, IPv6), IPv4, IPv6 + , isMatchedTo, makeAddrRange, toIPv4, toIPv6 ) +import Data.Int (Int64) +import Data.List (find) +import Data.Maybe (isJust, isNothing) +import Net.DNSBase ( Domain, T_tlsa, X_tlsa(..) ) +import Network.HostName (getHostName) +import qualified Network.TLS as TLS + +import GHC.IO.Exception (IOException(..), IOErrorType(TimeExpired)) + +import qualified Dane.Scanner.Opts as Opts +import Dane.Scanner.State +import Dane.Scanner.Util +import Dane.Scanner.SMTP.Addr +import Dane.Scanner.SMTP.Certs +import Dane.Scanner.SMTP.Internal +import Dane.Scanner.SMTP.Proto +import Dane.Scanner.SMTP.TLS + +data AddrChain = AddrChain + { peerAddr :: !IP + , peerChain :: PeerChain + } + +data MatchStatus = Pass + | Notlsa + | Nousable + | Nomatch + | Noname + | Notime + deriving (Eq) + +instance Show MatchStatus where + show Pass = "pass" + show Notlsa = "tlsa-absent" + show Nousable = "tlsa-unusable" + show Nomatch = "tlsa-mismatch" + show Noname = "name-mismatch" + show Notime = "cert-expired" + +-- | Outcome of an SMTP probe at one IP address. +data PeerChain + = Probed PeerProbe + -- ^ TLS handshake completed. Carries the per-probe details + -- (TLS info, presented names, cert chain, TLSA-match result, + -- time observed) in a separate 'PeerProbe' record so the + -- error variants stay flat and the printer can destructure + -- the success case in one step. + | SmtpError SmtpState Int String + -- ^ SMTP protocol or TLS handshake error. The 'Int' is the + -- SMTP response code or one of the negative sentinels: @-1@ + -- for handshake failure or connection reset, @-2@ for + -- EOF\/recv error, @-3@ for send error. The 'String' carries + -- whatever message the server or stack provided (often empty + -- for the negative-code paths). + | ChainException String + -- ^ Unhandled exception during the probe. Pre-rendered to a + -- 'String' via 'displayException' at capture time so the + -- 'PeerChain' value carries no existential dictionary. + +-- | Probe-success details captured after a successful STARTTLS +-- handshake. +data PeerProbe = PeerProbe + { peerNames :: [TLS.HostName] + , peerCerts :: [CertInfo] + , matchName :: Maybe TLS.HostName + , matchDepth :: Maybe Int + , matchStatus :: !MatchStatus + , peerTime :: !Int64 + , peerTlsVersion :: !TLS.Version + , peerTlsCipher :: !TLS.Cipher + , peerTlsGroup :: !(Maybe TLS.Group) + } + +-- | https://www.iana.org/assignments/iana-ipv4-special-registry +-- +reserved4 :: [ AddrRange IPv4 ] +reserved4 = map (makeAddrRange <$> toIPv4 . fst <*> snd) + [ ( [0,0,0,0], 8 ) -- RFC1122 + , ( [10,0,0,0], 8 ) -- RFC1918 + , ( [100,64,0,0], 10 ) -- RFC6598 + , ( [127,0,0,0], 8 ) -- RFC1122 + , ( [169,254,0,0], 16 ) -- RFC3927 + , ( [172,16,0,0], 12 ) -- RFC1918 + , ( [192,0,0,0], 24 ) -- RFC6890 + , ( [192,0,2,0], 24 ) -- RFC5737 + , ( [192,31,196,0], 24 ) -- RFC7535 + , ( [192,52,193,0], 24 ) -- RFC7450 + , ( [192,88,99,0], 24 ) -- RFC3068 + , ( [192,168,0,0], 16 ) -- RFC1918 + , ( [192,175,48,0], 24 ) -- RFC7534 + , ( [198,18,0,0], 15 ) -- RFC2544 + , ( [198,51,100,0], 24 ) -- RFC5737 + , ( [203,0,113,0], 24 ) -- RFC5737 + , ( [224,0,0,0], 4 ) -- RFC1112 + , ( [240,0,0,0], 4 ) -- RFC1112 + ] + +-- | https://www.iana.org/assignments/iana-ipv6-special-registry +-- +reserved6 :: [ AddrRange IPv6 ] +reserved6 = map (makeAddrRange <$> toIPv6 . fst <*> snd) + [ ( [0,0,0,0,0,0,0,0], 128 ) -- RFC4291 + , ( [0,0,0,0,0,0,0,1], 128 ) -- RFC4291 + , ( [0,0,0,0,0,0xffff,0,0], 96 ) -- RFC4291 + , ( [0x64,0xff9b,0,0,0,0,0,0], 96 ) -- RFC6052 + , ( [0x100,0,0,0,0,0,0,0], 64 ) -- RFC6666 + , ( [0x2001,0,0,0,0,0,0,0], 23 ) -- RFC2928 + , ( [0x2620,0x4f,0x8000,0,0,0,0,0], 48 ) -- RFC7534 + , ( [0xfc00,0,0,0,0,0,0,0], 7 ) -- RFC4193 + , ( [0xfe80,0,0,0,0,0,0,0], 10 ) -- RFC4291 + -- 6to4 versions of IPv4 reserved addresses + , ( [0x2002,0,0,0,0,0,0,0], 24 ) -- RFC1122 + , ( [0x2002,0x0a00,0,0,0,0,0,0], 24 ) -- RFC1918 + , ( [0x2002,0x6440,0,0,0,0,0,0], 26 ) -- RFC6598 + , ( [0x2002,0x7f00,0,0,0,0,0,0], 24 ) -- RFC1122 + , ( [0x2002,0xa9fe,0,0,0,0,0,0], 32 ) -- RFC3927 + , ( [0x2002,0xac10,0,0,0,0,0,0], 28 ) -- RFC1918 + , ( [0x2002,0xc000,0,0,0,0,0,0], 40 ) -- RFC6890 + , ( [0x2002,0xc000,0x0200,0,0,0,0,0], 40 ) -- RFC5737 + , ( [0x2002,0xc01f,0xc200,0,0,0,0,0], 40 ) -- RFC7535 + , ( [0x2002,0xc034,0xc100,0,0,0,0,0], 40 ) -- RFC7450 + , ( [0x2002,0xc058,0x6300,0,0,0,0,0], 40 ) -- RFC3068 + , ( [0x2002,0xc0a8,0,0,0,0,0,0], 32 ) -- RFC1918 + , ( [0x2002,0xc0af,0x3000,0,0,0,0,0], 40 ) -- RFC7534 + , ( [0x2002,0xc612,0,0,0,0,0,0], 31 ) -- RFC2544 + , ( [0x2002,0xc633,0x6400,0,0,0,0,0], 40 ) -- RFC5737 + , ( [0x2002,0xcb00,0x7100,0,0,0,0,0], 40 ) -- RFC5737 + , ( [0x2002,0xe000,0,0,0,0,0,0], 20 ) -- RFC1112 + , ( [0x2002,0xf000,0,0,0,0,0,0], 20 ) -- RFC1112 + ] + +getAddrChains :: Domain -- MX hostname + -> Domain -- TLSA base domain + -> [Domain] -- DNS reference identifiers + -> [T_tlsa] -- Host TLSA rdata, typed + -> [IP] -- Host addresses (already converted from T_a/T_aaaa) + -> Scanner [AddrChain] +getAddrChains mx base names tlsards addrs = do + opts <- gets scannerOpts + let down = find (== (d2s mx)) (Opts.downMX opts) + skip = if_ (Opts.upsideDown opts) isNothing isJust + if skip down + then return [] + else mapM perAddr addrs + where + perAddr :: IP -> Scanner AddrChain + perAddr a = do + allow <- gets $ Opts.useReserved . scannerOpts + case a of + IPv4 ip4 + | not allow && any (isMatchedTo ip4) reserved4 + -> scannerFail $ AddrChain a $ SmtpError CONNECT (-1) "" + | otherwise -> doAddr base names tlsards a + IPv6 ip6 + | not allow && any (isMatchedTo ip6) reserved6 + -> scannerFail $ AddrChain a $ SmtpError CONNECT (-1) "" + | otherwise -> doAddr base names tlsards a + +doAddr :: Domain -- TLSA base domain + -> [Domain] -- DNS reference identifiers + -> [T_tlsa] -- TLSA RRset data, typed + -> IP -- peer address + -> Scanner AddrChain +doAddr base refnames tlsards peerAddr = do + opts <- gets scannerOpts + helo <- maybe (liftIO getHostName) return $ Opts.smtpHelo opts + let basenm = d2s base + tout = Opts.smtpTimeout opts * 1000 + llen = Opts.smtpLineLen opts + eechecks = Opts.eeChecks opts + addOff = Opts.addDays opts + sigAlgs = Opts.sigAlgs opts + -- Run the connect + SMTP + TLS + cert capture as a pure 'IO' + -- action inside the 'ipConn' bracket; the 'Scanner' state + -- update is then a single 'scannerFail' driven by the @isOK@ + -- flag returned from the closure. + (peerChain, isOK) <- liftIO $ ipConn peerAddr 25 tout \case + Left IOError{..} -> case ioe_type of + TimeExpired -> pure (SmtpError CONNECT 0 "", False) + _ -> pure (SmtpError CONNECT 500 "", False) + Right sock -> do + st <- dosmtp =<< startState sigAlgs helo basenm tout llen sock + case smtpErr st of + DataErr err -> pure ( ChainException $ displayException $ errLoc err st + , False ) + OtherErr e -> pure ( ChainException $ displayException e + , False ) + ProtoErr code m -> pure ( SmtpError (smtpState st) code $ b2s m + , False ) + TlsHandError t -> pure ( SmtpError (smtpState st) (-1) $ show t + , False ) + TlsRecvError -> pure ( SmtpError (smtpState st) (-2) "" + , False ) + TlsSendError -> pure ( SmtpError (smtpState st) (-3) "" + , False ) + SmtpOK + | SmtpTLS ctx <- smtpConn st -> do + (peerNames, peerCerts, peerTime) <- readIORef (chainRef st) + (peerTlsVersion, peerTlsCipher, peerTlsGroup) <- tlsInfo ctx + let matchName = namecheck refnames peerNames + vtime = peerTime + fromIntegral addOff * 86400 + (d, s) = tlsamatch eechecks matchName vtime tlsards peerCerts + pure ( Probed PeerProbe{matchDepth = d, matchStatus = s, ..} + , s == Pass ) + | otherwise + -> pure (SmtpError STARTTLS 0 "", False) + when (not isOK) $ scannerFail () + return AddrChain { peerAddr = peerAddr, peerChain = peerChain } + where + b2s = BC.unpack + + -- Match a TLS peer-presented name (already a 'String') against + -- the DNS reference identifiers (canonicalised through 'd2s'). + -- Wildcard handling follows RFC 6125: '*' matches at the first + -- label only, and only when the remainder has at least two + -- labels (so '*.example' doesn't match the apex). + namecheck :: [Domain] -> [String] -> Maybe String + namecheck [] _ = Nothing + namecheck (d:ds) names = + let dom = d2s d + match = find ((== dom) . map toLower) names + in case match of + Just _ -> match + Nothing | p <- dropWhile (/= '.') dom + , (_:t) <- p + , '.' `elem` t + , wild <- find (== ('*' : p)) names + , Just _ <- wild + -> wild + | otherwise -> namecheck ds names + + -- Compare the cert's precomputed hash/SPKI bytes against the + -- typed TLSA RRset. The 'ByteString' fields on 'CertHashes' + -- are converted to 'ShortByteString' for the 'T_TLSA' equality + -- check (T_TLSA's data field is short-bytestring-shaped). + cinfomatch depth rds CertInfo{..} = + let u = if depth == 0 then 3 else 2 + short = SB.toShort + in T_TLSA u 1 1 (short (_spki256 _hashes)) `elem` rds || + T_TLSA u 0 1 (short (_cert256 _hashes)) `elem` rds || + T_TLSA u 1 2 (short (_spki512 _hashes)) `elem` rds || + T_TLSA u 0 2 (short (_cert512 _hashes)) `elem` rds || + T_TLSA u 1 0 (short _spki) `elem` rds || + T_TLSA u 0 0 (short _cert) `elem` rds + + tlsamatch :: Bool + -> Maybe String + -> Int64 + -> [T_tlsa] + -> [CertInfo] + -> (Maybe Int, MatchStatus) + tlsamatch _ _ _ [] _ = (Nothing, Notlsa) + tlsamatch _ _ _ (usable -> []) _ = (Nothing, Nousable) + tlsamatch eechecks nm tm rds certinfos = go False 0 certinfos + where + -- | If we never find a matching TLSA record, report that! + -- Namecheck failure or expiration are only reported if we + -- at least find a TLSA match. + go _ _ [] = (Nothing, Nomatch) + go expired depth (c@CertInfo{..}:cs) = + let matched = cinfomatch depth rds c + e = expired || fst _life > tm || snd _life < tm + in case depth == 0 && not eechecks of + True | matched -> (Just 0, Pass) + | null [u | T_TLSA u _ _ _ <- rds, u /= 3] + -> (Nothing, Nomatch) + | otherwise + -> go e (depth+1) cs + False | matched + -> case () of + _ | Nothing <- nm -> (Nothing, Noname) + | e -> (Nothing, Notime) + | otherwise -> (Just depth, Pass) + | otherwise + -> go e (depth+1) cs + + -- A TLSA RRset is "usable" if any record has a usage from + -- {DANE-TA, DANE-EE} = {2, 3}, a selector from {Cert, SPKI} = + -- {0, 1}, and a matching type from {Full, SHA-256, SHA-512} = + -- {0, 1, 2}. Now pattern-matches on typed 'T_TLSA' record + -- syntax instead of the old 'RD_TLSA' constructor. + usable rds = [ u | T_TLSA u s m _ <- rds + , u `elem` [2,3] + , s `elem` [0,1] + , m `elem` [0,1,2] ] diff --git a/Dane/Scanner/SMTP/Internal.hs b/Dane/Scanner/SMTP/Internal.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/Internal.hs @@ -0,0 +1,151 @@ +module Dane.Scanner.SMTP.Internal + ( ProtoState(..) + , SmtpM + , SmtpState(..) + , SmtpReply(..) + , SmtpErr(..) + , SmtpConn(..) + , SmtpFeature(..) + , timeLimit + , timeLeft + , startState + , ioErr + , eofErr + , timeErr + , errLoc + , tryIO + ) where + +import qualified System.Clock as Sys +import System.IO.Error as Sys + +import GHC.IO.Exception (IOErrorType(EOF, TimeExpired)) + +import Control.Exception (SomeException, IOException, try) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.State.Strict (StateT, gets) +import Data.ByteString.Char8 (ByteString, pack) +import Data.IORef (IORef, newIORef) +import Data.Int (Int64) +import Network.Socket (Socket) +import qualified Network.TLS as TLS + +import Dane.Scanner.Opts (SigAlgs) +import Dane.Scanner.SMTP.Certs (ChainInfo) + +data ProtoState = ProtoState + { smtpState :: !SmtpState + , smtpErr :: !SmtpErr + , clientName :: !ByteString + , serverName :: !String + , smtpConn :: !SmtpConn + , smtpTimeout :: !Int + , llenLimit :: !Int + , ioDeadline :: !Sys.TimeSpec + , features :: ![SmtpFeature] + , chainRef :: !(IORef ChainInfo) + , tlsSigAlgs :: !SigAlgs -- ^ TLS signature-algorithm preference + } + +type SmtpM = StateT ProtoState IO + +data SmtpConn = SmtpPlain Socket + | SmtpTLS TLS.Context + +data SmtpFeature = FeatureTLS + | FeatureSIZE Int64 + | FeatureUTF8 + deriving (Eq) + +data SmtpState = CONNECT + | GREETING + | EHLO + | STARTTLS + | DOTLS + | QUIT + | DONE + deriving (Eq, Enum, Show, Ord) + +data SmtpReply = SmtpReply + { replyCode :: !Int + , replyCont :: !Bool + , replyText :: !ByteString + } + deriving (Show) + +data SmtpErr = SmtpOK + | TlsHandError TLS.TLSError + | TlsRecvError + | TlsSendError + | DataErr IOException + | ProtoErr Int ByteString + | OtherErr SomeException + +timeLimit :: Int -> IO Sys.TimeSpec +timeLimit tmout = do + now <- Sys.getTime Sys.Monotonic + return $! Sys.fromNanoSecs + $ (fromIntegral tmout * 1000) + Sys.toNanoSecs now + +timeLeft :: SmtpM Int +timeLeft = do + deadline <- gets ioDeadline + now <- liftIO $ Sys.getTime Sys.Monotonic + return $! fromIntegral + $ flip div 1000 + $ Sys.toNanoSecs + $ Sys.diffTimeSpec deadline now + +-- | Initialize the client SMTP protocol state +-- +startState :: SigAlgs -- ^ TLS signature-algorithm preference + -> String -- ^ SMTP client EHLO name + -> String -- ^ SMTP server name + -> Int -- ^ SMTP command timeout (us) + -> Int -- ^ SMTP response line length limit + -> Socket -- ^ Socket connected to the SMTP server + -> IO ProtoState +startState sigAlgs helo peer tout llen sock = do + cref <- newIORef undefined + deadline <- timeLimit tout + return ProtoState + { smtpState = GREETING + , clientName = pack helo + , serverName = peer + , smtpConn = SmtpPlain sock + , smtpTimeout = tout + , ioDeadline = deadline + , smtpErr = SmtpOK + , llenLimit = llen + , features = [] + , chainRef = cref + , tlsSigAlgs = sigAlgs + } + +ioErr :: String -> IOException -> IOException +ioErr loc err = Sys.ioeSetLocation err loc + +eofErr :: String -> IOException +eofErr loc = Sys.mkIOError EOF loc Nothing Nothing + +timeErr :: String -> IOException +timeErr loc = Sys.mkIOError TimeExpired loc Nothing Nothing + +errLoc :: IOException -> ProtoState -> IOException +errLoc err st = + let loc = Sys.ioeGetLocation err + in if (loc /= "") + then Sys.ioeSetLocation err $ + (showString. show $ smtpState st). + showChar ' '. + showString loc $ "" + else Sys.ioeSetLocation err $ show $ smtpState st + +-- | 'Control.Exception.try' monomorphised at 'IOException', matching +-- the @safe-exceptions@ helper of the same name. Async exceptions +-- (anything wrapped in 'SomeAsyncException') pass through unchanged +-- — only @IOException@s are caught — which is what every caller +-- here wants: the @timeout@ wrapping each call needs async +-- @TimeExpired@ to propagate so the timeout actually fires. +tryIO :: IO a -> IO (Either IOException a) +tryIO = try diff --git a/Dane/Scanner/SMTP/Parse.hs b/Dane/Scanner/SMTP/Parse.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/Parse.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +module Dane.Scanner.SMTP.Parse (SmtpReply(..), parseReply) + where + +import Control.Applicative ( (<|>) ) +import Control.Monad (mzero) +import Data.Attoparsec.ByteString.Char8 (Parser, parseOnly) +import qualified Data.Attoparsec.ByteString.Char8 as AP +import qualified Data.ByteString.Char8 as BC +import Data.Char (ord) +import Data.Either (isLeft) + +import Dane.Scanner.SMTP.Internal + +digit :: Parser Int +digit = do + c <- AP.satisfy AP.isDigit + return $ ord(c) - ord('0') + +space :: Parser Char +space = AP.char ' ' + +hyphen :: Parser Char +hyphen = AP.char '-' + +textchar :: Parser BC.ByteString +textchar = do + c <- AP.satisfy $ (&&) <$> (/= '\r') <*> (/= '\n') + return $ BC.singleton c + +barecr :: Parser BC.ByteString +barecr = do + c <- AP.char '\r' *> AP.peekChar + case c of + Just '\n' -> mzero + _ -> return $ BC.singleton '\r' + +text :: Parser BC.ByteString +text = do + chunks <- AP.many' $ (textchar <|> barecr) + return $ mconcat chunks + +parser :: Parser SmtpReply +parser = do + digits <- AP.count 3 digit + let replyCode = foldl (\acc x -> 10 * acc + x) 0 digits + replyCont <- isLeft <$> AP.eitherP hyphen space + replyText <- text + AP.endOfLine + AP.endOfInput + return $! SmtpReply{..} + +parseReply :: BC.ByteString -> Maybe SmtpReply +parseReply reply = + case (parseOnly parser reply) of + Right x -> Just x + Left _ -> Nothing diff --git a/Dane/Scanner/SMTP/Proto.hs b/Dane/Scanner/SMTP/Proto.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/Proto.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dane.Scanner.SMTP.Proto (dosmtp) where + +import qualified Control.Monad.Trans.State.Strict as ST +import qualified Data.ByteString as B +import qualified Data.ByteString.Char8 as BC +import qualified Data.Text as T +import qualified Data.Text.Encoding as E +import qualified Streaming.ByteString as Q +import qualified Streaming.Prelude as Streaming +import Control.Monad (when) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (get, gets, modify') +import Data.Function ((&)) + +import Dane.Scanner.Source (strictLines) +import Dane.Scanner.SMTP.Sock +import Dane.Scanner.SMTP.Parse +import Dane.Scanner.SMTP.Internal +import Dane.Scanner.SMTP.TLS + +crlf :: B.ByteString +crlf = "\r\n" + +ok :: SmtpErr -> Bool +ok SmtpOK = True +ok _ = False + +smtpSendHello :: SmtpM B.ByteString +smtpSendHello = do + deadline <- liftIO . timeLimit =<< gets smtpTimeout + modify' \s -> s { smtpState = EHLO, ioDeadline = deadline } + name <- gets clientName + pure $ "EHLO " <> name <> crlf + +smtpGreeting :: Int -> SmtpReply -> SmtpM B.ByteString +smtpGreeting _ r + | replyCont r = pure B.empty + | code <- replyCode r + , code `div` 100 /= 2 + = do modify' \s -> s { smtpErr = ProtoErr code $ replyText r } + pure B.empty + | otherwise = smtpSendHello + +smtpHello :: Int -> SmtpReply -> SmtpM B.ByteString +smtpHello count r = do + when (count > 0 + && "STARTTLS" == T.toUpper (E.decodeLatin1 (replyText r))) do + modify' \s -> s { features = FeatureTLS:features s } + if | replyCont r -> pure B.empty + | code <- replyCode r + , code `div` 100 /= 2 + -> do modify' \s -> s { smtpErr = ProtoErr code $ replyText r } + pure B.empty + | otherwise -> do + deadline <- liftIO . timeLimit =<< gets smtpTimeout + modify' \s -> s { ioDeadline = deadline } + st <- get + if | FeatureTLS `elem` features st + , not (hasTLS st) + -> "STARTTLS\r\n" <$ modify' \s -> s { smtpState = STARTTLS } + | otherwise + -> "QUIT\r\n" <$ modify' \s -> s { smtpState = QUIT } + +smtpStartTLS :: Int -> SmtpReply -> SmtpM B.ByteString +smtpStartTLS _ r = do + when (not $ replyCont r) do + let code = replyCode r + if | code `div` 100 == 2 + -> modify' \s -> s { smtpState = DOTLS } + | otherwise + -> modify' \s -> s { smtpErr = ProtoErr code $ replyText r } + pure B.empty + +smtpQuit :: Int -> SmtpReply -> SmtpM B.ByteString +smtpQuit _ r = do + when (not $ replyCont r) do + let code = replyCode r + if | code `div` 100 == 2 -> do + get >>= \st -> when (hasTLS st) endTLS + modify' \s -> s { smtpState = DONE } + | otherwise + -> modify' \s -> s { smtpErr = ProtoErr code $ replyText r } + pure B.empty + +-- | SMTP state machine over a 'ByteStream' input. Reads lines via +-- 'strictLines' (so the per-reply length cap from 'llenLimit' is +-- enforced on every line), dispatches them on 'smtpState', and +-- writes the resulting client commands back out as a 'ByteStream' +-- that the caller pipes to 'sockSink' (for plaintext) or 'tlsSink' +-- (for the post-STARTTLS phase). +proto :: Q.ByteStream SmtpM () -> Q.ByteStream SmtpM () +proto src = lift get >>= \ st -> do + when (smtpState st == DOTLS) do -- Redo EHLO after TLS + lift smtpSendHello >>= Q.chunk + loop 0 $ strictLines (fromIntegral $ llenLimit st) src + where + loop count str = do + st <- lift get + if | DONE <- smtpState st -> pure () + | DOTLS <- smtpState st -> pure () + | not $ ok $ smtpErr st -> pure () + | otherwise -> lift (Streaming.uncons str) >>= \ case + Nothing + -> lift $ gets smtpErr >>= \e -> when (ok e) do + modify' \s -> s { smtpErr = DataErr $ eofErr "read" } + Just (bs, bss) + | B.null bs + -> lift $ gets smtpErr >>= \e -> when (ok e) do + modify' \s -> s { smtpErr = DataErr $ eofErr "read" } + | B.length bs >= llenLimit st + -> lift $ gets smtpErr >>= \e -> when (ok e) do + modify' \s -> s { smtpErr = ProtoErr 401 $ + "Reply too long: " <> bs <> "..." } + | otherwise -> case parseReply bs of + Nothing -> pure () + Just r -> do + let count' = if replyCont r then count + 1 else 0 + cmd <- case smtpState st of + GREETING -> lift $ smtpGreeting count r + EHLO -> lift $ smtpHello count r + STARTTLS -> lift $ smtpStartTLS count r + QUIT -> lift $ smtpQuit count r + _ -> lift $ fail $ + "Unexpected SMTP state " + ++ show (smtpState st) + when (not $ BC.null cmd) do + Q.chunk cmd + loop count' bss + +dosmtp :: ProtoState -> IO ProtoState +dosmtp start = do + st <- ST.execStateT (sockSource & proto & sockSink) start + case smtpErr st of + SmtpOK + | smtpState st == DOTLS + -> do + tlsst <- ST.execStateT startTLS st + case smtpErr tlsst of + SmtpOK -> ST.execStateT (tlsSource & proto & tlsSink) tlsst + _ -> return tlsst + _ -> return st diff --git a/Dane/Scanner/SMTP/Sock.hs b/Dane/Scanner/SMTP/Sock.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/Sock.hs @@ -0,0 +1,61 @@ +module Dane.Scanner.SMTP.Sock + ( sockSource + , sockSink + ) where + +import qualified Data.ByteString as B +import qualified Streaming.ByteString as Q +import Control.Monad ((>=>)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (gets, modify') +import Network.Socket (Socket) +import Network.Socket.ByteString (recv, send) +import System.Timeout (timeout) + +import Dane.Scanner.SMTP.Internal + +-- | Write the whole bytestring to the socket, looping if 'send' +-- only consumes a prefix. Returns once every byte has been sent +-- or the underlying 'send' has thrown. +sockWrite :: Socket -> B.ByteString -> IO () +sockWrite sock bs = send sock bs >>= \ case + n | n < B.length bs -> sockWrite sock $ B.drop n bs + | otherwise -> pure () + +-- | Consume a 'ByteStream' and push each chunk down the plaintext +-- socket. Errors and timeouts are recorded in 'smtpErr' and +-- stop the loop. +sockSink :: Q.ByteStream SmtpM () -> SmtpM () +sockSink str = gets smtpConn >>= \ case + SmtpPlain sock -> go sock str + _ -> fail "Non-plaintext channel" + where + go sock = Q.unconsChunk >=> \ case + Right (bs, bss) -> do + tm <- timeLeft + liftIO (timeout tm $ tryIO $ sockWrite sock bs) >>= \ case + Just (Right _) -> go sock bss + Just (Left e) + -> modify' \s -> s { smtpErr = DataErr $ ioErr "write" e } + _ -> modify' \s -> s { smtpErr = DataErr $ timeErr "write" } + Left () -> pure () + +-- | Read chunks off the plaintext socket and produce a +-- 'ByteStream' for downstream consumers. EOF, errors and +-- timeouts are recorded in 'smtpErr' and terminate the stream. +sockSource :: Q.ByteStream SmtpM () +sockSource = lift (gets smtpConn) >>= \ case + SmtpPlain sock -> go sock + _ -> error "Non-plaintext channel" + where + go sock = do + tm <- lift timeLeft + liftIO (timeout tm $ tryIO $ recv sock 65536) >>= \ case + Just (Right bs) + | B.length bs > 0 -> Q.chunk bs >> go sock + | otherwise + -> lift $ modify' \s -> s { smtpErr = DataErr $ eofErr "read" } + Just (Left e) + -> lift $ modify' \s -> s { smtpErr = DataErr $ ioErr "read" e } + _ -> lift $ modify' \s -> s { smtpErr = DataErr $ timeErr "read" } diff --git a/Dane/Scanner/SMTP/TLS.hs b/Dane/Scanner/SMTP/TLS.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/SMTP/TLS.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dane.Scanner.SMTP.TLS + ( tlsSource + , tlsSink + , tlsParams + , connTLS + , hasTLS + , endTLS + , startTLS + , tlsInfo + ) where + +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as LB +import qualified Data.List as L +import qualified Data.X509.CertificateStore as X509 +import qualified Network.TLS as TLS +import qualified Network.TLS.Extra as TLS +import qualified Network.TLS.Extra.CipherCBC as TLS +import qualified Streaming.ByteString as Q +import Control.Applicative ((<|>)) +import Control.Exception (Handler(..), catches, toException) +import Control.Monad ((>=>)) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.State.Strict (gets, modify') +import Data.Default.Class +import Data.Function ((&)) +import Data.IORef (IORef) +import Data.Maybe (isJust) +import Network.Socket (Socket) +import Network.TLS (Version(TLS12, TLS13)) +import System.Timeout (timeout) + +import Dane.Scanner.Opts (SigAlgs(..), SigAlgGroup(..)) +import Dane.Scanner.SMTP.Certs +import Dane.Scanner.SMTP.Internal + +-- callback args: serviceid fingerprint certificate +nullCache :: TLS.ValidationCache +nullCache = TLS.ValidationCache + { TLS.cacheQuery = \_ _ _ -> return TLS.ValidationCacheUnknown + , TLS.cacheAdd = \_ _ _ -> return () + } + +tlsParams :: SigAlgs + -> String + -> IORef ChainInfo + -> X509.CertificateStore + -> TLS.ClientParams +tlsParams sigAlgs host cref store = + (TLS.defaultParamsClient host "smtp") + { TLS.clientUseServerNameIndication = True + , TLS.clientHooks = def + { TLS.onCertificateRequest = \ _ -> return Nothing + , TLS.onServerCertificate = genChainInfo cref + , TLS.onSuggestALPN = return Nothing + , TLS.onSelectKeyShareGroups = chooseKS + } + , TLS.clientShared = def + { TLS.sharedCAStore = store + , TLS.sharedCredentials = mempty + , TLS.sharedValidationCache = nullCache + , TLS.sharedSessionManager = TLS.noSessionManager + } + , TLS.clientSupported = def & \ d -> d + { TLS.supportedCiphers = chooseCS + , TLS.supportedVersions = [TLS13, TLS12] + , TLS.supportedCompressions = [TLS.nullCompression] + , TLS.supportedSecureRenegotiation = True + , TLS.supportedSession = False + , TLS.supportedFallbackScsv = False + , TLS.supportedEmptyPacket = True + , TLS.supportedGroups = chooseGS (TLS.supportedGroups d) + , TLS.supportedHashSignatures = case sigAlgs of + SigAlgs [] -> TLS.supportedHashSignatures d + SigAlgs gs -> concatMap sigAlgsFor gs + } + , TLS.clientWantSessionResume = Nothing -- no session to resume + , TLS.clientDebug = def -- Can override DRBG seed + , TLS.clientWantTicket = False + } + where + -- Expand a named group to its (HashAlgorithm, SignatureAlgorithm) + -- pairs. RSA covers both TLS 1.3 (RSA-PSS-RSAE) and TLS 1.2 + -- (RSA-PKCS#1) variants; ECDSA covers the three NIST P-curves; + -- EdDSA covers Ed25519 and Ed448. Within each group the pairs + -- are listed in the conventional SHA-256\/384\/512 order; the + -- caller controls the group-level order via the @--sigalgs@ + -- option, and the TLS library honours that order when offering + -- algorithms to the server. + sigAlgsFor :: SigAlgGroup -> [(TLS.HashAlgorithm, TLS.SignatureAlgorithm)] + sigAlgsFor SigEcdsa = (,) <$> [ TLS.HashSHA256 + , TLS.HashSHA384 + , TLS.HashSHA512 ] + <*> [ TLS.SignatureECDSA ] + sigAlgsFor SigRsa = -- TLS 1.3 RSA-PSS-RSAE + ((,) TLS.HashIntrinsic <$> + [ TLS.SignatureRSApssRSAeSHA256 + , TLS.SignatureRSApssRSAeSHA384 + , TLS.SignatureRSApssRSAeSHA512 ]) + ++ + -- TLS 1.2 RSA-PKCS#1 + ((,) <$> [ TLS.HashSHA256 + , TLS.HashSHA384 + , TLS.HashSHA512 ] + <*> [ TLS.SignatureRSA ]) + sigAlgsFor SigEdDsa = (,) TLS.HashIntrinsic <$> + [ TLS.SignatureEd25519 + , TLS.SignatureEd448 ] + + -- Add some DHE TLS 1.2 ciphers, with the AES128 choice first + chooseCS :: [TLS.Cipher] + chooseCS = + TLS.ciphersuite_strong ++ + case L.uncons $ reverse TLS.ciphersuite_dhe_rsa of + Just (l, cs) -> l : reverse cs + Nothing -> [] + ++ TLS.ciphersuite_pfs_sha2_cbc + + chooseGS :: [TLS.Group] -> [TLS.Group] + chooseGS = go False + where + go _ [] = [] + go dheSeen (g@(TLS.Group n) : gs) + -- No P521 or SecP384r1MLKEM1024 + | n == 25 || n == 4589 = go dheSeen gs + -- All other EC curves + | n < 256 + = g : go dheSeen gs + -- Replace FFDHE list with just ffdhe2048 and ffdhe3072 + | n >= 256 && n < 512 + = if dheSeen + then go dheSeen gs + else TLS.FFDHE2048 : TLS.FFDHE3072 : go True gs + | otherwise + = g : go dheSeen gs + + chooseKS :: [TLS.Group] -> [TLS.Group] + chooseKS = go Nothing Nothing + where + go g2 g3 (g@(TLS.Group n) : gs) + -- EC, if possible + | n < 256 = [g] + -- else FFDHE, if possible + | n < 512 = go (g2 <|> Just g) g3 gs + -- else anything goes + | otherwise = go g2 (g3 <|> Just g) gs + go (Just g) _ _ = [g] + go _ (Just g) _ = [g] + go _ _ _ = [] + +-- | Read decrypted records off the TLS context and produce a +-- 'ByteStream' for downstream consumers. Errors, EOF and +-- timeouts are recorded in 'smtpErr' and terminate the stream. +tlsSource :: Q.ByteStream SmtpM () +tlsSource = lift (gets smtpConn) >>= \ case + SmtpTLS ctx -> go ctx + _ -> error "Non-TLS channel" + where + go ctx = do + tm <- lift timeLeft + liftIO (timeout tm (doRecv ctx)) >>= \ case + Just (Right bs) + | B.length bs > 0 -> Q.chunk bs >> go ctx + | otherwise + -> lift $ modify' \s -> s { smtpErr = DataErr $ eofErr "TLS read" } + Just (Left e) + -> lift $ modify' \s -> s { smtpErr = e } + _ -> lift $ modify' \s -> s { smtpErr = DataErr $ timeErr "TLS read" } + + doRecv ctx = (Right <$> TLS.recvData ctx) `catches` + [ Handler handleTLS, Handler handleIO ] + + handleTLS e = case e of + TLS.Terminated _ _ _ -> return $ Left TlsRecvError + _ -> return $ Left $ OtherErr $ toException e + + handleIO e = return $ Left $ DataErr e + +-- | Consume a 'ByteStream' and write each chunk through the TLS +-- context. Errors and timeouts are recorded in 'smtpErr' and +-- stop the loop. +tlsSink :: Q.ByteStream SmtpM () -> SmtpM () +tlsSink str = gets smtpConn >>= \ case + SmtpTLS ctx -> go ctx str + _ -> fail "Non-TLS channel" + where + go ctx = Q.unconsChunk >=> \ case + Right (bs, bss) -> do + tm <- timeLeft + liftIO (timeout tm (doSend ctx bs)) >>= \ case + Just (Right _) -> go ctx bss + Just (Left e) -> modify' \s -> s { smtpErr = e } + _ -> modify' \s -> s { smtpErr = DataErr $ timeErr "TLS write" } + Left () -> pure () + + doSend ctx bs = (Right <$> TLS.sendData ctx (LB.fromStrict bs)) `catches` + [ Handler handleTLS, Handler handleIO ] + + handleTLS e = case e of + TLS.Terminated _ _ _ -> return $ Left TlsSendError + _ -> return $ Left $ OtherErr $ toException e + + handleIO e = return $ Left $ DataErr e + +endTLS :: SmtpM () +endTLS = gets smtpConn >>= \ case + SmtpTLS ctx -> go ctx + _ -> error "Non-TLS channel" + where + go ctx = do + tm <- timeLeft + liftIO (timeout tm (doBye ctx)) >>= \ case + Just (Right _) -> pure () + Just (Left e) -> modify' \s -> s { smtpErr = e } + _ -> modify' \s -> s { smtpErr = DataErr $ timeErr "shutdown" } + + doBye ctx = (Right <$> TLS.bye ctx) `catches` + [ Handler handleTLS, Handler handleIO ] + + handleTLS e = case e of + TLS.Terminated _ _ _ -> return $ Left TlsSendError + _ -> return $ Left $ OtherErr $ toException e + + handleIO e = return $ Left $ DataErr e + +connTLS :: SmtpConn -> Maybe TLS.Context +connTLS (SmtpTLS ctx) = Just ctx +connTLS _ = Nothing + +hasTLS :: ProtoState -> Bool +hasTLS = isJust . connTLS . smtpConn + +startTLS :: SmtpM () +startTLS = gets smtpConn >>= \ case + SmtpPlain sock -> go sock + _ -> error "Non-plaintext channel" + where + go :: Socket -> SmtpM () + go sock = do + servername <- gets serverName + cref <- gets chainRef + sigAlgs <- gets tlsSigAlgs + store <- getStore Nothing + ctx <- TLS.contextNew sock $ tlsParams sigAlgs servername cref store + tmout <- gets smtpTimeout + liftIO (timeout tmout (doHandshake ctx)) >>= \ case + Just (Right _) -> do + deadline <- liftIO $ timeLimit tmout + modify' \s -> s { smtpConn = SmtpTLS ctx, ioDeadline = deadline } + Just (Left e) -> modify' \s -> s { smtpErr = e } + _ -> modify' \s -> s { smtpErr = DataErr $ timeErr "handshake" } + + getStore :: Maybe FilePath -> SmtpM X509.CertificateStore + getStore cafp = + maybe (return Nothing) + (\fp -> liftIO $ X509.readCertificateStore fp) cafp >>= + return . maybe (X509.makeCertificateStore []) id + + doHandshake ctx = (Right <$> TLS.handshake ctx) `catches` + [ Handler handleTLS, Handler handleIO ] + + handleTLS e = case e of + TLS.HandshakeFailed t -> return $ Left $ TlsHandError t + TLS.Terminated _ _ t -> return $ Left $ TlsHandError t + _ -> return $ Left $ OtherErr $ toException e + + handleIO e = return $ Left $ DataErr e + +tlsInfo :: TLS.Context -> IO (TLS.Version, TLS.Cipher, Maybe TLS.Group) +tlsInfo ctx = do + ~(Just i) <- TLS.contextGetInformation ctx + return $ (,,) <$> TLS.infoVersion + <*> TLS.infoCipher + <*> TLS.infoSupportedGroup + $! i diff --git a/Dane/Scanner/Source.hs b/Dane/Scanner/Source.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/Source.hs @@ -0,0 +1,24 @@ +module Dane.Scanner.Source + ( strictLines + ) where + +import qualified Data.ByteString as B +import qualified Streaming.ByteString.Char8 as Q +import Control.Monad ((>=>)) +import Data.Bitraversable (bitraverse) +import Data.Int (Int64) +import Streaming (Stream, Of, inspect, unfold) + +-- | Stream lines as strict 'B.ByteString' values truncated to +-- @limit@ bytes. Newline characters are retained on lines that +-- fit within the limit (so a non-empty chunk that does not end in +-- @\\n@ signals a long line that was cut off mid-content); an +-- empty chunk signals end-of-input. +-- +strictLines :: Monad m + => Int64 -- ^ Line length limit + -> Q.ByteStream m r -- ^ Input 'Q.ByteStream' + -> Stream (Of B.ByteString) m r +strictLines limit = unfold (inspect >=> bitraverse pure trim) . Q.lineSplit 1 + where + trim = Q.toStrict . Q.drained . Q.splitAt limit diff --git a/Dane/Scanner/State.hs b/Dane/Scanner/State.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/State.hs @@ -0,0 +1,27 @@ +module Dane.Scanner.State + ( Scanner + , ScannerSt(..) + , evalScanner + , scannerFail + ) where + +import qualified Control.Monad.Trans.State.Strict as ST +import Net.DNSBase.Resolver (Resolver) + +import Dane.Scanner.Opts + +data ScannerSt = ScannerSt + { scannerOpts :: !Opts + , scannerResolver :: !Resolver + , scannerOK :: !Bool + } + +type Scanner = ST.StateT ScannerSt IO + +evalScanner :: Scanner a -> ScannerSt -> IO a +evalScanner = ST.evalStateT + +scannerFail :: a -> Scanner a +scannerFail x = do + ST.modify $ \s -> s { scannerOK = False } + return x diff --git a/Dane/Scanner/Util.hs b/Dane/Scanner/Util.hs new file mode 100644 --- /dev/null +++ b/Dane/Scanner/Util.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Dane.Scanner.Util + ( bs2hex + , d2s + , gettime + , headDef + , if_ + , nonempty + , rootOrTLD + ) where + +import qualified System.Posix.Time as Sys +import Foreign.C.Types (CTime(..)) + +import qualified Data.ByteString.Builder as LB +import Data.ByteString.Char8 (ByteString) +import qualified Data.ByteString.Lazy as LB +import Data.Int (Int64) + +import Net.DNSBase (Domain, canonicalise, labelCount, toHost) +import Net.DNSBase.Present (presentString) + + +-- | Hexadecimal representation of the input ByteString as a new ByteString +-- +bs2hex :: ByteString -> ByteString +bs2hex = LB.toStrict . LB.toLazyByteString . LB.byteStringHex +{-# INLINE bs2hex #-} + + +-- | Render a 'Domain' as its canonical lowercase 'String' form, +-- with no trailing dot. Calls 'canonicalise' to lowercase the +-- domain, then 'toHost' to drop the trailing root label, then +-- 'presentString' to materialise the bytes. Not valid on the +-- root domain; callers know they're working with host names. +d2s :: Domain -> String +d2s d = presentString (toHost (canonicalise d)) mempty + + +-- | Get POSIX time (in a more usable form) +-- +gettime :: IO Int64 +gettime = Sys.epochTime >>= \(CTime t) -> return t + + +-- | Safe @head@ that returns a default value for empty lists +-- +headDef :: a -> [a] -> a +headDef z [] = z +headDef _ (h:_) = h +{-# INLINE headDef #-} + + +-- | de-sugared pure ternary +-- +if_ :: Bool -> a -> a -> a +if_ True x _ = x +if_ False _ y = y +{-# INLINE if_ #-} + + +-- | Macro for not @null@ +-- +nonempty :: [a] -> Bool +nonempty [] = False +nonempty _ = True +{-# INLINE nonempty #-} + + +-- | Test whether a domain is either the root domain ".", or is +-- a TLD and therefore has only one label. +-- +rootOrTLD :: Domain -> Maybe Domain +rootOrTLD d + | labelCount d <= 1 = Just d + | otherwise = Nothing +{-# INLINE rootOrTLD #-} diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2016,2017 Viktor Dukhovni + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Viktor Dukhovni nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,303 @@ +# Check DANE TLSA security of an email domain + +## Features + +- Test the local resolver configuration by verifying the validity of + the root zone DNSKEY and SOA RRSets. + +- Test the DNSSEC delegation chain of a given TLD (DS, DNSKEY and + SOA), or just DNSKEY and SOA when checking the root zone itself. + +- Check whether an email domain is fully protected (across all of + its MX hosts) by DANE TLSA records, and whether these match the + actual certificate chains seen at each IP address of each MX host. + +- Perform certificate chain verification at a time offset from the + current time to ensure that certificates are not about to expire + too soon. + +A non-zero exit status is returned if any DNS lookups fail or if the +MX records or MX hosts are in an unsigned zone, or if for one of the +MX hosts no associated secure TLSA records are found. A non-zero exit +status is also returned if any of the attempted SMTP connections fail +to complete a TLS handshake whose certificate chain matches the TLSA +records. + +By default `danecheck` makes one TLS connection per IP and offers +the TLS library's full default set of signature algorithms, letting +the server pick. Hosts that publish both ECDSA and RSA certificates +are uncommon, and when only one is correctly bound to a TLSA record +it is almost always RSA — so testing whichever cert the server +prioritises is usually sufficient. + +Where both certificate kinds are in use and you want to probe them +independently, the `--sigalgs` option restricts (and orders) the +signature-algorithm groups offered to the server. The argument is +a comma-separated, case-insensitive list of named groups drawn from +`rsa`, `ecdsa` and `eddsa`: + +* `--sigalgs ecdsa`   offer only ECDSA (P-256\/P-384\/P-521 with + SHA-2) +* `--sigalgs rsa`     offer only RSA (RSA-PSS for TLS 1.3, + RSA-PKCS#1 for TLS 1.2) +* `--sigalgs eddsa`   offer only Ed25519 and Ed448 +* `--sigalgs ecdsa,rsa`    offer ECDSA first, fall back to RSA +* `--sigalgs any` (or omit the option)   the TLS library default + +Servers that don't support any of the offered algorithms will fail +the TLS handshake, which is the intended diagnostic — it confirms +that the requested cert kind isn't available at that peer. + +## Synopsis + +For an overview of the `danecheck` command-line interface, run +`danecheck --help`. + +When scanning the root domain, what's checked is secure retrieval +of the root DNSKEY and SOA RRSets. Similarly, when scanning a +top-level domain, what's checked is secure retrieval of its DS, +DNSKEY and SOA records. For all other domains, MX records, address +records and TLSA records are retrieved and must be DNSSEC signed. + +Each MX host is expected to have TLSA records, an SMTP connection +is made to each address of each such MX host (with the '-A' option +connections are also made to MX hosts that don't have DNSSEC-signd +TLSA records). A TLS handshake is performed to retrieve the +host's certificate chain, which is verified against the DNS TLSA +RRs. If anything is unavailable, insecure or wrong, a non-zero +exit code is returned. + +The '-D' option can be used zero or more times to skip SMTP +connections to MX hosts that are expected to be down. The '-U' +option inverts the action of the '-D' option, and connects to only +those MX hosts that are specified via the '-D' option (none if no +such hosts are specified). + +Some "reserved" MX host addresses are assumed invalid and not tested by +default. The command will report a non-zero exit status when these are +encountered. The reserved addresses are the address blocks from the IANA +IPv4 and IPv6 special purpose address registries: + +* [IPv4 Special-Purpose Address Registry](https://www.iana.org/assignments/iana-ipv4-special-registry) +* [IPv6 Special-Purpose Address Registry](https://www.iana.org/assignments/iana-ipv6-special-registry) + +these include, for example, the RFC1918 private IPv4 ranges, and +should not appear among the addresses of MX hosts of internet-facing +email domains. If you're testing a non-public domain on an internal +network, you can use the `-R` option to enable connections to +reserved addresses. + +## Building the software + +### Prerequisite: A working GHC toolchain + +`danecheck` is written in Haskell and depends only on libraries +available from [Hackage](https://hackage.haskell.org/); no external +C libraries are required. + +The recommended way to install a Haskell toolchain is via +[`ghcup`](https://www.haskell.org/ghcup/): + + $ curl --proto '=https' --tlsv1.2 -sSf \ + https://get-ghcup.haskell.org | sh + +Once `ghcup` is installed, fetch GHC and `cabal-install`: + + $ ghcup install ghc 9.12.4 + $ ghcup set ghc 9.12.4 + $ ghcup install cabal recommended + +`danecheck` is tested against GHC 9.10.3, 9.12.4 and 9.14.1; any of +these will work. Use whichever your system already provides, or the +most recent one if you're starting fresh. + +**Disk space note**: each GHC toolchain installed by `ghcup` is +substantial — a single GHC takes roughly **2.2–3.0 GB** under +`~/.ghcup/ghc//`. By comparison the cabal package store +for `danecheck` and its transitive dependencies is around **470 MB** +under `~/.cabal/store/-/`. Plan for around 3 GB +of free space for a fresh single-GHC setup, more if you install +multiple GHC versions. Old GHC versions can be removed via `ghcup +rm ghc ` when no longer needed. + +**GHC 9.14.1 dependency bounds**: a couple of `danecheck`'s +transitive dependencies have not yet relaxed their upper bounds to +admit the `base`, `containers` and `time` versions shipped with GHC +9.14.1. Two install scenarios behave differently: + +* **Building from a source checkout** (e.g. after `git clone`): + the `cabal.project` shipped in this repository already carries + the necessary `allow-newer: base, containers, time` stanza, and + Cabal applies it automatically. Nothing to do. +* **Installing from Hackage with `cabal install danecheck`**: + Cabal does *not* consult the package's own `cabal.project` + during a Hackage install. Pass the override on the command line + yourself: + + $ cabal install danecheck --allow-newer=base,containers,time + + or add the same line to your own `cabal.project` / cabal config. + +GHC 9.10.3 and 9.12.4 build cleanly in either scenario without any +workaround. + +### Compile and install danecheck + +From the top of the source tree: + + $ cabal update + $ cabal build danecheck + $ exe=$(cabal -v0 list-bin danecheck) + $ strip "$exe" + $ install "$exe" ~/.local/bin # or any directory on your PATH + +For a self-contained install from Hackage (no source checkout +required), `cabal install danecheck` will fetch the released version +and place the binary under the path configured by `cabal`'s +`installdir` setting (typically `~/.cabal/bin`). + +## Getting Started + +### Choose a working DNSSEC-validating resolver + +It is assumed that your system has a working DNSSEC-validating +resolver (BIND 9, unbound or similar) running locally and +listening on the loopback interface at UDP and TCP at +127.0.0.1:53. + +By default the system's `/etc/resolv.conf` file is ignored and the +default nameserver list consists of just "127.0.0.1". If you want +to specify a different validating resolver, use the `-n` option to +select an alternate IP address. The `/etc/resolv.conf` nameserver +list can be selected via the `-N` option. + +### Check that the software and resolver are working + +Assuming the installation directory is ~/.local/bin: + + $ PATH=$HOME/.local/bin:$PATH + $ danecheck || printf "ERROR: root zone record validation failed\n" >&2 + +This should output a validated copy of the root zone SOA RR and +not print the ERROR message. For example: + + $ danecheck + . IN SOA a.root-servers.net. nstld@verisign-grs.com. 2026060900 1800 900 604800 86400 ; NoError AD=1 + +The trailing `; NoError AD=1` comment on each output line indicates +the rcode and DNSSEC AD bit of the response. A validated answer +shows `NoError AD=1`; failures or insecure answers (`AD=0`) are +diagnosed in place. + +Validated DS and DNSKEY records are not printed: their successful +retrieval is implicit in the SOA line being secure and present. +Only failing or insecure lookups along the validation chain produce +diagnostic output, so the steady-state success case is intentionally +brief. + +The `.` between the first and second DNS labels of the SOA contact +mailbox field is displayed as an `@` sign, since some domains have +literal `.` characters in the localpart (first label) of the +address. The trailing `.` is not stripped from the domain part of +the address. + +### Check your TLD + +If your domain's ancestor TLD is not DNSSEC signed (still the case +for some ccTLD domains), then DNSSEC will not be used for your +domain either, except from resolvers that have configured a custom +trust-anchor for your domain or one of its ancestor domains. When +checking the DNSSEC status of a TLD `danecheck` walks the DS, +DNSKEY and SOA records. As with the root, validated DS and DNSKEY +records are not printed; only the SOA confirmation appears in the +success case: + + $ danecheck org + org. IN SOA a0.org.afilias-nst.info. hostmaster.donuts.email. 1781006459 7200 900 1209600 3600 ; NoError AD=1 + +## Checking your own domain + +With your resolver tested for working root zone security and DNSSEC working for +your TLD, you can proceed to regularly test your own domain. Example: + + $ domain=ietf.org + $ danecheck ietf.org + ietf.org. IN MX 0 mail2.ietf.org. ; NoError AD=1 + mail2.ietf.org. IN A 166.84.6.31 ; NoError AD=1 + mail2.ietf.org. IN AAAA 2602:f977:800:f7f6::1 ; NoError AD=1 + _25._tcp.mail2.ietf.org. IN TLSA 3 1 1 810e86ff280553ec895b7f35132a3e919f9aa0517b181645492cd56c8bc2e67a ; NoError AD=1 + mail2.ietf.org[166.84.6.31]: pass: TLSA match: depth = 0, name = *.ietf.org + TLS = TLS1.3 with TLS_CHACHA20_POLY1305_SHA256,X25519,PubKeyALG_EC + name = *.ietf.org + depth = 0 + Issuer CommonName = E8 + Issuer Organization = Let's Encrypt + notBefore = 2026-04-17T08:18:28Z + notAfter = 2026-07-16T08:18:27Z + Subject CommonName = *.ietf.org + pkey sha256 [matched] <- 3 1 1 810e86ff280553ec895b7f35132a3e919f9aa0517b181645492cd56c8bc2e67a + depth = 1 + Issuer CommonName = ISRG Root X1 + Issuer Organization = Internet Security Research Group + notBefore = 2024-03-13T00:00:00Z + notAfter = 2027-03-12T23:59:59Z + Subject CommonName = E8 + Subject Organization = Let's Encrypt + pkey sha256 [nomatch] <- 2 1 1 885bf0572252c6741dc9a52f5044487fef2a93b811cdedfad7624cc283b7cdd5 + mail2.ietf.org[2602:f977:800:f7f6::1]: pass: TLSA match: depth = 0, name = *.ietf.org + TLS = TLS1.3 with TLS_CHACHA20_POLY1305_SHA256,X25519,PubKeyALG_EC + name = *.ietf.org + depth = 0 + Issuer CommonName = E8 + Issuer Organization = Let's Encrypt + notBefore = 2026-04-17T08:18:28Z + notAfter = 2026-07-16T08:18:27Z + Subject CommonName = *.ietf.org + pkey sha256 [matched] <- 3 1 1 810e86ff280553ec895b7f35132a3e919f9aa0517b181645492cd56c8bc2e67a + depth = 1 + Issuer CommonName = ISRG Root X1 + Issuer Organization = Internet Security Research Group + notBefore = 2024-03-13T00:00:00Z + notAfter = 2027-03-12T23:59:59Z + Subject CommonName = E8 + Subject Organization = Let's Encrypt + pkey sha256 [nomatch] <- 2 1 1 885bf0572252c6741dc9a52f5044487fef2a93b811cdedfad7624cc283b7cdd5 + +If the exit code indicates failure you should check the output for: + +* DNS Failures + - Any failed DNS queries (not `NoError` or `NODATA`) or insecure answers (`AD=0`) + - Non-existent MX hosts or TLSA records +* SMTP failures + - Failures to connect to an MX host at one or more of its IP addresses + - Rejected or timed-out SMTP commands + - Lack of STARTTLS support + - Failure to complete the TLS handshake +* Chain verification failures + - Failure to find matching TLSA records + - Name check failure with DANE-TA(2) TLSA records + - Certificate expiration with DANE-TA(2) TLSA records + +## Skipping out-of-service MX hosts + +If some of your MX hosts are down and you want to verify the +certificate chains of only the remaining hosts, you can specify +the `--down` (`-D`) option one or more times to skip SMTP tests +for those hosts. Their DNS security (including presence of TLSA +records) is still tested and is still required for the overall +check to succeed. Use `--upside-down` (`-U`) to invert the sense +of `-D` and probe *only* the listed hosts, leaving the rest +unchecked. + +## Common failure reasons + +- Certificates not matching TLSA records +- No SMTP service on a subset of MX host IP addresses +- STARTTLS not offered +- TLSA Lookups ServFail +- Invalid MX hostname (only MX hosts with "LDH" labels are + considered valid). +- MX target resolving to an IANA special-purpose IPv4 or IPv6 + address (RFC1918 private space, loopback, 6to4 of any of the + above, etc.) — overridable with `-R` for testing on internal + networks diff --git a/danecheck.cabal b/danecheck.cabal new file mode 100644 --- /dev/null +++ b/danecheck.cabal @@ -0,0 +1,110 @@ +cabal-version: 3.12 + +Name: danecheck +Version: 1.0.0.0 +Synopsis: DANE SMTP validator +Description: + @danecheck@ is a diagnostic tool that verifies the + DANE TLSA security (RFC 7672) of an email domain's SMTP + delivery path. For the given domain it follows the MX + records, looks up A\/AAAA addresses for each MX host, + queries TLSA records at @_25._tcp.\@ (with the + RFC 7672 CNAME extension to a TLSA base name), connects + on port 25, performs STARTTLS, and reports whether each + peer's certificate chain matches the TLSA RRset. + . + Output is streamed in BIND-style record form with + per-IP diagnostics: the DNS chain for each lookup, the + negotiated TLS version, cipher and key-exchange group, + the presented peer names, and a depth-by-depth view + of the certificate chain with TLSA match\/mismatch + annotations. The process exit code reflects whether + the domain validated cleanly. + . + See the @README.md@ for usage examples and command-line + options. + +License: BSD-3-Clause +License-File: LICENSE +Author: Viktor Dukhovni (with contributions from Peter Duchovni) +Maintainer: postfix-users@dukhovni.org +Category: Network +Homepage: https://github.com/vdukhovni/danecheck +Bug-Reports: https://github.com/vdukhovni/danecheck/issues +Build-Type: Simple +Extra-Doc-Files: README.md +tested-with: GHC == 9.10.3 + , GHC == 9.12.4 + , GHC == 9.14.1 + +Source-Repository head + Type: git + Location: https://github.com/vdukhovni/danecheck.git + +Executable danecheck + HS-Source-Dirs: "." + Default-Language: GHC2024 + GHC-Options: -Wall + Main-Is: Dane/Scanner/Main.hs + + Default-Extensions: + BlockArguments + MultiWayIf + NegativeLiterals + PatternSynonyms + StrictData + ViewPatterns + + Other-Extensions: + FlexibleContexts + OverloadedStrings + RecordWildCards + RequiredTypeArguments + TemplateHaskell + + Other-Modules: + Dane.Scanner.Source + Dane.Scanner.State + Dane.Scanner.Util + Dane.Scanner.DNS.Dane + Dane.Scanner.DNS.Lookup + Dane.Scanner.DNS.Reply + Dane.Scanner.DNS.Toascii + Dane.Scanner.Opts + Dane.Scanner.SMTP.Addr + Dane.Scanner.SMTP.Certs + Dane.Scanner.SMTP.Chain + Dane.Scanner.SMTP.Internal + Dane.Scanner.SMTP.Parse + Dane.Scanner.SMTP.Proto + Dane.Scanner.SMTP.Sock + Dane.Scanner.SMTP.TLS + + Build-Depends: + attoparsec >= 0.14.4 && < 0.15, + base >= 4.20 && < 5, + bytestring >= 0.10 && < 0.13, + clock >= 0.8 && < 0.9, + containers >= 0.6 && < 0.9, + crypton >=1.0 && <1.2, + crypton-asn1-encoding >=0.9 && <0.11, + crypton-asn1-types >=0.3 && <0.5, + crypton-x509 >=1.7 && <1.10, + crypton-x509-store >=1.7 && <1.10, + crypton-x509-validation >=1.7 && <1.10, + data-default-class >= 0.1 && < 0.3, + dnsbase ^>= 1.0.2, + hostname ^>= 1.0, + idna2008 ^>= 1.0, + iproute >= 1.6 && < 1.8, + network >= 3.0 && < 3.3, + optparse-applicative >= 0.14 && < 0.20, + ram >=0.19 && <0.23, + streaming ^>= 0.2, + streaming-bytestring >=0.2 && <0.4, + text >= 1.2 && < 2.2, + time-hourglass >= 0.2 && < 0.4, + tls ^>= 2.4.3, + transformers >= 0.5 && < 0.7, + unix >= 2.7 && < 2.9, + unix-time >= 0.3 && < 0.6