Commit d321af8c authored by Vlad Dumitru's avatar Vlad Dumitru
Browse files

use HTTP Basic Auth

parent f1f214eb
Pipeline #6042 passed with stages
in 2 minutes and 20 seconds
......@@ -43,9 +43,9 @@ let encode_version (hash, (info, branch_head)) =
; "info", encode_version_info info
]
let encode_version_listing : (Speechcake.Database.VS.Metadata.hash, (Speechcake.Database.VS.Metadata.t * string option)) Hashtbl.t encoder =
let encode_version_listing : (Speechcake.Database.VS.Metadata.hash * (Speechcake.Database.VS.Metadata.t * string option)) list encoder =
fun versions ->
Core.Hashtbl.to_alist versions
versions
|> Base.List.dedup_and_sort ~compare:(fun (_, (x, _)) (_, (y, _)) ->
let dx, dy = Speechcake.Database.VS.Metadata.(date x, date y) in
String.compare dx dy)
......@@ -160,7 +160,7 @@ let encode_tier_info : tier_info -> string * Yojson.Basic.t =
module D = Decoders_yojson.Safe.Decode
module D = Decoders_yojson.Basic.Decode
type 'a decoder = 'a D.decoder
......
......@@ -2,12 +2,106 @@ open Core
module C = Codec
module D = Decoders_yojson.Safe.Decode
module D = Decoders_yojson.Basic.Decode
module E = Decoders_yojson.Basic.Encode
module Role = struct
type t =
| Visitor (* read-only access to the "latest" branches *)
| Annotator of string (* read-only to "latest", read-write to own branches *)
| Maintainer (* read-write everything *)
let to_string = function
| Visitor -> "visitor"
| Annotator _ -> "annotator"
| Maintainer -> "maintainer"
let to_json t =
E.string (to_string t)
let of_string ~username = function
| "visitor" -> Some Visitor
| "annotator" -> Some (Annotator username)
| "maintainer" -> Some Maintainer
| _ -> None
let of_json ~username =
D.of_of_string ~msg:"role" (of_string ~username)
let read_access_filter = function
| Visitor -> Some [ "latest" ]
| Annotator name -> Some [ "latest"; name ]
| Maintainer -> None
let write_access_filter = function
| Visitor -> Some []
| Annotator name -> Some [ name ]
| Maintainer -> None
end
module Make_user (H : Digestif.S) = struct
type t =
{ username : string
; full_name : string
; password : H.t
; role : Role.t
}
let to_string { username; full_name; role; _ } =
Fmt.str "%s %s (%s)"
(Role.to_string role)
username
full_name
let hash_of_json =
D.of_of_string ~msg:"hash" (H.consistent_of_hex_opt)
let of_json =
let open Decoders_yojson.Basic.Decode in
let* username = field "username" string in
let* full_name = field "full_name" string in
let* password = field "password" hash_of_json in
let+ role = field "role" (Role.of_json ~username)
in
{ username; full_name; password; role }
let read_access_filter { role; _ }=
Role.read_access_filter role
let write_access_filter { role; _ } =
Role.write_access_filter role
end
module Make_user_list (H : Digestif.S) = struct
module User = Make_user (H)
type t = User.t list
let of_json =
D.list User.of_json
let authenticate t ~username:u ~password:p =
let p = H.digest_string p in
let match_username_password User.{ username=u'; password=p'; _ } =
String.equal u u' && H.equal p p'
in
List.find t ~f:match_username_password
end
module User_list = Make_user_list (Digestif.SHA256)
let init repo_path =
let string_of_error = function
| `Duplicate_key k -> "duplicate key " ^ k
| `Decoding_error (name, reason) -> Fmt.str "failed to decode %s: %s" name (Decoders_yojson.Basic.Decode.string_of_error reason)
| `Duplicate_key k ->
"duplicate key " ^ k
| `Decoding_error (name, reason) ->
Fmt.str "failed to decode %s: %s" name
(Decoders_yojson.Basic.Decode.string_of_error reason)
in
begin match Speechcake.load repo_path with
| Ok db -> db
......@@ -44,6 +138,11 @@ let get_tiers db ?prefix request =
|> Yojson.Safe.to_string in
Dream.json body
let filter_entries ~filter ~f xs =
match filter with
| None -> xs
| Some bs -> List.filter xs ~f:(fun x -> List.mem bs (f x) ~equal:String.equal)
let get_versions db request =
let uuid = Dream.param "uuid" request in
let versions = Action.versions ~db ~uuid in
......@@ -51,6 +150,7 @@ let get_versions db request =
| Ok versions ->
let body =
versions
|> Hashtbl.to_alist
|> C.encode_version_listing
|> Yojson.Safe.to_string in
Dream.json body
......@@ -101,7 +201,7 @@ let get_tier db request =
[ "key", `List (List.map doc.Speechcake.Document.key ~f:(fun part -> `String part))
; "uuid", `String uuid
; "tags", `List (List.map (Set.to_list doc.tags) ~f:(fun tag -> `String tag))
; "versions", C.encode_version_listing (Core.Hashtbl.of_alist_exn (module Speechcake.Database.VS.Metadata.Hash) branches)
; "versions", C.encode_version_listing branches
(*; "branches", `List (Base.List.map branches ~f:(fun (name, ptr) ->
`List [ `String name; `String (Speechcake.Database.VS.Metadata.string_of_hash ptr)]))*)
]
......@@ -408,14 +508,79 @@ let diff_tiers db request =
Dream.respond ~status:`Bad_Request (string_of_error e)
let authorization_header =
let open Angstrom in
let* kind = take_while Base.Char.is_alpha in
let* _ = skip_while Base.Char.is_whitespace in
let* value = take_while Base.Char.is_print in
match String.lowercase kind, Base64.decode value with
| "basic", Ok payload ->
let parts = Base.String.split ~on:':' payload in
begin match parts with
| [ username; password ] ->
return (username, password)
| username :: password_parts ->
return (username, Base.String.concat ~sep:":" password_parts)
| _ ->
fail "malformed Basic auth payload"
end
| _, Ok _ ->
fail "unsupported authorization method"
| _, Error (`Msg reason) ->
fail ("malformed authorization header: " ^ reason)
let require_header ~header request =
Dream.header header request
|> Base.Result.of_option ~error:(`Missing_header header)
let parse_basic_auth header =
Angstrom.parse_string ~consume:All authorization_header header
|> Base.Result.map_error ~f:(fun e -> `Parsing_error e)
let authenticated user_list inner_handler request =
let user_var =
Dream.new_local ~name:"user" ~show_value:User_list.User.to_string () in
let result =
let open Base.Result.Monad_infix in
require_header ~header:"authorization" request
>>= parse_basic_auth
>>= fun (username, password) ->
User_list.authenticate user_list ~username ~password
|> Base.Result.of_option ~error:(`Unauthorized)
in
match result with
| Ok user ->
Dream.with_local user_var user request |> inner_handler
| Error (`Missing_header _) ->
Dream.respond ~status:`Unauthorized
~headers:[ "www-authenticate", "Basic realm=\"Speechcake\"" ]
""
| Error (`Parsing_error e) ->
Dream.respond ~status:`Bad_Request e
| Error `Unauthorized ->
Dream.respond ~status:`Forbidden ""
let read_user_list () =
let result =
Decoders_yojson.Basic.Decode.decode_file User_list.of_json "users.json"
in
match result with
| Ok user_list -> user_list
| Error error -> failwith (Decoders_yojson.Basic.Decode.string_of_error error)
let run_server repo_path interface port =
let open Dream in
initialize_log ~level:`Debug () ;
let db = init repo_path in
let user_list = read_user_list () in
run ~interface ~port
@@ logger
@@ cors
@@ authenticated user_list
@@ router
[
(* webapp static files *)
......
......@@ -205,8 +205,6 @@ module Make (C : Contents.S) (S : Persistent_store.S) = struct
Error (`Unimplemented "cannot commit to a branch when none of the members of the merge are the head of the branch")
module Encode = struct
let tag_map_encoder (tags : (string, hash) Core.Hashtbl.t) =
let open Decoders_yojson.Basic.Encode in
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment