diff --git a/.ocamlformat b/.ocamlformat index 150000d..c9d45a2 100644 --- a/.ocamlformat +++ b/.ocamlformat @@ -1 +1,2 @@ profile = ocamlformat +version = 0.27.0 diff --git a/bin/main.ml b/bin/main.ml index 0d3645a..071577e 100644 --- a/bin/main.ml +++ b/bin/main.ml @@ -7,23 +7,6 @@ let handlers = ; (get, "/robots.txt", Api.Robots.handler) ; (get, "/xrpc/_health", Api.Health.handler) ; (get, "/.well-known/did.json", Api.Well_known.did_json) - ; ( get - , "/.well-known/oauth-protected-resource" - , Api.Well_known.oauth_protected_resource ) - ; ( get - , "/.well-known/oauth-authorization-server" - , Api.Well_known.oauth_authorization_server ) - ; (* oauth *) - (options, "/oauth/par", Api.Oauth_.Par.options_handler) - ; (post, "/oauth/par", Api.Oauth_.Par.post_handler) - ; (get, "/oauth/authorize", Api.Oauth_.Authorize.get_handler) - ; (post, "/oauth/authorize", Api.Oauth_.Authorize.post_handler) - ; (options, "/oauth/token", Api.Oauth_.Token.options_handler) - ; (post, "/oauth/token", Api.Oauth_.Token.post_handler) - ; (* account *) - (get, "/account/login", Api.Account_.Login.get_handler) - ; (post, "/account/login", Api.Account_.Login.post_handler) - ; (get, "/account/logout", Api.Account_.Logout.handler) ; (* unauthed *) ( get , "/xrpc/com.atproto.server.describeServer" @@ -32,7 +15,7 @@ let handlers = ; ( get , "/xrpc/com.atproto.identity.resolveHandle" , Api.Identity.ResolveHandle.handler ) - ; (* account management *) + ; (* account *) ( post , "/xrpc/com.atproto.server.createInviteCode" , Api.Server.CreateInviteCode.handler ) @@ -82,22 +65,16 @@ let handlers = , "/xrpc/com.atproto.actor.putPreferences" , Api.Actor.PutPreferences.handler ) ] -let static_routes = - [Dream.get "/public/**" (Dream.static "_build/default/public")] - let main = let%lwt db = Data_store.connect ~create:true () in let%lwt () = Data_store.init db in Dream.serve ~interface:"0.0.0.0" ~port:8008 @@ Dream.logger - @@ Dream.set_secret (Env.jwt_key |> Kleidos.privkey_to_multikey) - @@ Dream.cookie_sessions @@ Xrpc.service_proxy_middleware db - @@ Xrpc.dpop_middleware @@ Xrpc.cors_middleware @@ Dream.router + @@ Dream.router @@ List.map (fun (fn, path, handler) -> fn path (fun req -> handler ({req; db} : Xrpc.init)) ) handlers - @ static_routes let () = Lwt_main.run main diff --git a/dune b/dune deleted file mode 100644 index a40e8d6..0000000 --- a/dune +++ /dev/null @@ -1,21 +0,0 @@ -(subdir - public/ - (rule - (target index.css) - (deps - %{workspace_root}/tools/tailwindcss/tailwindcss - (:input %{workspace_root}/public/main.css) - (source_tree %{workspace_root}/public) - (source_tree %{workspace_root}/pegasus/lib/templates)) - (action - (chdir - %{workspace_root} - (run - %{workspace_root}/tools/tailwindcss/tailwindcss - -m - -i - %{input} - -o - %{target}))))) - -(copy_files public/*) diff --git a/dune-project b/dune-project index 96f72d3..fc0cc0a 100644 --- a/dune-project +++ b/dune-project @@ -47,21 +46,16 @@ (cohttp-lwt-unix (>= 6.1.1)) (dns-client (>= 10.2.0)) dream - html_of_jsx - mlx (re (>= 1.13.2)) (safepass (>= 3.1)) (timedesc (>= 3.1.0)) - (uri (>= 4.4.0)) (uuidm (>= 0.9.10)) (yojson (>= 3.0.0)) (lwt_ppx (>= 5.9.1)) (ppx_deriving_yojson (>= 3.9.1)) ppx_rapper ppx_rapper_lwt - (alcotest :with-test) - (ocamlformat-mlx :with-dev-setup) - (ocamlmerlin-mlx :with-dev-setup))) + (alcotest :with-test))) (package (name mist) @@ -103,14 +97,3 @@ (hacl-star (>= 0.7.2)) (mirage-crypto-ec (>= 2.0.1)) (multibase (>= 0.1.0)))) - -(package - (name tailwindcss) (allow_empty)) - -(dialect - (name mlx) - (implementation - (extension mlx) - (merlin_reader mlx) - (preprocess - (run mlx-pp %{input-file})))) diff --git a/kleidos/kleidos.ml b/kleidos/kleidos.ml index 6998a09..f31a808 100644 --- a/kleidos/kleidos.ml +++ b/kleidos/kleidos.ml @@ -220,7 +220,3 @@ let verify ~pubkey ~msg ~signature : bool = let pubkey_to_did_key pubkey : string = let pubkey, (module Curve : CURVE) = pubkey in Curve.pubkey_to_did_key pubkey - -let privkey_to_multikey privkey : string = - let privkey, (module Curve : CURVE) = privkey in - Curve.privkey_to_multikey privkey diff --git a/mist/lib/mst.ml b/mist/lib/mst.ml index 510806c..180393f 100644 --- a/mist/lib/mst.ml +++ b/mist/lib/mst.ml @@ -498,9 +498,7 @@ struct match Util.at_index index seq with | Some (Leaf (k, v, _)) when k = key -> ( (* include the found leaf block to prove existence *) - match%lwt - Store.get_bytes t.blockstore v - with + match%lwt Store.get_bytes t.blockstore v with | Some leaf_bytes -> Lwt.return (Block_map.set v leaf_bytes Block_map.empty) | None -> @@ -533,7 +531,8 @@ struct | Some cid_left -> ( match%lwt Store.get_bytes t.blockstore cid_left with | Some b -> - Lwt.return (Block_map.set cid_left b Block_map.empty) + Lwt.return + (Block_map.set cid_left b Block_map.empty) | None -> Lwt.return Block_map.empty ) | None -> diff --git a/pegasus.opam b/pegasus.opam index 39b379d..fb505ea 100644 --- a/pegasus.opam +++ b/pegasus.opam @@ -18,12 +18,9 @@ depends: [ "cohttp-lwt-unix" {>= "6.1.1"} "dns-client" {>= "10.2.0"} "dream" - "html_of_jsx" - "mlx" "re" {>= "1.13.2"} "safepass" {>= "3.1"} "timedesc" {>= "3.1.0"} - "uri" {>= "4.4.0"} "uuidm" {>= "0.9.10"} "yojson" {>= "3.0.0"} "lwt_ppx" {>= "5.9.1"} @@ -31,8 +28,6 @@ depends: [ "ppx_rapper" "ppx_rapper_lwt" "alcotest" {with-test} - "ocamlformat-mlx" {with-dev-setup} - "ocamlmerlin-mlx" {with-dev-setup} "odoc" {with-doc} ] build: [ diff --git a/pegasus/lib/api/account_/login.ml b/pegasus/lib/api/account_/login.ml deleted file mode 100644 index 95be648..0000000 --- a/pegasus/lib/api/account_/login.ml +++ /dev/null @@ -1,49 +0,0 @@ -let get_handler = - Xrpc.handler (fun ctx -> - let redirect_url = - if List.length @@ Dream.all_queries ctx.req > 0 then - Uri.make ~path:"/oauth/authorize" ~query:(Util.copy_query ctx.req) () - |> Uri.to_string - else "/account" - in - let csrf_token = Dream.csrf_token ctx.req in - let html = - JSX.render (Templates.Login.make ~redirect_url ~csrf_token ()) - in - Dream.html html ) - -let post_handler = - Xrpc.handler (fun ctx -> - let csrf_token = Dream.csrf_token ctx.req in - match%lwt Dream.form ctx.req with - | `Ok fields -> ( - let identifier = List.assoc "identifier" fields in - let password = List.assoc "password" fields in - let redirect_url = - List.assoc_opt "redirect_url" fields - |> Option.value ~default:"/account" - in - let%lwt actor = - Data_store.try_login ~id:identifier ~password ctx.db - in - match actor with - | None -> - let html = - JSX.render - (Templates.Login.make ~redirect_url - ~error:"Invalid username or password. Please try again." - ~csrf_token () ) - in - Dream.html ~status:`Unauthorized html - | Some {did; _} -> - let%lwt () = Dream.invalidate_session ctx.req in - let%lwt () = Dream.set_session_field ctx.req "did" did in - Dream.redirect ctx.req redirect_url ) - | _ -> - let html = - JSX.render - (Templates.Login.make ~redirect_url:"/account" - ~error:"Invalid credentials provided. Please try again." - ~csrf_token () ) - in - Dream.html ~status:`Unauthorized html ) diff --git a/pegasus/lib/api/account_/logout.ml b/pegasus/lib/api/account_/logout.ml deleted file mode 100644 index 4839ff9..0000000 --- a/pegasus/lib/api/account_/logout.ml +++ /dev/null @@ -1,4 +0,0 @@ -let handler = - Xrpc.handler (fun ctx -> - let%lwt () = Dream.invalidate_session ctx.req in - Dream.redirect ctx.req "/account/login" ) diff --git a/pegasus/lib/api/actor/putPreferences.ml b/pegasus/lib/api/actor/putPreferences.ml index b84cbc2..ddaa25b 100644 --- a/pegasus/lib/api/actor/putPreferences.ml +++ b/pegasus/lib/api/actor/putPreferences.ml @@ -1,5 +1,5 @@ let handler = - Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} -> + Xrpc.handler ~auth:Authorization (fun {req; db; auth} -> let did = Auth.get_authed_did_exn auth in let%lwt body = Dream.body req in let prefs = diff --git a/pegasus/lib/api/identity/updateHandle.ml b/pegasus/lib/api/identity/updateHandle.ml index 75ccc81..d104e5e 100644 --- a/pegasus/lib/api/identity/updateHandle.ml +++ b/pegasus/lib/api/identity/updateHandle.ml @@ -1,7 +1,7 @@ type request = {handle: string} [@@deriving yojson] let handler = - Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} -> + Xrpc.handler ~auth:Authorization (fun {req; auth; db} -> let did = Auth.get_authed_did_exn auth in let%lwt body = Dream.body req in let handle = @@ -17,7 +17,8 @@ let handler = | Ok () -> ( match%lwt Data_store.get_actor_by_identifier handle db with | Some _ -> - Errors.invalid_request ~name:"InvalidHandle" "handle already in use" + Errors.invalid_request ~name:"InvalidHandle" + "handle already in use" | None -> let%lwt () = Data_store.update_actor_handle ~did ~handle db in let%lwt _ = @@ -66,6 +67,8 @@ let handler = ~msg:"failed to submit plc operation" () ) else Lwt.return_unit in - let () = Ttl_cache.String_cache.remove Id_resolver.Did.cache did in + let () = + Ttl_cache.String_cache.remove Id_resolver.Did.cache did + in let%lwt _ = Sequencer.sequence_identity db ~did ~handle () in Dream.empty `OK ) ) diff --git a/pegasus/lib/api/oauth_/authorize.ml b/pegasus/lib/api/oauth_/authorize.ml deleted file mode 100644 index 1a43f31..0000000 --- a/pegasus/lib/api/oauth_/authorize.ml +++ /dev/null @@ -1,184 +0,0 @@ -open Oauth -open Oauth.Types - -let get_session_user (ctx : Xrpc.context) = - match Dream.session_field ctx.req "did" with - | Some did -> - Lwt.return_some did - | None -> - Lwt.return_none - -let get_handler = - Xrpc.handler (fun ctx -> - let login_redirect = - Uri.make ~path:"/account/login" ~query:(Util.copy_query ctx.req) () - |> Uri.to_string |> Dream.redirect ctx.req - in - let client_id = Dream.query ctx.req "client_id" in - let request_uri = Dream.query ctx.req "request_uri" in - match (client_id, request_uri) with - | None, _ | _, None -> - login_redirect - | Some client_id, Some request_uri -> ( - let prefix = Constants.request_uri_prefix in - if not (String.starts_with ~prefix request_uri) then login_redirect - else - let request_id = - String.sub request_uri (String.length prefix) - (String.length request_uri - String.length prefix) - in - match%lwt Queries.get_par_request ctx.db request_id with - | None -> - login_redirect - | Some req_record -> ( - if req_record.client_id <> client_id then login_redirect - else - let req = - Yojson.Safe.from_string req_record.request_data - |> par_request_of_yojson - |> Result.map_error (fun _ -> - Errors.internal_error ~msg:"failed to parse par request" - () ) - |> Result.get_ok - in - let%lwt metadata = - try%lwt Client.fetch_client_metadata client_id - with _ -> - Errors.internal_error - ~msg:"failed to fetch client metadata" () - in - let code = - "cod-" - ^ Uuidm.to_string - (Uuidm.v4_gen (Random.State.make_self_init ()) ()) - in - let expires_at = Util.now_ms () + Constants.code_expiry_ms in - let%lwt () = - Queries.insert_auth_code ctx.db - { code - ; request_id - ; authorized_by= None - ; authorized_at= None - ; expires_at - ; used= false } - in - match%lwt get_session_user ctx with - | None -> - login_redirect - | Some did -> ( - match req.login_hint with - | Some hint when hint <> did -> - login_redirect - | _ -> - let%lwt handle = - match%lwt - Data_store.get_actor_by_identifier did ctx.db - with - | Some {handle; _} -> - Lwt.return handle - | None -> - Errors.internal_error - ~msg:"failed to resolve user" () - in - let scopes = String.split_on_char ' ' req.scope in - let csrf_token = Dream.csrf_token ctx.req in - let html = - JSX.render - (Templates.Oauth_authorize.make ~metadata ~handle - ~scopes ~code ~request_uri ~csrf_token () ) - in - Dream.html html ) ) ) ) - -let post_handler = - Xrpc.handler (fun ctx -> - match%lwt get_session_user ctx with - | None -> - Errors.auth_required "missing authentication" - | Some user_did -> ( - match%lwt Dream.form ctx.req with - | `Ok fields -> ( - let action = List.assoc_opt "action" fields in - let code = List.assoc_opt "code" fields in - let request_uri = List.assoc_opt "request_uri" fields in - match (action, code, request_uri) with - | Some "deny", _, Some request_uri -> ( - let prefix = Constants.request_uri_prefix in - let request_id = - String.sub request_uri (String.length prefix) - (String.length request_uri - String.length prefix) - in - let%lwt req_record = - Queries.get_par_request ctx.db request_id - in - match req_record with - | Some rec_ -> - let req = - Yojson.Safe.from_string rec_.request_data - |> par_request_of_yojson |> Result.get_ok - in - let params = - [ ("error", "access_denied") - ; ("error_description", "Unable to authorize user.") - ; ("state", req.state) - ; ("iss", "https://" ^ Env.hostname) ] - in - let query = - String.concat "&" - (List.map - (fun (k, v) -> k ^ "=" ^ Uri.pct_encode v) - params ) - in - Dream.redirect ctx.req (req.redirect_uri ^ "?" ^ query) - | None -> - Errors.invalid_request "request expired" ) - | Some "allow", Some code, Some _request_uri -> ( - let%lwt code_record = Queries.get_auth_code ctx.db code in - match code_record with - | None -> - Errors.invalid_request "invalid code" - | Some code_rec -> ( - if code_rec.authorized_by <> None then - Errors.invalid_request "code already authorized" - else if code_rec.used then - Errors.invalid_request "code already used" - else if Util.now_ms () > code_rec.expires_at then - Errors.invalid_request "code expired" - else - let%lwt () = - Queries.activate_auth_code ctx.db code user_did - in - let%lwt req_record = - Queries.get_par_request ctx.db code_rec.request_id - in - match req_record with - | None -> - Errors.internal_error ~msg:"request not found" () - | Some rec_ -> - let req = - Yojson.Safe.from_string rec_.request_data - |> par_request_of_yojson |> Result.get_ok - in - let params = - [ ("code", code) - ; ("state", req.state) - ; ("iss", "https://" ^ Env.hostname) ] - in - let query = - String.concat "&" - (List.map - (fun (k, v) -> k ^ "=" ^ Uri.pct_encode v) - params ) - in - let separator = - match req.response_mode with - | Some "fragment" -> - "#" - | _ -> - "?" - in - Dream.redirect ctx.req - (req.redirect_uri ^ separator ^ query) ) ) - | _ -> - Errors.invalid_request "invalid request" ) - | _ -> - Errors.invalid_request "invalid request" ) ) diff --git a/pegasus/lib/api/oauth_/par.ml b/pegasus/lib/api/oauth_/par.ml deleted file mode 100644 index e321105..0000000 --- a/pegasus/lib/api/oauth_/par.ml +++ /dev/null @@ -1,41 +0,0 @@ -open Oauth -open Oauth.Types - -let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content) - -let post_handler = - Xrpc.handler ~auth:DPoP (fun ctx -> - let proof = Auth.get_dpop_proof_exn ctx.auth in - let%lwt req = Xrpc.parse_body ctx.req par_request_of_yojson in - let%lwt client = - try%lwt Client.fetch_client_metadata req.client_id - with e -> - Errors.log_exn ~req:ctx.req e ; - Errors.invalid_request "failed to fetch client metadata" - in - if req.response_type <> "code" then - Errors.invalid_request "only response_type=code supported" - else if req.code_challenge_method <> "S256" then - Errors.invalid_request "only code_challenge_method=S256 supported" - else if not (List.mem req.redirect_uri client.redirect_uris) then - Errors.invalid_request "invalid redirect_uri" - else - let request_id = - "req-" - ^ Uuidm.to_string (Uuidm.v4_gen (Random.State.make_self_init ()) ()) - in - let request_uri = Constants.request_uri_prefix ^ request_id in - let expires_at = Util.now_ms () + Constants.par_request_ttl_ms in - let request : oauth_request = - { request_id - ; client_id= req.client_id - ; request_data= Yojson.Safe.to_string (par_request_to_yojson req) - ; dpop_jkt= Some proof.jkt - ; expires_at - ; created_at= Util.now_ms () } - in - let%lwt () = Queries.insert_par_request ctx.db request in - Dream.json ~status:`Created - @@ Yojson.Safe.to_string - @@ `Assoc - [("request_uri", `String request_uri); ("expires_in", `Int 300)] ) diff --git a/pegasus/lib/api/oauth_/token.ml b/pegasus/lib/api/oauth_/token.ml deleted file mode 100644 index 99bd63a..0000000 --- a/pegasus/lib/api/oauth_/token.ml +++ /dev/null @@ -1,179 +0,0 @@ -open Oauth - -let options_handler = Xrpc.handler (fun _ -> Dream.empty `No_Content) - -let post_handler = - Xrpc.handler ~auth:DPoP (fun ctx -> - let%lwt req = Xrpc.parse_body ctx.req Types.token_request_of_yojson in - let proof = Auth.get_dpop_proof_exn ctx.auth in - match req.grant_type with - | "authorization_code" -> ( - match req.code with - | None -> - Errors.invalid_request "code required" - | Some code -> ( - let%lwt code_record = Queries.consume_auth_code ctx.db code in - match code_record with - | None -> - Errors.invalid_request "invalid code" - | Some code_rec -> ( - if Util.now_ms () > code_rec.expires_at then - Errors.invalid_request "code expired" - else - match code_rec.authorized_by with - | None -> - Errors.invalid_request "code not authorized" - | Some did -> ( - let%lwt par_req = - Queries.get_par_request ctx.db code_rec.request_id - in - match par_req with - | None -> - Errors.internal_error ~msg:"request not found" () - | Some par_record -> - let orig_req = - Yojson.Safe.from_string par_record.request_data - |> Types.par_request_of_yojson |> Result.get_ok - in - ( match req.redirect_uri with - | None -> - Errors.invalid_request "redirect_uri required" - | Some uri when uri <> orig_req.redirect_uri -> - Errors.invalid_request "redirect_uri mismatch" - | _ -> - () ) ; - ( match req.code_verifier with - | None -> - Errors.invalid_request "code_verifier required" - | Some verifier -> - let computed = - Digestif.SHA256.digest_string verifier - |> Digestif.SHA256.to_raw_string - |> Base64.( - encode_exn ~pad:false - ~alphabet:uri_safe_alphabet ) - in - if orig_req.code_challenge <> computed then - Errors.invalid_request "invalid code_verifier" - ) ; - ( match par_record.dpop_jkt with - | Some stored when stored <> proof.jkt -> - Errors.invalid_request "DPoP key mismatch" - | _ -> - () ) ; - let token_id = - "tok-" - ^ Uuidm.to_string - (Uuidm.v4_gen - (Random.State.make_self_init ()) - () ) - in - let refresh_token = - "ref-" - ^ Uuidm.to_string - (Uuidm.v4_gen - (Random.State.make_self_init ()) - () ) - in - let now_sec = int_of_float (Unix.gettimeofday ()) in - let expires_in = - Constants.access_token_expiry_ms / 1000 - in - let exp_sec = now_sec + expires_in in - let expires_at = exp_sec * 1000 in - let claims = - `Assoc - [ ("jti", `String token_id) - ; ("sub", `String did) - ; ("iat", `Int now_sec) - ; ("exp", `Int exp_sec) - ; ("scope", `String orig_req.scope) - ; ("aud", `String ("https://" ^ Env.hostname)) - ; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ] - in - let access_token = - Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key - in - let%lwt () = - Queries.insert_oauth_token ctx.db - { refresh_token - ; client_id= req.client_id - ; did - ; dpop_jkt= proof.jkt - ; scope= orig_req.scope - ; expires_at } - in - let nonce = Dpop.next_nonce () in - Dream.json - ~headers: - [ ("DPoP-Nonce", nonce) - ; ("Access-Control-Expose-Headers", "DPoP-Nonce") - ; ("Cache-Control", "no-store") ] - @@ Yojson.Safe.to_string - @@ `Assoc - [ ("access_token", `String access_token) - ; ("token_type", `String "DPoP") - ; ("refresh_token", `String refresh_token) - ; ("expires_in", `Int expires_in) - ; ("scope", `String orig_req.scope) - ; ("sub", `String did) ] ) ) ) ) - | "refresh_token" -> ( - match req.refresh_token with - | None -> - Errors.invalid_request "refresh_token required" - | Some refresh_token -> ( - let%lwt token_record = - Queries.get_oauth_token_by_refresh ctx.db refresh_token - in - match token_record with - | None -> - Errors.invalid_request "invalid refresh token" - | Some session -> - if session.client_id <> req.client_id then - Errors.invalid_request "client_id mismatch" - else if session.dpop_jkt <> proof.jkt then - Errors.invalid_request "DPoP key mismatch" - else - let new_token_id = - "tok-" - ^ Uuidm.to_string - (Uuidm.v4_gen (Random.State.make_self_init ()) ()) - in - let new_refresh = - "ref-" - ^ Uuidm.to_string - (Uuidm.v4_gen (Random.State.make_self_init ()) ()) - in - let now_sec = int_of_float (Unix.gettimeofday ()) in - let expires_in = Constants.access_token_expiry_ms / 1000 in - let exp_sec = now_sec + expires_in in - let new_expires_at = exp_sec * 1000 in - let claims = - `Assoc - [ ("jti", `String new_token_id) - ; ("sub", `String session.did) - ; ("iat", `Int now_sec) - ; ("exp", `Int exp_sec) - ; ("scope", `String session.scope) - ; ("aud", `String ("https://" ^ Env.hostname)) - ; ("cnf", `Assoc [("jkt", `String proof.jkt)]) ] - in - let new_access_token = - Jwt.sign_jwt claims ~typ:"at+jwt" Env.jwt_key - in - let%lwt () = - Queries.update_oauth_token ctx.db - ~old_refresh_token:refresh_token - ~new_refresh_token:new_refresh ~expires_at:new_expires_at - in - Dream.json ~headers:[("Cache-Control", "no-store")] - @@ Yojson.Safe.to_string - @@ `Assoc - [ ("access_token", `String new_access_token) - ; ("token_type", `String "DPoP") - ; ("refresh_token", `String new_refresh) - ; ("expires_in", `Int expires_in) - ; ("scope", `String session.scope) - ; ("sub", `String session.did) ] ) ) - | _ -> - Errors.invalid_request ("unsupported grant_type: " ^ req.grant_type) ) diff --git a/pegasus/lib/api/server/createSession.ml b/pegasus/lib/api/server/createSession.ml index 2141941..283d1ab 100644 --- a/pegasus/lib/api/server/createSession.ml +++ b/pegasus/lib/api/server/createSession.ml @@ -17,7 +17,7 @@ type response = [@@deriving yojson {strict= false}] let handler = - Xrpc.handler (fun {req; auth; db; _} -> + Xrpc.handler (fun {req; db; auth} -> let%lwt {identifier; password; _} = Xrpc.parse_body req request_of_yojson in diff --git a/pegasus/lib/api/server/getServiceAuth.ml b/pegasus/lib/api/server/getServiceAuth.ml index cb8433e..2590e31 100644 --- a/pegasus/lib/api/server/getServiceAuth.ml +++ b/pegasus/lib/api/server/getServiceAuth.ml @@ -1,7 +1,7 @@ type response = {token: string} [@@deriving yojson {strict= false}] let handler = - Xrpc.handler ~auth:Authorization (fun {req; auth; db; _} -> + Xrpc.handler ~auth:Authorization (fun {req; auth; db} -> let did = Auth.get_authed_did_exn auth in let aud, lxm = match (Dream.query req "aud", Dream.query req "lxm") with diff --git a/pegasus/lib/api/well_known.ml b/pegasus/lib/api/well_known.ml index 982ddc3..07a3a1d 100644 --- a/pegasus/lib/api/well_known.ml +++ b/pegasus/lib/api/well_known.ml @@ -1,10 +1,3 @@ -open struct - let make_url pth = - Uri.(make ~scheme:"https" ~host:Env.hostname ~path:pth () |> to_string) - - let pds_url = `String (make_url "") -end - let did_json = Xrpc.handler (fun _ -> Dream.json @@ Yojson.Safe.to_string @@ -15,53 +8,5 @@ let did_json = , `Assoc [ ("id", `String "#atproto_pds") ; ("type", `String "AtprotoPersonalDataServer") - ; ("serviceEndpoint", pds_url) ] ) ] ) - -let oauth_protected_resource = - Xrpc.handler (fun _ -> - Dream.json @@ Yojson.Safe.to_string - @@ `Assoc - [ ("authorization_servers", `List [pds_url]) - ; ("bearer_methods_supported", `List [`String "header"]) - ; ("resource", pds_url) - ; ("resource_documentation", `String "https://atproto.com") - ; ("scopes_supported", `List []) ] ) - -let oauth_authorization_server = - Xrpc.handler (fun _ -> - Dream.json @@ Yojson.Safe.to_string - @@ `Assoc - [ ("issuer", pds_url) - ; ("authorization_endpoint", `String (make_url "/oauth/authorize")) - ; ("token_endpoint", `String (make_url "/oauth/token")) - ; ( "pushed_authorization_request_endpoint" - , `String (make_url "/oauth/par") ) - ; ("require_pushed_authorization_requests", `Bool true) - ; ( "scopes_supported" - , `List - [ `String "atproto" - ; `String "transition:email" - ; `String "transition:generic" - ; `String "transition:chat.bsky" ] ) - ; ("subject_types_supported", `List [`String "public"]) - ; ("response_types_supported", `List [`String "code"]) - ; ( "response_modes_supported" - , `List [`String "query"; `String "fragment"] ) - ; ( "grant_types_supported" - , `List [`String "authorization_code"; `String "refresh_token"] ) - ; ("code_challenge_methods_supported", `List [`String "S256"]) - ; ("ui_locales_supported", `List [`String "en-US"]) - ; ( "display_values_supported" - , `List [`String "page"; `String "popup"; `String "touch"] ) - ; ("authorization_response_iss_parameter_supported", `Bool true) - ; ( "request_object_signing_alg_values_supported" - , `List [`String "ES256"; `String "ES256K"] ) - ; ("request_object_encryption_alg_values_supported", `List []) - ; ("request_object_encryption_enc_values_supported", `List []) - ; ( "token_endpoint_auth_methods_supported" - , `List [`String "none"; `String "private_key_jwt"] ) - ; ( "token_endpoint_auth_signing_alg_values_supported" - , `List [`String "ES256"; `String "ES256K"] ) - ; ( "dpop_signing_alg_values_supported" - , `List [`String "ES256"; `String "ES256K"] ) - ; ("client_id_metadata_document_supported", `Bool true) ] ) + ; ("serviceEndpoint", `String ("https://" ^ Env.hostname)) ] ) + ] ) diff --git a/pegasus/lib/auth.ml b/pegasus/lib/auth.ml index a4119f7..5738224 100644 --- a/pegasus/lib/auth.ml +++ b/pegasus/lib/auth.ml @@ -15,8 +15,6 @@ type credentials = | Admin | Access of {did: string} | Refresh of {did: string; jti: string} - | OAuth of {did: string; proof: Oauth.Dpop.proof} - | DPoP of {proof: Oauth.Dpop.proof} let verify_bearer_jwt t token expected_scope = match Jwt.verify_jwt token Env.jwt_key with @@ -44,7 +42,7 @@ let verify_auth ?(refresh = false) credentials did = match credentials with | Admin -> true - | (Access {did= creds} | OAuth {did= creds; _}) when creds = did -> + | Access {did= creds} when creds = did -> true | Refresh {did= creds; _} when creds = did && refresh -> true @@ -52,18 +50,12 @@ let verify_auth ?(refresh = false) credentials did = false let get_authed_did_exn = function - | Access {did} | OAuth {did; _} -> + | Access {did} -> did | Refresh {did; _} -> did | _ -> - Errors.auth_required "invalid authorization header" - -let get_dpop_proof_exn = function - | OAuth {proof; _} | DPoP {proof} -> - proof - | _ -> - Errors.invalid_request "invalid DPoP header" + Errors.auth_required "Invalid authorization header" let get_session_info identifier db = let%lwt actor = @@ -92,7 +84,7 @@ let get_session_info identifier db = module Verifiers = struct open struct let parse_header req expected_type = - match Dream.header req "Authorization" with + match Dream.header req "authorization" with | Some header -> ( match String.split_on_char ' ' header with | [typ; token] @@ -103,7 +95,6 @@ module Verifiers = struct Error "invalid authorization header" ) | None -> Error "missing authorization header" - end let parse_basic req = match parse_header req "Basic" with @@ -121,8 +112,7 @@ module Verifiers = struct Error "invalid basic authorization header" let parse_bearer req = parse_header req "Bearer" - - let parse_dpop req = parse_header req "DPoP" + end type ctx = {req: Dream.request; db: Data_store.t} @@ -132,7 +122,7 @@ module Verifiers = struct fun {req; _} -> match Dream.header req "authorization" with | Some _ -> - Lwt.return_error @@ Errors.auth_required "invalid authorization header" + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" | None -> Lwt.return_ok Unauthenticated @@ -144,11 +134,11 @@ module Verifiers = struct | "admin", p when p = Env.admin_password -> Lwt.return_ok Admin | _ -> - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) | Error _ -> - Lwt.return_error @@ Errors.auth_required "invalid authorization header" + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" - let bearer : verifier = + let access : verifier = fun {req; db} -> match parse_bearer req with | Ok jwt -> ( @@ -160,79 +150,13 @@ module Verifiers = struct | Some {deactivated_at= Some _; _} -> Lwt.return_error @@ Errors.auth_required ~name:"AccountDeactivated" - "account is deactivated" + "Account is deactivated" | None -> - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) | Error _ -> - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) | Error _ -> - Lwt.return_error @@ Errors.auth_required "invalid authorization header" - - let dpop : verifier = - fun {req; _} -> - let dpop_header = Dream.header req "DPoP" in - match - Oauth.Dpop.verify_dpop_proof - ~mthd:(Dream.method_to_string @@ Dream.method_ req) - ~url:(Dream.target req) ~dpop_header () - with - | Error "use_dpop_nonce" -> - Lwt.return_error @@ Errors.use_dpop_nonce () - | Error e -> - Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e) - | Ok proof -> - Lwt.return_ok (DPoP {proof}) - - let oauth : verifier = - fun {req; db} -> - match parse_dpop req with - | Error e -> - Lwt.return_error @@ Errors.invalid_request ("dpop error: " ^ e) - | Ok token -> ( - match%lwt dpop {req; db} with - | Error e -> - Lwt.return_error e - | Ok (DPoP {proof}) -> ( - match Jwt.verify_jwt token Env.jwt_key with - | Error e -> - Lwt.return_error @@ Errors.auth_required e - | Ok (_header, claims) -> ( - let open Yojson.Safe.Util in - try - let did = claims |> member "sub" |> to_string in - let exp = claims |> member "exp" |> to_int in - let jkt_claim = - claims |> member "cnf" |> member "jkt" |> to_string - in - let now = int_of_float (Unix.gettimeofday ()) in - if jkt_claim <> proof.jkt then - Lwt.return_error @@ Errors.auth_required "dpop key mismatch" - else if exp < now then - Lwt.return_error @@ Errors.auth_required "token expired" - else - let%lwt session = - try%lwt - let%lwt sess = get_session_info did db in - Lwt.return_ok sess - with _ -> - Lwt.return_error - @@ Errors.auth_required "invalid credentials" - in - match session with - | Ok {active= Some true; _} -> - Lwt.return_ok (OAuth {did; proof}) - | Ok _ -> - Lwt.return_error - @@ Errors.auth_required ~name:"AccountDeactivated" - "account is deactivated" - | Error _ -> - Lwt.return_error - @@ Errors.auth_required "invalid credentials" - with _ -> - Lwt.return_error @@ Errors.auth_required "malformed JWT claims" ) - ) - | Ok _ -> - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" let refresh : verifier = fun {req; db} -> @@ -246,13 +170,13 @@ module Verifiers = struct | Some {deactivated_at= Some _; _} -> Lwt.return_error @@ Errors.auth_required ~name:"AccountDeactivated" - "account is deactivated" + "Account is deactivated" | None -> - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) | Error "" | Error _ -> - Lwt.return_error @@ Errors.auth_required "invalid credentials" ) + Lwt.return_error @@ Errors.auth_required "Invalid credentials" ) | Error _ -> - Lwt.return_error @@ Errors.auth_required "invalid authorization header" + Lwt.return_error @@ Errors.auth_required "Invalid authorization header" let authorization : verifier = fun ctx -> @@ -263,38 +187,24 @@ module Verifiers = struct | Some ("Basic" :: _) -> admin ctx | Some ("Bearer" :: _) -> - bearer ctx - | Some ("DPoP" :: _) -> - oauth ctx + access ctx | _ -> Lwt.return_error @@ Errors.auth_required ~name:"InvalidToken" - "unexpected authorization type" + "Unexpected authorization type" let any : verifier = fun ctx -> try authorization ctx with _ -> unauthenticated ctx - type t = - | Unauthenticated - | Admin - | Bearer - | DPoP - | OAuth - | Refresh - | Authorization - | Any + type t = Unauthenticated | Admin | Access | Refresh | Authorization | Any let of_t = function | Unauthenticated -> unauthenticated | Admin -> admin - | Bearer -> - bearer - | DPoP -> - dpop - | OAuth -> - oauth + | Access -> + access | Refresh -> refresh | Authorization -> diff --git a/pegasus/lib/data_store.ml b/pegasus/lib/data_store.ml index 3628d7a..7b27372 100644 --- a/pegasus/lib/data_store.ml +++ b/pegasus/lib/data_store.ml @@ -71,7 +71,6 @@ module Queries = struct |sql}] () conn in - let$! () = [%rapper execute (* no need to store issued tokens, just revoked ones; stolen from millipds https://github.com/DavidBuchanan314/millipds/blob/8f89a01e7d367a2a46f379960e9ca50347dcce71/src/millipds/database.py#L253 *) @@ -83,95 +82,6 @@ module Queries = struct ) |sql}] () conn - in - let$! () = - [%rapper - execute - {sql| CREATE TABLE IF NOT EXISTS oauth_requests ( - request_id TEXT PRIMARY KEY, - client_id TEXT NOT NULL, - request_data TEXT NOT NULL, - dpop_jkt TEXT, - expires_at INTEGER NOT NULL, - created_at INTEGER NOT NULL - ) - |sql}] - () conn - in - let$! () = - [%rapper - execute - {sql| CREATE TABLE IF NOT EXISTS oauth_codes ( - code TEXT PRIMARY KEY, - request_id TEXT NOT NULL REFERENCES oauth_requests(request_id) ON DELETE CASCADE, - authorized_by TEXT, - authorized_at INTEGER, - expires_at INTEGER NOT NULL, - used BOOLEAN DEFAULT FALSE - ) - |sql}] - () conn - in - let$! () = - [%rapper - execute - {sql| CREATE TABLE IF NOT EXISTS oauth_tokens ( - refresh_token TEXT UNIQUE NOT NULL, - client_id TEXT NOT NULL, - did TEXT NOT NULL, - dpop_jkt TEXT, - scope TEXT NOT NULL, - expires_at INTEGER NOT NULL - ) - |sql}] - () conn - in - let$! () = - [%rapper - execute - {sql| CREATE INDEX IF NOT EXISTS oauth_requests_expires_idx ON oauth_requests(expires_at); - CREATE INDEX IF NOT EXISTS oauth_codes_expires_idx ON oauth_codes(expires_at); - CREATE INDEX IF NOT EXISTS oauth_tokens_refresh_idx ON oauth_tokens(refresh_token); - |sql}] - () conn - in - let$! () = - [%rapper - execute - {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_requests - AFTER INSERT ON oauth_requests - BEGIN - DELETE FROM oauth_requests WHERE expires_at < unixepoch() * 1000; - END - |sql} - syntax_off] - () conn - in - let$! () = - [%rapper - execute - {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_codes - AFTER INSERT ON oauth_codes - BEGIN - DELETE FROM oauth_codes WHERE expires_at < unixepoch() * 1000 OR used = 1; - END - |sql} - syntax_off] - () conn - in - let$! () = - [%rapper - execute - {sql| CREATE TRIGGER IF NOT EXISTS cleanup_expired_oauth_tokens - AFTER INSERT ON oauth_tokens - BEGIN - DELETE FROM oauth_tokens WHERE expires_at < unixepoch() * 1000; - END - |sql} - syntax_off] - () conn - in - Lwt.return_ok () let create_actor = [%rapper @@ -311,8 +221,6 @@ end type t = Util.caqti_pool let connect ?create ?write () : t Lwt.t = - if create = Some true then - Util.mkfile_p Util.Constants.pegasus_db_filepath ~perm:0o644 ; Util.connect_sqlite ?create ?write Util.Constants.pegasus_db_location let init conn : unit Lwt.t = Util.use_pool conn Queries.create_tables diff --git a/pegasus/lib/dune b/pegasus/lib/dune index 03d9eab..f8fdf84 100644 --- a/pegasus/lib/dune +++ b/pegasus/lib/dune @@ -9,7 +9,6 @@ cohttp-lwt-unix dns-client.unix dream - html_of_jsx ipld kleidos lwt @@ -19,13 +18,12 @@ safepass str timedesc - uri uuidm yojson lwt_ppx ppx_deriving_yojson.runtime ppx_rapper_lwt) (preprocess - (pps html_of_jsx.ppx lwt_ppx ppx_deriving_yojson ppx_rapper))) + (pps lwt_ppx ppx_deriving_yojson ppx_rapper))) (include_subdirs qualified) diff --git a/pegasus/lib/env.ml b/pegasus/lib/env.ml index b2c65be..f06f5eb 100644 --- a/pegasus/lib/env.ml +++ b/pegasus/lib/env.ml @@ -1,35 +1,15 @@ -let getenv name = - try Sys.getenv name - with Not_found -> failwith ("Missing environment variable " ^ name) - let data_dir = Option.value ~default:"./data" @@ Sys.getenv_opt "DATA_DIR" -let hostname = getenv "PDS_HOSTNAME" +let hostname = Sys.getenv "PDS_HOSTNAME" let did = Option.value ~default:("did:web:" ^ hostname) @@ Sys.getenv_opt "PDS_DID" -let invite_required = getenv "INVITE_CODE_REQUIRED" = "true" - -let rotation_key = getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str +let invite_required = Sys.getenv "INVITE_CODE_REQUIRED" = "true" -let jwt_key = getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str +let rotation_key = + Sys.getenv "ROTATION_KEY_MULTIBASE" |> Kleidos.parse_multikey_str -let admin_password = getenv "ADMIN_PASSWORD" +let jwt_key = Sys.getenv "JWK_MULTIBASE" |> Kleidos.parse_multikey_str -let dpop_nonce_secret = - match Sys.getenv_opt "DPOP_NONCE_SECRET" with - | Some sec -> - let secret = - Base64.(decode_exn ~alphabet:uri_safe_alphabet ~pad:false) sec - |> Bytes.of_string - in - if Bytes.length secret = 32 then secret - else failwith "DPOP_NONCE_SECRET must be 32 bytes in base64uri" - | None -> - let secret = Mirage_crypto_rng_unix.getrandom 32 in - Dream.warning (fun log -> - log "DPOP_NONCE_SECRET not set; using DPOP_NONCE_SECRET=%s" - ( Base64.(encode ~alphabet:uri_safe_alphabet ~pad:false) secret - |> Result.get_ok ) ) ; - Bytes.of_string secret +let admin_password = Sys.getenv "ADMIN_PASSWORD" diff --git a/pegasus/lib/errors.ml b/pegasus/lib/errors.ml index 1c3fa23..9b4248b 100644 --- a/pegasus/lib/errors.ml +++ b/pegasus/lib/errors.ml @@ -4,8 +4,6 @@ exception InternalServerError of (string * string) exception AuthError of (string * string) -exception UseDpopNonceError - let is_xrpc_error = function | InvalidRequestError _ | InternalServerError _ | AuthError _ -> true @@ -21,8 +19,6 @@ let internal_error ?(name = "InternalServerError") let auth_required ?(name = "AuthRequired") msg = raise (AuthError (name, msg)) -let use_dpop_nonce () = raise UseDpopNonceError - let exn_to_response exn = let format_response error msg status = Dream.json ~status @@ Yojson.Safe.to_string @@ -35,8 +31,6 @@ let exn_to_response exn = format_response error message `Internal_Server_Error | AuthError (error, message) -> format_response error message `Unauthorized - | UseDpopNonceError -> - Dream.json ~status:`Bad_Request {|{ "error": "use_dpop_nonce" }|} | _ -> format_response "InternalServerError" "Internal server error" `Internal_Server_Error diff --git a/pegasus/lib/id_resolver.ml b/pegasus/lib/id_resolver.ml index 43ef302..32d6593 100644 --- a/pegasus/lib/id_resolver.ml +++ b/pegasus/lib/id_resolver.ml @@ -1,4 +1,5 @@ open Cohttp_lwt +open Cohttp_lwt_unix let did_regex = Str.regexp {|^did:([a-z]+):([a-zA-Z0-9._:%\-]*[a-zA-Z0-9._\-])$|} @@ -11,7 +12,7 @@ module Handle = struct let uri = Uri.of_string ("https://" ^ handle ^ "/.well-known/atproto-did") in - let%lwt {status; _}, body = Util.http_get uri in + let%lwt {status; _}, body = Client.get uri in match status with | `OK -> let%lwt did = Body.to_string body in @@ -163,7 +164,7 @@ module Did = struct ~path:(Uri.pct_encode did) () in let%lwt {status; _}, body = - Util.http_get uri + Client.get uri ~headers:(Cohttp.Header.of_list [("Accept", "application/json")]) in match status with @@ -185,7 +186,7 @@ module Did = struct ~path:"/.well-known/did.json" () in let%lwt {status; _}, body = - Util.http_get uri + Client.get uri ~headers:(Cohttp.Header.of_list [("Accept", "application/json")]) in match status with diff --git a/pegasus/lib/jwt.ml b/pegasus/lib/jwt.ml index 3e32ff3..26f4160 100644 --- a/pegasus/lib/jwt.ml +++ b/pegasus/lib/jwt.ml @@ -19,9 +19,9 @@ let b64_encode str = let b64_decode str = match Base64.decode ~pad:false ~alphabet:Base64.uri_safe_alphabet str with | Ok s -> - s + Ok s | Error (`Msg e) -> - failwith e + Error e let extract_signature_components signature = if Bytes.length signature <> 64 then failwith "expected 64 byte jwt signature" @@ -30,7 +30,7 @@ let extract_signature_components signature = let s = Bytes.sub signature 32 32 in (r, s) -let sign_jwt payload ?(typ = "JWT") signing_key = +let sign_jwt payload signing_key = let _, (module Curve : Kleidos.CURVE) = signing_key in let alg = match Curve.name with @@ -51,7 +51,7 @@ let sign_jwt payload ?(typ = "JWT") signing_key = failwith "invalid curve" in let header_json = - `Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String typ)] + `Assoc [("alg", `String alg); ("crv", `String crv); ("typ", `String "JWT")] in let encoded_header = header_json |> Yojson.Safe.to_string |> b64_encode in let encoded_payload = payload |> Yojson.Safe.to_string |> b64_encode in @@ -65,24 +65,32 @@ let sign_jwt payload ?(typ = "JWT") signing_key = let decode_jwt jwt = match String.split_on_char '.' jwt with | [header_b64; payload_b64; _] -> ( + match (b64_decode header_b64, b64_decode payload_b64) with + | Ok header_str, Ok payload_str -> ( try - let header = Yojson.Safe.from_string (b64_decode header_b64) in - let payload = Yojson.Safe.from_string (b64_decode payload_b64) in + let header = Yojson.Safe.from_string header_str in + let payload = Yojson.Safe.from_string payload_str in Ok (header, payload) - with _ -> Error "invalid jwt" ) + with _ -> Error "invalid json in jwt" ) + | Error e, _ | _, Error e -> + Error e ) | _ -> Error "invalid jwt format" let verify_jwt jwt pubkey = match String.split_on_char '.' jwt with - | [header_b64; payload_b64; signature_b64] -> - let signature = Bytes.of_string (b64_decode signature_b64) in + | [header_b64; payload_b64; signature_b64] -> ( + match b64_decode signature_b64 with + | Error e -> + Error e + | Ok signature_str -> + let signature = Bytes.of_string signature_str in let signing_input = header_b64 ^ "." ^ payload_b64 in let verified = Kleidos.verify ~pubkey ~msg:(Bytes.of_string signing_input) ~signature in if verified then decode_jwt jwt - else Error "jwt signature verification failed" + else Error "jwt signature verification failed" ) | _ -> Error "invalid jwt format" @@ -90,9 +98,7 @@ let generate_jwt did = let now_s = int_of_float (Unix.gettimeofday ()) in let access_exp = now_s + Defaults.access_token_exp in let refresh_exp = now_s + Defaults.refresh_token_exp in - let jti = - Uuidm.v4_gen (Random.State.make_self_init ()) () |> Uuidm.to_string - in + let jti = Uuidm.v4_gen (Random.get_state ()) () |> Uuidm.to_string in let access_payload = symmetric_jwt_to_yojson { scope= "com.atproto.access" diff --git a/pegasus/lib/oauth/client.ml b/pegasus/lib/oauth/client.ml deleted file mode 100644 index d460457..0000000 --- a/pegasus/lib/oauth/client.ml +++ /dev/null @@ -1,45 +0,0 @@ -open Types - -let fetch_client_metadata client_id : client_metadata Lwt.t = - let%lwt {status; _}, res = Util.http_get (Uri.of_string client_id) in - if status <> `OK then - let%lwt () = Cohttp_lwt.Body.drain_body res in - failwith - (Printf.sprintf "client metadata not found; http %d" - (Cohttp.Code.code_of_status status) ) - else - let%lwt body = Cohttp_lwt.Body.to_string res in - let json = Yojson.Safe.from_string body in - let metadata = - match client_metadata_of_yojson json with - | Ok metadata -> - metadata - | Error err -> - failwith err - in - if metadata.client_id <> client_id then failwith "client_id mismatch" - else - let scopes = String.split_on_char ' ' metadata.scope in - if not (List.mem "atproto" scopes) then - failwith "scope must include 'atproto'" - else - List.iter - (function - | "authorization_code" | "refresh_token" -> - () - | grant -> - failwith ("invalid grant type: " ^ grant) ) - metadata.grant_types ; - List.iter - (fun uri -> - let u = Uri.of_string uri in - let host = Uri.host u in - match Uri.scheme u with - | Some "https" when host <> Some "localhost" -> - () - | Some "http" when host = Some "127.0.0.1" || host = Some "[::1]" -> - () - | _ -> - failwith ("invalid redirect_uri: " ^ uri) ) - metadata.redirect_uris ; - Lwt.return metadata diff --git a/pegasus/lib/oauth/constants.ml b/pegasus/lib/oauth/constants.ml deleted file mode 100644 index cedbe25..0000000 --- a/pegasus/lib/oauth/constants.ml +++ /dev/null @@ -1,15 +0,0 @@ -let max_dpop_age_s = 60 - -let dpop_rotation_interval_ms = 60_000L - -let jti_ttl_s = 3600 - -let jti_cache_size = 10_000 - -let par_request_ttl_ms = 300_000 - -let code_expiry_ms = 300_000 - -let access_token_expiry_ms = 60 * 60 * 1000 - -let request_uri_prefix = "urn:ietf:params:oauth:request_uri:" diff --git a/pegasus/lib/oauth/dpop.ml b/pegasus/lib/oauth/dpop.ml deleted file mode 100644 index a083146..0000000 --- a/pegasus/lib/oauth/dpop.ml +++ /dev/null @@ -1,204 +0,0 @@ -type nonce_state = - { secret: bytes - ; mutable counter: int64 - ; mutable prev: string - ; mutable curr: string - ; mutable next: string - ; rotation_interval_ms: int64 } - -type ec_jwk = {crv: string; kty: string; x: string; y: string} -[@@deriving yojson] - -type proof = {jti: string; jkt: string; htm: string; htu: string} -[@@deriving yojson] - -let jti_cache : (string, int) Hashtbl.t = - Hashtbl.create Constants.jti_cache_size - -let cleanup_jti_cache () = - let now = int_of_float (Unix.gettimeofday ()) in - Hashtbl.filter_map_inplace - (fun _ expires_at -> if expires_at > now then Some expires_at else None) - jti_cache - -let compute_nonce secret counter = - let data = Bytes.create 8 in - Bytes.set_int64_be data 0 counter ; - Digestif.SHA256.( - hmac_bytes ~key:(Bytes.to_string secret) data - |> to_raw_string |> Jwt.b64_encode ) - -let create_nonce_state secret = - let counter = - Int64.div - (Int64.of_float (Unix.gettimeofday () *. 1000.)) - Constants.dpop_rotation_interval_ms - in - { secret - ; counter - ; prev= compute_nonce secret (Int64.pred counter) - ; curr= compute_nonce secret counter - ; next= compute_nonce secret (Int64.succ counter) - ; rotation_interval_ms= Constants.dpop_rotation_interval_ms } - -let nonce_state = ref (create_nonce_state Env.dpop_nonce_secret) - -let next_nonce () = - let now_counter = - Int64.div - (Int64.of_float (Unix.gettimeofday () *. 1000.)) - !nonce_state.rotation_interval_ms - in - if now_counter <> !nonce_state.counter then ( - !nonce_state.prev <- !nonce_state.curr ; - !nonce_state.curr <- !nonce_state.next ; - !nonce_state.next <- - compute_nonce !nonce_state.secret (Int64.succ now_counter) ; - !nonce_state.counter <- now_counter ) ; - !nonce_state.next - -let verify_nonce nonce = - let valid = - nonce = !nonce_state.prev || nonce = !nonce_state.curr - || nonce = !nonce_state.next - in - ignore next_nonce ; valid - -let add_jti jti = - let expires_at = int_of_float (Unix.gettimeofday ()) + Constants.jti_ttl_s in - if Hashtbl.mem jti_cache jti then false (* replay *) - else ( - Hashtbl.add jti_cache jti expires_at ; - (* clean up every once in a while *) - if Hashtbl.length jti_cache mod 100 = 0 then cleanup_jti_cache () ; - true ) - -let normalize_url url = - let uri = Uri.of_string url in - Uri.make ~scheme:"https" - ~host:(Uri.host uri |> Option.value ~default:Env.hostname) - ~path:(Uri.path uri) () - |> Uri.to_string - -let compute_jwk_thumbprint jwk = - let {crv; kty; x; y} = jwk in - let tp = - (* keys must be in lexicographic order *) - Printf.sprintf {|{"crv":"%s","kty":"%s","x":"%s","y":"%s"}|} crv kty x y - in - Digestif.SHA256.(digest_string tp |> to_raw_string |> Jwt.b64_encode) - -let verify_signature jwt jwk = - let parts = String.split_on_char '.' jwt in - match parts with - | [header_b64; payload_b64; sig_b64] -> - let signing_input = header_b64 ^ "." ^ payload_b64 in - let msg = Bytes.of_string signing_input in - let {x; y; crv; _} = jwk in - let x = x |> Jwt.b64_decode |> Bytes.of_string in - let y = y |> Jwt.b64_decode |> Bytes.of_string in - let pubkey = Bytes.cat (Bytes.of_string "\x04") (Bytes.cat x y) in - let pubkey = - ( pubkey - , match crv with - | "secp256k1" -> - (module Kleidos.K256 : Kleidos.CURVE) - | "P-256" -> - (module Kleidos.P256 : Kleidos.CURVE) - | _ -> - failwith "unsupported algorithm" ) - in - let sig_bytes = Jwt.b64_decode sig_b64 |> Bytes.of_string in - let r = Bytes.sub sig_bytes 0 32 in - let s = Bytes.sub sig_bytes 32 32 in - let signature = Bytes.cat r s in - Kleidos.verify ~pubkey ~msg ~signature - | _ -> - false - -let verify_dpop_proof ~mthd ~url ~dpop_header ?access_token () = - match dpop_header with - | None -> - Error "missing dpop header" - | Some jwt -> ( - let open Yojson.Safe.Util in - match String.split_on_char '.' jwt with - | [header_b64; payload_b64; _] -> ( - let header = Yojson.Safe.from_string (Jwt.b64_decode header_b64) in - let payload = Yojson.Safe.from_string (Jwt.b64_decode payload_b64) in - let typ = header |> member "typ" |> to_string in - if typ <> "dpop+jwt" then Error "invalid typ in dpop proof" - else - let alg = header |> member "alg" |> to_string in - if alg <> "ES256" && alg <> "ES256K" then - Error "only es256 and es256k supported for dpop" - else - let jwk = - header |> member "jwk" |> ec_jwk_of_yojson |> Result.get_ok - in - if - not - ( match (alg, jwk.crv) with - | "ES256", "P-256" -> - true - | "ES256K", "secp256k1" -> - true - | _ -> - false ) - then - Error - (Printf.sprintf "algorithm %s doesn't match curve %s" alg - jwk.crv ) - else - let jti = payload |> member "jti" |> to_string in - let htm = payload |> member "htm" |> to_string in - let htu = payload |> member "htu" |> to_string in - let iat = payload |> member "iat" |> to_int in - let nonce_claim = - payload |> member "nonce" |> to_string_option - in - match nonce_claim with - (* error must be this string; see https://datatracker.ietf.org/doc/html/rfc9449#section-8 *) - | None -> - Error "use_dpop_nonce" - | Some n when not (verify_nonce n) -> - Error "use_dpop_nonce" - | Some _ -> ( - if htm <> mthd then Error "htm mismatch" - else if - not (String.equal (normalize_url htu) (normalize_url url)) - then Error "htu mismatch" - else - let now = int_of_float (Unix.gettimeofday ()) in - if now - iat > Constants.max_dpop_age_s then - Error "dpop proof too old" - else if iat - now > 5 then Error "dpop proof in future" - else if not (add_jti jti) then - Error "dpop proof replay detected" - else if not (verify_signature jwt jwk) then - Error "invalid dpop signature" - else - let jkt = compute_jwk_thumbprint jwk in - (* verify ath if access token is provided *) - match access_token with - | Some token -> - let ath_claim = - payload |> member "ath" |> to_string_option - in - let expected_ath = - Digestif.SHA256.( - digest_string token |> to_raw_string - |> Jwt.b64_encode ) - in - if Some expected_ath <> ath_claim then - Error "ath mismatch" - else Ok {jti; jkt; htm; htu} - | None -> - let ath_claim = - payload |> member "ath" |> to_string_option - in - if ath_claim <> None then - Error "ath claim not allowed without access token" - else Ok {jti; jkt; htm; htu} ) ) - | _ -> - Error "invalid dpop jwt" ) diff --git a/pegasus/lib/oauth/queries.ml b/pegasus/lib/oauth/queries.ml deleted file mode 100644 index 6fa9d89..0000000 --- a/pegasus/lib/oauth/queries.ml +++ /dev/null @@ -1,138 +0,0 @@ -[@@@warning "-missing-record-field-pattern"] - -open Types - -let insert_par_request conn req = - Util.use_pool conn - @@ [%rapper - execute - {sql| - INSERT INTO oauth_requests (request_id, client_id, request_data, dpop_jkt, expires_at, created_at) - VALUES (%string{request_id}, %string{client_id}, %string{request_data}, %string?{dpop_jkt}, %int{expires_at}, %int{created_at}) - |sql} - record_in] - req - -let get_par_request conn request_id = - Util.use_pool conn - @@ [%rapper - get_opt - {sql| - SELECT @string{request_id}, @string{client_id}, @string{request_data}, - @string?{dpop_jkt}, @int{expires_at}, @int{created_at} - FROM oauth_requests - WHERE request_id = %string{request_id} - AND expires_at > %int{now} - |sql} - record_out] - ~request_id ~now:(Util.now_ms ()) - -let insert_auth_code conn code = - Util.use_pool conn - @@ [%rapper - execute - {sql| - INSERT INTO oauth_codes (code, request_id, authorized_by, authorized_at, expires_at, used) - VALUES (%string{code}, %string{request_id}, %string?{authorized_by}, %int?{authorized_at}, %int{expires_at}, 0) - |sql} - record_in] - code - -let get_auth_code conn code = - Util.use_pool conn - @@ [%rapper - get_opt - {sql| - SELECT @string{code}, @string{request_id}, @string?{authorized_by}, - @int?{authorized_at}, @int{expires_at}, @bool{used} - FROM oauth_codes - WHERE code = %string{code} - |sql} - record_out] - ~code - -let activate_auth_code conn code did = - let authorized_at = Util.now_ms () in - Util.use_pool conn - @@ [%rapper - execute - {sql| - UPDATE oauth_codes - SET authorized_by = %string{did}, - authorized_at = %int{authorized_at} - WHERE code = %string{code} - |sql}] - ~did ~authorized_at ~code - -let consume_auth_code conn code = - Util.use_pool conn - @@ [%rapper - get_opt - {sql| - UPDATE oauth_codes - SET used = 1 - WHERE code = %string{code} AND used = 0 - RETURNING @string{code}, @string{request_id}, @string?{authorized_by}, - @int?{authorized_at}, @int{expires_at}, @bool{used} - |sql} - record_out] - ~code - -let insert_oauth_token conn token = - Util.use_pool conn - @@ [%rapper - execute - {sql| - INSERT INTO oauth_tokens (refresh_token, client_id, did, dpop_jkt, scope, expires_at) - VALUES (%string{refresh_token}, %string{client_id}, %string{did}, %string{dpop_jkt}, %string{scope}, %int{expires_at}) - |sql} - record_in] - token - -let get_oauth_token_by_refresh conn refresh_token = - Util.use_pool conn - @@ [%rapper - get_opt - {sql| - SELECT @string{refresh_token}, @string{client_id}, @string{did}, - @string{dpop_jkt}, @string{scope}, @int{expires_at} - FROM oauth_tokens - WHERE refresh_token = %string{refresh_token} - |sql} - record_out] - ~refresh_token - -let update_oauth_token conn ~old_refresh_token ~new_refresh_token ~expires_at = - Util.use_pool conn - @@ [%rapper - execute - {sql| - UPDATE oauth_tokens - SET refresh_token = %string{new_refresh_token}, - expires_at = %int{expires_at} - WHERE refresh_token = %string{old_refresh_token} - |sql}] - ~new_refresh_token ~expires_at ~old_refresh_token - -let delete_oauth_token_by_refresh conn refresh_token = - Util.use_pool conn - @@ [%rapper - execute - {sql| - DELETE FROM oauth_tokens WHERE refresh_token = %string{refresh_token} - |sql}] - ~refresh_token - -let get_oauth_tokens_by_did conn did = - Util.use_pool conn - @@ [%rapper - get_many - {sql| - SELECT @string{refresh_token}, @string{client_id}, @string{did}, - @string{dpop_jkt}, @string{scope}, @int{expires_at} - FROM oauth_tokens - WHERE did = %string{did} - ORDER BY expires_at ASC - |sql} - record_out] - ~did diff --git a/pegasus/lib/oauth/types.ml b/pegasus/lib/oauth/types.ml deleted file mode 100644 index 0fd1333..0000000 --- a/pegasus/lib/oauth/types.ml +++ /dev/null @@ -1,71 +0,0 @@ -type par_request = - { client_id: string - ; response_type: string - ; response_mode: string option [@default None] - ; redirect_uri: string - ; scope: string - ; state: string - ; code_challenge: string - ; code_challenge_method: string - ; login_hint: string option [@default None] - ; dpop_jkt: string option [@default None] - ; client_assertion_type: string option [@default None] - ; client_assertion: string option [@default None] } -[@@deriving yojson {strict= false}] - -type token_request = - { grant_type: string - ; code: string option [@default None] - ; redirect_uri: string option [@default None] - ; code_verifier: string option [@default None] - ; refresh_token: string option [@default None] - ; client_id: string - ; client_assertion_type: string option [@default None] - ; client_assertion: string option [@default None] } -[@@deriving yojson {strict= false}] - -type client_metadata = - { client_id: string - ; client_name: string option [@default None] - ; client_uri: string - ; redirect_uris: string list - ; grant_types: string list - ; response_types: string list - ; scope: string - ; token_endpoint_auth_method: string - ; token_endpoint_auth_signing_alg: string option [@default None] - ; application_type: string - ; dpop_bound_access_tokens: bool - ; jwks_uri: string option [@default None] - ; jwks: Yojson.Safe.t option [@default None] } -[@@deriving yojson {strict= false}] - -type dpop_proof = {jti: string; jkt: string; htm: string; htu: string} -[@@deriving yojson {strict= false}] - -type oauth_request = - { request_id: string - ; client_id: string - ; request_data: string - ; dpop_jkt: string option [@default None] - ; expires_at: int - ; created_at: int } -[@@deriving yojson {strict= false}] - -type oauth_code = - { code: string - ; request_id: string - ; authorized_by: string option [@default None] - ; authorized_at: int option [@default None] - ; expires_at: int - ; used: bool } -[@@deriving yojson {strict= false}] - -type oauth_token = - { refresh_token: string - ; client_id: string - ; did: string - ; dpop_jkt: string - ; scope: string - ; expires_at: int } -[@@deriving yojson {strict= false}] diff --git a/pegasus/lib/plc.ml b/pegasus/lib/plc.ml index 02740a0..e680832 100644 --- a/pegasus/lib/plc.ml +++ b/pegasus/lib/plc.ml @@ -302,7 +302,7 @@ let get_audit_log ?endpoint did : (audit_log, string) Lwt_result.t = did in let headers = Http.Header.init_with "Accept" "application/json" in - let%lwt res, body = Util.http_get ~headers uri in + let%lwt res, body = Client.get ~headers uri in match res.status with | `OK -> let%lwt body = Body.to_string body in diff --git a/pegasus/lib/templates/components/button.mlx b/pegasus/lib/templates/components/button.mlx deleted file mode 100644 index fd8bb0b..0000000 --- a/pegasus/lib/templates/components/button.mlx +++ /dev/null @@ -1,33 +0,0 @@ -let base_classes = - "py-1 px-4 text-lg rounded-lg w-full flex items-center justify-center \ - transition delay-50 duration-300 focus-visible:outline-none disabled:text-mist-80" - -type kind = Primary | Secondary | Tertiary | Danger - -let classes = function - | Primary -> - base_classes - ^ " bg-white font-serif text-mana-200 shadow-whisper \ - hover:shadow-shimmer hover:bg-mist-20 focus-visible:shadow-shimmer \ - focus-visible:bg-mist-20 active:shadow-glow disabled:bg-mana-40" - | Secondary -> - base_classes - ^ " bg-feather font-serif underline text-mana-100 hover:no-underline \ - focus-visible:shadow-whisper active:shadow-whisper disabled:no-underline \ - disabled:bg-mana-40" - | Tertiary -> - base_classes - ^ " font-sans underline text-mana-100 hover:no-underline \ - focus-visible:text-mana-200 active:text-mana-200" - | Danger -> - base_classes - ^ " bg-white font-serif text-phoenix-100 shadow-bleed hover:bg-mist-20 \ - hover:text-phoenix-40 focus:bg-mist-20 focus:text-phoenix-40 \ - focus-visible:outline-none active:bg-phoenix-40 active:text-mist-20 \ - disabled:bg-mana-40" - -let make ?id ?name ?(kind = Primary) ?(type_ = "button") ?onclick ?value - ?(class_ = "") ~children () = - diff --git a/pegasus/lib/templates/components/input.mlx b/pegasus/lib/templates/components/input.mlx deleted file mode 100644 index 093216e..0000000 --- a/pegasus/lib/templates/components/input.mlx +++ /dev/null @@ -1,56 +0,0 @@ -open JSX - -(* putting this inline messes with ocamlformat-mlx *) -let req_marker = " *" - -let make ?id ~name ?(class_ = "") ?(type_ = "text") ?label ?(sr_only = false) - ?value ?placeholder ?(required = false) ?(disabled = false) ?trailing () = - let id = Option.value id ~default:name in - let placeholder = if label <> None && sr_only then label else placeholder in - let input = - - in -
- ( match label with - | Some label -> -
- - ( if required then null - else "optional" ) -
- | None -> - null ) - ( if type_ = "hidden" then input - else -
- input - ( match trailing with - | Some trailing -> -
trailing
- | None -> - null ) -
) -
diff --git a/pegasus/lib/templates/icons/circle_alert.mlx b/pegasus/lib/templates/icons/circle_alert.mlx deleted file mode 100644 index 24c890d..0000000 --- a/pegasus/lib/templates/icons/circle_alert.mlx +++ /dev/null @@ -1,11 +0,0 @@ -let make ?class_ () = - - - diff --git a/pegasus/lib/templates/layout.mlx b/pegasus/lib/templates/layout.mlx deleted file mode 100755 index 5a26067..0000000 --- a/pegasus/lib/templates/layout.mlx +++ /dev/null @@ -1,16 +0,0 @@ -open JSX - -let make ?(title = "Pegasus") ~children () = - - - - - - (string title) - - - children - - diff --git a/pegasus/lib/templates/login.mlx b/pegasus/lib/templates/login.mlx deleted file mode 100755 index c8eae6e..0000000 --- a/pegasus/lib/templates/login.mlx +++ /dev/null @@ -1,35 +0,0 @@ -open JSX -open Components - -let make ~redirect_url ?error ~csrf_token () = - -
-

"sign in"

- - "Enter your handle, email address, or DID, and your password." - -
- - - - - ( match error with - | Some error -> - - (string error) - - | None -> - null ) - -
- - "Or " - - "create an account" - - "." - -
- diff --git a/pegasus/lib/templates/oauth_authorize.mlx b/pegasus/lib/templates/oauth_authorize.mlx deleted file mode 100755 index 47864c4..0000000 --- a/pegasus/lib/templates/oauth_authorize.mlx +++ /dev/null @@ -1,64 +0,0 @@ -open JSX -open Components - -let cimd_suffix_len = String.length "/oauth-client-metadata.json" - -let make ~(metadata : Oauth.Types.client_metadata) ~handle ~scopes ~code - ~request_uri ~csrf_token () = - let client_id = Uri.of_string metadata.client_id in - let raw_host = Uri.host client_id |> Option.get in - let path = Uri.path client_id in - let path = String.sub path 0 (String.length path - cimd_suffix_len) in - let hostname = raw_host ^ path in - let rendered_name = - match metadata.client_name with - | Some client_name -> - - (string client_name) - (string (" (" ^ hostname ^ ")")) - - | None when String.length path = 0 -> - (string hostname) - | None -> - - (string raw_host) (string path) - - in - let rendered_handle = - "@" (string handle) - in - -
-

- (string ("authorizing " ^ hostname)) -

-

- "You’re signing into " - rendered_name - " as " - rendered_handle - " and granting it the following permissions:" -

- -
- - - - - -
-
- diff --git a/pegasus/lib/util.ml b/pegasus/lib/util.ml index 169c55e..7a391e1 100644 --- a/pegasus/lib/util.ml +++ b/pegasus/lib/util.ml @@ -287,8 +287,12 @@ let find_blob_refs (record : Mist.Lex.repo_record) : Mist.Blob_ref.t list = let is_none = function None -> true | _ -> false let validate_handle handle = + if not @@ String.ends_with ~suffix:("." ^ Env.hostname) handle then + Error (Errors.InvalidRequestError ("InvalidHandle", "invalid handle suffix")) + else let front = - String.sub handle 0 (String.length handle - (String.length Env.hostname + 1)) + String.sub handle 0 + (String.length handle - (String.length Env.hostname + 1)) in if String.contains front '.' then Error @@ -297,7 +301,8 @@ let validate_handle handle = else match String.length front with | l when l < 3 -> - Error (Errors.InvalidRequestError ("InvalidHandle", "handle too short")) + Error + (Errors.InvalidRequestError ("InvalidHandle", "handle too short")) | l when l > 18 -> Error (Errors.InvalidRequestError ("InvalidHandle", "handle too long")) | _ -> @@ -319,48 +324,3 @@ let sig_matches_some_did_key ~did_keys ~signature ~msg = valid ) did_keys <> None - -let rec http_get ?(max_redirects = 5) ?headers uri = - let%lwt ans = Cohttp_lwt_unix.Client.get ?headers uri in - follow_redirect ~max_redirects uri ans - -and follow_redirect ~max_redirects request_uri (response, body) = - let status = Http.Response.status response in - (* the unconsumed body would otherwise leak memory *) - let%lwt () = - if status <> `OK then Cohttp_lwt.Body.drain_body body else Lwt.return_unit - in - match status with - | `OK -> - Lwt.return (response, body) - | `Permanent_redirect | `Moved_permanently -> - handle_redirect ~permanent:true ~max_redirects request_uri response - | `Found | `Temporary_redirect -> - handle_redirect ~permanent:false ~max_redirects request_uri response - | `Not_found | `Gone -> - failwith "not found" - | status -> - Printf.ksprintf failwith "unhandled status: %s" - (Cohttp.Code.string_of_status status) - -and handle_redirect ~permanent ~max_redirects request_uri response = - if max_redirects <= 0 then failwith "too many redirects" - else - let headers = Http.Response.headers response in - let location = Http.Header.get headers "location" in - match location with - | None -> - failwith "redirection without Location header" - | Some url -> - let uri = Uri.of_string url in - let%lwt () = - if permanent then - Logs_lwt.warn (fun m -> - m "Permanent redirection from %s to %s" - (Uri.to_string request_uri) - url ) - else Lwt.return_unit - in - http_get uri ~max_redirects:(max_redirects - 1) - -let copy_query req = Dream.all_queries req |> List.map (fun (k, v) -> (k, [v])) diff --git a/pegasus/lib/xrpc.ml b/pegasus/lib/xrpc.ml index a3295d5..366a68c 100644 --- a/pegasus/lib/xrpc.ml +++ b/pegasus/lib/xrpc.ml @@ -10,18 +10,18 @@ type handler = context -> Dream.response Lwt.t let handler ?(auth : Auth.Verifiers.t = Any) (hdlr : handler) (init : init) = let open Errors in let auth = Auth.Verifiers.of_t auth in - try%lwt match%lwt auth init with | Ok creds -> ( try%lwt hdlr {req= init.req; db= init.db; auth= creds} with e -> - if not (is_xrpc_error e) then log_exn ~req:init.req e ; + ( match is_xrpc_error e with + | true -> + () + | false -> + log_exn ~req:init.req e ) ; exn_to_response e ) | Error e -> exn_to_response e - with e -> - if not (is_xrpc_error e) then log_exn ~req:init.req e ; - exn_to_response e let parse_query (req : Dream.request) (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a = @@ -29,14 +29,16 @@ let parse_query (req : Dream.request) let queries = Dream.all_queries req in let query_json = `Assoc (List.map (fun (k, v) -> (k, `String v)) queries) in query_json |> of_yojson |> Result.get_ok - with _ -> Errors.invalid_request "invalid query string" + with _ -> Errors.invalid_request "Invalid query string" let parse_body (req : Dream.request) (of_yojson : Yojson.Safe.t -> ('a, string) result) : 'a Lwt.t = try%lwt let%lwt body = Dream.body req in body |> Yojson.Safe.from_string |> of_yojson |> Result.get_ok |> Lwt.return - with _ -> Errors.invalid_request "invalid request body" + with e -> + Errors.log_exn e ; + Errors.invalid_request "Invalid request body" let service_proxy (ctx : context) (proxy_header : string) = let did = Auth.get_authed_did_exn ctx.auth in @@ -85,7 +87,7 @@ let service_proxy (ctx : context) (proxy_header : string) = let headers = Http.Header.of_list [("Authorization", "Bearer " ^ jwt)] in match Dream.method_ ctx.req with | `GET -> ( - let%lwt res, body = Util.http_get uri ~headers in + let%lwt res, body = Client.get uri ~headers in match res.status with | `OK -> let%lwt body = Body.to_string body in @@ -119,30 +121,10 @@ let service_proxy (ctx : context) (proxy_header : string) = let service_proxy_middleware db inner_handler req = match Dream.header req "atproto-proxy" with | Some header -> - handler ~auth:Authorization (fun ctx -> service_proxy ctx header) {req; db} + handler ~auth:Access (fun ctx -> service_proxy ctx header) {req; db} | None -> inner_handler req -let dpop_middleware inner_handler req = - let%lwt res = inner_handler req in - match Dream.header req "DPoP" with - | Some _ -> - Dream.add_header res "DPoP-Nonce" (Oauth.Dpop.next_nonce ()) ; - Dream.add_header res "Access-Control-Expose-Headers" "DPoP-Nonce" ; - Lwt.return res - | None -> - Lwt.return res - -let cors_middleware inner_handler req = - let%lwt res = inner_handler req in - Dream.add_header res "Access-Control-Allow-Origin" "*" ; - Dream.add_header res "Access-Control-Allow-Methods" - "GET, POST, PUT, DELETE, OPTIONS" ; - Dream.add_header res "Access-Control-Allow-Headers" - "Content-Type, Authorization, DPoP" ; - Dream.add_header res "Access-Control-Max-Age" "86400" ; - Lwt.return res - let resolve_repo_did ctx repo = if String.starts_with ~prefix:"did:" repo then Lwt.return repo else diff --git a/public/fonts/Fragment.woff b/public/fonts/Fragment.woff deleted file mode 100644 index 76d12df..0000000 Binary files a/public/fonts/Fragment.woff and /dev/null differ diff --git a/public/fonts/Fragment.woff2 b/public/fonts/Fragment.woff2 deleted file mode 100644 index 2078dd3..0000000 Binary files a/public/fonts/Fragment.woff2 and /dev/null differ diff --git a/public/main.css b/public/main.css deleted file mode 100644 index 771d00b..0000000 --- a/public/main.css +++ /dev/null @@ -1,48 +0,0 @@ -@import "tailwindcss" source("../pegasus/lib/templates"); - -@font-face { - font-family: "Fragment"; - src: - url("fonts/Fragment.woff2") format("woff2"), - url("fonts/Fragment.woff") format("woff"); - font-weight: normal; - font-style: normal; - font-display: swap; -} - -@font-face { - font-family: "Geist"; - src: url("https://fonts.gstatic.com/s/geist/v4/gyByhwUxId8gMEwcGFWNOITd.woff2") - format("woff2"); - font-weight: 300 400; - font-style: normal; - font-display: swap; -} - -@theme { - --font-serif: Fragment, Georgia, "Times New Roman", Times, serif; - --font-sans: Geist, Helvetica, -apple-system, system-ui, sans-serif; - --font-weight-normal: 300; - --font-weight-medium: 400; - - --tracking-normal: 0.01em; - - --color-*: initial; - --color-white: #fff; - --color-feather-100: #c8cfd2; - --color-phoenix-40: #e499a6; - --color-phoenix-100: #db4c64; - --color-mana-40: #9b9eaa; - --color-mana-100: #6558a1; - --color-mana-200: #312b4d; - --color-mist-20: #ecedf8; - --color-mist-40: #dee1e3; - --color-mist-60: #a4a9ac; - --color-mist-80: #737579; - --color-mist-100: #4f4f53; - - --shadow-whisper: inset 0 0 1em #97baff8c; - --shadow-shimmer: inset 0 0 1em #79a7ed99; - --shadow-glow: inset 0 0 2em #2d37ba73; - --shadow-bleed: inset 0 0 2em #db4c6466; -} diff --git a/tailwindcss.opam b/tailwindcss.opam deleted file mode 100644 index a7bbe6d..0000000 --- a/tailwindcss.opam +++ /dev/null @@ -1,27 +0,0 @@ -# This file is generated by dune, edit dune-project instead -opam-version: "2.0" -maintainer: ["futurGH"] -authors: ["futurGH"] -license: "MPL-2.0" -homepage: "https://github.com/futurGH/pegasus" -bug-reports: "https://github.com/futurGH/pegasus/issues" -depends: [ - "dune" {>= "3.20"} - "odoc" {with-doc} -] -build: [ - ["dune" "subst"] {dev} - [ - "dune" - "build" - "-p" - name - "-j" - jobs - "@install" - "@runtest" {with-test} - "@doc" {with-doc} - ] -] -dev-repo: "git+https://github.com/futurGH/pegasus.git" -x-maintenance-intent: ["(latest)"] diff --git a/tools/tailwindcss/dune b/tools/tailwindcss/dune deleted file mode 100644 index 79d1ff1..0000000 --- a/tools/tailwindcss/dune +++ /dev/null @@ -1,88 +0,0 @@ -(rule - (target tailwindcss-linux-x64) - (action - (progn - (with-stdout-to - %{target} - (bash - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) - (run chmod +x %{target})))) - -(rule - (target tailwindcss-linux-arm64) - (action - (progn - (with-stdout-to - %{target} - (bash - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) - (run chmod +x %{target})))) - -(rule - (target tailwindcss-macos-x64) - (action - (progn - (with-stdout-to - %{target} - (bash - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) - (run chmod +x %{target})))) - -(rule - (target tailwindcss-macos-arm64) - (action - (progn - (with-stdout-to - %{target} - (bash - "cat 2> /dev/null < $(which tailwindcss) || curl -#fSL https://github.com/tailwindlabs/tailwindcss/releases/download/v4.1.7/%{target}")) - (run chmod +x %{target})))) - -(rule - (enabled_if - (and - (= %{architecture} amd64) - (= %{system} linux))) - (target tailwindcss) - (deps tailwindcss-linux-x64) - (action - (copy %{deps} tailwindcss))) - -(rule - (enabled_if - (and - (= %{architecture} arm64) - (= %{system} linux))) - (target tailwindcss) - (deps tailwindcss-linux-arm64) - (action - (copy %{deps} tailwindcss))) - -(rule - (enabled_if - (and - (= %{architecture} amd64) - (= %{system} macosx))) - (target tailwindcss) - (deps tailwindcss-macos-x64) - (action - (copy %{deps} tailwindcss))) - -(rule - (enabled_if - (and - (= %{architecture} arm64) - (= %{system} macosx))) - (target tailwindcss) - (deps tailwindcss-macos-arm64) - (action - (copy %{deps} tailwindcss))) - -(alias - (name default) - (deps tailwindcss)) - -(install - (section bin) - (package tailwindcss) - (files tailwindcss))