add /admin

src/app.ml

@@ -45,8 +45,8 @@ let () = Dream.log "open_registration: %b" open_registration
 let port =
   match Scfg.Query.get_dir "port" config with
   | None -> 8080
-  | Some open_registration -> (
+  | Some port -> (
-    match Scfg.Query.get_param 0 open_registration with
+    match Scfg.Query.get_param 0 port with
     | Error e -> failwith e
     | Ok n -> (
       try
@@ -61,11 +61,18 @@ let () = Dream.log "port: %d" port
 let log =
   match Scfg.Query.get_dir "log" config with
   | None -> true
-  | Some open_registration -> (
+  | Some log -> (
-    match Scfg.Query.get_param 0 open_registration with
+    match Scfg.Query.get_param 0 log with
     | Error e -> failwith e
     | Ok "true" -> true
     | Ok "false" -> false
     | Ok _unknown -> failwith "invalid `log` value in configuration file" )
 
 let () = Dream.log "log: %b" log
+
+let admins =
+  let dirs = Scfg.Query.get_dirs "admin" config in
+  List.map
+    (fun dir ->
+      Result.fold ~error:failwith ~ok:Fun.id (Scfg.Query.get_param 0 dir) )
+    dirs

src/babillard.ml

@@ -98,11 +98,19 @@ module Q = struct
        ON DELETE CASCADE, FOREIGN KEY(nick) REFERENCES user(nick) ON DELETE \
        CASCADE);"
 
-  let upload_report_post =
+  let upload_report =
     Caqti_request.exec
       Caqti_type.(tup4 string string float string)
       "INSERT INTO report VALUES (?,?,?,?);"
 
+  let ignore_report =
+    Caqti_request.exec Caqti_type.string "DELETE FROM report WHERE post_id=?;"
+
+  let get_reports =
+    Caqti_request.collect Caqti_type.unit
+      Caqti_type.(tup4 string string float string)
+      "SELECT * FROM report;"
+
   let upload_post_id =
     Caqti_request.exec
       Caqti_type.(tup2 string string)
@@ -468,7 +476,7 @@ let get_ops ids = unwrap_list get_op ids
 
 let try_delete_post ~nick id =
   let* post = get_post id in
-  if post.nick = nick then
+  if post.nick = nick || User.is_admin nick then
     let^ () = Db.exec Q.delete_post id in
     Ok ()
   else Error "You can only delete your posts"
@@ -479,5 +487,16 @@ let report ~nick ~reason id =
   else
     let reason = Dream.html_escape reason in
     let date = Unix.time () in
-    let^ () = Db.exec Q.upload_report_post (nick, reason, date, id) in
+    let^ () = Db.exec Q.upload_report (nick, reason, date, id) in
     Ok ()
+
+let ignore_report id =
+  let^ () = Db.exec Q.ignore_report id in
+  Ok ()
+
+let get_reports () =
+  let^ reports = Db.collect_list Q.get_reports () in
+  let* posts =
+    unwrap_list (fun (_nick, _reason, _date, id) -> get_post id) reports
+  in
+  Ok (posts, reports)

src/permap.ml

@@ -64,6 +64,53 @@ let login_post request =
   | `Wrong_session _ | `Expired _ | `Wrong_content_type ->
     Dream.empty `Bad_Request
 
+let admin_get request =
+  match Dream.session "nick" request with
+  | None ->
+    let redirect_url =
+      Format.sprintf "/login?redirect=%s" (Dream.to_percent_encoded "/admin")
+    in
+    Dream.respond ~status:`See_Other ~headers:[ ("Location", redirect_url) ] ""
+  | Some nick ->
+    if not (User.is_admin nick) then Dream.respond ~status:`Forbidden ""
+    else
+      let res =
+        match Babillard.get_reports () with
+        | Error e -> e
+        | Ok (posts, reports) ->
+          Pp_babillard.admin_page_content posts reports request
+      in
+      render_unsafe res request
+
+let admin_post request =
+  match Dream.session "nick" request with
+  | None -> render_unsafe "Not logged in" request
+  | Some nick -> (
+    if not (User.is_admin nick) then Dream.respond ~status:`Forbidden ""
+    else
+      match%lwt Dream.form request with
+      | `Ok [ ("action", action); ("post_id", id) ] -> (
+        let res =
+          match Babillard.get_post id with
+          | Error _e as e -> e
+          | Ok post -> (
+            let evil_nick = post.nick in
+            match action with
+            | "delete" -> Babillard.try_delete_post ~nick id
+            | "banish" -> User.banish evil_nick
+            | "ignore" -> Babillard.ignore_report id
+            | a -> Error (Format.sprintf "invalid action: `%s`" a) )
+        in
+        match res with
+        | Error e -> render_unsafe e request
+        | Ok () ->
+          Dream.respond ~status:`See_Other
+            ~headers:[ ("Location", "/admin") ]
+            "" )
+      | `Ok _ | `Expired _ | `Many_tokens _ | `Missing_token _
+      | `Invalid_token _ | `Wrong_session _ | `Wrong_content_type ->
+        Dream.empty `Bad_Request )
+
 let catalog request =
   let catalog_content =
     Result.fold ~ok:Fun.id ~error:Fun.id (Pp_babillard.catalog_content ())
@@ -139,8 +186,10 @@ let profile_get request =
   match Dream.session "nick" request with
   | None -> render_unsafe "Not logged in" request
   | Some nick ->
-    let bio = match User.get_bio nick with Ok bio -> bio | Error e -> e in
+    if User.exist nick then
-    render_unsafe (User_profile.f nick bio request) request
+      let bio = match User.get_bio nick with Ok bio -> bio | Error e -> e in
+      render_unsafe (User_profile.f nick bio request) request
+    else Dream.respond ~status:`Not_Found "User does not exists"
 
 let profile_post request =
   match Dream.session "nick" request with
@@ -304,6 +353,8 @@ let routes =
   [ get_ "/" babillard_get
   ; post "/" babillard_post
   ; get_ "/about" about
+  ; get_ "/admin" admin_get
+  ; post "/admin" admin_post
   ; get_ "/assets/**" (Dream.static ~loader:asset_loader "")
   ; get_ "/catalog" catalog
   ; get_ "/delete/:post_id" delete_get

src/pp_babillard.ml

@@ -159,6 +159,55 @@ let catalog_content () =
        (Format.pp_print_list ~pp_sep:Format.pp_print_space pp_thread_preview)
        ops )
 
+let pp_report fmt post report request =
+  let url = "/admin" in
+  let nick, reason, _date, id = report in
+  let input_post_id fmt id =
+    Format.fprintf fmt
+      {|<input value="%s" name="post_id" type="hidden"></input>|} id
+  in
+  let button fmt value =
+    Format.fprintf fmt
+      {|<button value="%s" name="action" type="submit" class="btn btn-primary">%s</button>|}
+      value
+      (String.uppercase_ascii value)
+  in
+  let form fmt value =
+    Format.fprintf fmt {|%s %a %a </form>|}
+      (Dream.form_tag ~action:url request)
+      input_post_id id button value
+  in
+
+  Format.fprintf fmt
+    {|
+<div class="report">
+    <div class="row mb-3">
+        <div class="col-md-6">
+            %a
+        </div>
+        <div class="col-md-6">
+            <span> From: %s Reason: %s</span>
+            <div>
+                %a
+                </form><br>
+                %a
+                </form><br>
+                %a
+                </form><br>
+            </div>
+        </div>
+    </div>
+</div><br>
+|}
+    pp_post (Post post) nick reason form "ignore" form "delete" form "banish"
+
+let admin_page_content posts reports request =
+  let posts_reports = List.combine posts reports in
+  Format.asprintf "%a"
+    (Format.pp_print_list ~pp_sep:Format.pp_print_space
+       (fun fmt (post, report) -> pp_report fmt post report request) )
+    posts_reports
+
 let pp_thread fmt op posts =
   let thread_data, _post = op in
   (*order by date *)

src/user.ml

@@ -15,11 +15,6 @@ module Q = struct
       "CREATE TABLE IF NOT EXISTS user (nick TEXT, password TEXT, email TEXT, \
        bio TEXT, avatar BLOB, PRIMARY KEY(nick));"
 
-  let create_plant_user_table =
-    Caqti_request.exec Caqti_type.unit
-      "CREATE TABLE IF NOT EXISTS plant_user (plant_id TEXT, nick TEXT, \
-       PRIMARY KEY(plant_id), FOREIGN KEY(nick) REFERENCES user(nick));"
-
   let get_password =
     Caqti_request.find_opt Caqti_type.string Caqti_type.string
       "SELECT password FROM user WHERE nick=?;"
@@ -53,6 +48,10 @@ module Q = struct
     Caqti_request.find_opt Caqti_type.string Caqti_type.string
       "SELECT bio FROM user WHERE nick=?;"
 
+  let get_email =
+    Caqti_request.find_opt Caqti_type.string Caqti_type.string
+      "SELECT email FROM user WHERE nick=?;"
+
   let get_avatar =
     Caqti_request.find_opt Caqti_type.string Caqti_type.string
       "SELECT avatar FROM user WHERE nick=?;"
@@ -61,10 +60,27 @@ module Q = struct
     Caqti_request.exec
       Caqti_type.(tup2 string string)
       "UPDATE user SET avatar=? WHERE nick=?;"
+
+  let create_banished_table =
+    Caqti_request.exec Caqti_type.unit
+      "CREATE TABLE IF NOT EXISTS banished (nick TEXT, email TEXT);"
+
+  let delete_user =
+    Caqti_request.exec Caqti_type.string "DELETE FROM user WHERE nick=?;"
+
+  let upload_banished =
+    Caqti_request.exec
+      Caqti_type.(tup2 string string)
+      "INSERT INTO banished VALUES (?,?);"
+
+  let get_banished =
+    Caqti_request.find Caqti_type.string
+      Caqti_type.(tup2 string string)
+      "SELECT * FROM banished WHERE nick=?;"
 end
 
 let () =
-  let tables = [ Q.create_user_table ] in
+  let tables = [ Q.create_user_table; Q.create_banished_table ] in
   if
     List.exists Result.is_error
       (List.map (fun query -> Db.exec query ()) tables)
@@ -72,6 +88,8 @@ let () =
 
 let exist nick = Result.is_ok (Db.find Q.get_user nick)
 
+let is_banished nick = Result.is_ok (Db.find Q.get_banished nick)
+
 let login ~nick ~password request =
   if exist nick then
     let^? good_password = Db.find_opt Q.get_password nick in
@@ -80,6 +98,7 @@ let login ~nick ~password request =
       let _unit_lwt = Dream.put_session "nick" nick request in
       Ok ()
     else Error "wrong password"
+  else if is_banished nick then Error "YOU ARE BANISHED"
   else Error "wrong user name"
 
 let register ~email ~nick ~password =
@@ -157,6 +176,10 @@ let get_bio nick =
   let^? bio = Db.find_opt Q.get_bio nick in
   Ok bio
 
+let get_email nick =
+  let^? email = Db.find_opt Q.get_email nick in
+  Ok email
+
 let get_avatar nick =
   let^? avatar = Db.find_opt Q.get_avatar nick in
   if String.length avatar = 0 then Ok None else Ok (Some avatar)
@@ -170,3 +193,11 @@ let upload_avatar files nick =
       let^ () = Db.exec Q.upload_avatar (content, nick) in
       Ok ()
   | _files -> Error "More than one file provided"
+
+let is_admin nick = List.mem nick App.admins
+
+let banish nick =
+  let* email = get_email nick in
+  let^ () = Db.exec Q.delete_user nick in
+  let^ () = Db.exec Q.upload_banished (nick, email) in
+  Ok ()