seppo/lib/cookie.ml

(*
 *    _  _   ____                         _  
 *  _| || |_/ ___|  ___ _ __  _ __   ___ | | 
 * |_  ..  _\___ \ / _ \ '_ \| '_ \ / _ \| | 
 * |_      _|___) |  __/ |_) | |_) | (_) |_| 
 *   |_||_| |____/ \___| .__/| .__/ \___/(_) 
 *                     |_|   |_|             
 *
 * Personal Social Web.
 *
 * cookie.ml
 *
 * Copyright (C) The #Seppo contributors. All rights reserved.
 *
 * This program is free software: you can redistribute it and/or modify
 * it under the terms of the GNU General Public License as published by
 * the Free Software Foundation, either version 3 of the License, or
 * (at your option) any later version.
 *
 * This program is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 * GNU General Public License for more details.
 *
 * You should have received a copy of the GNU General Public License
 * along with this program.  If not, see <http://www.gnu.org/licenses/>.
 *)

open Astring

(* TODO maybe make compatible with Cohttp.Cookie *)

(* https://opam.ocaml.org/packages/http-cookie/
 * https://developer.mozilla.org/en-US/docs/Web/HTTP/Headers/Set-Cookie *)

(* figure out the session cookie / authentication *)
(* http://pleac.sourceforge.net/pleac_ocaml/cgiprogramming.html *)
(* https://github.com/aantron/dream/blob/master/src/server/cookie.ml *)
(* https://aantron.github.io/dream/#cookies *)
(* https://aantron.github.io/dream/#val-from_cookie
   and
   https://aantron.github.io/dream/#val-to_set_cookie
*)

(* encrypt & decrypt
   https://github.com/aantron/dream/blob/181175d3a9e12c145033728b98a091e38e8501f6/src/cipher/cipher.ml
   https://github.com/aantron/dream/blob/master/src/cipher/cipher.ml#L92
*)

(* https://tools.ietf.org/html/draft-ietf-httpbis-rfc6265bis-07#section-4.2.1 *)
let of_string s : Cohttp.Cookie.cookie list =
  let sep = Char.equal in
  (* https://github.com/aantron/dream/blob/master/src/pure/formats.ml#L32 *)
  s
  |> String.fields ~is_sep:(sep ';')
  |> List.map (String.fields ~is_sep:(sep '='))
  |> List.fold_left (fun pairs -> function
      | [] -> pairs
      | [name] -> (String.trim name, "") :: pairs
      | [name; value] -> (String.trim name, String.trim value) :: pairs
      | _ -> assert false) []

(* https://tools.ietf.org/html/draft-ietf-httpbis-rfc6265bis-07#section-4.2.1
 * https://github.com/aantron/dream/blob/master/src/pure/formats.ml#L51
 *
 * Cohttp seems to not set SameSite, so we maintain our own.
*)
let to_string ?expires ?max_age ?domain ?path ?secure ?http_only ?same_site
    ((name, value) : Cohttp.Cookie.cookie)  =
  (* MIT License, Copyright 2021 Anton Bachin, 2022 Marcus Rohrmoser
     https://github.com/aantron/dream/blob/master/src/pure/formats.ml#L51 *)
  let expires =
    (* empty = session cookie. RFC2616, RFC1123 *)
    match Option.bind expires Ptime.of_float_s with
    | None -> ""
    | Some time -> "; Expires=" ^ Http.to_rfc1123 time
  and max_age =
    (* supposed to replace expires? *)
    match max_age with
    | None -> ""
    | Some seconds -> Printf.sprintf "; Max-Age=%.0f" seconds
  and domain =
    match domain with
    | None -> ""
    | Some domain -> Printf.sprintf "; Domain=%s" domain
  and path =
    match path with
    | None -> ""
    | Some path -> Printf.sprintf "; Path=%s" path
  and secure = match secure with Some true -> "; Secure" | _ -> ""
  and http_only = match http_only with Some true -> "; HttpOnly" | _ -> ""
  and same_site =
    match same_site with
    | None -> ""
    | Some `Strict -> "; SameSite=Strict"
    | Some `Lax -> "; SameSite=Lax"
    | Some `None -> "; SameSite=None"
  in
  Printf.sprintf "%s=%s%s%s%s%s%s%s%s" name value expires max_age domain path
    secure http_only same_site

let l12 = 12

let random_nonce () =
  (* https://github.com/lemaetech/summer/blob/main/lib/summer.ml#L510-L520 *)
  Mirage_crypto_rng.generate l12

let encrypt sec nonce adata =
  (* https://github.com/lemaetech/summer/blob/main/lib/summer.ml#L510-L520 *)
  assert (32 = (sec |> Cstruct.length));
  assert (l12 = (nonce |> Cstruct.length));
  let key = sec |> Mirage_crypto.Chacha20.of_secret in
  adata
  |> Mirage_crypto.Chacha20.authenticate_encrypt ~key ~nonce
  |> Cstruct.append nonce
  |> Cstruct.to_string
  |> Base64.(encode_string ~pad:false ~alphabet:uri_safe_alphabet)

let decrypt sec noadata =
  try
    assert (32 = (sec |> Cstruct.length));
    (* https://github.com/lemaetech/summer/blob/main/lib/summer.ml#L510-L520 *)
    let noadata = noadata
                  |> Base64.(decode_exn ~pad:false ~alphabet:uri_safe_alphabet)
                  |> Cstruct.of_string
    and key = sec |> Mirage_crypto.Chacha20.of_secret
    and len = 12 in
    let nonce = Cstruct.sub noadata 0 len in
    Option.bind
      (Cstruct.sub noadata len (Cstruct.length noadata - len)
       |> Mirage_crypto.Chacha20.authenticate_decrypt ~key ~nonce)
      (fun v -> Some (Cstruct.to_string v))
  with
    Invalid_argument _ -> None