Source file sendmail.ml

open Colombe.Sigs
open Colombe.State
open Colombe

let ( <.> ) f g x = f (g x)

module Value = struct
  type helo = Domain.t

  type mail_from = Reverse_path.t * (string * string option) list

  type rcpt_to = Forward_path.t * (string * string option) list

  type auth = PLAIN

  type pp_220 = string list

  type pp_221 = string list

  type pp_250 = string list

  type tp_354 = string list

  type code = int * string list

  type error =
    [ Request.Encoder.error
    | Reply.Decoder.error
    | `Unexpected_response of int * string list ]

  let pp_error ppf = function
    | #Request.Encoder.error as err -> Request.Encoder.pp_error ppf err
    | #Reply.Decoder.error as err -> Reply.Decoder.pp_error ppf err
    | `Unexpected_response (code, txts) ->
        Fmt.pf ppf "Unexpected response %3d: %a" code
          Fmt.(Dump.list string)
          txts

  type encoder = Encoder.encoder

  type decoder = Decoder.decoder

  type 'x send =
    | Helo : helo send
    | Mail_from : mail_from send
    | Rcpt_to : rcpt_to send
    | Data : unit send
    | Dot : unit send
    | Quit : unit send
    | Auth : auth send
    | Payload : string send

  type 'x recv =
    | PP_220 : pp_220 recv
    | PP_221 : pp_221 recv
    | PP_250 : pp_250 recv
    | TP_354 : tp_354 recv
    | Code : code recv

  let encode : type a. encoder -> a send -> a -> (unit, [> Encoder.error ]) t =
   fun encoder w v ->
    let fiber : a send -> [> Encoder.error ] Encoder.state = function
      | Payload -> Request.Encoder.request (`Payload v) encoder
      | Helo -> Request.Encoder.request (`Hello v) encoder
      | Mail_from -> Request.Encoder.request (`Mail v) encoder
      | Rcpt_to -> Request.Encoder.request (`Recipient v) encoder
      | Data -> Request.Encoder.request `Data encoder
      | Dot -> Request.Encoder.request `Data_end encoder
      | Quit -> Request.Encoder.request `Quit encoder
      | Auth ->
      match v with
      | PLAIN -> Request.Encoder.request (`Verb ("AUTH", [ "PLAIN" ])) encoder
    in
    let rec go = function
      | Encoder.Done -> Return ()
      | Encoder.Write { continue; buffer; off; len } ->
          Write { k = go <.> continue; buffer; off; len }
      | Encoder.Error err -> Error err in
    (go <.> fiber) w

  let decode : type a. decoder -> a recv -> (a, [> Decoder.error ]) t =
   fun decoder w ->
    let k : Reply.t -> (a, [> Decoder.error ]) t =
     fun v ->
      match (w, v) with
      | PP_220, `PP_220 txts -> Return txts
      | PP_221, `PP_221 txts -> Return txts
      | PP_250, `PP_250 txts -> Return txts
      | TP_354, `TP_354 txts -> Return txts
      | Code, `Other v -> Return v
      | Code, `PN_501 txts -> Return (501, txts)
      | Code, `PN_504 txts -> Return (504, txts)
      | Code, `PP_250 txts -> Return (250, txts)
      | _, v ->
          let code = Reply.code v in
          let txts = Reply.lines v in
          Error (`Unexpected_response (code, txts)) in
    let rec go = function
      | Decoder.Done v -> k v
      | Decoder.Read { buffer; off; len; continue } ->
          Read { k = go <.> continue; buffer; off; len }
      | Decoder.Error { error; _ } -> Error error in
    go (Reply.Decoder.response decoder)
end

let src = Logs.Src.create "sendmail" ~doc:"logs sendmail's event"

module Log = (val Logs.src_log src : Logs.LOG)

module Monad = State.Scheduler (State.Context) (Value)

let run :
    type s flow.
    s impl ->
    (flow, s) rdwr ->
    flow ->
    ('a, 'err) t ->
    (('a, 'err) result, s) io =
 fun { bind; return } rdwr flow m ->
  let ( >>= ) = bind in

  let rec go = function
    | Read { buffer; off; len; k } ->
        rdwr.rd flow buffer off len >>= fun v -> go (k v)
    | Write { buffer; off; len; k } ->
        rdwr.wr flow buffer off len >>= fun () -> go (k len)
    | Return v -> return (Ok v)
    | Error err -> return (Error err : ('a, 'err) result) in
  go m

let properly_quit_and_fail ctx err =
  let open Monad in
  reword_error
    (fun _ -> err)
    ( send ctx Value.Quit () >>= fun () ->
      recv ctx Value.PP_221 >>= fun _ -> fail err )

let auth ctx mechanism info =
  let open Monad in
  match info with
  | None -> return `Anonymous
  | Some (username, password) ->
  match mechanism with
  | Value.PLAIN -> (
      let* code, txts =
        send ctx Value.Auth mechanism >>= fun () -> recv ctx Value.Code in
      match code with
      | 504 -> properly_quit_and_fail ctx `Unsupported_mechanism
      | 538 -> properly_quit_and_fail ctx `Encryption_required
      | 534 -> properly_quit_and_fail ctx `Weak_mechanism
      | 334 -> (
          let* () =
            match txts with
            | [] ->
                let payload =
                  Base64.encode_exn (Fmt.strf "\000%s\000%s" username password)
                in
                send ctx Value.Payload payload
            | x :: _ ->
            match Base64.decode x with
            | Ok x ->
                let payload =
                  Base64.encode_exn
                    (Fmt.strf "%s\000%s\000%s" x username password) in
                send ctx Value.Payload payload
            | Error _ ->
                Log.warn (fun m ->
                    m "The server send an invalid base64 value: %S" x) ;
                let payload =
                  Base64.encode_exn (Fmt.strf "\000%s\000%s" username password)
                in
                send ctx Value.Payload payload in
          recv ctx Value.Code >>= function
          | 235, _txts -> return `Authenticated
          | 501, _txts -> properly_quit_and_fail ctx `Authentication_rejected
          | 535, _txts -> properly_quit_and_fail ctx `Authentication_failed
          | code, txts -> fail (`Protocol (`Unexpected_response (code, txts))))
      | code -> fail (`Protocol (`Unexpected_response (code, txts))))

type domain = Domain.t

type reverse_path = Reverse_path.t

type forward_path = Forward_path.t

type authentication = {
  username : string;
  password : string;
  mechanism : Value.auth;
}

type mechanism = Value.auth = PLAIN

type ('a, 's) stream = unit -> ('a option, 's) io

type error =
  [ `Protocol of Value.error
  | `Unsupported_mechanism
  | `Encryption_required
  | `Weak_mechanism
  | `Authentication_rejected
  | `Authentication_failed
  | `Authentication_required ]

let pp_error ppf = function
  | `Protocol err -> Value.pp_error ppf err
  | `Unsupported_mechanism -> Fmt.pf ppf "Unsupported mechanism"
  | `Encryption_required -> Fmt.pf ppf "Encryption required"
  | `Weak_mechanism -> Fmt.pf ppf "Weak mechanism"
  | `Authentication_rejected -> Fmt.pf ppf "Authentication rejected"
  | `Authentication_failed -> Fmt.pf ppf "Authentication failed"
  | `Authentication_required -> Fmt.pf ppf "Authentication required"

let has_8bit_mime_transport_extension = List.exists (( = ) "8BITMIME")

let pp_status ppf = function
  | `Anonymous -> Fmt.string ppf "<anonymous>"
  | `Authenticated -> Fmt.string ppf "<authenticated>"

let m0 ctx ?authentication ~domain sender recipients =
  let open Monad in
  recv ctx Value.PP_220 >>= fun _txts ->
  let* txts = send ctx Value.Helo domain >>= fun () -> recv ctx Value.PP_250 in
  let has_8bit_mime_transport_extension =
    has_8bit_mime_transport_extension txts in
  Log.debug (fun m ->
      m "8BITMIME extension: %b" has_8bit_mime_transport_extension) ;
  (match authentication with
  | Some a -> auth ctx a.mechanism (Some (a.username, a.password))
  | None -> return `Anonymous)
  >>= fun status ->
  Log.debug (fun m -> m "Auth status: %a" pp_status status) ;
  let parameters =
    if has_8bit_mime_transport_extension
    then [ ("BODY", Some "8BITMIME") ]
    else [] in
  let* code, txts =
    send ctx Value.Mail_from (sender, parameters) >>= fun () ->
    recv ctx Value.Code in
  let rec go = function
    | [] ->
        send ctx Value.Data () >>= fun () ->
        recv ctx Value.TP_354 >>= fun _txts -> return ()
    | x :: r ->
        send ctx Value.Rcpt_to (x, []) >>= fun () ->
        recv ctx Value.PP_250 >>= fun _txts -> go r in
  match code with
  | 250 -> go recipients
  | 530 -> properly_quit_and_fail ctx `Authentication_required
  | _ -> fail (`Protocol (`Unexpected_response (code, txts)))

let m1 ctx =
  let open Monad in
  let* _txts = send ctx Value.Dot () >>= fun () -> recv ctx Value.PP_250 in
  let* _txts = send ctx Value.Quit () >>= fun () -> recv ctx Value.PP_221 in
  return ()

let sendmail ({ bind; return } as impl) rdwr flow context ?authentication
    ~domain sender recipients mail =
  let ( >>- ) = bind in
  let ( >>= ) x f =
    x >>- function Ok v -> f v | Error _ as err -> return err in

  let m0 = m0 context ~domain ?authentication sender recipients in
  run impl rdwr flow m0 >>= fun () ->
  (* assert that context is empty. *)
  let rec go = function
    | Some (buf, off, len) ->
        if len >= 1 && buf.[off] = '.'
        then
          rdwr.wr flow "." 0 1 >>- fun () ->
          rdwr.wr flow buf off len >>- mail >>- go
        else rdwr.wr flow buf off len >>- mail >>- go
    | None -> return () in
  Log.debug (fun m -> m "Start to send email") ;
  mail () >>- go >>- fun () ->
  let m1 = m1 context in
  run impl rdwr flow m1