objective categorical abstract machine language personal data server
Move errors into their own file
+38
-48
+1
-1
pegasus/lib/api/actor/getPreferences.ml
+1
-1
pegasus/lib/api/actor/getPreferences.ml
+1
-1
pegasus/lib/api/actor/putPreferences.ml
+1
-1
pegasus/lib/api/actor/putPreferences.ml
+2
-2
pegasus/lib/api/server/createSession.ml
+2
-2
pegasus/lib/api/server/createSession.ml
+1
-3
pegasus/lib/auth.ml
+1
-3
pegasus/lib/auth.ml
···
104
104
| Refresh {did; _} ->
105
105
did
106
106
| _ ->
107
-
Util.Exceptions.Errors.auth_required "Invalid authorization header"
107
+
Errors.auth_required "Invalid authorization header"
108
108
109
109
let get_session_info identifier db =
110
110
let%lwt actor =
···
131
131
; status }
132
132
133
133
module Verifiers = struct
134
-
open Util.Exceptions
135
-
136
134
open struct
137
135
let parse_header req expected_type =
138
136
match Dream.header req "authorization" with
+32
pegasus/lib/errors.ml
+32
pegasus/lib/errors.ml
···
1
+
exception InvalidRequestError of (string * string)
2
+
3
+
exception InternalServerError of (string * string)
4
+
5
+
exception AuthError of (string * string)
6
+
7
+
let invalid_request ?(name = "InvalidRequest") msg =
8
+
raise (InvalidRequestError (name, msg))
9
+
10
+
let internal_error ?(name = "InternalServerError")
11
+
?(msg = "Internal server error") () =
12
+
raise (InternalServerError (name, msg))
13
+
14
+
let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg))
15
+
16
+
let exn_to_response exn =
17
+
let format_response error msg status =
18
+
Dream.json ~status @@ Yojson.Safe.to_string
19
+
@@ `Assoc [("error", `String error); ("message", `String msg)]
20
+
in
21
+
match exn with
22
+
| InvalidRequestError (error, message) ->
23
+
format_response error message `Bad_Request
24
+
| InternalServerError (error, message) ->
25
+
format_response error message `Internal_Server_Error
26
+
| AuthError (error, message) ->
27
+
format_response error message `Unauthorized
28
+
| _ ->
29
+
format_response "InternalServerError" "Internal server error"
30
+
`Internal_Server_Error
31
+
32
+
let log_exn exn = Dream.error (fun log -> log "%s" (Printexc.to_string exn))
-1
pegasus/lib/repository.ml
-1
pegasus/lib/repository.ml
-38
pegasus/lib/util.ml
-38
pegasus/lib/util.ml
···
1
-
module Exceptions = struct
2
-
exception InvalidRequestError of (string * string)
3
-
4
-
exception InternalServerError of (string * string)
5
-
6
-
exception AuthError of (string * string)
7
-
8
-
module Errors = struct
9
-
let invalid_request ?(name = "InvalidRequest") msg =
10
-
raise (InvalidRequestError (name, msg))
11
-
12
-
let internal_error ?(name = "InternalServerError")
13
-
?(msg = "Internal server error") () =
14
-
raise (InternalServerError (name, msg))
15
-
16
-
let auth_required ?(name = "AuthRequired") msg =
17
-
raise (AuthError (name, msg))
18
-
end
19
-
20
-
let exn_to_response exn =
21
-
let format_response error msg status =
22
-
Dream.json ~status @@ Yojson.Safe.to_string
23
-
@@ `Assoc [("error", `String error); ("message", `String msg)]
24
-
in
25
-
match exn with
26
-
| InvalidRequestError (error, message) ->
27
-
format_response error message `Bad_Request
28
-
| InternalServerError (error, message) ->
29
-
format_response error message `Internal_Server_Error
30
-
| AuthError (error, message) ->
31
-
format_response error message `Unauthorized
32
-
| _ ->
33
-
format_response "InternalServerError" "Internal server error"
34
-
`Internal_Server_Error
35
-
36
-
let log_exn exn = Dream.error (fun log -> log "%s" (Printexc.to_string exn))
37
-
end
38
-
39
1
module Constants = struct
40
2
let pegasus_db_location =
41
3
Filename.concat Env.database_dir "sqlite3://pegasus.db" |> Uri.of_string
+1
-2
pegasus/lib/xrpc.ml
+1
-2
pegasus/lib/xrpc.ml
···
1
-
open Util.Exceptions
2
-
3
1
type init = Auth.Verifiers.ctx
4
2
5
3
type context = {req: Dream.request; db: Data_store.t; auth: Auth.credentials}
···
8
6
9
7
let handler ?(auth : Auth.Verifiers.verifier = Auth.Verifiers.unauthenticated)
10
8
(hdlr : handler) (init : init) =
9
+
let open Errors in
11
10
match%lwt auth init with
12
11
| Ok creds -> (
13
12
try%lwt hdlr {req= init.req; db= init.db; auth= creds}