Feature/credits page (#177)

* fix login attempt email encoding

* add credits page

* only show privacy policy when filled out

* pass system event identifier and generalize cache

* update changelog

* remove log

* pass identifier to handle_system_event

* reset .env.samle

* fix changelog

---------

Co-authored-by: Timo Huber <[email protected]>

CHANGELOG.md

@@ -7,11 +7,16 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/) and this p
 ### Added
 
 - readonly admin comment on contacts
+- credits and privacy policy pages
 
 ### Changed
 
 - log failed login attempt as warning
 
+### Fixed
+
+- blocking of email addresses after too many failed login attempts
+
 ## [0.3.3](https://github.com/uzh/pool/tree/0.3.3) - 2023-08-02
 
 ### Added

pool/app/i18n/default.ml

@@ -34,6 +34,9 @@ let default_values =
         , "Das Passwort muss mindestens 8 Zeichen lang sein, eine Zahl, ein \
            Grossbuchstabe und ein Sonderzeichen enthalten." )
       ] )
+  ; ( "privacy_policy"
+    , [ "EN", "<h1>Privacy policy</h1>"; "DE", "<h1>Datenschutzerklärung</h1>" ]
+    )
   ]
   |> CCList.map (fun (key, data) ->
     let key = key |> Key.create |> get_or_failwith in

pool/app/i18n/entity.ml

@@ -12,6 +12,7 @@ module Key = struct
       | GreetingsText [@name "greetings_text"] [@printer print "greetings_text"]
       | PasswordPolicyText [@name "password_policy_text"]
           [@printer print "password_policy_text"]
+      | PrivacyPolicy [@name "privacy_policy"] [@printer print "privacy_policy"]
       | WelcomeText [@name "welcome_text"] [@printer print "welcome_text"]
     [@@deriving enum, eq, ord, sexp_of, show { with_path = false }, yojson]
   end
@@ -20,7 +21,7 @@ module Key = struct
   include Core
 
   let is_rich_text = function
-    | CreditsText | GreetingsText | WelcomeText -> true
+    | CreditsText | GreetingsText | PrivacyPolicy | WelcomeText -> true
     | PasswordPolicyText -> false
   ;;
 end

pool/app/i18n/i18n.ml

@@ -4,5 +4,39 @@ include Default
 module Guard = Entity_guard
 
 let find = Repo.find
+let find_with_default_content = Repo.find_with_default_content
 let find_by_key = Repo.find_by_key
+let find_by_key_opt = Repo.find_by_key_opt
 let find_all = Repo.find_all
+
+module I18nPageCache = struct
+  open Hashtbl
+
+  let tbl
+    : ( Pool_tenant.Database.Label.t * Entity.Key.t * Pool_common.Language.t
+    , bool ) t
+    =
+    create 5
+  ;;
+
+  let find = find_opt tbl
+
+  let add database_label key language value =
+    replace tbl (database_label, key, language) value
+  ;;
+
+  let clear () = clear tbl
+end
+
+let i18n_is_set database_label language key =
+  let open Utils.Lwt_result.Infix in
+  I18nPageCache.find (database_label, key, language)
+  |> function
+  | Some bool -> Lwt.return bool
+  | None ->
+    let%lwt existing =
+      find_by_key_opt database_label key language ||> CCOption.is_some
+    in
+    let () = I18nPageCache.add database_label key language existing in
+    Lwt.return existing
+;;

pool/app/i18n/i18n.mli

@@ -3,6 +3,7 @@ module Key : sig
     | CreditsText
     | GreetingsText
     | PasswordPolicyText
+    | PrivacyPolicy
     | WelcomeText
 
   val create : string -> (t, Pool_common.Message.error) result
@@ -54,14 +55,35 @@ val show_event : event -> string
 val handle_event : Pool_database.Label.t -> event -> unit Lwt.t
 val find : Pool_database.Label.t -> Pool_common.Id.t -> t Lwt.t
 
+val find_with_default_content
+  :  Pool_database.Label.t
+  -> Pool_common.Id.t
+  -> t Lwt.t
+
 val find_by_key
   :  Pool_database.Label.t
   -> Key.t
   -> Pool_common.Language.t
   -> t Lwt.t
 
+val find_by_key_opt
+  :  Pool_database.Label.t
+  -> Key.t
+  -> Pool_common.Language.t
+  -> t option Lwt.t
+
 val find_all : Pool_database.Label.t -> unit -> t list Lwt.t
 
+module I18nPageCache : sig
+  val clear : unit -> unit
+end
+
+val i18n_is_set
+  :  Pool_database.Label.t
+  -> Pool_common.Language.t
+  -> Key.t
+  -> bool Lwt.t
+
 module Guard : sig
   module Target : sig
     val to_authorizable

pool/app/i18n/repo/repo.ml

@@ -34,10 +34,25 @@ module Sql = struct
     Utils.Database.find (Pool_database.Label.value pool) find_request
   ;;
 
+  let find_with_default_content_request =
+    let open Caqti_request.Infix in
+    {sql|
+      WHERE uuid = UNHEX(REPLACE(?, '-', ''))
+    |sql}
+    |> select_from_i18n_sql
+    |> Pool_common.Repo.Id.t ->! RepoEntity.t_with_default_content
+  ;;
+
+  let find_with_default_content pool =
+    Utils.Database.find
+      (Pool_database.Label.value pool)
+      find_with_default_content_request
+  ;;
+
   let find_by_key_request =
     let open Caqti_request.Infix in
     {sql|
-      WHERE i18n_key = ? AND language = ?
+      WHERE i18n_key = ? AND language = ? AND content IS NOT NULL AND content != ''
     |sql}
     |> select_from_i18n_sql
     |> Caqti_type.(tup2 RepoEntity.Key.t Pool_common.Repo.Language.t)
@@ -51,9 +66,18 @@ module Sql = struct
       (key, language)
   ;;
 
+  let find_by_key_opt pool key language =
+    Utils.Database.find_opt
+      (Pool_database.Label.value pool)
+      find_by_key_request
+      (key, language)
+  ;;
+
   let find_all_request =
     let open Caqti_request.Infix in
-    "" |> select_from_i18n_sql |> Caqti_type.unit ->* RepoEntity.t
+    ""
+    |> select_from_i18n_sql
+    |> Caqti_type.unit ->* RepoEntity.t_with_default_content
   ;;
 
   let find_all pool =
@@ -118,7 +142,9 @@ module Sql = struct
 end
 
 let find = Sql.find
+let find_with_default_content = Sql.find_with_default_content
 let find_by_key = Sql.find_by_key
+let find_by_key_opt = Sql.find_by_key_opt
 let find_all = Sql.find_all
 let insert = Sql.insert
 let update = Sql.update

pool/app/i18n/repo/repo_entity.ml

@@ -21,3 +21,19 @@ let t =
          Common.Repo.Id.t
          (tup2 Key.t (tup2 Common.Repo.Language.t Content.t))))
 ;;
+
+let t_with_default_content =
+  let encode _ = failwith "Decode model only." in
+  let decode (id, (key, (language, content))) =
+    let open CCResult in
+    let content = CCOption.value ~default:"" content |> Content.of_string in
+    Ok { id; key; language; content }
+  in
+  Caqti_type.(
+    custom
+      ~encode
+      ~decode
+      (tup2
+         Common.Repo.Id.t
+         (tup2 Key.t (tup2 Common.Repo.Language.t (option string)))))
+;;

pool/app/pool_common/entity_i18n.ml

@@ -82,6 +82,7 @@ type nav_link =
   | Assignments
   | ContactInformation
   | Contacts
+  | Credits
   | CustomFields
   | Dashboard
   | Experiments
@@ -99,6 +100,7 @@ type nav_link =
   | Overview
   | ParticipationTags
   | PersonalDetails
+  | PrivacyPolicy
   | Profile
   | Queue
   | Rules

pool/app/pool_common/locales/i18n_de.ml

@@ -121,6 +121,7 @@ let nav_link_to_string = function
   | Assignments -> "Anmeldungen"
   | ContactInformation -> "Kontaktangaben"
   | Contacts -> "Kontakte"
+  | Credits -> "Impressum"
   | CustomFields -> "Felder"
   | Dashboard -> "Dashboard"
   | Experiments -> "Experimente"
@@ -138,6 +139,7 @@ let nav_link_to_string = function
   | Overview -> "Übersicht"
   | ParticipationTags -> "Teilnahmetags"
   | PersonalDetails -> "Persönliche Angaben"
+  | PrivacyPolicy -> "Datenschutzerklärung"
   | Profile -> "Profil"
   | Queue -> "Hintergrundjobs"
   | Rules -> "Regeln"

pool/app/pool_common/locales/i18n_en.ml

@@ -119,6 +119,7 @@ let nav_link_to_string = function
   | Assignments -> "Assignments"
   | ContactInformation -> "Contact information"
   | Contacts -> "Contacts"
+  | Credits -> "Credits"
   | CustomFields -> "Fields"
   | Dashboard -> "Dashboard"
   | Experiments -> "Experiments"
@@ -136,6 +137,7 @@ let nav_link_to_string = function
   | Overview -> "Overview"
   | ParticipationTags -> "Participation tags"
   | PersonalDetails -> "Personal details"
+  | PrivacyPolicy -> "Privacy policy"
   | Profile -> "Profile"
   | Queue -> "Queued jobs"
   | Rules -> "Rules"

pool/app/pool_user/pool_user.mli

@@ -246,24 +246,20 @@ module FailedLoginAttempt : sig
 
   type t =
     { id : Id.t
-    ; email : Entity.EmailAddress.t
+    ; email : EmailAddress.t
     ; counter : Counter.t
     ; blocked_until : BlockedUntil.t option
     }
 
   val create
     :  ?id:Id.t
-    -> Entity.EmailAddress.t
+    -> EmailAddress.t
     -> Counter.t
     -> BlockedUntil.t option
     -> t
 
   module Repo : sig
-    val find_opt
-      :  Pool_database.Label.t
-      -> Entity.EmailAddress.t
-      -> t option Lwt.t
-
+    val find_opt : Pool_database.Label.t -> EmailAddress.t -> t option Lwt.t
     val insert : Pool_database.Label.t -> t -> unit Lwt.t
     val delete : Pool_database.Label.t -> t -> unit Lwt.t
   end

pool/app/system_event/entity.ml

@@ -8,6 +8,8 @@ module Job = struct
   type t =
     | GuardianCacheCleared [@name "guardiancachecleared"]
         [@printer Utils.ppx_printer "guardiancachecleared"]
+    | I18nPageUpdated [@name "i18npageupdated"]
+        [@printer Utils.ppx_printer "i18npageupdated"]
     | SmtpAccountUpdated [@name "smtpaccountupdated"]
         [@printer Utils.ppx_printer "smtpaccountupdated"]
     | TenantDatabaseAdded of Pool_database.Label.t [@name "tenantdatabaseadded"]
@@ -53,11 +55,11 @@ module EventLog = struct
     let field = Pool_common.Message.Field.Host
     let schema () = schema field ()
 
-    let get () =
-      Format.asprintf
-        "%s-%s"
-        (Unix.gethostname ())
-        (() |> Unix.getpid |> CCInt.to_string)
+    let get ?identifier () =
+      let hostname = Unix.gethostname () in
+      match identifier with
+      | None -> hostname
+      | Some id -> Format.asprintf "%s-%s" hostname id
     ;;
   end
 

pool/app/system_event/event.ml

@@ -7,12 +7,16 @@ let handle_event : event -> unit Lwt.t = function
   | Created t -> Repo.insert Pool_database.root t
 ;;
 
-let handle_system_event system_event =
+let handle_system_event ?identifier system_event =
   let open Utils.Lwt_result.Infix in
   let open EventLog in
   let pool = Pool_database.root in
   let create_event_log ?message status =
-    create ?message system_event.id (ServiceIdentifier.get ()) status
+    create
+      ?message
+      system_event.id
+      (ServiceIdentifier.get ?identifier ())
+      status
     |> Repo.EventLog.insert pool
   in
   let success_log () = create_event_log Status.Successful in
@@ -31,6 +35,9 @@ let handle_system_event system_event =
   | GuardianCacheCleared ->
     let () = Guard.Persistence.Cache.clear () in
     success_log ()
+  | I18nPageUpdated ->
+    let () = I18n.I18nPageCache.clear () in
+    success_log ()
   | SmtpAccountUpdated ->
     let () = Email.Service.Cache.clear () in
     success_log ()

pool/app/system_event/service.ml

@@ -3,21 +3,21 @@ open Entity
 let src = Logs.Src.create "system_event.service"
 let get_or_failwith = Pool_common.Utils.get_or_failwith
 
-let run () =
+let run ?identifier () =
   let open Utils.Lwt_result.Infix in
   ()
-  |> EventLog.ServiceIdentifier.get
+  |> EventLog.ServiceIdentifier.get ?identifier
   |> Repo.find_pending
-  >|> Lwt_list.iter_s Event.handle_system_event
+  >|> Lwt_list.iter_s (Event.handle_system_event ?identifier)
 ;;
 
-let start_handler () =
+let start_handler ?identifier () =
   let open Schedule in
   let interval = Ptime.Span.of_int_s 10 in
   let periodic_fcn () =
     Logs.debug ~src (fun m ->
       m ~tags:Pool_database.(Logger.Tags.create root) "Run");
-    run ()
+    run ?identifier ()
   in
   create
     "system_events"
@@ -57,22 +57,24 @@ let schema =
     config
 ;;
 
-let start () =
+let start ?identifier () =
   Sihl.Configuration.require schema;
-  if read_bool Run then start_handler () else Lwt.return_unit
+  if read_bool Run then start_handler ?identifier () else Lwt.return_unit
 ;;
 
 let stop () = Lwt.return_unit
 
-let lifecycle =
+let lifecycle ?identifier () =
   Sihl.Container.create_lifecycle
     "System events"
     ~dependencies:(fun () -> [ Schedule.lifecycle ])
-    ~start
+    ~start:(start ?identifier)
     ~stop
 ;;
 
-let register () =
+let register ?identifier () =
   let configuration = Sihl.Configuration.make ~schema () in
-  Sihl.Container.Service.create ~configuration lifecycle
+  Sihl.Container.Service.create ~configuration (lifecycle ?identifier ())
 ;;
+
+let register_worker = register ~identifier:"worker"