diff --git a/Dmarc.App/Dmarc.App.fsproj b/Dmarc.App/Dmarc.App.fsproj
index da37621..24dd728 100644
--- a/Dmarc.App/Dmarc.App.fsproj
+++ b/Dmarc.App/Dmarc.App.fsproj
@@ -13,4 +13,8 @@
+
+
+
+
diff --git a/Dmarc.App/Program.fs b/Dmarc.App/Program.fs
index 9fdeff5..70a30ed 100644
--- a/Dmarc.App/Program.fs
+++ b/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
+
[]
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
+
+ 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
+ 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
+ eprintfn $"%O{record}"
+
+ Interlocked.Increment total |> ignore
+
+ printfn "Failed: %i/%i" failures.Value total.Value
0
diff --git a/Dmarc.Test/TestParse.fs b/Dmarc.Test/TestParse.fs
index cdb2748..9fb9d92 100644
--- a/Dmarc.Test/TestParse.fs
+++ b/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
}
diff --git a/Dmarc/Domain.fs b/Dmarc/Domain.fs
index dfc1384..90fbd52 100644
--- a/Dmarc/Domain.fs
+++ b/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 -> ""
+ | Some s -> s
+
+ let envelopeTo =
+ match this.EnvelopeTo with
+ | None -> ""
+ | 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 -> ""
+ | 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 |> String.concat ", "
+ let spf = this.SpfHead.ToString () + if tail = "" then "" else $", %s{tail}"
+ let dkim = this.Dkim |> Seq.map string |> 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"
diff --git a/Dmarc/XmlPatterns.fs b/Dmarc/XmlPatterns.fs
index 1733c6d..346dcb1 100644
--- a/Dmarc/XmlPatterns.fs
+++ b/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
+ []
+ let (|NamedNoChildren|_|) (name : string) (node : XmlNode) : unit voption =
+ if node.HasChildNodes then ValueNone
+ elif node.Name = name then ValueSome ()
+ else ValueNone
+
[]
let (|Int64|_|) (s : string) : int64 voption =
match System.Int64.TryParse s with
diff --git a/nix/deps.nix b/nix/deps.nix
index 53fabf1..f7c9cf7 100644
--- a/nix/deps.nix
+++ b/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";
+ })
]