Make it work on my own machine (#2)

Dmarc.App/Dmarc.App.fsproj

@@ -13,4 +13,8 @@
       <ProjectReference Include="..\Dmarc\Dmarc.fsproj" />
     </ItemGroup>
 
+    <ItemGroup>
+      <PackageReference Include="MimeKit" Version="4.6.0" />
+    </ItemGroup>
+
 </Project>

Dmarc.App/Program.fs

@@ -1,20 +1,221 @@
 namespace Dmarc.App
 
+open System
 open System.IO
+open System.IO.Compression
+open System.Security.Cryptography
+open System.Text
+open System.Threading
 open System.Xml
 open Dmarc
+open MimeKit
 
 module Program =
+    let emptyDisposable () =
+        { new System.IDisposable with
+            member _.Dispose () = ()
+        }
+
+    let loadXmlFromBase64Gzip (s : string) : XmlDocument =
+        let doc = XmlDocument ()
+
+        let bytes = Encoding.UTF8.GetBytes s
+        use reader = new MemoryStream (bytes)
+        use b64Transform = new FromBase64Transform ()
+        use b64Stream = new CryptoStream (reader, b64Transform, CryptoStreamMode.Read)
+        use gz = new GZipStream (b64Stream, CompressionMode.Decompress)
+
+        doc.Load gz
+        doc
+
+    let loadXmlFromGzip (s : Stream) : XmlDocument =
+        let doc = XmlDocument ()
+        use gz = new GZipStream (s, CompressionMode.Decompress, leaveOpen = true)
+
+        doc.Load gz
+        doc
+
+    let loadXmlFromFile (file : FileInfo) : XmlDocument =
+        let doc = XmlDocument ()
+        use file = file.OpenRead ()
+        doc.Load file
+        doc
+
     [<EntryPoint>]
     let main argv =
-        let file =
+        let dir, domain, email =
             match argv with
-            | [| file |] -> file
-            | _ -> failwith "Call with exactly one arg, the XML file to parse"
+            | [| f ; domain ; email |] -> DirectoryInfo f, domain, email
+            | _ -> failwith "give exactly three args, a mailbox folder, a domain, and a dmarc email address"
 
-        use s = File.OpenRead file
-        let doc = XmlDocument ()
-        doc.Load s
+        let errors = ResizeArray ()
 
-        let feedback = Feedback.ofXml doc.["feedback"]
+        let success =
+            dir.EnumerateFileSystemInfos ()
+            |> Seq.choose (fun entry ->
+                if Directory.Exists entry.FullName then
+                    failwith "Encountered a directory"
+
+                let file = FileInfo entry.FullName
+
+                let message = MimeMessage.Load file.FullName
+
+                let isDmarc =
+                    message.To
+                    |> Seq.exists (fun i ->
+                        match i with
+                        | :? MailboxAddress as i -> i.Address = email
+                        | _ ->
+                            match message.Headers.["X-Original-To"] with
+                            | null ->
+                                errors.Add message
+                                false
+                            | m -> m = email
+                    )
+
+                if not isDmarc then
+                    None
+                else
+
+                message.Attachments
+                |> Seq.map (fun m ->
+                    let contentsResult = new MemoryStream ()
+
+                    let m =
+                        match m with
+                        | :? MimePart as m -> m
+                        | _ -> failwithf "Not a MIME part: %+A" m
+
+                    do
+                        match m.ContentTransferEncoding with
+                        | ContentEncoding.Base64 ->
+                            use b64Transform = new FromBase64Transform ()
+
+                            use b64Stream =
+                                new CryptoStream (
+                                    m.Content.Stream,
+                                    b64Transform,
+                                    CryptoStreamMode.Read,
+                                    leaveOpen = true
+                                )
+
+                            b64Stream.CopyTo contentsResult
+                        | e -> failwithf "Unrecognised content encoding: %O" e
+
+                    contentsResult.Seek (0L, SeekOrigin.Begin) |> ignore<int64>
+
+                    let senderIsMimecast =
+                        message.From
+                        |> Seq.map (fun addr ->
+                            match addr with
+                            | :? MailboxAddress as a ->
+                                a.Domain.EndsWith (".mimecastreport.com", StringComparison.Ordinal)
+                            | _ -> failwithf "unrecognised sender: %+A" addr
+                        )
+                        |> Seq.tryExactlyOne
+
+                    let parent, stream =
+                        match m.ContentType.MimeType, senderIsMimecast with
+                        | "application/zip", _
+                        // mimecast is a lying liar who lies about their content types...
+                        | "application/gzip", Some true ->
+                            let result =
+                                try
+                                    new ZipArchive (contentsResult, ZipArchiveMode.Read, leaveOpen = true) |> Ok
+                                with :? InvalidDataException ->
+                                    if senderIsMimecast = Some true then
+                                        Error ()
+                                    else
+                                        reraise ()
+
+                            match result with
+                            | Ok result ->
+                                let entry = Seq.exactlyOne result.Entries
+                                result :> IDisposable, entry.Open ()
+                            | Error () ->
+                                // ... except when they don't lie
+                                // oh my god mimecast why can't you just be normal
+                                let s =
+                                    new GZipStream (contentsResult, CompressionMode.Decompress, leaveOpen = true)
+
+                                emptyDisposable (), s :> Stream
+                        | "application/gzip", _ ->
+                            let s =
+                                new GZipStream (contentsResult, CompressionMode.Decompress, leaveOpen = true)
+
+                            emptyDisposable (), s :> Stream
+                        | s, _ -> failwith $"Unrecognised MIME type: %s{s}"
+
+                    use parent = parent
+                    use stream = stream
+
+                    let doc = XmlDocument ()
+                    doc.Load stream
+                    doc
+                )
+                |> Seq.map (fun doc -> Feedback.ofXml doc.["feedback"])
+                |> Seq.toList
+                |> Some
+            )
+            |> Seq.concat
+            |> Seq.toList
+
+        if errors.Count <> 0 then
+            failwith $"Got errors! %+A{errors}"
+
+        let failures = ref 0
+        let total = ref 0
+        let tempErrors = ref 0
+
+        for report in success do
+            if not report.ReportMetadata.Error.IsEmpty then
+                eprintfn $"Got an error report: %+A{report}"
+
+            if report.PolicyPublished.Domain <> domain then
+                eprintfn $"Got a report which was not for my domain: %+A{report}"
+
+            for record in report.Records do
+                let mutable isOk = true
+
+                match record.Row.Policy.Disposition with
+                | Disposition.Quarantine ->
+                    isOk <- false
+                    eprintfn $"Quarantine"
+                | Disposition.Reject ->
+                    isOk <- false
+                    eprintfn $"Rejected"
+                | Disposition.None -> ()
+
+                match record.Row.Policy.Dkim with
+                | DmarcResult.Fail ->
+                    if
+                        record.AuthResults.Dkim
+                        |> List.forall (fun r -> r.Result = DkimResult.TempError)
+                    then
+                        eprintfn $"Temporary failure killed DKIM; not counting."
+                        Interlocked.Increment tempErrors |> ignore<int>
+                    else
+                        isOk <- false
+                        eprintfn $"Failed DKIM."
+                | DmarcResult.Pass -> ()
+
+                match record.Row.Policy.Spf with
+                | DmarcResult.Fail ->
+                    isOk <- false
+                    eprintfn $"Failed SPF"
+                | DmarcResult.Pass -> ()
+
+                match record.AuthResults.SpfHead.Result with
+                | SpfResult.Pass -> ()
+                | _ ->
+                    isOk <- false
+                    eprintfn $"SPF auth result was not Pass"
+
+                if not isOk then
+                    Interlocked.Increment failures |> ignore<int>
+                    eprintfn $"%O{record}"
+
+                Interlocked.Increment total |> ignore<int>
+
+        printfn "Failed: %i/%i" failures.Value total.Value
         0

Dmarc.Test/TestParse.fs

@@ -39,7 +39,7 @@ module TestParse =
         {
             OrgName = Some "google.com"
             Email = "noreply-dmarc-support@google.com"
-            ExtraContactInfo = Uri "https://support.google.com/a/answer/2466580"
+            ExtraContactInfo = Some (Uri "https://support.google.com/a/answer/2466580")
             ReportId = "12345678901234567890"
             DateRange = expectedDateRange
             Error = []
@@ -68,7 +68,7 @@ module TestParse =
             DkimAlignment = Some Alignment.Relaxed
             SpfAlignment = Some Alignment.Relaxed
             Policy = Disposition.None
-            SubdomainPolicy = Disposition.None
+            SubdomainPolicy = Some Disposition.None
             Percentage = 100
             FailureOptions = None
         }

Dmarc/Domain.fs

@@ -31,7 +31,8 @@ type ReportMetadata =
     {
         OrgName : string option
         Email : string
-        ExtraContactInfo : Uri
+        /// Mandatory according to the RFC, but Microsoft doesn't provide it
+        ExtraContactInfo : Uri option
         ReportId : string
         DateRange : DateRange
         Error : string list
@@ -80,10 +81,6 @@ type ReportMetadata =
             reportId
             |> Option.defaultWith (fun () -> failwith "expected report_id, got none")
 
-        let extraContactInfo =
-            extraContactInfo
-            |> Option.defaultWith (fun () -> failwith "expected extra_contact_info, got none")
-
         let dateRange =
             dateRange
             |> Option.defaultWith (fun () -> failwith "expected date_range, got none")
@@ -113,6 +110,12 @@ type Disposition =
     | Quarantine
     | Reject
 
+    override this.ToString () =
+        match this with
+        | Disposition.None -> "none"
+        | Disposition.Quarantine -> "quarantine"
+        | Disposition.Reject -> "reject"
+
     static member ofString (s : string) : Disposition =
         match s with
         | "none" -> Disposition.None
@@ -126,7 +129,8 @@ type PolicyPublished =
         DkimAlignment : Alignment option
         SpfAlignment : Alignment option
         Policy : Disposition
-        SubdomainPolicy : Disposition
+        /// Mandated by RFC-7489 but Yahoo doesn't send it
+        SubdomainPolicy : Disposition option
         Percentage : int
         /// Mandated by RFC-7489 but absent from Google's response.
         FailureOptions : string option
@@ -185,10 +189,6 @@ type PolicyPublished =
         let policy =
             policy |> Option.defaultWith (fun () -> failwith "expected policy, got none")
 
-        let subdomainPolicy =
-            subdomainPolicy
-            |> Option.defaultWith (fun () -> failwith "expected subdomainPolicy, got none")
-
         let percentage =
             percentage
             |> Option.defaultWith (fun () -> failwith "expected percentage, got none")
@@ -207,6 +207,11 @@ type DmarcResult =
     | Pass
     | Fail
 
+    override this.ToString () =
+        match this with
+        | DmarcResult.Pass -> "pass"
+        | DmarcResult.Fail -> "fail"
+
     static member ofString (s : string) : DmarcResult =
         match s with
         | "pass" -> DmarcResult.Pass
@@ -273,6 +278,15 @@ type PolicyEvaluated =
         Reason : PolicyOverrideReason list
     }
 
+    override this.ToString () =
+        let reason =
+            this.Reason
+            |> Seq.map (fun x -> x.ToString ())
+            |> String.concat "; "
+            |> fun s -> if String.IsNullOrEmpty s then "" else $" (reason: %s{s})"
+
+        $"d=%O{this.Disposition}, spf %O{this.Spf}, dkim %O{this.Dkim}%s{reason}"
+
     static member ofXml (node : XmlNode) : PolicyEvaluated =
         if not node.HasChildNodes then
             failwith "expected policy evaluation node to have children, but it did not"
@@ -296,7 +310,7 @@ type PolicyEvaluated =
                 match spf with
                 | None -> spf <- Some (DmarcResult.ofString v)
                 | Some v2 -> failwith $"spf appeared twice, values %O{v2} and %s{v}"
-            | OneChildNode "reason" v -> reason.Add (PolicyOverrideReason.ofXml v)
+            | NodeWithChildren "reason" -> reason.Add (PolicyOverrideReason.ofXml i)
             | _ -> failwith $"unrecognised node: %s{i.Name}, %s{i.InnerText}"
 
         let spf = spf |> Option.defaultWith (fun () -> failwith "expected spf, got none")
@@ -319,6 +333,9 @@ type Row =
         Policy : PolicyEvaluated
     }
 
+    override this.ToString () =
+        $"%O{this.SourceIp}: %i{this.Count} messages (%O{this.Policy})"
+
     static member ofXml (node : XmlNode) : Row =
         if not node.HasChildNodes then
             failwith "expected policy evaluation node to have children, but it did not"
@@ -367,6 +384,19 @@ type Identifier =
         HeaderFrom : string
     }
 
+    override this.ToString () =
+        let envelopeFrom =
+            match this.EnvelopeFrom with
+            | None -> "<no EnvelopeFrom>"
+            | Some s -> s
+
+        let envelopeTo =
+            match this.EnvelopeTo with
+            | None -> "<no EnvelopeTo>"
+            | Some s -> s
+
+        $"%s{this.HeaderFrom} (to: %s{envelopeTo}, from: %s{envelopeFrom})"
+
     static member ofXml (node : XmlNode) : Identifier =
         if not node.HasChildNodes then
             failwith "expected identifiers node to have children, but it did not"
@@ -430,6 +460,19 @@ type DkimAuthResult =
         HumanResult : string option
     }
 
+    override this.ToString () =
+        let selector =
+            match this.Selector with
+            | None -> ""
+            | Some s -> $" (%s{s})"
+
+        let humanResult =
+            match this.HumanResult with
+            | None -> ""
+            | Some s -> $" (%s{s})"
+
+        $"%s{this.Domain}%s{selector}: %O{this.Result}%s{humanResult}"
+
     static member ofXml (node : XmlNode) : DkimAuthResult =
         if not node.HasChildNodes then
             failwith "expected dkim auth result node to have children, but it did not"
@@ -457,6 +500,9 @@ type DkimAuthResult =
                 match humanResult with
                 | None -> humanResult <- Some v
                 | Some v2 -> failwith $"human_result appeared twice, values %s{v2} and %s{v}"
+            | NamedNoChildren "human_result" ->
+                // Mimecast sends this node empty
+                ()
             | _ -> failwith $"unrecognised node: %s{i.Name}, %s{i.InnerText}"
 
         let domain =
@@ -476,6 +522,11 @@ type SpfDomainScope =
     | Helo
     | Mfrom
 
+    override this.ToString () =
+        match this with
+        | SpfDomainScope.Helo -> "helo"
+        | SpfDomainScope.Mfrom -> "mfrom"
+
     static member ofString (s : string) : SpfDomainScope =
         match s with
         | "helo" -> SpfDomainScope.Helo
@@ -492,6 +543,16 @@ type SpfResult =
     | TempError
     | PermError
 
+    override this.ToString () =
+        match this with
+        | SpfResult.None -> "none"
+        | SpfResult.Neutral -> "neutral"
+        | SpfResult.Pass -> "pass"
+        | SpfResult.Fail -> "fail"
+        | SpfResult.SoftFail -> "softfail"
+        | SpfResult.TempError -> "temperror"
+        | SpfResult.PermError -> "permerror"
+
     static member ofString (s : string) : SpfResult =
         match s with
         | "none" -> SpfResult.None
@@ -513,6 +574,14 @@ type SpfAuthResult =
         Result : SpfResult
     }
 
+    override this.ToString () =
+        let scope =
+            match this.Scope with
+            | None -> "<no scope>"
+            | Some s -> (s : SpfDomainScope).ToString ()
+
+        $"%s{this.Domain}, %s{scope}: %O{this.Result}"
+
     static member ofXml (node : XmlNode) : SpfAuthResult =
         if not node.HasChildNodes then
             failwith "expected spf auth result to have children, but it did not"
@@ -556,6 +625,12 @@ type AuthResult =
         SpfTail : SpfAuthResult list
     }
 
+    override this.ToString () =
+        let tail = this.SpfTail |> Seq.map string<SpfAuthResult> |> String.concat ", "
+        let spf = this.SpfHead.ToString () + if tail = "" then "" else $", %s{tail}"
+        let dkim = this.Dkim |> Seq.map string<DkimAuthResult> |> String.concat ", "
+        $"[%s{spf} ||| %s{dkim}]"
+
     static member ofXml (node : XmlNode) : AuthResult =
         if not node.HasChildNodes then
             failwith "expected auth result to have children, but it did not"
@@ -592,6 +667,9 @@ type Record =
         AuthResults : AuthResult
     }
 
+    override this.ToString () =
+        $"""%O{this.Row} %O{this.Identifiers}: %O{this.AuthResults}"""
+
     static member ofXml (node : XmlNode) : Record =
         if not node.HasChildNodes then
             failwith "expected record result to have children, but it did not"

Dmarc/XmlPatterns.fs

@@ -21,6 +21,12 @@ module internal XmlPatterns =
     let (|NoChildrenNode|_|) (node : XmlNode) : string option =
         if node.HasChildNodes then None else Some node.Value
 
+    [<return : Struct>]
+    let (|NamedNoChildren|_|) (name : string) (node : XmlNode) : unit voption =
+        if node.HasChildNodes then ValueNone
+        elif node.Name = name then ValueSome ()
+        else ValueNone
+
     [<return : Struct>]
     let (|Int64|_|) (s : string) : int64 voption =
         match System.Int64.TryParse s with

nix/deps.nix

@@ -1,6 +1,11 @@
 # This file was automatically generated by passthru.fetch-deps.
 # Please dont edit it manually, your changes might get overwritten!
 {fetchNuGet}: [
+  (fetchNuGet {
+    pname = "BouncyCastle.Cryptography";
+    version = "2.3.1";
+    sha256 = "0wagr2ibc12mp58i1fql2xbfb1h2b1bpi1gpsynkl2il3mycvyxg";
+  })
   (fetchNuGet {
     pname = "fantomas";
     version = "6.3.4";
@@ -66,6 +71,11 @@
     version = "17.10.0";
     sha256 = "1bl471s7fx9jycr0cc8rylwf34mrvlg9qn1an6l86nisavfcyb7v";
   })
+  (fetchNuGet {
+    pname = "MimeKit";
+    version = "4.6.0";
+    sha256 = "1rmz54d836gjhm9mhpa57h6d36gw4pdqh9xjidyy7548c30qdqrr";
+  })
   (fetchNuGet {
     pname = "Nerdbank.GitVersioning";
     version = "3.6.133";
@@ -91,9 +101,19 @@
     version = "4.5.0";
     sha256 = "1srx1629s0k1kmf02nmz251q07vj6pv58mdafcr5dr0bbn1fh78i";
   })
+  (fetchNuGet {
+    pname = "System.Formats.Asn1";
+    version = "8.0.0";
+    sha256 = "04h75wflmzl0qh125p0209wx006rkyxic1y404m606yjvpl2alq1";
+  })
   (fetchNuGet {
     pname = "System.Reflection.Metadata";
     version = "1.6.0";
     sha256 = "1wdbavrrkajy7qbdblpbpbalbdl48q3h34cchz24gvdgyrlf15r4";
   })
+  (fetchNuGet {
+    pname = "System.Security.Cryptography.Pkcs";
+    version = "8.0.0";
+    sha256 = "04kqf1lhsq3fngiljanmrz2774x5h2fc8p57v04c51jwwqhwi9ya";
+  })
 ]