Merge pull request #13 from uzh/feature/82-extend-usage-of-context

Feature/82 extend usage of context

pool/app/contact/contact.mli

@@ -28,7 +28,7 @@ module NumberOfAssignments : sig
 end
 
 type t =
-  { user : Sihl_user.t
+  { user : Service.User.t
   ; recruitment_channel : RecruitmentChannel.t
   ; terms_accepted_at : Pool_user.TermsAccepted.t option
   ; language : Pool_common.Language.t option
@@ -76,6 +76,7 @@ val firstname : t -> Pool_user.Firstname.t
 val lastname : t -> Pool_user.Lastname.t
 val fullname : t -> string
 val email_address : t -> Pool_user.EmailAddress.t
+val sexp_of_t : t -> Sexplib0.Sexp.t
 val show : t -> string
 
 val find

pool/app/contact/dune

@@ -18,6 +18,7 @@
    ppx_deriving.enum
    ppx_deriving.eq
    ppx_deriving.show
+   ppx_sexp_conv
    ppx_variants_conv
    ppx_yojson_conv)))
 

pool/app/contact/entity.ml

@@ -1,11 +1,5 @@
 module User = Pool_user
 
-module Sihl_user = struct
-  include Sihl_user
-
-  let equal m k = CCString.equal m.id k.id
-end
-
 module RecruitmentChannel = struct
   let go m fmt _ = Format.pp_print_string fmt m
 
@@ -74,8 +68,8 @@ type t =
   ; paused_version : Pool_common.Version.t
   ; language_version : Pool_common.Version.t
   ; experiment_type_preference_version : Pool_common.Version.t
-  ; created_at : Ptime.t
-  ; updated_at : Ptime.t
+  ; created_at : Pool_common.Model.Ptime.t
+  ; updated_at : Pool_common.Model.Ptime.t
   }
 [@@deriving eq, show]
 
@@ -127,6 +121,10 @@ let firstname m = m.user |> User.user_firstname
 let lastname m = m.user |> User.user_lastname
 let email_address m = m.user.Sihl_user.email |> User.EmailAddress.of_string
 
+let sexp_of_t t =
+  t |> id |> Pool_common.Id.value |> fun s -> Sexplib0.Sexp.Atom s
+;;
+
 module Preview = struct
   type t =
     { user : Sihl_user.t

pool/app/contact/repo/repo_partial_update.ml

@@ -33,7 +33,7 @@ let partial_update pool (field : Entity.PartialUpdate.t) contact =
   let open PartialUpdate in
   match field with
   | Firstname (version, value) ->
-    let%lwt (_ : Entity.Sihl_user.t) =
+    let%lwt (_ : Sihl_user.t) =
       update_sihl_user
         pool
         ~firstname:(value |> Pool_user.Firstname.value)
@@ -48,7 +48,7 @@ let partial_update pool (field : Entity.PartialUpdate.t) contact =
         |sql} )
     |> update_user_table
   | Lastname (version, value) ->
-    let%lwt (_ : Entity.Sihl_user.t) =
+    let%lwt (_ : Sihl_user.t) =
       update_sihl_user
         pool
         ~lastname:(value |> Pool_user.Lastname.value)

pool/app/custom_field/entity.ml

@@ -168,10 +168,7 @@ module Validation = struct
   [@@deriving show, eq]
 
   module Ptime = struct
-    include Ptime
-
-    let t_of_yojson = Pool_common.Model.Ptime.t_of_yojson
-    let yojson_of_t = Pool_common.Model.Ptime.yojson_of_t
+    include Pool_common.Model.Ptime
   end
 
   module Text = struct

pool/app/email/entity.ml

@@ -2,12 +2,6 @@ module PoolError = Pool_common.Message
 module Database = Pool_database
 module User = Pool_user
 
-module Sihl_user = struct
-  include Sihl_user
-
-  let equal m k = CCString.equal m.id k.id
-end
-
 module Sihl_email = struct
   include Sihl_email
 

pool/app/pool_common/dune

@@ -1,7 +1,7 @@
 (library
  ; Cannot just be named as "common" because there is a module common in caqti-driver-mariadb
  (name pool_common)
- (libraries sihl utils)
+ (libraries service sihl utils)
  (preprocess
   (pps
    ppx_deriving.enum

pool/app/pool_common/entity.ml

@@ -58,7 +58,7 @@ module Language = struct
 end
 
 module Version = struct
-  type t = int [@@deriving eq, show, yojson]
+  type t = int [@@deriving eq, show, yojson, sexp_of]
 
   let value m = m
   let create () = 0

pool/app/pool_common/entity_i18n.ml

@@ -57,6 +57,7 @@ type nav_link =
   | Invitations
   | Locations
   | LoginInformation
+  | Login
   | Logout
   | Mailings
   | Overview

pool/app/pool_common/locales/i18n_de.ml

@@ -83,6 +83,7 @@ let nav_link_to_string = function
   | Invitations -> "Einladungen"
   | Locations -> "Standorte"
   | LoginInformation -> "Anmeldeinformationen"
+  | Login -> "Login"
   | Logout -> "Logout"
   | Mailings -> "Versand"
   | Overview -> "Übersicht"

pool/app/pool_common/locales/i18n_en.ml

@@ -75,6 +75,7 @@ let nav_link_to_string = function
   | I18n -> "Translations"
   | Invitations -> "Invitations"
   | LoginInformation -> "Login information"
+  | Login -> "Login"
   | Locations -> "Locations"
   | Logout -> "Logout"
   | Mailings -> "Mailings"

pool/app/pool_common/pool_common.mli

@@ -224,6 +224,7 @@ module Version : sig
 
   val equal : t -> t -> bool
   val pp : Format.formatter -> t -> unit
+  val sexp_of_t : t -> Ppx_sexp_conv_lib.Sexp.t
   val show : t -> string
   val value : t -> int
   val create : unit -> t

pool/app/pool_context/dune

@@ -1,5 +1,10 @@
 (library
  (name pool_context)
- (libraries pool_common pool_database pool_tenant sihl utils)
+ (libraries admin contact pool_common pool_database pool_tenant sihl utils)
  (preprocess
-  (pps lwt_ppx ppx_deriving.eq ppx_deriving.show ppx_sexp_conv)))
+  (pps
+   lwt_ppx
+   ppx_deriving.eq
+   ppx_deriving.show
+   ppx_sexp_conv
+   ppx_variants_conv)))

pool/app/pool_context/entity.ml

@@ -1,17 +1,26 @@
 module PoolError = Pool_common.Message
 open Sexplib.Conv
 
+(* TODO: Service.User.t for Admin and Root are placeholders and should be
+   replaced, when guadrian is implemented *)
+type user =
+  | Admin of Service.User.t
+  | Contact of Contact.t
+  | Root of Service.User.t
+[@@deriving eq, sexp_of, variants]
+
 type t =
   { query_language : Pool_common.Language.t option
   ; language : Pool_common.Language.t
   ; tenant_db : Pool_database.Label.t
   ; message : PoolError.Collection.t option
   ; csrf : string
+  ; user : user option
   }
 [@@deriving sexp_of]
 
-let create (query_language, language, tenant_db, message, csrf) =
-  { query_language; language; tenant_db; message; csrf }
+let create (query_language, language, tenant_db, message, csrf, user) =
+  { query_language; language; tenant_db; message; csrf; user }
 ;;
 
 let find_context key req =
@@ -40,6 +49,13 @@ let find_exn req =
 
 let set = set_context key
 
+let find_contact { user; _ } =
+  match user with
+  | Some (Contact c) -> Ok c
+  | None | Some (Admin _) | Some (Root _) ->
+    Error PoolError.(NotFound Field.User)
+;;
+
 module Tenant = struct
   type t =
     { tenant : Pool_tenant.t
@@ -55,4 +71,9 @@ module Tenant = struct
 
   let find = find_context key
   let set = set_context key
+
+  let get_tenant_languages req =
+    let open CCResult in
+    req |> find >|= fun c -> c.tenant_languages
+  ;;
 end

pool/app/pool_context/pool_context.mli

@@ -1,9 +1,19 @@
+type user =
+  | Admin of Service.User.t
+  | Contact of Contact.t
+  | Root of Service.User.t
+
+val admin : Service.User.t -> user
+val contact : Contact.t -> user
+val root : Service.User.t -> user
+
 type t =
   { query_language : Pool_common.Language.t option
   ; language : Pool_common.Language.t
   ; tenant_db : Pool_tenant.Database.Label.t
   ; message : Pool_common.Message.Collection.t option
   ; csrf : string
+  ; user : user option
   }
 
 val create
@@ -12,11 +22,13 @@ val create
      * Pool_tenant.Database.Label.t
      * Pool_common.Message.Collection.t option
      * string
+     * user option
   -> t
 
 val find : Rock.Request.t -> (t, Pool_common.Message.error) result
 val find_exn : Rock.Request.t -> t
 val set : Rock.Request.t -> t -> Rock.Request.t
+val find_contact : t -> (Contact.t, Pool_common.Message.error) result
 
 module Tenant : sig
   type t =
@@ -28,4 +40,8 @@ module Tenant : sig
   val key : t Rock.Context.key
   val find : Rock.Request.t -> (t, Pool_common.Message.error) result
   val set : Rock.Request.t -> t -> Rock.Request.t
+
+  val get_tenant_languages
+    :  Rock.Request.t
+    -> (Pool_common.Language.t list, Pool_common.Message.error) result
 end

pool/routes/routes.ml

@@ -125,7 +125,7 @@ module Admin = struct
   let middlewares =
     [ CustomMiddleware.Context.context `Admin ()
     ; CustomMiddleware.Tenant.valid_tenant ()
-    ; CustomMiddleware.Admin.require_admin ~login_path_f:(fun () -> "/login")
+    ; CustomMiddleware.Admin.require_admin ()
     ]
   ;;
 
@@ -320,13 +320,13 @@ end
 module Root = struct
   let middlewares =
     [ CustomMiddleware.Root.from_root_only ()
-    ; CustomMiddleware.Context.context `Root ()
+    ; CustomMiddleware.Context.context `Admin ()
     ]
   ;;
 
   let public_routes =
     let open Handler.Root in
-    [ get "" (forward_to_entrypoint "/root/tenants")
+    [ get "" (forward_to_entrypoint "/root/login")
     ; get "/login" Login.login_get
     ; post "/login" Login.login_post
     ; get "/logout" Login.logout
@@ -337,10 +337,7 @@ module Root = struct
     ]
   ;;
 
-  let locked_middlewares =
-    [ CustomMiddleware.Root.require_root ~login_path_f:(fun () -> "/root/login")
-    ]
-  ;;
+  let locked_middlewares = [ CustomMiddleware.Root.require_root () ]
 
   let locked_routes =
     let open Pool_common.Message.Field in

pool/service/service.ml

@@ -1,7 +1,14 @@
 (* Put infrastructure service setup here. This is where you decide which service
    implementation to use. *)
 module Migration = Sihl.Database.Migration.MariaDb
-module User = Sihl_user.MariaDb
+
+module User = struct
+  include Sihl_user.MariaDb
+  include Sihl_user
+
+  let sexp_of_t t = t.id |> fun s -> Sexplib0.Sexp.Atom s
+end
+
 module Token = Sihl_token.MariaDb
 module PasswordReset = Sihl_user.Password_reset.MakeMariaDb (Token)
 module EmailTemplate = Sihl_email.Template.MariaDb

pool/web/handler/admin_admins.ml

@@ -1,7 +1,7 @@
 module HttpUtils = Http_utils
 module Message = HttpUtils.Message
 
-let create_layout req = General.create_tenant_layout `Admin req
+let create_layout req = General.create_tenant_layout req
 
 let index req =
   let open Utils.Lwt_result.Infix in

pool/web/handler/admin_contacts.ml

@@ -1,7 +1,7 @@
 module HttpUtils = Http_utils
 module Message = HttpUtils.Message
 
-let create_layout req = General.create_tenant_layout `Admin req
+let create_layout req = General.create_tenant_layout req
 
 let index req =
   let open Utils.Lwt_result.Infix in
@@ -35,9 +35,7 @@ let detail_view action req =
     | `Edit ->
       let user_update_csrf = Htmx.user_update_csrf in
       let* tenant_languages =
-        Pool_context.Tenant.find req
-        |> Lwt_result.lift
-        >|= fun c -> c.Pool_context.Tenant.tenant_languages
+        Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift
       in
       let%lwt custom_fields =
         Custom_field.find_all_by_contact

pool/web/handler/admin_custom_field_groups.ml

@@ -2,7 +2,7 @@ module HttpUtils = Http_utils
 module Message = Pool_common.Message
 module Url = Page.Admin.CustomFields.Url
 
-let create_layout req = General.create_tenant_layout `Admin req
+let create_layout req = General.create_tenant_layout req
 
 let get_group_id req =
   HttpUtils.get_field_router_param req Message.Field.CustomFieldGroup

pool/web/handler/admin_custom_field_options.ml

@@ -2,7 +2,7 @@ module HttpUtils = Http_utils
 module Message = HttpUtils.Message
 module Url = Page.Admin.CustomFields.Url
 
-let create_layout req = General.create_tenant_layout `Admin req
+let create_layout req = General.create_tenant_layout req
 
 let get_option_id req =
   HttpUtils.get_field_router_param
@@ -44,7 +44,10 @@ let form ?id req custom_field =
          |> CCOption.map_or ~default:(Lwt_result.return None) (fun id ->
               Custom_field.find_option tenant_db id >|= CCOption.pure)
        in
-       let%lwt sys_languages = Settings.find_languages tenant_db in
+       let* custom_field = req |> get_field_id |> Custom_field.find tenant_db in
+       let* sys_languages =
+         Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift
+       in
        let flash_fetcher key = Sihl.Web.Flash.find key req in
        Page.Admin.CustomFieldOptions.detail
          ?custom_field_option
@@ -91,7 +94,9 @@ let write ?id req custom_field =
       err, error_path, [ HttpUtils.urlencoded_to_flash urlencoded ])
     @@
     let events =
-      let%lwt sys_languages = Settings.find_languages tenant_db in
+      let* sys_languages =
+        Pool_context.Tenant.get_tenant_languages req |> Lwt_result.lift
+      in
       match id with
       | None ->
         Cqrs_command.Custom_field_option_command.Create.handle