danecheck (empty) → 1.0.0.0
raw patch · 20 files changed
+3256/−0 lines, 20 filesdep +attoparsecdep +basedep +bytestring
Dependencies added: attoparsec, base, bytestring, clock, containers, crypton, crypton-asn1-encoding, crypton-asn1-types, crypton-x509, crypton-x509-store, crypton-x509-validation, data-default-class, dnsbase, hostname, idna2008, iproute, network, optparse-applicative, ram, streaming, streaming-bytestring, text, time-hourglass, tls, transformers, unix, unix-time
Files
- Dane/Scanner/DNS/Dane.hs +290/−0
- Dane/Scanner/DNS/Lookup.hs +255/−0
- Dane/Scanner/DNS/Reply.hs +614/−0
- Dane/Scanner/DNS/Toascii.hs +27/−0
- Dane/Scanner/Main.hs +15/−0
- Dane/Scanner/Opts.hs +246/−0
- Dane/Scanner/SMTP/Addr.hs +52/−0
- Dane/Scanner/SMTP/Certs.hs +184/−0
- Dane/Scanner/SMTP/Chain.hs +308/−0
- Dane/Scanner/SMTP/Internal.hs +151/−0
- Dane/Scanner/SMTP/Parse.hs +59/−0
- Dane/Scanner/SMTP/Proto.hs +144/−0
- Dane/Scanner/SMTP/Sock.hs +61/−0
- Dane/Scanner/SMTP/TLS.hs +278/−0
- Dane/Scanner/Source.hs +24/−0
- Dane/Scanner/State.hs +27/−0
- Dane/Scanner/Util.hs +78/−0
- LICENSE +30/−0
- README.md +303/−0
- danecheck.cabal +110/−0
+ Dane/Scanner/DNS/Dane.hs view
@@ -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 }
+ Dane/Scanner/DNS/Lookup.hs view
@@ -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.\<mx-host\>@ 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)
+ Dane/Scanner/DNS/Reply.hs view
@@ -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 <rdata> ; <rcode> AD=<n>@.+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)
+ Dane/Scanner/DNS/Toascii.hs view
@@ -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
+ Dane/Scanner/Main.hs view
@@ -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
+ Dane/Scanner/Opts.hs view
@@ -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)."+ )
+ Dane/Scanner/SMTP/Addr.hs view
@@ -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+ }
+ Dane/Scanner/SMTP/Certs.hs view
@@ -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
+ Dane/Scanner/SMTP/Chain.hs view
@@ -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] ]
+ Dane/Scanner/SMTP/Internal.hs view
@@ -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
+ Dane/Scanner/SMTP/Parse.hs view
@@ -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
+ Dane/Scanner/SMTP/Proto.hs view
@@ -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
+ Dane/Scanner/SMTP/Sock.hs view
@@ -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" }
+ Dane/Scanner/SMTP/TLS.hs view
@@ -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
+ Dane/Scanner/Source.hs view
@@ -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
+ Dane/Scanner/State.hs view
@@ -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
+ Dane/Scanner/Util.hs view
@@ -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 #-}
+ LICENSE view
@@ -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.
+ README.md view
@@ -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/<version>/`. By comparison the cabal package store+for `danecheck` and its transitive dependencies is around **470 MB**+under `~/.cabal/store/<ghc-version>-<hash>/`. 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 <version>` 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
+ danecheck.cabal view
@@ -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.\<mx\>@ (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