objective categorical abstract machine language personal data server
Differentiate pegasus logging from dream logging
+79
-73
+13
-13
pegasus/lib/api/account_/migrate/migrate.ml
+13
-13
pegasus/lib/api/account_/migrate/migrate.ml
···
91
91
| Ok () ->
92
92
(true, None)
93
93
| Error e ->
94
-
Dream.warning (fun log ->
94
+
Log.warn (fun log ->
95
95
log "migration %s: failed to deactivate old account: %s" did e ) ;
96
96
(false, Some e)
97
97
in
···
131
131
| Some session -> (
132
132
match%lwt Remote.request_plc_signature old_client with
133
133
| Error e ->
134
-
Dream.warning (fun log ->
134
+
Log.warn (fun log ->
135
135
log "migration %s: failed to request PLC signature: %s" did e ) ;
136
136
let%lwt () =
137
137
State.set ctx.req
···
396
396
| Ok () ->
397
397
(true, None)
398
398
| Error err ->
399
-
Dream.warning (fun log ->
399
+
Log.warn (fun log ->
400
400
log "migration %s: failed to deactivate old account: %s" did err ) ;
401
401
(false, Some err)
402
402
in
···
442
442
let%lwt () =
443
443
match%lwt Ops.check_account_status ~did with
444
444
| Ok status ->
445
-
Dream.info (fun log ->
445
+
Log.info (fun log ->
446
446
log
447
447
"migration %s: repo imported, indexed_records=%d, \
448
448
expected_blobs=%d"
449
449
did status.indexed_records status.expected_blobs ) ;
450
450
Lwt.return_unit
451
451
| Error e ->
452
-
Dream.warning (fun log ->
452
+
Log.warn (fun log ->
453
453
log "migration %s: failed to check account status: %s" did e ) ;
454
454
Lwt.return_unit
455
455
in
456
456
match%lwt Ops.list_missing_blobs ~did ~limit:50 () with
457
457
| Error e ->
458
-
Dream.warning (fun log ->
458
+
Log.warn (fun log ->
459
459
log "migration %s: failed to list missing blobs: %s" did e ) ;
460
460
transition_to_plc_token_step ctx ~old_client ~old_pds ~did ~handle
461
461
~email ~blobs_imported:0 ~blobs_failed:0
···
514
514
Ops.list_missing_blobs ~did:state.did ~limit:50 ?cursor ()
515
515
with
516
516
| Error e ->
517
-
Dream.warning (fun log ->
517
+
Log.warn (fun log ->
518
518
log "migration %s: failed to list missing blobs: %s" state.did e ) ;
519
519
transition_to_plc_token_step ctx ~old_client ~old_pds:state.old_pds
520
520
~did:state.did ~handle:state.handle ~email:state.email
···
581
581
| Ok _ ->
582
582
Lwt.return []
583
583
| Error e ->
584
-
Dream.warning (fun log ->
584
+
Log.warn (fun log ->
585
585
log "migration %s: failed to get old PDS credentials: %s"
586
586
state.did e ) ;
587
587
Lwt.return []
···
632
632
let%lwt () =
633
633
match%lwt Ops.check_account_status ~did:state.did with
634
634
| Ok status ->
635
-
Dream.info (fun log ->
635
+
Log.info (fun log ->
636
636
log
637
637
"migration %s: activating account, \
638
638
imported_blobs=%d/%d"
···
640
640
status.expected_blobs ) ;
641
641
Lwt.return_unit
642
642
| Error e ->
643
-
Dream.warning (fun log ->
643
+
Log.warn (fun log ->
644
644
log
645
645
"migration %s: failed to check status before \
646
646
activation: %s"
···
659
659
| Ok () ->
660
660
(true, None)
661
661
| Error e ->
662
-
Dream.warning (fun log ->
662
+
Log.warn (fun log ->
663
663
log
664
664
"migration %s: failed to deactivate old \
665
665
account: %s"
···
861
861
| Ok () ->
862
862
(true, None)
863
863
| Error e ->
864
-
Dream.warning (fun log ->
864
+
Log.warn (fun log ->
865
865
log
866
866
"migration %s: failed to deactivate old account: %s"
867
867
did e ) ;
···
895
895
| Ok () -> (
896
896
match%lwt Ops.list_missing_blobs ~did ~limit:50 () with
897
897
| Error e ->
898
-
Dream.warning (fun log ->
898
+
Log.warn (fun log ->
899
899
log "migration %s: failed to list missing blobs: %s"
900
900
did e ) ;
901
901
transition_to_plc_token_step ctx ~old_client:client
+1
-1
pegasus/lib/api/account_/migrate/ops.ml
+1
-1
pegasus/lib/api/account_/migrate/ops.ml
···
117
117
(fun cid_str ->
118
118
match%lwt Remote.fetch_blob ~did ~cid:cid_str client with
119
119
| Error e ->
120
-
Dream.warning (fun log ->
120
+
Log.warn (fun log ->
121
121
log "migration %s: failed to fetch blob %s: %s" did cid_str e ) ;
122
122
Lwt.return_error cid_str
123
123
| Ok (data, mimetype) -> (
+2
-2
pegasus/lib/api/account_/migrate/remote.ml
+2
-2
pegasus/lib/api/account_/migrate/remote.ml
···
185
185
Lwt.return_ok res.preferences
186
186
with
187
187
| Hermes.Xrpc_error {status; error; _} ->
188
-
Dream.warning (fun log ->
188
+
Log.warn (fun log ->
189
189
log "migration: failed to fetch preferences: %d %s" status error ) ;
190
190
Lwt.return_ok []
191
191
| exn ->
192
-
Dream.warning (fun log ->
192
+
Log.warn (fun log ->
193
193
log "migration: exception fetching preferences: %s"
194
194
(Printexc.to_string exn) ) ;
195
195
Lwt.return_ok []
+1
-1
pegasus/lib/api/identity/resolveHandle.ml
+1
-1
pegasus/lib/api/identity/resolveHandle.ml
+1
-1
pegasus/lib/api/identity/updateHandle.ml
+1
-1
pegasus/lib/api/identity/updateHandle.ml
+1
-1
pegasus/lib/api/oauth_/par.ml
+1
-1
pegasus/lib/api/oauth_/par.ml
+1
-1
pegasus/lib/api/proxy/appBskyFeedGetFeed.ml
+1
-1
pegasus/lib/api/proxy/appBskyFeedGetFeed.ml
···
49
49
| None ->
50
50
Errors.invalid_request "missing proxy header" )
51
51
with e ->
52
-
Dream.error (fun log ->
52
+
Log.err (fun log ->
53
53
log "failed to fetch feed generator record: %s"
54
54
(Printexc.to_string e) ) ;
55
55
Errors.internal_error ~msg:"failed to fetch feed generator record"
-1
pegasus/lib/api/server/requestPasswordReset.ml
-1
pegasus/lib/api/server/requestPasswordReset.ml
+1
-2
pegasus/lib/api/server/resetPassword.ml
+1
-2
pegasus/lib/api/server/resetPassword.ml
···
26
26
(fun {req; db; _} ->
27
27
let%lwt {token; password} = Xrpc.parse_body req input_of_yojson in
28
28
match%lwt reset_password ~token ~password db with
29
-
| Ok did ->
30
-
Dream.log "password reset completed for %s" did ;
29
+
| Ok _ ->
31
30
Dream.empty `OK
32
31
| Error InvalidToken ->
33
32
Errors.invalid_request ~name:"InvalidToken" "invalid or expired token"
+6
-6
pegasus/lib/auth.ml
+6
-6
pegasus/lib/auth.ml
···
27
27
let now_s = int_of_float (Unix.gettimeofday ()) in
28
28
match Jwt.symmetric_jwt_of_yojson payload with
29
29
| Error e ->
30
-
Dream.debug (fun log -> log "bearer jwt decode error: %s" e) ;
30
+
Log.debug (fun log -> log "bearer jwt decode error: %s" e) ;
31
31
Lwt.return_error "invalid token format"
32
32
| Ok jwt ->
33
33
if jwt.aud <> Env.did then Lwt.return_error "invalid aud"
···
259
259
| Error "use_dpop_nonce" ->
260
260
Lwt.return_error @@ Errors.use_dpop_nonce ()
261
261
| Error e ->
262
-
Dream.debug (fun log -> log ~request:req "dpop error: %s" e) ;
262
+
Log.debug (fun log -> log "dpop error: %s" e) ;
263
263
Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)
264
264
| Ok proof ->
265
265
Lwt.return_ok (DPoP {proof})
···
268
268
fun {req; db} ->
269
269
match parse_dpop req with
270
270
| Error e ->
271
-
Dream.debug (fun log -> log ~request:req "dpop error: %s" e) ;
271
+
Log.debug (fun log -> log "dpop error: %s" e) ;
272
272
Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)
273
273
| Ok token -> (
274
274
match
···
280
280
| Error "use_dpop_nonce" ->
281
281
Lwt.return_error @@ Errors.use_dpop_nonce ()
282
282
| Error e ->
283
-
Dream.debug (fun log -> log ~request:req "dpop error: %s" e) ;
283
+
Log.debug (fun log -> log "dpop error: %s" e) ;
284
284
Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e)
285
285
| Ok proof -> (
286
286
match Jwt.verify_jwt token ~pubkey:Env.jwt_pubkey with
287
287
| Error e ->
288
-
Dream.debug (fun log -> log ~request:req "invalid jwt: %s" e) ;
288
+
Log.debug (fun log -> log "invalid jwt: %s" e) ;
289
289
Lwt.return_error @@ Errors.auth_required e
290
290
| Ok (_header, claims) -> (
291
291
let open Yojson.Safe.Util in
···
400
400
| Ok _ ->
401
401
check_actor_status did db
402
402
| Error e ->
403
-
Dream.debug (fun log -> log "service jwt verification failed: %s" e) ;
403
+
Log.debug (fun log -> log "service jwt verification failed: %s" e) ;
404
404
Lwt.return_error
405
405
@@ Errors.invalid_request ~name:"InvalidToken"
406
406
"jwt signature does not match jwt issuer"
+1
-1
pegasus/lib/blob_store.ml
+1
-1
pegasus/lib/blob_store.ml
+1
-1
pegasus/lib/env.ml
+1
-1
pegasus/lib/env.ml
···
56
56
match getenv_opt "PDS_DPOP_NONCE_SECRET" ~default:"" with
57
57
| "" ->
58
58
let secret = Mirage_crypto_rng_unix.getrandom 32 in
59
-
Dream.warning (fun log ->
59
+
Log.warn (fun log ->
60
60
log "PDS_DPOP_NONCE_SECRET not set; using PDS_DPOP_NONCE_SECRET=%s"
61
61
( Base64.(encode ~alphabet:uri_safe_alphabet ~pad:false) secret
62
62
|> Result.get_ok ) ) ;
+7
-9
pegasus/lib/errors.ml
+7
-9
pegasus/lib/errors.ml
···
53
53
in
54
54
match exn with
55
55
| InvalidRequestError (error, message) ->
56
-
Dream.debug (fun log -> log "invalid request: %s - %s" error message) ;
56
+
Log.debug (fun log -> log "invalid request: %s - %s" error message) ;
57
57
format_response error message `Bad_Request
58
58
| InternalServerError (error, message) ->
59
-
Dream.debug (fun log ->
60
-
log "internal server error: %s - %s" error message ) ;
59
+
Log.debug (fun log -> log "internal server error: %s - %s" error message) ;
61
60
format_response error message `Internal_Server_Error
62
61
| AuthError (error, message) ->
63
-
Dream.debug (fun log -> log "auth error: %s - %s" error message) ;
62
+
Log.debug (fun log -> log "auth error: %s - %s" error message) ;
64
63
format_response error message `Unauthorized
65
64
| NotFoundError (error, message) ->
66
-
Dream.debug (fun log -> log "not found error: %s - %s" error message) ;
65
+
Log.debug (fun log -> log "not found error: %s - %s" error message) ;
67
66
format_response error message `Not_Found
68
67
| UseDpopNonceError ->
69
-
Dream.debug (fun log -> log "use_dpop_nonce error") ;
68
+
Log.debug (fun log -> log "use_dpop_nonce error") ;
70
69
Dream.json ~status:`Bad_Request
71
70
~headers:
72
71
[ ("WWW-Authenticate", {|DPoP error="use_dpop_nonce"|})
73
72
; ("Access-Control-Expose-Headers", "DPoP-Nonce, WWW-Authenticate") ]
74
73
{|{ "error": "use_dpop_nonce" }|}
75
74
| e ->
76
-
Dream.warning (fun log ->
75
+
Log.warn (fun log ->
77
76
log "unexpected internal error: %s" (Printexc.to_string e) ) ;
78
77
format_response "InternalServerError" "Internal server error"
79
78
`Internal_Server_Error
80
79
81
-
let log_exn ?req exn =
82
-
Dream.error (fun log -> log ?request:req "%s" (Printexc.to_string exn))
80
+
let log_exn = Log.log_exn
+1
-1
pegasus/lib/jwt.ml
+1
-1
pegasus/lib/jwt.ml
···
159
159
let did = Option.value did ~default:iss_did in
160
160
match%lwt Id_resolver.Did.resolve did with
161
161
| Error e ->
162
-
Dream.debug (fun log ->
162
+
Log.debug (fun log ->
163
163
log "failed to resolve did %s: %s" did e ) ;
164
164
Lwt.return_error
165
165
@@ InternalError "could not resolve jwt issuer did"
+11
pegasus/lib/log.ml
+11
pegasus/lib/log.ml
···
1
+
let default_src = Logs.Src.create "pegasus"
2
+
3
+
let debug ?(src = default_src) = Logs.debug ~src
4
+
5
+
let err ?(src = default_src) = Logs.err ~src
6
+
7
+
let warn ?(src = default_src) = Logs.warn ~src
8
+
9
+
let info ?(src = default_src) = Logs.info ~src
10
+
11
+
let log_exn exn = err (fun log -> log "%s" (Printexc.to_string exn))
+1
-1
pegasus/lib/oauth/dpop.ml
+1
-1
pegasus/lib/oauth/dpop.ml
+11
-12
pegasus/lib/s3/backup.ml
+11
-12
pegasus/lib/s3/backup.ml
···
14
14
in
15
15
match result with
16
16
| Ok _ ->
17
-
Dream.info (fun log -> log "S3 backup uploaded: %s" key) ;
17
+
Log.info (fun log -> log "S3 backup uploaded: %s" key) ;
18
18
Lwt.return_unit
19
19
| Error e ->
20
-
Dream.error (fun log ->
20
+
Log.err (fun log ->
21
21
log "S3 backup upload failed for %s: %s" key
22
22
(Util.s3_error_to_string e) ) ;
23
23
Lwt.return_unit
···
27
27
if Sys.file_exists db_path then (
28
28
let timestamp = timestamp_string () in
29
29
let key = Printf.sprintf "backups/pegasus-%s.db" timestamp in
30
-
Dream.info (fun log -> log "starting main database backup") ;
30
+
Log.info (fun log -> log "starting main database backup") ;
31
31
upload_to_s3 ~config ~file_path:db_path ~key )
32
32
else (
33
-
Dream.warning (fun log -> log "main database not found: %s" db_path) ;
33
+
Log.warn (fun log -> log "main database not found: %s" db_path) ;
34
34
Lwt.return_unit )
35
35
36
36
let backup_user_db ~config ~did : unit Lwt.t =
···
43
43
else Lwt.return_unit
44
44
45
45
let backup_all_user_dbs ~config ~ds : unit Lwt.t =
46
-
Dream.info (fun log -> log "starting backup of user databases") ;
46
+
Log.info (fun log -> log "starting backup of user databases") ;
47
47
let rec backup_batch cursor count =
48
48
let%lwt actors = Data_store.list_actors ~cursor ~limit:100 ds in
49
49
match actors with
50
50
| [] ->
51
-
Dream.info (fun log -> log "backed up %d user databases" count) ;
51
+
Log.info (fun log -> log "backed up %d user databases" count) ;
52
52
Lwt.return_unit
53
53
| actors ->
54
54
let%lwt () =
···
65
65
let do_backup () : unit Lwt.t =
66
66
match Env.s3_config with
67
67
| Some config when config.backups_enabled ->
68
-
Dream.info (fun log -> log "starting S3 backup") ;
68
+
Log.info (fun log -> log "starting S3 backup") ;
69
69
let%lwt ds = Data_store.connect () in
70
70
let%lwt () = backup_main_db ~config in
71
71
let%lwt () = backup_all_user_dbs ~config ~ds in
72
-
Dream.info (fun log -> log "S3 backup completed") ;
72
+
Log.info (fun log -> log "S3 backup completed") ;
73
73
Lwt.return_unit
74
74
| _ ->
75
75
Lwt.return_unit
···
77
77
let queue_backups () : unit Lwt.t =
78
78
match Env.s3_config with
79
79
| Some config when config.backups_enabled ->
80
-
Dream.info (fun log -> log "starting hourly S3 backups") ;
80
+
Log.info (fun log -> log "starting hourly S3 backups") ;
81
81
let%lwt () =
82
82
Lwt.catch
83
83
(fun () -> do_backup ())
84
84
(fun e ->
85
-
Dream.error (fun log ->
86
-
log "backup failed: %s" (Printexc.to_string e) ) ;
85
+
Log.err (fun log -> log "backup failed: %s" (Printexc.to_string e)) ;
87
86
Lwt.return_unit )
88
87
in
89
88
let rec loop () =
···
92
91
Lwt.catch
93
92
(fun () -> do_backup ())
94
93
(fun e ->
95
-
Dream.error (fun log ->
94
+
Log.err (fun log ->
96
95
log "backup failed: %s" (Printexc.to_string e) ) ;
97
96
Lwt.return_unit )
98
97
in
+8
-8
pegasus/lib/s3/blob_migration.ml
+8
-8
pegasus/lib/s3/blob_migration.ml
···
1
1
let migrate_user ~did : (int * int) Lwt.t =
2
2
match Env.s3_config with
3
3
| Some config when config.blobs_enabled ->
4
-
Dream.info (fun log -> log "migrating blobs for user %s" did) ;
4
+
Log.info (fun log -> log "migrating blobs for user %s" did) ;
5
5
let%lwt user_db = User_store.connect did in
6
6
let migrated = ref 0 in
7
7
let errors = ref 0 in
···
38
38
Sys.remove local_path ; incr migrated ; Lwt.return_unit
39
39
)
40
40
else (
41
-
Dream.warning (fun log ->
41
+
Log.warn (fun log ->
42
42
log "local blob file not found: %s" local_path ) ;
43
43
Lwt.return_unit ) )
44
44
(fun e ->
45
-
Dream.error (fun log ->
45
+
Log.err (fun log ->
46
46
log "blob migration error for %s: %s"
47
47
(Cid.to_string cid) (Printexc.to_string e) ) ;
48
48
incr errors ;
···
53
53
migrate_batch (Cid.to_string last_cid)
54
54
in
55
55
let%lwt () = migrate_batch "" in
56
-
Dream.info (fun log ->
56
+
Log.info (fun log ->
57
57
log "blob migration complete for %s: %d migrated, %d errors" did
58
58
!migrated !errors ) ;
59
59
Lwt.return (!migrated, !errors)
60
60
| _ ->
61
-
Dream.error (fun log -> log "S3 blob storage not enabled") ;
61
+
Log.err (fun log -> log "S3 blob storage not enabled") ;
62
62
Lwt.return (0, 0)
63
63
64
64
let migrate_all () : unit Lwt.t =
65
65
match Env.s3_config with
66
66
| Some config when config.blobs_enabled ->
67
-
Dream.info (fun log -> log "migrating all blobs to S3") ;
67
+
Log.info (fun log -> log "migrating all blobs to S3") ;
68
68
let%lwt ds = Data_store.connect () in
69
69
let total_migrated = ref 0 in
70
70
let total_errors = ref 0 in
···
87
87
migrate_batch last.did
88
88
in
89
89
let%lwt () = migrate_batch "" in
90
-
Dream.info (fun log ->
90
+
Log.info (fun log ->
91
91
log "blob migration complete: %d total migrated, %d total errors"
92
92
!total_migrated !total_errors ) ;
93
93
Lwt.return_unit
94
94
| _ ->
95
-
Dream.error (fun log -> log "S3 blob storage not enabled") ;
95
+
Log.err (fun log -> log "S3 blob storage not enabled") ;
96
96
Lwt.return_unit
+1
-1
pegasus/lib/sequencer.ml
+1
-1
pegasus/lib/sequencer.ml
+2
-2
pegasus/lib/util.ml
+2
-2
pegasus/lib/util.ml
···
561
561
recipients
562
562
|> Option.get
563
563
in
564
-
Dream.log "email to %s: %s" to_addr text
564
+
Log.info (fun log -> log "email to %s: %s" to_addr text)
565
565
in
566
566
match (Env.smtp_config, Env.smtp_sender) with
567
567
| Some config, Some sender -> (
···
571
571
| Ok message -> (
572
572
try%lwt Letters.send ~config ~sender ~recipients ~message
573
573
with e ->
574
-
Errors.log_exn e ;
574
+
Log.log_exn e ;
575
575
Lwt.return (log_email ()) ) )
576
576
| _ ->
577
577
Lwt.return (log_email ())
+8
-8
pegasus/lib/xrpc.ml
+8
-8
pegasus/lib/xrpc.ml
···
112
112
apply_rate_limits ~nsid rate_limits ctx ;
113
113
try%lwt hdlr ctx
114
114
with e ->
115
-
if not (is_xrpc_error e) then log_exn ~req:init.req e ;
115
+
if not (is_xrpc_error e) then log_exn e ;
116
116
exn_to_response e
117
117
with Rate_limiter.Rate_limit_exceeded status ->
118
118
rate_limit_response status )
···
124
124
| Rate_limiter.Rate_limit_exceeded status ->
125
125
rate_limit_response status
126
126
| e ->
127
-
if not (is_xrpc_error e) then log_exn ~req:init.req e ;
127
+
if not (is_xrpc_error e) then log_exn e ;
128
128
exn_to_response e
129
129
with Redirect r -> Dream.redirect init.req r
130
130
···
141
141
in
142
142
match query_json |> of_yojson with
143
143
| Error e ->
144
-
Dream.debug (fun log -> log "error parsing query: %s" e) ;
144
+
Log.debug (fun log -> log "error parsing query: %s" e) ;
145
145
Errors.internal_error ()
146
146
| Ok query ->
147
147
query
···
173
173
| _ ->
174
174
Lwt.return (`Assoc []) )
175
175
in
176
+
Log.debug (fun l -> l "body: %s" (Yojson.Safe.to_string body_assoc)) ;
176
177
match of_yojson body_assoc with
177
178
| Error e ->
178
-
Dream.debug (fun log -> log "error parsing body: %s" e) ;
179
+
Log.debug (fun log -> log "error parsing body: %s" e) ;
179
180
Errors.internal_error ()
180
181
| Ok body ->
181
182
Lwt.return body
···
267
268
Body.to_stream body |> Lwt_stream.iter_s (Dream.write stream) )
268
269
| e ->
269
270
let%lwt () = Body.drain_body body in
270
-
Dream.error (fun log ->
271
+
Log.err (fun log ->
271
272
log "error when proxying to %s: %s" (Uri.to_string uri)
272
273
(Http.Status.to_string e) ) ;
273
274
Errors.internal_error ~msg:"failed to proxy request" () )
···
289
290
Body.to_stream body |> Lwt_stream.iter_s (Dream.write stream) )
290
291
| e ->
291
292
let%lwt () = Body.drain_body body in
292
-
Dream.error (fun log ->
293
+
Log.err (fun log ->
293
294
log "error when proxying to %s: %s" (Uri.to_string uri)
294
295
(Http.Status.to_string e) ) ;
295
296
Errors.internal_error ~msg:"failed to proxy request" () )
296
297
| _ ->
297
298
Errors.invalid_request "unsupported method" )
298
299
| Error e ->
299
-
Dream.error (fun log ->
300
-
log ~request:ctx.req "error when resolving destination service: %s" e ) ;
300
+
Log.err (fun log -> log "error when resolving destination service: %s" e) ;
301
301
Errors.internal_error ~msg:"failed to resolve destination service" ()
302
302
303
303
let service_proxy_handler db req =