module Oauth exposing ( AuthEndpoints , TokenResponse , codeVerifierGenerator , dnsTxtDecoder , encodeFormBody , extractAuthEndpoints , extractAuthServerUrl , extractPdsEndpoint , extractRequestUri , extractToken , fetchAuthMetadata , fetchDidDocument , fetchProtectedResource , pushAuthorizationRequest , refreshToken , resolveHandleViaAppview , resolveHandleViaDoh , resolveHandleViaWellKnown , stateGenerator , tokenExchange ) import Http import Json.Decode as Decode import Json.Encode as Encode import Random import Url import Xrpc exposing (HttpResponse, expectResponse) -- Handle resolution resolveHandleViaDoh : String -> String -> (Result Http.Error String -> msg) -> Cmd msg resolveHandleViaDoh dohUrl handle tagger = Http.request { method = "GET" , headers = [ Http.header "Accept" "application/dns-json" ] , url = dohUrl ++ "?name=_atproto." ++ handle ++ "&type=TXT" , body = Http.emptyBody , expect = Http.expectJson tagger (dnsTxtDecoder handle) , timeout = Just 5000 , tracker = Nothing } resolveHandleViaWellKnown : String -> (Result Http.Error String -> msg) -> Cmd msg resolveHandleViaWellKnown handle tagger = Http.request { method = "GET" , headers = [] , url = "https://" ++ handle ++ "/.well-known/atproto-did" , body = Http.emptyBody , expect = Http.expectString tagger , timeout = Just 5000 , tracker = Nothing } resolveHandleViaAppview : String -> String -> (Result Http.Error String -> msg) -> Cmd msg resolveHandleViaAppview appviewUrl handle tagger = Http.get { url = appviewUrl ++ "/xrpc/com.atproto.identity.resolveHandle?handle=" ++ Url.percentEncode handle , expect = Http.expectJson tagger (Decode.field "did" Decode.string) } dnsTxtDecoder : String -> Decode.Decoder String dnsTxtDecoder handle = Decode.maybe (Decode.field "Answer" (Decode.list txtRecordDecoder)) |> Decode.andThen (\answers -> case answers of Just (first :: _) -> Decode.succeed first _ -> Decode.fail ("No TXT record for _atproto." ++ handle) ) txtRecordDecoder : Decode.Decoder String txtRecordDecoder = Decode.field "data" Decode.string |> Decode.andThen (\data -> let cleaned : String cleaned = String.filter (\c -> c /= '"') data in if String.startsWith "did=" cleaned then Decode.succeed (String.dropLeft 4 cleaned) else Decode.fail ("Unexpected TXT: " ++ cleaned) ) -- Discovery fetchDidDocument : String -> String -> (Result Http.Error String -> msg) -> Cmd msg fetchDidDocument plcDirectoryUrl did tagger = if String.startsWith "did:web:" did then Http.get { url = "https://" ++ String.dropLeft 8 did ++ "/.well-known/did.json" , expect = Http.expectString tagger } else Http.get { url = plcDirectoryUrl ++ "/" ++ did , expect = Http.expectString tagger } fetchProtectedResource : String -> (Result Http.Error String -> msg) -> Cmd msg fetchProtectedResource pdsEndpoint tagger = Http.get { url = pdsEndpoint ++ "/.well-known/oauth-protected-resource" , expect = Http.expectString tagger } fetchAuthMetadata : String -> (Result Http.Error String -> msg) -> Cmd msg fetchAuthMetadata authServerUrl tagger = Http.get { url = authServerUrl ++ "/.well-known/oauth-authorization-server" , expect = Http.expectString tagger } -- PAR + token exchange pushAuthorizationRequest : { parEndpoint : String , clientId : String , redirectUri : String , codeChallenge : String , state : String , loginHint : String , dpopJkt : String , jwt : String } -> (Result String HttpResponse -> msg) -> Cmd msg pushAuthorizationRequest p tagger = let body : String body = encodeFormBody [ ( "response_type", "code" ) , ( "client_id", p.clientId ) , ( "redirect_uri", p.redirectUri ) , ( "scope", "atproto repo:site.standard.publication?action=create&action=update blob?accept=image/*" ) , ( "code_challenge", p.codeChallenge ) , ( "code_challenge_method", "S256" ) , ( "state", p.state ) , ( "login_hint", p.loginHint ) , ( "dpop_jkt", p.dpopJkt ) ] in Http.request { method = "POST" , headers = [ Http.header "DPoP" p.jwt ] , url = p.parEndpoint , body = Http.stringBody "application/x-www-form-urlencoded" body , expect = expectResponse tagger , timeout = Nothing , tracker = Nothing } refreshToken : { tokenEndpoint : String , clientId : String , refreshToken : String , jwt : String } -> (Result String HttpResponse -> msg) -> Cmd msg refreshToken p tagger = let body : String body = encodeFormBody [ ( "grant_type", "refresh_token" ) , ( "refresh_token", p.refreshToken ) , ( "client_id", p.clientId ) ] in Http.request { method = "POST" , headers = [ Http.header "DPoP" p.jwt ] , url = p.tokenEndpoint , body = Http.stringBody "application/x-www-form-urlencoded" body , expect = expectResponse tagger , timeout = Nothing , tracker = Nothing } tokenExchange : { tokenEndpoint : String , clientId : String , redirectUri : String , code : String , codeVerifier : String , jwt : String } -> (Result String HttpResponse -> msg) -> Cmd msg tokenExchange p tagger = let body : String body = encodeFormBody [ ( "grant_type", "authorization_code" ) , ( "code", p.code ) , ( "code_verifier", p.codeVerifier ) , ( "redirect_uri", p.redirectUri ) , ( "client_id", p.clientId ) ] in Http.request { method = "POST" , headers = [ Http.header "DPoP" p.jwt ] , url = p.tokenEndpoint , body = Http.stringBody "application/x-www-form-urlencoded" body , expect = expectResponse tagger , timeout = Nothing , tracker = Nothing } -- Response parsers extractPdsEndpoint : String -> Result String ( String, Maybe String ) extractPdsEndpoint body = Decode.decodeString (Decode.field "service" (Decode.list serviceDecoder) |> Decode.andThen (\services -> case findPdsService services of Just ( pds, authServer ) -> Decode.succeed ( pds, authServer ) Nothing -> Decode.fail "No #atproto_pds service found" ) ) body |> Result.mapError Decode.errorToString extractAuthServerUrl : String -> Result String String extractAuthServerUrl body = Decode.decodeString (Decode.field "authorization_servers" (Decode.index 0 Decode.string)) body |> Result.mapError Decode.errorToString type alias AuthEndpoints = { authorizationEndpoint : String , tokenEndpoint : String , parEndpoint : String , issuer : String } extractAuthEndpoints : String -> Result String AuthEndpoints extractAuthEndpoints body = Decode.decodeString (Decode.map4 AuthEndpoints (Decode.field "authorization_endpoint" Decode.string) (Decode.field "token_endpoint" Decode.string) (Decode.field "pushed_authorization_request_endpoint" Decode.string) (Decode.field "issuer" Decode.string) ) body |> Result.mapError Decode.errorToString extractRequestUri : String -> Result String String extractRequestUri body = Decode.decodeString (Decode.field "request_uri" Decode.string) body |> Result.mapError Decode.errorToString type alias TokenResponse = { accessToken : String , refreshToken : Maybe String , sub : String } extractToken : String -> Result String TokenResponse extractToken body = Decode.decodeString (Decode.map3 TokenResponse (Decode.field "access_token" Decode.string) (Decode.maybe (Decode.field "refresh_token" Decode.string)) (Decode.field "sub" Decode.string) ) body |> Result.mapError Decode.errorToString -- DID doc helpers type alias ServiceEntry = { id : String , endpoint : String , authServer : Maybe String } serviceDecoder : Decode.Decoder ServiceEntry serviceDecoder = Decode.map3 ServiceEntry (Decode.field "id" Decode.string) (Decode.field "serviceEndpoint" Decode.string) (Decode.maybe (Decode.field "authorization_server" Decode.string)) findPdsService : List ServiceEntry -> Maybe ( String, Maybe String ) findPdsService services = services |> List.filter (\s -> s.id == "#atproto_pds") |> List.head |> Maybe.map (\s -> ( s.endpoint, s.authServer )) -- Random generators unreserved : String unreserved = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-._~" codeVerifierGenerator : Random.Generator String codeVerifierGenerator = Random.list 64 (randomCharFrom unreserved) |> Random.map String.fromList stateGenerator : Random.Generator String stateGenerator = Random.list 32 (randomCharFrom unreserved) |> Random.map String.fromList randomCharFrom : String -> Random.Generator Char randomCharFrom source = Random.int 0 (String.length source - 1) |> Random.map (\i -> String.dropLeft i source |> String.uncons |> Maybe.map Tuple.first |> Maybe.withDefault 'A' ) -- Form encoding encodeFormBody : List ( String, String ) -> String encodeFormBody pairs = pairs |> List.map (\( k, v ) -> k ++ "=" ++ Url.percentEncode v) |> String.join "&"