Source file log_selector.ml

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
open Core
open Async_smtp
module Regex = Re2

let readme =
  "The query language is the Blang language:\n\n\
   B ::=\n\
  \  | envelope_sender REGEX\n\
  \  | envelope_recipient REGEX\n\
  \  | recipient REGEX\n\
  \  | subject REGEX\n\
  \  | rfc822_id REGEX\n\
  \  | flows FLOWS\n\n\
   E ::=\n\
  \  | True\n\
  \  | False\n\
  \  | (and E E ...)\n\
  \  | (or E E ...)\n\
  \  | (not E)\n\
  \  | (if E E E)\n\
  \  | (B)\n\n\
   Examples:\n\n\
   (and (recipient foo) (envelope_sender bar))\n\
   (subject \"Awesome email subject\")\n"
;;

module Mail_fingerprint = Smtp_mail_log.Mail_fingerprint

module Base = struct
  type t =
    [ `envelope_sender of Regex.t
    | `envelope_recipient of Regex.t
    | `recipient of Regex.t
    | `subject of Regex.t
    | `rfc822_id of Regex.t
    | `flows of Smtp_mail_log.Stable.Flows.V1.t
    ]
  [@@deriving sexp]

  let regex = function
    | `envelope_sender regex
    | `envelope_recipient regex
    | `recipient regex
    | `subject regex
    | `rfc822_id regex -> regex
    | `flows (flows : Smtp_mail_log.Flows.t) ->
      List.map (flows :> string list) ~f:Regex.escape
      |> List.map ~f:(sprintf "(%s)")
      |> String.concat ~sep:"|"
      |> Regex.of_string
  ;;

  let matches_message_header msg header regex =
    Option.value_map (Smtp_mail_log.Message.email msg) ~default:false ~f:(fun msg ->
      List.exists (Mail_fingerprint.headers msg) ~f:(fun (name, value) ->
        String.Caseless.equal header name && Regex.matches regex value))
  ;;

  let matches_message t msg =
    match t with
    | `envelope_sender regex ->
      Smtp_mail_log.Message.sender msg
      |> Option.map ~f:(function
        | `String str -> str
        | `Sender sender -> Smtp_envelope.Sender.to_string sender)
      |> Option.value_map ~default:false ~f:(Regex.matches regex)
    | `envelope_recipient regex | `recipient regex ->
      Smtp_mail_log.Message.recipients msg
      |> Option.value ~default:[]
      |> List.map ~f:(function
        | `String str -> str
        | `Email email -> Email_address.to_string email)
      |> List.exists ~f:(Regex.matches regex)
    | `subject regex -> matches_message_header msg "Subject" regex
    | `rfc822_id regex ->
      matches_message_header msg "Message-Id" regex
      || Smtp_mail_log.Message.rfc822_id msg
         |> Option.value_map ~default:false ~f:(Regex.matches regex)
    | `flows flows ->
      Smtp_mail_log.Flows.are_related flows (Smtp_mail_log.Message.flows msg)
  ;;
end

type t = Base.t Blang.t [@@deriving sexp]

let rec cnf = function
  | Blang.True -> [] (* The Empty conjunction is true *)
  | False -> [ [] ] (* The Empty disjunction is false *)
  | Base b -> [ [ `Base b ] ]
  | And (q1, q2) -> cnf q1 @ cnf q2
  | Or (q1, q2) ->
    List.map (List.cartesian_product (cnf q1) (cnf q2)) ~f:(fun (p, q) -> p @ q)
  | Not q ->
    (match q with
     | Base b -> [ [ `Not_base b ] ]
     | True -> cnf Blang.false_
     | False -> cnf Blang.true_
     | Not q -> cnf q
     | And (q1, q2) -> cnf (Blang.or_ [ Blang.not_ q1; Blang.not_ q2 ])
     | Or (q1, q2) -> cnf (Blang.and_ [ Blang.not_ q1; Blang.not_ q2 ])
     | If (c, q1, q2) -> cnf (Blang.if_ c (Blang.not_ q1) (Blang.not_ q2)))
  | If (c, qt, qf) ->
    (* Using the disjunctive representation of [If].
       Its more intuitive, and its cnf rewrite contains additional
       non-negated disjuncts that make for a better [permissive_cnf] *)
    cnf (Blang.or_ [ Blang.and_ [ c; qt ]; Blang.and_ [ Blang.not_ c; qf ] ])
;;

let permissive_cnf t =
  let reduce_disjunction =
    let rec loop acc = function
      | `Base t :: ts -> loop (t :: acc) ts
      | `Not_base _ :: _ -> None
      | [] -> Some (List.rev acc)
    in
    loop []
  in
  let t = List.filter_map (cnf t) ~f:reduce_disjunction in
  (* Short circuit the case that there is a [False] in the conjunction *)
  if List.mem t [] ~equal:Poly.equal then [ [] ] else t
;;

let arg = Command.Arg_type.create (fun s -> t_of_sexp (Sexp.of_string s))

let matches_message t session =
  Blang.eval t (fun base -> Base.matches_message base session)
;;