diff --git a/elm.json b/elm.json index 699d4a3..a63f5b0 100644 --- a/elm.json +++ b/elm.json @@ -7,7 +7,9 @@ "dependencies": { "direct": { "elm/browser": "1.0.2", + "elm/bytes": "1.0.8", "elm/core": "1.0.5", + "elm/file": "1.0.5", "elm/html": "1.0.1", "elm/http": "2.0.0", "elm/json": "1.1.4", @@ -16,8 +18,6 @@ "elm/random": "1.0.0" }, "indirect": { - "elm/bytes": "1.0.8", - "elm/file": "1.0.5", "elm/virtual-dom": "1.0.5" } }, diff --git a/src/Date.elm b/src/Date.elm new file mode 100644 index 0000000..3017bbc --- /dev/null +++ b/src/Date.elm @@ -0,0 +1,70 @@ +module Date exposing (isoFromPosix) + +import Time + + +isoFromPosix : Time.Posix -> String +isoFromPosix posix = + let + ms : Int + ms = + Time.posixToMillis posix + + pad : Int -> Int -> String + pad width n = + String.padLeft width '0' (String.fromInt n) + in + pad 4 (Time.toYear Time.utc posix) + ++ "-" + ++ pad 2 (monthNumber (Time.toMonth Time.utc posix)) + ++ "-" + ++ pad 2 (Time.toDay Time.utc posix) + ++ "T" + ++ pad 2 (Time.toHour Time.utc posix) + ++ ":" + ++ pad 2 (Time.toMinute Time.utc posix) + ++ ":" + ++ pad 2 (Time.toSecond Time.utc posix) + ++ "." + ++ pad 3 (modBy 1000 ms) + ++ "Z" + + +monthNumber : Time.Month -> Int +monthNumber m = + case m of + Time.Jan -> + 1 + + Time.Feb -> + 2 + + Time.Mar -> + 3 + + Time.Apr -> + 4 + + Time.May -> + 5 + + Time.Jun -> + 6 + + Time.Jul -> + 7 + + Time.Aug -> + 8 + + Time.Sep -> + 9 + + Time.Oct -> + 10 + + Time.Nov -> + 11 + + Time.Dec -> + 12 diff --git a/src/Dpop.elm b/src/Dpop.elm new file mode 100644 index 0000000..2e23d6f --- /dev/null +++ b/src/Dpop.elm @@ -0,0 +1,160 @@ +module Dpop exposing + ( PendingAction(..) + , SignParams + , actionFromId + , actionId + , dpopDecoder + , sessionEncoder + , sha256Decoder + , signFor + , xrpcSignInput + ) + +import Json.Decode as Decode +import Json.Encode as Encode +import Ports +import Types exposing (Session) + + +type PendingAction + = ActionPAR + | ActionToken + | ActionRefresh + | ActionListPublications + | ActionListDocuments + | ActionCreatePublication + | ActionPutPublication String + | ActionUploadIcon + + +type alias SignParams = + { htm : String + , htu : String + , nonce : Maybe String + , accessToken : Maybe String + } + + +actionId : PendingAction -> String +actionId action = + case action of + ActionPAR -> + "par" + + ActionToken -> + "token" + + ActionRefresh -> + "refresh" + + ActionListPublications -> + "listPubs" + + ActionListDocuments -> + "listDocs" + + ActionCreatePublication -> + "createPub" + + ActionPutPublication rkey -> + "putPub:" ++ rkey + + ActionUploadIcon -> + "uploadIcon" + + +actionFromId : String -> Maybe PendingAction +actionFromId id = + if id == "par" then + Just ActionPAR + + else if id == "token" then + Just ActionToken + + else if id == "refresh" then + Just ActionRefresh + + else if id == "listPubs" then + Just ActionListPublications + + else if id == "listDocs" then + Just ActionListDocuments + + else if id == "createPub" then + Just ActionCreatePublication + + else if id == "uploadIcon" then + Just ActionUploadIcon + + else if String.startsWith "putPub:" id then + Just (ActionPutPublication (String.dropLeft 7 id)) + + else + Nothing + + +signFor : PendingAction -> SignParams -> Cmd msg +signFor action params = + let + fields : List ( String, Encode.Value ) + fields = + [ ( "id", Encode.string (actionId action) ) + , ( "htm", Encode.string params.htm ) + , ( "htu", Encode.string params.htu ) + ] + ++ (params.nonce |> Maybe.map (\n -> [ ( "nonce", Encode.string n ) ]) |> Maybe.withDefault []) + ++ (params.accessToken |> Maybe.map (\t -> [ ( "accessToken", Encode.string t ) ]) |> Maybe.withDefault []) + in + Ports.signDpop (Encode.object fields) + + +xrpcSignInput : Session -> String -> SignParams +xrpcSignInput session method = + { htm = + if method == "listRecords" then + "GET" + + else + "POST" + , htu = session.pdsEndpoint ++ "/xrpc/com.atproto.repo." ++ method + , nonce = Nothing + , accessToken = Just session.accessToken + } + + +dpopDecoder : Decode.Decoder (Result String { id : String, jwt : String }) +dpopDecoder = + Decode.field "id" Decode.string + |> Decode.andThen + (\id -> + Decode.field "error" (Decode.nullable Decode.string) + |> Decode.andThen + (\maybeErr -> + case maybeErr of + Just e -> + Decode.succeed (Err e) + + Nothing -> + Decode.field "jwt" Decode.string + |> Decode.map (\jwt -> Ok { id = id, jwt = jwt }) + ) + ) + + +sha256Decoder : Decode.Decoder { id : String, v : String } +sha256Decoder = + Decode.map2 (\id v -> { id = id, v = v }) + (Decode.field "id" Decode.string) + (Decode.field "value" Decode.string) + + +sessionEncoder : Session -> Encode.Value +sessionEncoder s = + Encode.object + [ ( "did", Encode.string s.did ) + , ( "handle", Encode.string s.handle ) + , ( "pdsEndpoint", Encode.string s.pdsEndpoint ) + , ( "tokenEndpoint", Encode.string s.tokenEndpoint ) + , ( "accessToken", Encode.string s.accessToken ) + , ( "refreshToken", s.refreshToken |> Maybe.map Encode.string |> Maybe.withDefault Encode.null ) + ] diff --git a/src/Lexicons.elm b/src/Lexicons.elm index c68b262..7a3c9b4 100644 --- a/src/Lexicons.elm +++ b/src/Lexicons.elm @@ -1,76 +1,250 @@ -module Lexicons exposing (..) +module Lexicons exposing + ( blobRefDecoder + , documentDecoder + , emptyPublication + , hexToRgb + , publicationListItemDecoder + , publicationRecordEncoder + , rgbToHex + ) import Json.Decode as Decode exposing (Decoder) import Json.Encode as Encode import Types exposing (..) + +-- Publication + + publicationListItemDecoder : Decoder Publication publicationListItemDecoder = - Decode.map6 Publication - (Decode.field "uri" - (Decode.string - |> Decode.map - (\uri -> - uri - |> String.split "/" - |> List.reverse - |> List.head - |> Maybe.withDefault "" - ) - ) - ) + Decode.map8 Publication + (Decode.field "uri" rkeyFromUri) (Decode.field "value" (Decode.field "url" Decode.string)) (Decode.field "value" (Decode.field "name" Decode.string)) (Decode.field "value" (Decode.maybe (Decode.field "description" Decode.string))) - (Decode.field "value" (Decode.maybe (Decode.field "avatar" Decode.string))) + (Decode.field "value" (Decode.maybe (Decode.field "icon" blobRefDecoder))) (Decode.field "value" (Decode.maybe (Decode.field "basicTheme" basicThemeDecoder))) + (Decode.field "value" (Decode.maybe (Decode.field "preferences" preferencesDecoder))) + (Decode.field "value" (Decode.maybe (Decode.field "createdAt" Decode.string))) + + +rkeyFromUri : Decoder String +rkeyFromUri = + Decode.string + |> Decode.map + (\uri -> + uri + |> String.split "/" + |> List.reverse + |> List.head + |> Maybe.withDefault "" + ) basicThemeDecoder : Decoder BasicTheme basicThemeDecoder = - Decode.map2 BasicTheme - (Decode.field "primaryColor" Decode.string) - (Decode.field "secondaryColor" Decode.string) + Decode.map4 BasicTheme + (Decode.field "background" rgbDecoder) + (Decode.field "foreground" rgbDecoder) + (Decode.field "accent" rgbDecoder) + (Decode.field "accentForeground" rgbDecoder) + + +rgbDecoder : Decoder RgbColor +rgbDecoder = + Decode.map3 RgbColor + (Decode.field "r" Decode.int) + (Decode.field "g" Decode.int) + (Decode.field "b" Decode.int) + + +blobRefDecoder : Decoder BlobRef +blobRefDecoder = + Decode.map3 BlobRef + (Decode.at [ "ref", "$link" ] Decode.string) + (Decode.field "mimeType" Decode.string) + (Decode.field "size" Decode.int) + + +preferencesDecoder : Decoder Preferences +preferencesDecoder = + Decode.map Preferences + (Decode.maybe (Decode.field "showInDiscover" Decode.bool)) -publicationEncoder : Publication -> Encode.Value -publicationEncoder pub = - Encode.object - [ ( "$type", Encode.string "site.standard.publication" ) - , ( "url", Encode.string pub.url ) - , ( "name", Encode.string pub.name ) - , ( "description", pub.description |> Maybe.map Encode.string |> Maybe.withDefault Encode.null ) - , ( "avatar", pub.avatar |> Maybe.map Encode.string |> Maybe.withDefault Encode.null ) - , ( "basicTheme", pub.basicTheme |> Maybe.map basicThemeEncoder |> Maybe.withDefault Encode.null ) - ] + +-- Publication record encoder (only includes fields that are Just) + + +publicationRecordEncoder : Publication -> Encode.Value +publicationRecordEncoder pub = + let + required : List ( String, Encode.Value ) + required = + [ ( "$type", Encode.string "site.standard.publication" ) + , ( "url", Encode.string pub.url ) + , ( "name", Encode.string pub.name ) + ] + + optionals : List ( String, Encode.Value ) + optionals = + List.filterMap identity + [ Maybe.map (\d -> ( "description", Encode.string d )) pub.description + , Maybe.map (\i -> ( "icon", blobRefEncoder i )) pub.icon + , Maybe.map (\t -> ( "basicTheme", basicThemeEncoder t )) pub.basicTheme + , Maybe.map (\p -> ( "preferences", preferencesEncoder p )) pub.preferences + , Maybe.map (\c -> ( "createdAt", Encode.string c )) pub.createdAt + ] + in + Encode.object (required ++ optionals) basicThemeEncoder : BasicTheme -> Encode.Value basicThemeEncoder theme = Encode.object - [ ( "primaryColor", Encode.string theme.primaryColor ) - , ( "secondaryColor", Encode.string theme.secondaryColor ) + [ ( "background", rgbEncoder theme.background ) + , ( "foreground", rgbEncoder theme.foreground ) + , ( "accent", rgbEncoder theme.accent ) + , ( "accentForeground", rgbEncoder theme.accentForeground ) + ] + + +rgbEncoder : RgbColor -> Encode.Value +rgbEncoder c = + Encode.object + [ ( "r", Encode.int c.r ) + , ( "g", Encode.int c.g ) + , ( "b", Encode.int c.b ) ] +blobRefEncoder : BlobRef -> Encode.Value +blobRefEncoder blob = + Encode.object + [ ( "$type", Encode.string "blob" ) + , ( "ref", Encode.object [ ( "$link", Encode.string blob.link ) ] ) + , ( "mimeType", Encode.string blob.mimeType ) + , ( "size", Encode.int blob.size ) + ] + + +preferencesEncoder : Preferences -> Encode.Value +preferencesEncoder prefs = + Encode.object + (List.filterMap identity + [ Maybe.map (\b -> ( "showInDiscover", Encode.bool b )) prefs.showInDiscover + ] + ) + + + +-- Document + + documentDecoder : Decoder Document documentDecoder = Decode.map6 Document (Decode.field "title" Decode.string) - (Decode.field "path" Decode.string) + (Decode.maybe (Decode.field "path" Decode.string)) (Decode.field "site" Decode.string) (Decode.field "publishedAt" Decode.string) (Decode.maybe (Decode.field "url" Decode.string)) (Decode.maybe (Decode.field "description" Decode.string)) + +-- Hex ↔ RGB helpers + + +hexToRgb : String -> Maybe RgbColor +hexToRgb raw = + let + cleaned : String + cleaned = + if String.startsWith "#" raw then + String.dropLeft 1 raw + + else + raw + in + if String.length cleaned == 6 then + Maybe.map3 RgbColor + (parseHexByte (String.slice 0 2 cleaned)) + (parseHexByte (String.slice 2 4 cleaned)) + (parseHexByte (String.slice 4 6 cleaned)) + + else + Nothing + + +rgbToHex : RgbColor -> String +rgbToHex c = + "#" ++ byteToHex c.r ++ byteToHex c.g ++ byteToHex c.b + + +parseHexByte : String -> Maybe Int +parseHexByte s = + case String.toList (String.toLower s) of + [ a, b ] -> + Maybe.map2 (\x y -> x * 16 + y) (hexDigit a) (hexDigit b) + + _ -> + Nothing + + +hexDigit : Char -> Maybe Int +hexDigit c = + if c >= '0' && c <= '9' then + Just (Char.toCode c - Char.toCode '0') + + else if c >= 'a' && c <= 'f' then + Just (Char.toCode c - Char.toCode 'a' + 10) + + else + Nothing + + +byteToHex : Int -> String +byteToHex n = + let + clamped : Int + clamped = + clamp 0 255 n + + hi : Int + hi = + clamped // 16 + + lo : Int + lo = + modBy 16 clamped + in + hexDigitToChar hi ++ hexDigitToChar lo + + +hexDigitToChar : Int -> String +hexDigitToChar n = + if n < 10 then + String.fromInt n + + else + String.fromChar (Char.fromCode (Char.toCode 'a' + n - 10)) + + + +-- Empty publication (for Create flow) + + emptyPublication : Publication emptyPublication = { rkey = "" , url = "" , name = "" , description = Nothing - , avatar = Nothing + , icon = Nothing , basicTheme = Nothing + , preferences = Nothing + , createdAt = Nothing } diff --git a/src/Oauth.elm b/src/Oauth.elm new file mode 100644 index 0000000..513a6e3 --- /dev/null +++ b/src/Oauth.elm @@ -0,0 +1,386 @@ +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 "&" diff --git a/src/Route.elm b/src/Route.elm new file mode 100644 index 0000000..3f885a6 --- /dev/null +++ b/src/Route.elm @@ -0,0 +1,144 @@ +module Route exposing + ( Route(..) + , basePathFromAppUrl + , getQueryParam + , parseRoute + , routeToPath + , selectedFromRoute + ) + +import Url + + + +-- Routes + + +type Route + = RouteHome + | RouteNewPub + | RoutePub String + + +{-| Routes live in the URL fragment (`#/pub/`) so the static host serves +the same `index.html` for every deep link. +-} +parseRoute : Url.Url -> Route +parseRoute url = + let + fragment : String + fragment = + Maybe.withDefault "" url.fragment + in + case String.split "/" (trimSlashes fragment) of + [ "" ] -> + RouteHome + + [ "pub", "new" ] -> + RouteNewPub + + [ "pub", rkey ] -> + if String.isEmpty rkey then + RouteHome + + else + RoutePub rkey + + _ -> + RouteHome + + +routeToPath : String -> Route -> String +routeToPath basePath route = + let + prefix : String + prefix = + if String.endsWith "/" basePath then + basePath + + else + basePath ++ "/" + in + case route of + RouteHome -> + prefix + + RouteNewPub -> + prefix ++ "#/pub/new" + + RoutePub rkey -> + prefix ++ "#/pub/" ++ rkey + + +basePathFromAppUrl : String -> String +basePathFromAppUrl appUrl = + case Url.fromString appUrl of + Just u -> + if String.endsWith "/" u.path then + u.path + + else + u.path ++ "/" + + Nothing -> + "/" + + +selectedFromRoute : Route -> Maybe String +selectedFromRoute route = + case route of + RoutePub rkey -> + Just rkey + + RouteNewPub -> + Just "" + + _ -> + Nothing + + +getQueryParam : String -> Url.Url -> Maybe String +getQueryParam name url = + case url.query of + Nothing -> + Nothing + + Just q -> + q + |> String.split "&" + |> List.filterMap + (\pair -> + case String.split "=" pair of + [ k, v ] -> + if k == name then + Url.percentDecode v + + else + Nothing + + _ -> + Nothing + ) + |> List.head + + + +-- Internals + + +trimSlashes : String -> String +trimSlashes path = + let + withoutLeading : String + withoutLeading = + if String.startsWith "/" path then + String.dropLeft 1 path + + else + path + in + if String.endsWith "/" withoutLeading then + String.dropRight 1 withoutLeading + + else + withoutLeading diff --git a/src/State.elm b/src/State.elm index 449fa6d..fa0b3f7 100644 --- a/src/State.elm +++ b/src/State.elm @@ -1,154 +1,45 @@ module State exposing - ( HttpResponse - , Msg(..) - , PendingAction(..) - , Route(..) - , actionFromId - , actionId + ( Msg(..) + , ThemeField(..) , decrementPending - , dnsTxtDecoder + , defaultBasicTheme , docMatchesPub , documentUrl - , encodeFormBody , errorFromBody , examples - , extractAuthEndpoints - , extractAuthServerUrl + , extractBlobRef , extractCursor - , extractPdsEndpoint - , extractRequestUri - , extractToken - , getQueryParam , getSelectedPub , init , initModel , isNonceRetry , normalizeHandle , originOf - , parseRoute - , routeToPath , subscriptions , update ) import Browser import Browser.Navigation as Nav +import Date import Dict +import Dpop exposing (PendingAction(..)) +import File +import File.Select import Http import Json.Decode as Decode import Json.Encode as Encode import Lexicons exposing (..) +import Oauth import Ports import Process import Random +import Route exposing (Route(..)) import Task import Time import Types exposing (..) import Url - - - --- Routes - - -type Route - = RouteHome - | RouteNewPub - | RoutePub String - - -parseRoute : String -> Url.Url -> Route -parseRoute basePath url = - let - stripped : String - stripped = - stripPrefix (trimSlashes basePath) (trimSlashes url.path) - in - case String.split "/" stripped of - [ "" ] -> - RouteHome - - [ "pub", "new" ] -> - RouteNewPub - - [ "pub", rkey ] -> - if String.isEmpty rkey then - RouteHome - - else - RoutePub rkey - - _ -> - RouteHome - - -stripPrefix : String -> String -> String -stripPrefix prefix s = - if String.isEmpty prefix then - s - - else if String.startsWith (prefix ++ "/") s then - String.dropLeft (String.length prefix + 1) s - - else if s == prefix then - "" - - else - s - - -trimSlashes : String -> String -trimSlashes path = - let - withoutLeading : String - withoutLeading = - if String.startsWith "/" path then - String.dropLeft 1 path - - else - path - in - if String.endsWith "/" withoutLeading then - String.dropRight 1 withoutLeading - - else - withoutLeading - - -basePathFromAppUrl : String -> String -basePathFromAppUrl appUrl = - case Url.fromString appUrl of - Just u -> - if String.endsWith "/" u.path then - u.path - - else - u.path ++ "/" - - Nothing -> - "/" - - -routeToPath : String -> Route -> String -routeToPath basePath route = - let - prefix : String - prefix = - if String.endsWith "/" basePath then - String.dropRight 1 basePath - - else - basePath - in - case route of - RouteHome -> - prefix ++ "/" - - RouteNewPub -> - prefix ++ "/pub/new" - - RoutePub rkey -> - prefix ++ "/pub/" ++ rkey +import Xrpc exposing (HttpResponse) @@ -161,62 +52,39 @@ examples = --- Pending actions awaiting a DPoP signature - - -type PendingAction - = ActionPAR - | ActionToken - | ActionListPublications - | ActionListDocuments - | ActionCreatePublication - | ActionPutPublication String - - -actionId : PendingAction -> String -actionId action = - case action of - ActionPAR -> - "par" - - ActionToken -> - "token" - - ActionListPublications -> - "listPubs" +-- Publication editor - ActionListDocuments -> - "listDocs" - - ActionCreatePublication -> - "createPub" - ActionPutPublication rkey -> - "putPub:" ++ rkey +type ThemeField + = Background + | Foreground + | Accent + | AccentForeground -actionFromId : String -> Maybe PendingAction -actionFromId id = - if id == "par" then - Just ActionPAR - - else if id == "token" then - Just ActionToken +defaultBasicTheme : BasicTheme +defaultBasicTheme = + { background = RgbColor 255 255 255 + , foreground = RgbColor 0 0 0 + , accent = RgbColor 59 130 246 + , accentForeground = RgbColor 255 255 255 + } - else if id == "listPubs" then - Just ActionListPublications - else if id == "listDocs" then - Just ActionListDocuments +setThemeField : ThemeField -> RgbColor -> BasicTheme -> BasicTheme +setThemeField field color theme = + case field of + Background -> + { theme | background = color } - else if id == "createPub" then - Just ActionCreatePublication + Foreground -> + { theme | foreground = color } - else if String.startsWith "putPub:" id then - Just (ActionPutPublication (String.dropLeft 7 id)) + Accent -> + { theme | accent = color } - else - Nothing + AccentForeground -> + { theme | accentForeground = color } @@ -228,7 +96,7 @@ init flags url key = let basePath : String basePath = - basePathFromAppUrl flags.appUrl + Route.basePathFromAppUrl flags.appUrl config : Config config = @@ -251,8 +119,18 @@ init flags url key = base : Model base = initModel config flags.jkt key clientId redirectUri + + maybeSession : Maybe Session + maybeSession = + Decode.decodeValue sessionDecoder flags.session + |> Result.toMaybe + + maybePending : Maybe PendingOAuth + maybePending = + Decode.decodeValue pendingOAuthDecoder flags.pendingOAuth + |> Result.toMaybe in - case ( getQueryParam "code" url, getQueryParam "state" url, flags.pendingOAuth ) of + case ( Route.getQueryParam "code" url, Route.getQueryParam "state" url, maybePending ) of ( Just code, Just stateParam, Just pending ) -> if stateParam == pending.state then ( { base @@ -265,7 +143,7 @@ init flags url key = , oauthDid = pending.did , oauthHandle = pending.handle } - , signDpopFor ActionToken + , Dpop.signFor ActionToken { htm = "POST" , htu = pending.tokenEndpoint , nonce = Nothing @@ -279,17 +157,17 @@ init flags url key = ) _ -> - case flags.session of + case maybeSession of Just session -> ( { base | page = Dashboard session , isLoading = True , pendingRequests = 2 - , selectedPubRkey = selectedFromRoute (parseRoute basePath url) + , selectedPubRkey = Route.selectedFromRoute (Route.parseRoute url) } , Cmd.batch - [ signDpopFor ActionListPublications (xrpcSignInput session "listRecords") - , signDpopFor ActionListDocuments (xrpcSignInput session "listRecords") + [ Dpop.signFor ActionListPublications (Dpop.xrpcSignInput session "listRecords") + , Dpop.signFor ActionListDocuments (Dpop.xrpcSignInput session "listRecords") ] ) @@ -297,17 +175,26 @@ init flags url key = ( base, Cmd.none ) -selectedFromRoute : Route -> Maybe String -selectedFromRoute route = - case route of - RoutePub rkey -> - Just rkey +sessionDecoder : Decode.Decoder Session +sessionDecoder = + Decode.map6 Session + (Decode.field "did" Decode.string) + (Decode.field "handle" Decode.string) + (Decode.field "pdsEndpoint" Decode.string) + (Decode.field "tokenEndpoint" Decode.string) + (Decode.field "accessToken" Decode.string) + (Decode.maybe (Decode.field "refreshToken" Decode.string)) - RouteNewPub -> - Just "" - _ -> - Nothing +pendingOAuthDecoder : Decode.Decoder PendingOAuth +pendingOAuthDecoder = + Decode.map6 PendingOAuth + (Decode.field "state" Decode.string) + (Decode.field "codeVerifier" Decode.string) + (Decode.field "tokenEndpoint" Decode.string) + (Decode.field "pdsEndpoint" Decode.string) + (Decode.field "did" Decode.string) + (Decode.field "handle" Decode.string) initModel : Config -> String -> Nav.Key -> String -> String -> Model @@ -327,9 +214,12 @@ initModel config jkt key clientId redirectUri = , examplePhase = Idle , publications = [] , selectedPubRkey = Nothing + , draftPublication = Nothing , documents = [] , publicationsCursor = Nothing , documentsCursor = Nothing + , pendingIconFile = Nothing + , pendingActionId = Nothing , oauthCode = "" , oauthCodeVerifier = "" , oauthCodeChallenge = "" @@ -386,30 +276,27 @@ type Msg | UpdatePubName String | UpdatePubUrl String | UpdatePubDescription String - | UpdatePubPrimaryColor String - | UpdatePubSecondaryColor String + | UpdatePubThemeColor ThemeField String + | SetDefaultTheme + | RemoveTheme + | SetShowInDiscover Bool + | RemovePreferences + | PickIcon + | IconFileSelected File.File + | RemoveIcon | SavePublication + | SaveWithTimestamp Time.Posix | RotateExample | FadeOutComplete | FadeInComplete | ClearNotification + | ClearError | Logout | LinkClicked Browser.UrlRequest | UrlChanged Url.Url --- HttpResponse captures headers so we can read DPoP-Nonce - - -type alias HttpResponse = - { status : Int - , headers : Dict.Dict String String - , body : String - } - - - -- Update @@ -431,8 +318,8 @@ update msg model = else ( { model | isLoading = True, error = Nothing, oauthHandle = handle } , Cmd.batch - [ Random.generate VerifierGenerated codeVerifierGenerator - , Random.generate StateGenerated stateGenerator + [ Random.generate VerifierGenerated Oauth.codeVerifierGenerator + , Random.generate StateGenerated Oauth.stateGenerator ] ) @@ -443,12 +330,12 @@ update msg model = ( { model | oauthCodeVerifier = v } , Cmd.batch [ Ports.sha256 (Encode.object [ ( "id", Encode.string "challenge" ), ( "input", Encode.string v ) ]) - , resolveHandleViaDoh model.config.dohUrl model.oauthHandle + , Oauth.resolveHandleViaDoh model.config.dohUrl model.oauthHandle HandleResolvedDoh ] ) Sha256Computed value -> - case Decode.decodeValue sha256Decoder value of + case Decode.decodeValue Dpop.sha256Decoder value of Ok { id, v } -> if id == "challenge" then ( { model | oauthCodeChallenge = v }, Cmd.none ) @@ -461,38 +348,38 @@ update msg model = HandleResolvedDoh (Ok did) -> ( { model | oauthDid = String.trim did } - , fetchDidDocument model.config.plcDirectoryUrl (String.trim did) + , Oauth.fetchDidDocument model.config.plcDirectoryUrl (String.trim did) DidDocumentFetched ) HandleResolvedDoh (Err _) -> - ( model, resolveHandleViaWellKnown model.oauthHandle ) + ( model, Oauth.resolveHandleViaWellKnown model.oauthHandle HandleResolvedWellKnown ) HandleResolvedWellKnown (Ok did) -> ( { model | oauthDid = String.trim did } - , fetchDidDocument model.config.plcDirectoryUrl (String.trim did) + , Oauth.fetchDidDocument model.config.plcDirectoryUrl (String.trim did) DidDocumentFetched ) HandleResolvedWellKnown (Err _) -> - ( model, resolveHandleViaAppview model.config.bskyAppviewUrl model.oauthHandle ) + ( model, Oauth.resolveHandleViaAppview model.config.bskyAppviewUrl model.oauthHandle HandleResolvedAppview ) HandleResolvedAppview (Ok did) -> - ( { model | oauthDid = did }, fetchDidDocument model.config.plcDirectoryUrl did ) + ( { model | oauthDid = did }, Oauth.fetchDidDocument model.config.plcDirectoryUrl did DidDocumentFetched ) HandleResolvedAppview (Err err) -> ( stopLoadingWithError ("Failed to resolve handle: " ++ httpErrorToString err) model, Cmd.none ) DidDocumentFetched (Ok body) -> - case extractPdsEndpoint body of + case Oauth.extractPdsEndpoint body of Ok ( pdsEndpoint, maybeAuthServer ) -> case maybeAuthServer of Just authServer -> ( { model | oauthPdsEndpoint = pdsEndpoint, oauthIssuer = authServer } - , fetchAuthMetadata authServer + , Oauth.fetchAuthMetadata authServer AuthMetadataFetched ) Nothing -> ( { model | oauthPdsEndpoint = pdsEndpoint } - , fetchProtectedResource pdsEndpoint + , Oauth.fetchProtectedResource pdsEndpoint AuthServerFound ) Err decodeErr -> @@ -502,9 +389,9 @@ update msg model = ( stopLoadingWithError ("Failed to fetch DID document: " ++ httpErrorToString err) model, Cmd.none ) AuthServerFound (Ok body) -> - case extractAuthServerUrl body of + case Oauth.extractAuthServerUrl body of Ok authServer -> - ( { model | oauthIssuer = authServer }, fetchAuthMetadata authServer ) + ( { model | oauthIssuer = authServer }, Oauth.fetchAuthMetadata authServer AuthMetadataFetched ) Err decodeErr -> ( stopLoadingWithError ("Failed to find authorization server: " ++ decodeErr) model, Cmd.none ) @@ -513,7 +400,7 @@ update msg model = ( stopLoadingWithError ("Failed to discover authorization server: " ++ httpErrorToString err) model, Cmd.none ) AuthMetadataFetched (Ok body) -> - case extractAuthEndpoints body of + case Oauth.extractAuthEndpoints body of Ok endpoints -> let updated : Model @@ -526,7 +413,7 @@ update msg model = } in ( updated - , signDpopFor ActionPAR + , Dpop.signFor ActionPAR { htm = "POST" , htu = endpoints.parEndpoint , nonce = Dict.get (originOf endpoints.parEndpoint) model.nonces @@ -541,7 +428,7 @@ update msg model = ( stopLoadingWithError ("Failed to fetch auth metadata: " ++ httpErrorToString err) model, Cmd.none ) DpopSigned value -> - case Decode.decodeValue dpopDecoder value of + case Decode.decodeValue Dpop.dpopDecoder value of Ok (Ok { id, jwt }) -> dispatchSigned id jwt model @@ -552,7 +439,7 @@ update msg model = ( stopLoadingWithError ("DPoP port error: " ++ Decode.errorToString decodeErr) model, Cmd.none ) SignedResponse id result -> - case ( actionFromId id, result ) of + case ( Dpop.actionFromId id, result ) of ( Just action, Ok resp ) -> let updated : Model @@ -562,6 +449,9 @@ update msg model = if isNonceRetry resp then ( updated, retrySigned action updated resp ) + else if isInvalidToken resp && action /= ActionRefresh then + attemptRefresh id updated + else if resp.status >= 200 && resp.status < 300 then handleSuccess action resp.body updated @@ -572,7 +462,7 @@ update msg model = ( stopLoadingWithError err model, Cmd.none ) ( Nothing, _ ) -> - ( model, Cmd.none ) + ( stopLoadingWithError ("Unknown signed-response id: " ++ id) model, Cmd.none ) SelectPublication maybeRkey -> let @@ -588,22 +478,30 @@ update msg model = Nothing -> RouteHome + + draft : Maybe Publication + draft = + if maybeRkey == Just "" then + case model.draftPublication of + Just _ -> + model.draftPublication + + Nothing -> + Just emptyPublication + + else + Nothing in - ( { model | selectedPubRkey = maybeRkey } - , Nav.pushUrl model.navKey (routeToPath model.config.basePath route) + ( { model | selectedPubRkey = maybeRkey, draftPublication = draft } + , Nav.pushUrl model.navKey (Route.routeToPath model.config.basePath route) ) InitPublication -> ( { model - | publications = - if List.any (\p -> String.isEmpty p.rkey) model.publications then - model.publications - - else - emptyPublication :: model.publications + | draftPublication = Just emptyPublication , selectedPubRkey = Just "" } - , Nav.pushUrl model.navKey (routeToPath model.config.basePath RouteNewPub) + , Nav.pushUrl model.navKey (Route.routeToPath model.config.basePath RouteNewPub) ) UpdatePubName v -> @@ -626,56 +524,62 @@ update msg model = ) model - UpdatePubPrimaryColor v -> - updatePub - (\p -> - { p - | basicTheme = - Just - { primaryColor = v - , secondaryColor = Maybe.withDefault "#000000" (Maybe.map .secondaryColor p.basicTheme) - } - } - ) - model + UpdatePubThemeColor field hex -> + case hexToRgb hex of + Just rgb -> + updatePub (\p -> { p | basicTheme = Just (setThemeField field rgb (Maybe.withDefault defaultBasicTheme p.basicTheme)) }) model - UpdatePubSecondaryColor v -> - updatePub - (\p -> - { p - | basicTheme = - Just - { primaryColor = Maybe.withDefault "#000000" (Maybe.map .primaryColor p.basicTheme) - , secondaryColor = v - } - } - ) - model + Nothing -> + ( model, Cmd.none ) - SavePublication -> - case ( model.page, model.selectedPubRkey, getSelectedPub model ) of - ( Dashboard session, Just rkey, Just _ ) -> - let - action : PendingAction - action = - if String.isEmpty rkey then - ActionCreatePublication + SetDefaultTheme -> + updatePub (\p -> { p | basicTheme = Just defaultBasicTheme }) model - else - ActionPutPublication rkey - in - ( { model | isLoading = True } - , signDpopFor action + RemoveTheme -> + updatePub (\p -> { p | basicTheme = Nothing }) model + + SetShowInDiscover v -> + updatePub (\p -> { p | preferences = Just { showInDiscover = Just v } }) model + + RemovePreferences -> + updatePub (\p -> { p | preferences = Nothing }) model + + PickIcon -> + ( model, File.Select.file [ "image/*" ] IconFileSelected ) + + IconFileSelected file -> + case model.page of + Dashboard session -> + ( { model | pendingIconFile = Just file, isLoading = True } + , Dpop.signFor ActionUploadIcon { htm = "POST" - , htu = htuFor action { model | page = Dashboard session } + , htu = session.pdsEndpoint ++ "/xrpc/com.atproto.repo.uploadBlob" , nonce = Dict.get (originOf session.pdsEndpoint) model.nonces , accessToken = Just session.accessToken } ) + LoginView -> + ( model, Cmd.none ) + + RemoveIcon -> + updatePub (\p -> { p | icon = Nothing }) model + + SavePublication -> + case ( model.page, getSelectedPub model ) of + ( Dashboard _, Just pub ) -> + if pub.createdAt == Nothing then + ( model, Task.perform SaveWithTimestamp Time.now ) + + else + startSave model + _ -> ( model, Cmd.none ) + SaveWithTimestamp posix -> + startSave (updatePubModel (\p -> { p | createdAt = Just (Date.isoFromPosix posix) }) model) + RotateExample -> ( { model | examplePhase = FadingOut } , Task.perform (\_ -> FadeOutComplete) (Process.sleep 250) @@ -695,11 +599,15 @@ update msg model = ClearNotification -> ( { model | notification = Nothing }, Cmd.none ) + ClearError -> + ( { model | error = Nothing }, Cmd.none ) + Logout -> ( { model | page = LoginView , publications = [] , selectedPubRkey = Nothing + , draftPublication = Nothing , documents = [] , nonces = Dict.empty , oauthCode = "" @@ -713,7 +621,7 @@ update msg model = , oauthTokenEndpoint = "" , oauthParEndpoint = "" } - , Cmd.batch [ Ports.clearSession (), Nav.pushUrl model.navKey (routeToPath model.config.basePath RouteHome) ] + , Cmd.batch [ Ports.clearSession (), Nav.pushUrl model.navKey (Route.routeToPath model.config.basePath RouteHome) ] ) LinkClicked urlRequest -> @@ -728,22 +636,22 @@ update msg model = let selected : Maybe String selected = - selectedFromRoute (parseRoute model.config.basePath url) + Route.selectedFromRoute (Route.parseRoute url) - publications : List Publication - publications = - case selected of - Just "" -> - if List.any (\p -> String.isEmpty p.rkey) model.publications then - model.publications + draft : Maybe Publication + draft = + if selected == Just "" then + case model.draftPublication of + Just _ -> + model.draftPublication - else - emptyPublication :: model.publications + Nothing -> + Just emptyPublication - _ -> - model.publications + else + Nothing in - ( { model | selectedPubRkey = selected, publications = publications }, Cmd.none ) + ( { model | selectedPubRkey = selected, draftPublication = draft }, Cmd.none ) @@ -752,47 +660,93 @@ update msg model = dispatchSigned : String -> String -> Model -> ( Model, Cmd Msg ) dispatchSigned id jwt model = - case actionFromId id of + case Dpop.actionFromId id of Just ActionPAR -> - ( model, sendPar model jwt ) + ( model + , Oauth.pushAuthorizationRequest + { parEndpoint = model.oauthParEndpoint + , clientId = model.clientId + , redirectUri = model.redirectUri + , codeChallenge = model.oauthCodeChallenge + , state = model.oauthState + , loginHint = model.oauthHandle + , dpopJkt = model.jkt + , jwt = jwt + } + (SignedResponse id) + ) Just ActionToken -> - ( model, sendTokenExchange model jwt ) + ( model + , Oauth.tokenExchange + { tokenEndpoint = model.oauthTokenEndpoint + , clientId = model.clientId + , redirectUri = model.redirectUri + , code = model.oauthCode + , codeVerifier = model.oauthCodeVerifier + , jwt = jwt + } + (SignedResponse id) + ) + + Just ActionRefresh -> + case ( model.page, model.page |> sessionRefreshToken ) of + ( Dashboard session, Just rt ) -> + ( model + , Oauth.refreshToken + { tokenEndpoint = session.tokenEndpoint + , clientId = model.clientId + , refreshToken = rt + , jwt = jwt + } + (SignedResponse id) + ) + + _ -> + ( stopLoadingWithError "Refresh dispatch dropped: no refresh token" model, Cmd.none ) Just ActionListPublications -> case model.page of Dashboard session -> - ( model, sendListRecords session "site.standard.publication" model.publicationsCursor jwt id ) + ( model, Xrpc.listRecords session "site.standard.publication" model.publicationsCursor jwt (SignedResponse id) ) LoginView -> - ( model, Cmd.none ) + ( stopLoadingWithError "listRecords dispatch dropped: not on dashboard" model, Cmd.none ) Just ActionListDocuments -> case model.page of Dashboard session -> - ( model, sendListRecords session "site.standard.document" model.documentsCursor jwt id ) + ( model, Xrpc.listRecords session "site.standard.document" model.documentsCursor jwt (SignedResponse id) ) LoginView -> - ( model, Cmd.none ) + ( stopLoadingWithError "listRecords dispatch dropped: not on dashboard" model, Cmd.none ) Just ActionCreatePublication -> case ( model.page, getSelectedPub model ) of ( Dashboard session, Just pub ) -> - ( model, sendCreateRecord session "site.standard.publication" (publicationEncoder pub) jwt id ) + ( model, Xrpc.createRecord session "site.standard.publication" (publicationRecordEncoder pub) jwt (SignedResponse id) ) _ -> - ( model, Cmd.none ) + ( stopLoadingWithError "createRecord dispatch dropped: selection lost" model, Cmd.none ) Just (ActionPutPublication rkey) -> case ( model.page, getSelectedPub model ) of ( Dashboard session, Just pub ) -> - ( model, sendPutRecord session "site.standard.publication" rkey (publicationEncoder pub) jwt id ) + ( model, Xrpc.putRecord session "site.standard.publication" rkey (publicationRecordEncoder pub) jwt (SignedResponse id) ) _ -> - ( model, Cmd.none ) + ( stopLoadingWithError ("putRecord dispatch dropped: selection lost (rkey " ++ rkey ++ ")") model, Cmd.none ) + + Just ActionUploadIcon -> + case ( model.page, model.pendingIconFile ) of + ( Dashboard session, Just file ) -> + ( model, Xrpc.uploadBlob session file jwt (SignedResponse id) ) + + _ -> + ( stopLoadingWithError "uploadBlob dispatch dropped: no pending file" model, Cmd.none ) Nothing -> - ( model, Cmd.none ) + ( stopLoadingWithError ("Unknown DPoP action id: " ++ id) model, Cmd.none ) @@ -803,7 +757,7 @@ handleSuccess : PendingAction -> String -> Model -> ( Model, Cmd Msg ) handleSuccess action body model = case action of ActionPAR -> - case extractRequestUri body of + case Oauth.extractRequestUri body of Ok requestUri -> let authUrl : String @@ -831,7 +785,7 @@ handleSuccess action body model = ( stopLoadingWithError ("Failed to parse PAR response: " ++ decodeErr) model, Cmd.none ) ActionToken -> - case extractToken body of + case Oauth.extractToken body of Ok { accessToken, refreshToken, sub } -> let session : Session @@ -839,6 +793,7 @@ handleSuccess action body model = { did = sub , handle = model.oauthHandle , pdsEndpoint = model.oauthPdsEndpoint + , tokenEndpoint = model.oauthTokenEndpoint , accessToken = accessToken , refreshToken = refreshToken } @@ -856,17 +811,20 @@ handleSuccess action body model = , oauthState = "" } , Cmd.batch - [ Ports.saveSession (sessionEncoder session) + [ Ports.saveSession (Dpop.sessionEncoder session) , Ports.clearPendingOAuth () - , Nav.pushUrl model.navKey (routeToPath model.config.basePath RouteHome) - , signDpopFor ActionListPublications (xrpcSignInput session "listRecords") - , signDpopFor ActionListDocuments (xrpcSignInput session "listRecords") + , Nav.pushUrl model.navKey (Route.routeToPath model.config.basePath RouteHome) + , Dpop.signFor ActionListPublications (Dpop.xrpcSignInput session "listRecords") + , Dpop.signFor ActionListDocuments (Dpop.xrpcSignInput session "listRecords") ] ) Err decodeErr -> ( stopLoadingWithError ("Failed to parse token response: " ++ decodeErr) model, Cmd.none ) + ActionRefresh -> + handleRefreshSuccess body model + ActionListPublications -> case Decode.decodeString (Decode.field "records" (Decode.list (Decode.maybe publicationListItemDecoder))) body of Ok maybePubs -> @@ -902,15 +860,11 @@ handleSuccess action body model = ActionListDocuments -> case Decode.decodeString (Decode.field "records" (Decode.list (Decode.maybe (Decode.field "value" documentDecoder)))) body of Ok maybeDocs -> - let - updated : Model - updated = - { model - | documents = model.documents ++ List.filterMap identity maybeDocs - , documentsCursor = extractCursor body - } - in - continueOrFinish ActionListDocuments updated + continueOrFinish ActionListDocuments + { model + | documents = model.documents ++ List.filterMap identity maybeDocs + , documentsCursor = extractCursor body + } Err decodeErr -> ( decrementPending { model | error = Just ("Failed to decode documents: " ++ Decode.errorToString decodeErr) } @@ -923,6 +877,16 @@ handleSuccess action body model = ActionPutPublication _ -> updateSavedRkey body model + ActionUploadIcon -> + case extractBlobRef body of + Ok blob -> + ( updatePubModel (\p -> { p | icon = Just blob }) { model | isLoading = False, pendingIconFile = Nothing, notification = Just "Icon uploaded." } + , Cmd.none + ) + + Err decodeErr -> + ( stopLoadingWithError ("Failed to parse blob response: " ++ decodeErr) { model | pendingIconFile = Nothing }, Cmd.none ) + {-| After a list page response: if a non-empty cursor was returned, fetch the next page; otherwise mark the collection as fully loaded. @@ -944,12 +908,18 @@ continueOrFinish action model = in case ( model.page, cursor ) of ( Dashboard session, Just _ ) -> - ( model, signDpopFor action (xrpcSignInput session "listRecords") ) + ( model, Dpop.signFor action (Dpop.xrpcSignInput session "listRecords") ) _ -> ( decrementPending model, Cmd.none ) +extractBlobRef : String -> Result String BlobRef +extractBlobRef body = + Decode.decodeString (Decode.field "blob" blobRefDecoder) body + |> Result.mapError Decode.errorToString + + extractCursor : String -> Maybe String extractCursor body = case Decode.decodeString (Decode.field "cursor" Decode.string) body of @@ -977,13 +947,30 @@ updateSavedRkey body model = previousRkey = Maybe.withDefault "" model.selectedPubRkey - apply : Publication -> Publication - apply p = - if p.rkey == previousRkey then - { p | rkey = rkey } + wasCreate : Bool + wasCreate = + String.isEmpty previousRkey + + publications : List Publication + publications = + if wasCreate then + case model.draftPublication of + Just draft -> + { draft | rkey = rkey } :: model.publications + + Nothing -> + model.publications else - p + List.map + (\p -> + if p.rkey == previousRkey then + { p | rkey = rkey } + + else + p + ) + model.publications cmd : Cmd Msg cmd = @@ -991,10 +978,16 @@ updateSavedRkey body model = Cmd.none else - Nav.replaceUrl model.navKey (routeToPath model.config.basePath (RoutePub rkey)) + Nav.replaceUrl model.navKey (Route.routeToPath model.config.basePath (RoutePub rkey)) in ( { model - | publications = List.map apply model.publications + | publications = publications + , draftPublication = + if wasCreate then + Nothing + + else + model.draftPublication , selectedPubRkey = Just rkey , isLoading = False , notification = Just "Publication saved!" @@ -1002,8 +995,8 @@ updateSavedRkey body model = , cmd ) - Err _ -> - ( { model | isLoading = False, notification = Just "Publication saved!" }, Cmd.none ) + Err decodeErr -> + ( stopLoadingWithError ("Save returned an unexpected response: " ++ Decode.errorToString decodeErr ++ " — body: " ++ body) model, Cmd.none ) @@ -1026,7 +1019,7 @@ retrySigned action model resp = Nothing -> Dict.get (originOf htu) model.nonces in - signDpopFor action + Dpop.signFor action { htm = htmFor action , htu = htu , nonce = nonce @@ -1056,6 +1049,14 @@ htuFor action model = ActionToken -> model.oauthTokenEndpoint + ActionRefresh -> + case model.page of + Dashboard s -> + s.tokenEndpoint + + LoginView -> + model.oauthTokenEndpoint + ActionListPublications -> sessionPds model ++ "/xrpc/com.atproto.repo.listRecords" @@ -1068,6 +1069,9 @@ htuFor action model = ActionPutPublication _ -> sessionPds model ++ "/xrpc/com.atproto.repo.putRecord" + ActionUploadIcon -> + sessionPds model ++ "/xrpc/com.atproto.repo.uploadBlob" + sessionPds : Model -> String sessionPds model = @@ -1088,6 +1092,9 @@ accessTokenForAction action model = ( ActionToken, _ ) -> Nothing + ( ActionRefresh, _ ) -> + Nothing + ( _, Dashboard session ) -> Just session.accessToken @@ -1152,6 +1159,102 @@ storeNonce origin resp model = model +{-| Refresh succeeded: update session tokens, persist, re-sign the original +failed action so its caller doesn't see the 401. +-} +handleRefreshSuccess : String -> Model -> ( Model, Cmd Msg ) +handleRefreshSuccess body model = + case ( Oauth.extractToken body, model.page, model.pendingActionId ) of + ( Ok t, Dashboard oldSession, Just pendingId ) -> + let + newSession : Session + newSession = + { oldSession + | accessToken = t.accessToken + , refreshToken = + case t.refreshToken of + Just _ -> + t.refreshToken + + Nothing -> + oldSession.refreshToken + } + + updated : Model + updated = + { model | page = Dashboard newSession, pendingActionId = Nothing } + in + case Dpop.actionFromId pendingId of + Just action -> + ( updated + , Cmd.batch + [ Ports.saveSession (Dpop.sessionEncoder newSession) + , Dpop.signFor action + { htm = htmFor action + , htu = htuFor action updated + , nonce = Dict.get (originOf (htuFor action updated)) updated.nonces + , accessToken = Just newSession.accessToken + } + ] + ) + + Nothing -> + ( stopLoadingWithError ("Refresh succeeded but pending action id is unknown: " ++ pendingId) updated + , Ports.saveSession (Dpop.sessionEncoder newSession) + ) + + ( Err decodeErr, _, _ ) -> + ( stopLoadingWithError ("Failed to parse refresh response: " ++ decodeErr) model, Cmd.none ) + + _ -> + ( stopLoadingWithError "Refresh succeeded but session state is invalid." model, Cmd.none ) + + +{-| Token expired (401 invalid\_token). Stash the failed action's id, sign a +DPoP for the refresh request; on success we re-dispatch the original action. +-} +attemptRefresh : String -> Model -> ( Model, Cmd Msg ) +attemptRefresh failedId model = + case ( model.page, model.page |> sessionRefreshToken ) of + ( Dashboard session, Just _ ) -> + ( { model | pendingActionId = Just failedId } + , Dpop.signFor ActionRefresh + { htm = "POST" + , htu = session.tokenEndpoint + , nonce = Dict.get (originOf session.tokenEndpoint) model.nonces + , accessToken = Nothing + } + ) + + _ -> + ( stopLoadingWithError "Session expired and no refresh token available. Please log in again." model + , Ports.clearSession () + ) + + +sessionRefreshToken : Page -> Maybe String +sessionRefreshToken page = + case page of + Dashboard s -> + s.refreshToken + + LoginView -> + Nothing + + +isInvalidToken : HttpResponse -> Bool +isInvalidToken resp = + resp.status + == 401 + && (case Decode.decodeString (Decode.field "error" Decode.string) resp.body of + Ok "invalid_token" -> + True + + _ -> + False + ) + + isNonceRetry : HttpResponse -> Bool isNonceRetry resp = (resp.status == 400 || resp.status == 401) @@ -1197,6 +1300,9 @@ stopLoadingWithError err model = getSelectedPub : Model -> Maybe Publication getSelectedPub model = case model.selectedPubRkey of + Just "" -> + model.draftPublication + Just rkey -> List.filter (\p -> p.rkey == rkey) model.publications |> List.head @@ -1216,6 +1322,7 @@ docMatchesPub did pub doc = {-| Resolve a document's canonical URL. Use `doc.url` when present; otherwise fall back to `pub.url` + `doc.path`, normalizing the slash between them. +Falls back to `pub.url` alone when path is absent. -} documentUrl : Publication -> Document -> String documentUrl pub doc = @@ -1232,21 +1339,30 @@ documentUrl pub doc = else pub.url - - path : String - path = - if String.startsWith "/" doc.path then - doc.path + in + case doc.path of + Just p -> + if String.startsWith "/" p then + base ++ p else - "/" ++ doc.path - in - base ++ path + base ++ "/" ++ p + + Nothing -> + pub.url updatePub : (Publication -> Publication) -> Model -> ( Model, Cmd Msg ) updatePub fn model = + ( updatePubModel fn model, Cmd.none ) + + +updatePubModel : (Publication -> Publication) -> Model -> Model +updatePubModel fn model = case model.selectedPubRkey of + Just "" -> + { model | draftPublication = Maybe.map fn model.draftPublication } + Just rkey -> let apply : Publication -> Publication @@ -1257,504 +1373,36 @@ updatePub fn model = else p in - ( { model | publications = List.map apply model.publications }, Cmd.none ) + { model | publications = List.map apply model.publications } Nothing -> - ( model, Cmd.none ) - - - --- DPoP port I/O - - -signDpopFor : PendingAction -> { htm : String, htu : String, nonce : Maybe String, accessToken : Maybe String } -> Cmd Msg -signDpopFor action params = - let - fields : List ( String, Encode.Value ) - fields = - [ ( "id", Encode.string (actionId action) ) - , ( "htm", Encode.string params.htm ) - , ( "htu", Encode.string params.htu ) - ] - ++ (params.nonce |> Maybe.map (\n -> [ ( "nonce", Encode.string n ) ]) |> Maybe.withDefault []) - ++ (params.accessToken |> Maybe.map (\t -> [ ( "accessToken", Encode.string t ) ]) |> Maybe.withDefault []) - in - Ports.signDpop (Encode.object fields) - - -xrpcSignInput : Session -> String -> { htm : String, htu : String, nonce : Maybe String, accessToken : Maybe String } -xrpcSignInput session method = - { htm = - if method == "listRecords" then - "GET" - - else - "POST" - , htu = session.pdsEndpoint ++ "/xrpc/com.atproto.repo." ++ method - , nonce = Nothing - , accessToken = Just session.accessToken - } - - -dpopDecoder : Decode.Decoder (Result String { id : String, jwt : String }) -dpopDecoder = - Decode.field "id" Decode.string - |> Decode.andThen - (\id -> - Decode.field "error" (Decode.nullable Decode.string) - |> Decode.andThen - (\maybeErr -> - case maybeErr of - Just e -> - Decode.succeed (Err e) - - Nothing -> - Decode.field "jwt" Decode.string - |> Decode.map (\jwt -> Ok { id = id, jwt = jwt }) - ) - ) - - -sha256Decoder : Decode.Decoder { id : String, v : String } -sha256Decoder = - Decode.map2 (\id v -> { id = id, v = v }) - (Decode.field "id" Decode.string) - (Decode.field "value" Decode.string) - - -sessionEncoder : Session -> Encode.Value -sessionEncoder s = - Encode.object - [ ( "did", Encode.string s.did ) - , ( "handle", Encode.string s.handle ) - , ( "pdsEndpoint", Encode.string s.pdsEndpoint ) - , ( "accessToken", Encode.string s.accessToken ) - , ( "refreshToken", s.refreshToken |> Maybe.map Encode.string |> Maybe.withDefault Encode.null ) - ] - - - --- 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' - ) - - - --- HTTP helpers (handle resolution + discovery) - - -resolveHandleViaDoh : String -> String -> Cmd Msg -resolveHandleViaDoh dohUrl handle = - Http.request - { method = "GET" - , headers = [ Http.header "Accept" "application/dns-json" ] - , url = dohUrl ++ "?name=_atproto." ++ handle ++ "&type=TXT" - , body = Http.emptyBody - , expect = Http.expectJson HandleResolvedDoh (dnsTxtDecoder handle) - , timeout = Just 5000 - , tracker = Nothing - } - - -resolveHandleViaWellKnown : String -> Cmd Msg -resolveHandleViaWellKnown handle = - Http.request - { method = "GET" - , headers = [] - , url = "https://" ++ handle ++ "/.well-known/atproto-did" - , body = Http.emptyBody - , expect = Http.expectString HandleResolvedWellKnown - , timeout = Just 5000 - , tracker = Nothing - } - - -resolveHandleViaAppview : String -> String -> Cmd Msg -resolveHandleViaAppview appviewUrl handle = - Http.get - { url = appviewUrl ++ "/xrpc/com.atproto.identity.resolveHandle?handle=" ++ Url.percentEncode handle - , expect = Http.expectJson HandleResolvedAppview (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 + model - _ -> - Decode.fail ("No TXT record for _atproto." ++ handle) - ) +startSave : Model -> ( Model, Cmd Msg ) +startSave model = + case ( model.page, model.selectedPubRkey, getSelectedPub model ) of + ( Dashboard session, Just rkey, Just _ ) -> + let + action : PendingAction + action = + if String.isEmpty rkey then + ActionCreatePublication -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) + else + ActionPutPublication rkey + in + ( { model | isLoading = True } + , Dpop.signFor action + { htm = "POST" + , htu = htuFor action model + , nonce = Dict.get (originOf session.pdsEndpoint) model.nonces + , accessToken = Just session.accessToken + } ) - -fetchDidDocument : String -> String -> Cmd Msg -fetchDidDocument plcDirectoryUrl did = - if String.startsWith "did:web:" did then - Http.get - { url = "https://" ++ String.dropLeft 8 did ++ "/.well-known/did.json" - , expect = Http.expectString DidDocumentFetched - } - - else - Http.get - { url = plcDirectoryUrl ++ "/" ++ did - , expect = Http.expectString DidDocumentFetched - } - - -fetchProtectedResource : String -> Cmd Msg -fetchProtectedResource pdsEndpoint = - Http.get - { url = pdsEndpoint ++ "/.well-known/oauth-protected-resource" - , expect = Http.expectString AuthServerFound - } - - -fetchAuthMetadata : String -> Cmd Msg -fetchAuthMetadata authServerUrl = - Http.get - { url = authServerUrl ++ "/.well-known/oauth-authorization-server" - , expect = Http.expectString AuthMetadataFetched - } - - - --- Signed HTTP requests (after receiving DPoP JWT) - - -sendPar : Model -> String -> Cmd Msg -sendPar model jwt = - let - body : String - body = - encodeFormBody - [ ( "response_type", "code" ) - , ( "client_id", model.clientId ) - , ( "redirect_uri", model.redirectUri ) - , ( "scope", "atproto" ) - , ( "code_challenge", model.oauthCodeChallenge ) - , ( "code_challenge_method", "S256" ) - , ( "state", model.oauthState ) - , ( "login_hint", model.oauthHandle ) - , ( "dpop_jkt", model.jkt ) - ] - in - Http.request - { method = "POST" - , headers = [ Http.header "DPoP" jwt ] - , url = model.oauthParEndpoint - , body = Http.stringBody "application/x-www-form-urlencoded" body - , expect = expectResponse (SignedResponse (actionId ActionPAR)) - , timeout = Nothing - , tracker = Nothing - } - - -sendTokenExchange : Model -> String -> Cmd Msg -sendTokenExchange model jwt = - let - body : String - body = - encodeFormBody - [ ( "grant_type", "authorization_code" ) - , ( "code", model.oauthCode ) - , ( "code_verifier", model.oauthCodeVerifier ) - , ( "redirect_uri", model.redirectUri ) - , ( "client_id", model.clientId ) - ] - in - Http.request - { method = "POST" - , headers = [ Http.header "DPoP" jwt ] - , url = model.oauthTokenEndpoint - , body = Http.stringBody "application/x-www-form-urlencoded" body - , expect = expectResponse (SignedResponse (actionId ActionToken)) - , timeout = Nothing - , tracker = Nothing - } - - -sendListRecords : Session -> String -> Maybe String -> String -> String -> Cmd Msg -sendListRecords session collection cursor jwt id = - let - cursorParam : String - cursorParam = - case cursor of - Just c -> - "&cursor=" ++ Url.percentEncode c - - Nothing -> - "" - in - Http.request - { method = "GET" - , headers = - [ Http.header "Authorization" ("DPoP " ++ session.accessToken) - , Http.header "DPoP" jwt - ] - , url = - session.pdsEndpoint - ++ "/xrpc/com.atproto.repo.listRecords?repo=" - ++ Url.percentEncode session.did - ++ "&collection=" - ++ Url.percentEncode collection - ++ "&limit=100" - ++ cursorParam - , body = Http.emptyBody - , expect = expectResponse (SignedResponse id) - , timeout = Nothing - , tracker = Nothing - } - - -sendCreateRecord : Session -> String -> Encode.Value -> String -> String -> Cmd Msg -sendCreateRecord session collection record jwt id = - Http.request - { method = "POST" - , headers = - [ Http.header "Authorization" ("DPoP " ++ session.accessToken) - , Http.header "DPoP" jwt - ] - , url = session.pdsEndpoint ++ "/xrpc/com.atproto.repo.createRecord" - , body = - Http.jsonBody - (Encode.object - [ ( "repo", Encode.string session.did ) - , ( "collection", Encode.string collection ) - , ( "record", record ) - ] - ) - , expect = expectResponse (SignedResponse id) - , timeout = Nothing - , tracker = Nothing - } - - -sendPutRecord : Session -> String -> String -> Encode.Value -> String -> String -> Cmd Msg -sendPutRecord session collection rkey record jwt id = - Http.request - { method = "POST" - , headers = - [ Http.header "Authorization" ("DPoP " ++ session.accessToken) - , Http.header "DPoP" jwt - ] - , url = session.pdsEndpoint ++ "/xrpc/com.atproto.repo.putRecord" - , body = - Http.jsonBody - (Encode.object - [ ( "repo", Encode.string session.did ) - , ( "collection", Encode.string collection ) - , ( "rkey", Encode.string rkey ) - , ( "record", record ) - ] - ) - , expect = expectResponse (SignedResponse id) - , timeout = Nothing - , tracker = Nothing - } - - -expectResponse : (Result String HttpResponse -> msg) -> Http.Expect msg -expectResponse tagger = - Http.expectStringResponse tagger - (\response -> - case response of - Http.BadUrl_ url -> - Err ("Bad URL: " ++ url) - - Http.Timeout_ -> - Err "Request timed out" - - Http.NetworkError_ -> - Err "Network error" - - Http.BadStatus_ meta body -> - Ok { status = meta.statusCode, headers = meta.headers, body = body } - - Http.GoodStatus_ meta body -> - Ok { status = meta.statusCode, headers = meta.headers, body = body } - ) - - - --- 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 - - -extractAuthEndpoints : String -> Result String { authorizationEndpoint : String, tokenEndpoint : String, parEndpoint : String, issuer : String } -extractAuthEndpoints body = - Decode.decodeString - (Decode.map4 (\auth token par iss -> { authorizationEndpoint = auth, tokenEndpoint = token, parEndpoint = par, issuer = iss }) - (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 - - -extractToken : String -> Result String { accessToken : String, refreshToken : Maybe String, sub : String } -extractToken body = - Decode.decodeString - (Decode.map3 (\a r s -> { accessToken = a, refreshToken = r, sub = s }) - (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 )) - - - --- URL helpers - - -getQueryParam : String -> Url.Url -> Maybe String -getQueryParam name url = - case url.query of - Nothing -> - Nothing - - Just q -> - q - |> String.split "&" - |> List.filterMap - (\pair -> - case String.split "=" pair of - [ k, v ] -> - if k == name then - Url.percentDecode v - - else - Nothing - - _ -> - Nothing - ) - |> List.head - - - --- Form encoding - - -encodeFormBody : List ( String, String ) -> String -encodeFormBody pairs = - pairs - |> List.map (\( k, v ) -> k ++ "=" ++ Url.percentEncode v) - |> String.join "&" - - - --- Error rendering + _ -> + ( model, Cmd.none ) httpErrorToString : Http.Error -> String diff --git a/src/Types.elm b/src/Types.elm index 46c5f31..2b20915 100644 --- a/src/Types.elm +++ b/src/Types.elm @@ -1,5 +1,6 @@ module Types exposing ( BasicTheme + , BlobRef , Config , Document , ExamplePhase(..) @@ -7,12 +8,16 @@ module Types exposing , Model , Page(..) , PendingOAuth + , Preferences , Publication + , RgbColor , Session ) import Browser.Navigation as Nav import Dict exposing (Dict) +import File +import Json.Decode as Decode @@ -33,6 +38,10 @@ type alias Config = -- Flags from JS bootstrap +{-| Raw flags from JS. `session` and `pendingOAuth` are kept as opaque JSON +values so that schema mismatches in stored data don't crash the app at boot — +they're decoded leniently in `init` and dropped on failure. +-} type alias Flags = { clientName : String , appUrl : String @@ -41,8 +50,8 @@ type alias Flags = , bskyAppviewUrl : String , jkt : String , now : Int - , session : Maybe Session - , pendingOAuth : Maybe PendingOAuth + , session : Decode.Value + , pendingOAuth : Decode.Value } @@ -54,6 +63,7 @@ type alias Session = { did : String , handle : String , pdsEndpoint : String + , tokenEndpoint : String , accessToken : String , refreshToken : Maybe String } @@ -89,16 +99,6 @@ type ExamplePhase --- Sign purposes (for routing DPoP port responses) - - -type SignPurpose - = SignPAR - | SignToken - | SignXrpc String - - - -- Model @@ -122,9 +122,12 @@ type alias Model = -- Lexicon state , publications : List Publication , selectedPubRkey : Maybe String + , draftPublication : Maybe Publication , documents : List Document , publicationsCursor : Maybe String , documentsCursor : Maybe String + , pendingIconFile : Maybe File.File + , pendingActionId : Maybe String -- OAuth flow (transient, cleared on success) , oauthCode : String @@ -153,20 +156,39 @@ type alias Publication = , url : String , name : String , description : Maybe String - , avatar : Maybe String + , icon : Maybe BlobRef , basicTheme : Maybe BasicTheme + , preferences : Maybe Preferences + , createdAt : Maybe String } type alias BasicTheme = - { primaryColor : String - , secondaryColor : String + { background : RgbColor + , foreground : RgbColor + , accent : RgbColor + , accentForeground : RgbColor } +type alias RgbColor = + { r : Int, g : Int, b : Int } + + +type alias BlobRef = + { link : String + , mimeType : String + , size : Int + } + + +type alias Preferences = + { showInDiscover : Maybe Bool } + + type alias Document = { title : String - , path : String + , path : Maybe String , site : String , publishedAt : String , url : Maybe String diff --git a/src/View.elm b/src/View.elm index 5cc91a8..cb8c750 100644 --- a/src/View.elm +++ b/src/View.elm @@ -4,7 +4,8 @@ import Browser import Html exposing (..) import Html.Attributes exposing (..) import Html.Events exposing (..) -import State exposing (Msg(..), docMatchesPub, documentUrl, examples, getSelectedPub) +import Lexicons exposing (rgbToHex) +import State exposing (Msg(..), ThemeField(..), defaultBasicTheme, docMatchesPub, documentUrl, examples, getSelectedPub) import Types exposing (..) @@ -43,6 +44,7 @@ view model = , body = [ main_ [ class "container" ] [ viewNotification model + , viewError model , header [] [ h1 [] [ text model.config.clientName ] , p [] @@ -77,6 +79,19 @@ viewNotification model = text "" +viewError : Model -> Html Msg +viewError model = + case model.error of + Just err -> + div [ class "error-banner" ] + [ text err + , button [ class "outline notification-close", onClick ClearError ] [ text "✕" ] + ] + + Nothing -> + text "" + + -- Login @@ -116,9 +131,6 @@ viewLogin model = else text "Sign in with Atmosphere account" ] - , model.error - |> Maybe.map (\err -> p [ class "error" ] [ text err ]) - |> Maybe.withDefault (text "") ] ] @@ -191,7 +203,7 @@ viewPublicationEditor model session = ] ] , h3 [] [ text "Edit Publication" ] - , viewPublicationForm model pub + , viewPublicationForm model session pub , viewPublicationDocuments model session pub ] @@ -199,8 +211,8 @@ viewPublicationEditor model session = p [ class "empty" ] [ text "Publication not found." ] -viewPublicationForm : Model -> Publication -> Html Msg -viewPublicationForm model pub = +viewPublicationForm : Model -> Session -> Publication -> Html Msg +viewPublicationForm model session pub = Html.form [] [ viewField "Publication Name" "This is the title of your site. It appears in feed readers, browser tabs, and search results. Keep it descriptive but concise." @@ -222,53 +234,146 @@ viewPublicationForm model pub = [] , small [] [ text "Example: 'Musings on decentralized protocols and the future of the web.'" ] ] - , fieldset [] - [ legend [] [ text "Visual Theme" ] - , p [] [ text "Colors used by compatible readers (like Leaflet or Pckt) to style your content so it feels like your brand even when read elsewhere." ] - , div [ class "theme-colors" ] - [ label [] - [ text "Primary Color" - , input - [ type_ "color" - , value (pub.basicTheme |> Maybe.map .primaryColor |> Maybe.withDefault "#3b82f6") - , onInput UpdatePubPrimaryColor - ] - [] - , small [] [ text "Used for headings and primary buttons." ] - ] - , label [] - [ text "Secondary Color" - , input - [ type_ "color" - , value (pub.basicTheme |> Maybe.map .secondaryColor |> Maybe.withDefault "#1d4ed8") - , onInput UpdatePubSecondaryColor - ] - [] - , small [] [ text "Used for accents and hover states." ] - ] + , viewIconSection session pub + , viewThemeSection pub + , viewPreferencesSection pub + , div [ class "save-row" ] + [ button + [ type_ "button" + , onClick SavePublication + , disabled model.isLoading + , attribute "aria-busy" + (if model.isLoading then + "true" + + else + "false" + ) + ] + [ if model.isLoading then + text "Saving..." + + else if String.isEmpty pub.rkey then + text "Create Publication" + + else + text "Save" ] + , case model.error of + Just err -> + p [ class "inline-error" ] [ text err ] + + Nothing -> + text "" ] - , button - [ type_ "button" - , onClick SavePublication - , disabled model.isLoading - , attribute "aria-busy" - (if model.isLoading then - "true" - - else - "false" - ) + ] + + +viewIconSection : Session -> Publication -> Html Msg +viewIconSection session pub = + fieldset [] + [ legend [] [ text "Icon" ] + , p [] [ text "Square image used to identify the publication (at least 256×256). Max 1 MB." ] + , case pub.icon of + Just icon -> + div [ class "icon-row" ] + [ img [ src (blobUrl session icon), alt "Icon", class "icon-preview" ] [] + , small [] [ text (icon.mimeType ++ " · " ++ humanSize icon.size) ] + , button [ type_ "button", class "outline secondary", onClick RemoveIcon ] [ text "Remove icon" ] + , button [ type_ "button", onClick PickIcon ] [ text "Replace" ] + ] + + Nothing -> + button [ type_ "button", onClick PickIcon ] [ text "Upload icon" ] + ] + + +blobUrl : Session -> BlobRef -> String +blobUrl session blob = + session.pdsEndpoint + ++ "/xrpc/com.atproto.sync.getBlob?did=" + ++ session.did + ++ "&cid=" + ++ blob.link + + +humanSize : Int -> String +humanSize bytes = + if bytes < 1024 then + String.fromInt bytes ++ " B" + + else if bytes < 1024 * 1024 then + String.fromInt (bytes // 1024) ++ " KB" + + else + String.fromInt (bytes // (1024 * 1024)) ++ " MB" + + +viewThemeSection : Publication -> Html Msg +viewThemeSection pub = + fieldset [] + [ legend [] [ text "Visual theme" ] + , p [] + [ text "Colors used by compatible readers (like " + , a [ href "https://leaflet.pub", target "_blank", rel "noopener noreferrer" ] [ text "Leaflet" ] + , text ", " + , a [ href "https://pckt.app", target "_blank", rel "noopener noreferrer" ] [ text "Pckt" ] + , text ", or " + , a [ href "https://offprint.app", target "_blank", rel "noopener noreferrer" ] [ text "Offprint" ] + , text ") to style your content so it feels like your brand even when read elsewhere." ] - [ if model.isLoading then - text "Saving..." + , case pub.basicTheme of + Just theme -> + div [] + [ div [ class "theme-colors" ] + [ viewColor "Background" "Color used for content background" Background theme.background + , viewColor "Foreground" "Color used for content text" Foreground theme.foreground + , viewColor "Accent" "Color used for links and button backgrounds" Accent theme.accent + , viewColor "Accent foreground" "Color used for button text" AccentForeground theme.accentForeground + ] + , button [ type_ "button", class "outline secondary", onClick RemoveTheme ] [ text "Remove theme" ] + ] - else if String.isEmpty pub.rkey then - text "Create Publication" + Nothing -> + button [ type_ "button", onClick SetDefaultTheme ] [ text "Add a theme" ] + ] - else - text "Save Changes" + +viewColor : String -> String -> ThemeField -> RgbColor -> Html Msg +viewColor labelText helpText field color = + label [] + [ text labelText + , input + [ type_ "color" + , value (rgbToHex color) + , onInput (UpdatePubThemeColor field) ] + [] + , small [] [ text helpText ] + ] + + +viewPreferencesSection : Publication -> Html Msg +viewPreferencesSection pub = + fieldset [] + [ legend [] [ text "Preferences" ] + , case pub.preferences of + Just prefs -> + div [] + [ label [] + [ input + [ type_ "checkbox" + , checked (Maybe.withDefault True prefs.showInDiscover) + , onCheck SetShowInDiscover + ] + [] + , text "Show in discovery feeds" + ] + , button [ type_ "button", class "outline secondary", onClick RemovePreferences ] [ text "Remove preferences" ] + ] + + Nothing -> + button [ type_ "button", onClick (SetShowInDiscover True) ] [ text "Set preferences" ] ] diff --git a/src/Xrpc.elm b/src/Xrpc.elm new file mode 100644 index 0000000..5339304 --- /dev/null +++ b/src/Xrpc.elm @@ -0,0 +1,140 @@ +module Xrpc exposing + ( HttpResponse + , createRecord + , expectResponse + , listRecords + , putRecord + , uploadBlob + ) + +import Dict exposing (Dict) +import File +import Http +import Json.Encode as Encode +import Types exposing (Session) +import Url + + +type alias HttpResponse = + { status : Int + , headers : Dict String String + , body : String + } + + +expectResponse : (Result String HttpResponse -> msg) -> Http.Expect msg +expectResponse tagger = + Http.expectStringResponse tagger + (\response -> + case response of + Http.BadUrl_ url -> + Err ("Bad URL: " ++ url) + + Http.Timeout_ -> + Err "Request timed out" + + Http.NetworkError_ -> + Err "Network error" + + Http.BadStatus_ meta body -> + Ok { status = meta.statusCode, headers = meta.headers, body = body } + + Http.GoodStatus_ meta body -> + Ok { status = meta.statusCode, headers = meta.headers, body = body } + ) + + +listRecords : Session -> String -> Maybe String -> String -> (Result String HttpResponse -> msg) -> Cmd msg +listRecords session collection cursor jwt tagger = + let + cursorParam : String + cursorParam = + case cursor of + Just c -> + "&cursor=" ++ Url.percentEncode c + + Nothing -> + "" + in + Http.request + { method = "GET" + , headers = + [ Http.header "Authorization" ("DPoP " ++ session.accessToken) + , Http.header "DPoP" jwt + ] + , url = + session.pdsEndpoint + ++ "/xrpc/com.atproto.repo.listRecords?repo=" + ++ Url.percentEncode session.did + ++ "&collection=" + ++ Url.percentEncode collection + ++ "&limit=100" + ++ cursorParam + , body = Http.emptyBody + , expect = expectResponse tagger + , timeout = Nothing + , tracker = Nothing + } + + +createRecord : Session -> String -> Encode.Value -> String -> (Result String HttpResponse -> msg) -> Cmd msg +createRecord session collection record jwt tagger = + Http.request + { method = "POST" + , headers = + [ Http.header "Authorization" ("DPoP " ++ session.accessToken) + , Http.header "DPoP" jwt + ] + , url = session.pdsEndpoint ++ "/xrpc/com.atproto.repo.createRecord" + , body = + Http.jsonBody + (Encode.object + [ ( "repo", Encode.string session.did ) + , ( "collection", Encode.string collection ) + , ( "record", record ) + ] + ) + , expect = expectResponse tagger + , timeout = Nothing + , tracker = Nothing + } + + +putRecord : Session -> String -> String -> Encode.Value -> String -> (Result String HttpResponse -> msg) -> Cmd msg +putRecord session collection rkey record jwt tagger = + Http.request + { method = "POST" + , headers = + [ Http.header "Authorization" ("DPoP " ++ session.accessToken) + , Http.header "DPoP" jwt + ] + , url = session.pdsEndpoint ++ "/xrpc/com.atproto.repo.putRecord" + , body = + Http.jsonBody + (Encode.object + [ ( "repo", Encode.string session.did ) + , ( "collection", Encode.string collection ) + , ( "rkey", Encode.string rkey ) + , ( "record", record ) + ] + ) + , expect = expectResponse tagger + , timeout = Nothing + , tracker = Nothing + } + + +uploadBlob : Session -> File.File -> String -> (Result String HttpResponse -> msg) -> Cmd msg +uploadBlob session file jwt tagger = + Http.request + { method = "POST" + , headers = + [ Http.header "Authorization" ("DPoP " ++ session.accessToken) + , Http.header "DPoP" jwt + ] + , url = session.pdsEndpoint ++ "/xrpc/com.atproto.repo.uploadBlob" + , body = Http.fileBody file + , expect = expectResponse tagger + , timeout = Nothing + , tracker = Nothing + } diff --git a/src/build.js b/src/build.js index 35a851e..671e9fd 100644 --- a/src/build.js +++ b/src/build.js @@ -25,7 +25,8 @@ const metadata = { client_name: APP_NAME, client_uri: APP_URL, redirect_uris: [APP_URL + "/"], - scope: "atproto", + scope: + "atproto repo:site.standard.publication?action=create&action=update blob?accept=image/*", grant_types: ["authorization_code", "refresh_token"], response_types: ["code"], application_type: "web", diff --git a/src/index.html b/src/index.html index fcdcdf9..e36fecc 100644 --- a/src/index.html +++ b/src/index.html @@ -77,6 +77,48 @@ .theme-colors label { flex: 1; } + .save-row { + display: flex; + align-items: center; + gap: 1rem; + flex-wrap: wrap; + margin-bottom: 2rem; + } + .save-row button { + margin: 0; + } + .inline-error { + margin: 0; + color: var(--pico-del-color); + font-size: 0.875rem; + } + .error-banner { + background: var(--pico-del-color); + color: white; + padding: 0.75rem 1.25rem; + border-radius: var(--pico-border-radius); + margin-bottom: 1rem; + display: flex; + align-items: center; + justify-content: space-between; + gap: 1rem; + } + .icon-row { + display: flex; + align-items: center; + gap: 1rem; + flex-wrap: wrap; + } + .icon-row button { + margin: 0; + } + .icon-preview { + width: 64px; + height: 64px; + border-radius: 8px; + object-fit: cover; + background: var(--pico-muted-border-color); + } .doc-excerpt { margin: 0.25rem 0 0; font-size: 0.875rem; diff --git a/tests/LexiconTests.elm b/tests/LexiconTests.elm index 4f43708..5e54b4e 100644 --- a/tests/LexiconTests.elm +++ b/tests/LexiconTests.elm @@ -17,7 +17,7 @@ suite = let json : String json = - """{"uri":"at://did:plc:123/site.standard.publication/3mjaxtes2yf2v","value":{"url":"https://test.com","name":"Test","description":"A test","avatar":"https://test.com/a.jpg","basicTheme":{"primaryColor":"#ff0000","secondaryColor":"#00ff00"}}}""" + """{"uri":"at://did:plc:123/site.standard.publication/3mjaxtes2yf2v","value":{"url":"https://test.com","name":"Test","description":"A test","icon":{"$type":"blob","ref":{"$link":"bafkre1"},"mimeType":"image/png","size":1234},"basicTheme":{"background":{"r":255,"g":255,"b":255},"foreground":{"r":0,"g":0,"b":0},"accent":{"r":59,"g":130,"b":246},"accentForeground":{"r":255,"g":255,"b":255}},"preferences":{"showInDiscover":false},"createdAt":"2026-04-11T00:00:00Z"}}""" in case Decode.decodeString publicationListItemDecoder json of Ok pub -> @@ -26,8 +26,11 @@ suite = , \p -> Expect.equal p.url "https://test.com" , \p -> Expect.equal p.name "Test" , \p -> Expect.equal p.description (Just "A test") - , \p -> Expect.equal p.avatar (Just "https://test.com/a.jpg") - , \p -> Expect.equal p.basicTheme (Just { primaryColor = "#ff0000", secondaryColor = "#00ff00" }) + , \p -> Expect.equal p.icon (Just { link = "bafkre1", mimeType = "image/png", size = 1234 }) + , \p -> Expect.equal (Maybe.map .background p.basicTheme) (Just (RgbColor 255 255 255)) + , \p -> Expect.equal (Maybe.map .accent p.basicTheme) (Just (RgbColor 59 130 246)) + , \p -> Expect.equal (Maybe.andThen .showInDiscover p.preferences) (Just False) + , \p -> Expect.equal p.createdAt (Just "2026-04-11T00:00:00Z") ] pub @@ -45,8 +48,10 @@ suite = Expect.all [ \p -> Expect.equal p.rkey "self" , \p -> Expect.equal p.description Nothing - , \p -> Expect.equal p.avatar Nothing + , \p -> Expect.equal p.icon Nothing , \p -> Expect.equal p.basicTheme Nothing + , \p -> Expect.equal p.preferences Nothing + , \p -> Expect.equal p.createdAt Nothing ] pub @@ -59,13 +64,13 @@ suite = let json : String json = - """{"title":"Hello","path":"/hello","site":"https://example.com","publishedAt":"2026-05-01T12:00:00Z"}""" + """{"title":"Hello","site":"https://example.com","publishedAt":"2026-05-01T12:00:00Z"}""" in case Decode.decodeString documentDecoder json of Ok doc -> Expect.all [ \d -> Expect.equal d.title "Hello" - , \d -> Expect.equal d.path "/hello" + , \d -> Expect.equal d.path Nothing , \d -> Expect.equal d.site "https://example.com" , \d -> Expect.equal d.publishedAt "2026-05-01T12:00:00Z" , \d -> Expect.equal d.url Nothing @@ -75,7 +80,7 @@ suite = Err err -> Expect.fail (Decode.errorToString err) - , test "decodes a document record with a canonical url" <| + , test "decodes a document record with a canonical url and path" <| \_ -> let json : String @@ -84,7 +89,11 @@ suite = in case Decode.decodeString documentDecoder json of Ok doc -> - Expect.equal (Just "https://custom.example/hi") doc.url + Expect.all + [ \d -> Expect.equal d.path (Just "/hi") + , \d -> Expect.equal d.url (Just "https://custom.example/hi") + ] + doc Err err -> Expect.fail (Decode.errorToString err) @@ -93,7 +102,7 @@ suite = let json : String json = - """{"title":"Hi","path":"/hi","site":"https://example.com","publishedAt":"2026-05-01T12:00:00Z","description":"a short excerpt"}""" + """{"title":"Hi","site":"https://example.com","publishedAt":"2026-05-01T12:00:00Z","description":"a short excerpt"}""" in case Decode.decodeString documentDecoder json of Ok doc -> @@ -102,30 +111,89 @@ suite = Err err -> Expect.fail (Decode.errorToString err) ] - , describe "publicationEncoder" - [ test "round-trips a publication through encoder + decoder shape" <| + , describe "publicationRecordEncoder" + [ test "omits absent optionals (no null values)" <| \_ -> let pub : Publication pub = - { rkey = "self" + { rkey = "" , url = "https://x.test" , name = "X" - , description = Just "desc" - , avatar = Nothing - , basicTheme = Just { primaryColor = "#112233", secondaryColor = "#445566" } + , description = Nothing + , icon = Nothing + , basicTheme = Nothing + , preferences = Nothing + , createdAt = Nothing } encoded : String encoded = - Encode.encode 0 (publicationEncoder pub) + Encode.encode 0 (publicationRecordEncoder pub) in Expect.all [ String.contains "\"$type\":\"site.standard.publication\"" >> Expect.equal True , String.contains "\"url\":\"https://x.test\"" >> Expect.equal True - , String.contains "\"avatar\":null" >> Expect.equal True - , String.contains "\"primaryColor\":\"#112233\"" >> Expect.equal True + , String.contains "null" >> Expect.equal False + , String.contains "description" >> Expect.equal False + , String.contains "icon" >> Expect.equal False + , String.contains "basicTheme" >> Expect.equal False + , String.contains "preferences" >> Expect.equal False + ] + encoded + , test "includes all fields when present" <| + \_ -> + let + pub : Publication + pub = + { rkey = "abc" + , url = "https://x.test" + , name = "X" + , description = Just "desc" + , icon = Just { link = "bafkre1", mimeType = "image/png", size = 1234 } + , basicTheme = + Just + { background = RgbColor 255 255 255 + , foreground = RgbColor 0 0 0 + , accent = RgbColor 59 130 246 + , accentForeground = RgbColor 255 255 255 + } + , preferences = Just { showInDiscover = Just True } + , createdAt = Just "2026-04-11T00:00:00Z" + } + + encoded : String + encoded = + Encode.encode 0 (publicationRecordEncoder pub) + in + Expect.all + [ String.contains "\"description\":\"desc\"" >> Expect.equal True + , String.contains "\"$link\":\"bafkre1\"" >> Expect.equal True + , String.contains "\"mimeType\":\"image/png\"" >> Expect.equal True + , String.contains "\"showInDiscover\":true" >> Expect.equal True + , String.contains "\"createdAt\":\"2026-04-11T00:00:00Z\"" >> Expect.equal True + , String.contains "\"r\":59" >> Expect.equal True ] encoded ] + , describe "hex ↔ RGB" + [ test "hexToRgb parses #rrggbb" <| + \_ -> Expect.equal (Just (RgbColor 255 128 0)) (hexToRgb "#ff8000") + , test "hexToRgb without hash" <| + \_ -> Expect.equal (Just (RgbColor 0 0 0)) (hexToRgb "000000") + , test "hexToRgb rejects bad input" <| + \_ -> Expect.equal Nothing (hexToRgb "xyz") + , test "rgbToHex formats zero-padded lowercase" <| + \_ -> Expect.equal "#ff8000" (rgbToHex (RgbColor 255 128 0)) + , test "rgbToHex zero" <| + \_ -> Expect.equal "#000000" (rgbToHex (RgbColor 0 0 0)) + , test "round-trip" <| + \_ -> + case hexToRgb "#1a2b3c" of + Just c -> + Expect.equal "#1a2b3c" (rgbToHex c) + + Nothing -> + Expect.fail "parse failed" + ] ] diff --git a/tests/StateTests.elm b/tests/StateTests.elm index ce248f2..d25b58a 100644 --- a/tests/StateTests.elm +++ b/tests/StateTests.elm @@ -1,32 +1,36 @@ module StateTests exposing (suite) import Dict +import Dpop exposing (PendingAction(..), actionFromId, actionId) import Expect import Json.Decode as Decode -import State +import Oauth exposing - ( PendingAction(..) - , Route(..) - , actionFromId - , actionId - , decrementPending - , dnsTxtDecoder - , docMatchesPub - , documentUrl + ( dnsTxtDecoder , encodeFormBody - , errorFromBody , extractAuthEndpoints , extractAuthServerUrl - , extractCursor , extractPdsEndpoint , extractRequestUri , extractToken + ) +import Route + exposing + ( Route(..) , getQueryParam + , parseRoute + , routeToPath + ) +import State + exposing + ( decrementPending + , docMatchesPub + , documentUrl + , errorFromBody + , extractCursor , isNonceRetry , normalizeHandle , originOf - , parseRoute - , routeToPath ) import Test exposing (..) import Types exposing (Document, Publication) @@ -194,39 +198,33 @@ suite = Err err -> Expect.fail err ] - , describe "parseRoute (no base path)" - [ test "parses /" <| - \_ -> Expect.equal RouteHome (routeFor "/" "/") - , test "parses /pub/new" <| - \_ -> Expect.equal RouteNewPub (routeFor "/" "/pub/new") - , test "parses /pub/" <| - \_ -> Expect.equal (RoutePub "abc123") (routeFor "/" "/pub/abc123") - , test "unknown path falls back to home" <| - \_ -> Expect.equal RouteHome (routeFor "/" "/anything/else") - ] - , describe "parseRoute (with base path /std-pub/)" - [ test "parses /std-pub/" <| - \_ -> Expect.equal RouteHome (routeFor "/std-pub/" "/std-pub/") - , test "parses /std-pub (no trailing slash)" <| - \_ -> Expect.equal RouteHome (routeFor "/std-pub/" "/std-pub") - , test "parses /std-pub/pub/abc123" <| - \_ -> Expect.equal (RoutePub "abc123") (routeFor "/std-pub/" "/std-pub/pub/abc123") - , test "parses /std-pub/pub/new" <| - \_ -> Expect.equal RouteNewPub (routeFor "/std-pub/" "/std-pub/pub/new") + , describe "parseRoute (hash-based)" + [ test "no fragment is home" <| + \_ -> Expect.equal RouteHome (routeFor "/anything") + , test "empty hash is home" <| + \_ -> Expect.equal RouteHome (routeFor "/#") + , test "#/pub/new" <| + \_ -> Expect.equal RouteNewPub (routeFor "/#/pub/new") + , test "#/pub/" <| + \_ -> Expect.equal (RoutePub "abc123") (routeFor "/#/pub/abc123") + , test "unknown fragment falls back to home" <| + \_ -> Expect.equal RouteHome (routeFor "/#/anything/else") + , test "ignores the path; only fragment matters" <| + \_ -> Expect.equal (RoutePub "xyz") (routeFor "/std-pub/anything#/pub/xyz") ] , describe "routeToPath" [ test "home at root base is /" <| \_ -> Expect.equal "/" (routeToPath "/" RouteHome) , test "publication at root base" <| - \_ -> Expect.equal "/pub/xyz" (routeToPath "/" (RoutePub "xyz")) + \_ -> Expect.equal "/#/pub/xyz" (routeToPath "/" (RoutePub "xyz")) , test "new at root base" <| - \_ -> Expect.equal "/pub/new" (routeToPath "/" RouteNewPub) + \_ -> Expect.equal "/#/pub/new" (routeToPath "/" RouteNewPub) , test "home at /std-pub/ base" <| \_ -> Expect.equal "/std-pub/" (routeToPath "/std-pub/" RouteHome) , test "publication at /std-pub/ base" <| - \_ -> Expect.equal "/std-pub/pub/xyz" (routeToPath "/std-pub/" (RoutePub "xyz")) - , test "new at /std-pub/ base" <| - \_ -> Expect.equal "/std-pub/pub/new" (routeToPath "/std-pub/" RouteNewPub) + \_ -> Expect.equal "/std-pub/#/pub/xyz" (routeToPath "/std-pub/" (RoutePub "xyz")) + , test "appends slash to base when missing" <| + \_ -> Expect.equal "/std-pub/#/pub/xyz" (routeToPath "/std-pub" (RoutePub "xyz")) ] , describe "documentUrl" [ test "uses canonical url when present" <| @@ -264,7 +262,7 @@ suite = d = docAt "ignored" in - { d | path = "some/post" } + { d | path = Just "some/post" } in Expect.equal "https://example.com/some/post" (documentUrl examplePub doc) ] @@ -397,11 +395,11 @@ suite = ] -routeFor : String -> String -> Route -routeFor basePath path = - case Url.fromString ("http://app.test" ++ path) of +routeFor : String -> Route +routeFor pathWithFragment = + case Url.fromString ("http://app.test" ++ pathWithFragment) of Just u -> - parseRoute basePath u + parseRoute u Nothing -> RouteHome @@ -418,15 +416,17 @@ examplePub = , url = "https://example.com" , name = "Ex" , description = Nothing - , avatar = Nothing + , icon = Nothing , basicTheme = Nothing + , preferences = Nothing + , createdAt = Nothing } docAt : String -> Document docAt site = { title = "T" - , path = "/p" + , path = Just "/p" , site = site , publishedAt = "2026-01-01T00:00:00Z" , url = Nothing