module State exposing ( Msg(..) , ThemeField(..) , decrementPending , defaultBasicTheme , docMatchesPub , documentUrl , errorFromBody , examples , extractBlobRef , extractCursor , getSelectedPub , init , initModel , isNonceRetry , normalizeHandle , originOf , 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 import Xrpc exposing (HttpResponse) -- Login page cycling examples examples : List String examples = [ "Bluesky", "Blacksky", "Eurosky", "Tangled" ] -- Publication editor type ThemeField = Background | Foreground | Accent | AccentForeground defaultBasicTheme : BasicTheme defaultBasicTheme = { background = RgbColor 255 255 255 , foreground = RgbColor 0 0 0 , accent = RgbColor 59 130 246 , accentForeground = RgbColor 255 255 255 } setThemeField : ThemeField -> RgbColor -> BasicTheme -> BasicTheme setThemeField field color theme = case field of Background -> { theme | background = color } Foreground -> { theme | foreground = color } Accent -> { theme | accent = color } AccentForeground -> { theme | accentForeground = color } -- Init init : Flags -> Url.Url -> Nav.Key -> ( Model, Cmd Msg ) init flags url key = let basePath : String basePath = Route.basePathFromAppUrl flags.appUrl config : Config config = { clientName = flags.clientName , appUrl = flags.appUrl , basePath = basePath , plcDirectoryUrl = flags.plcDirectoryUrl , dohUrl = flags.dohUrl , bskyAppviewUrl = flags.bskyAppviewUrl } clientId : String clientId = flags.appUrl ++ "/client-metadata.json" redirectUri : String redirectUri = flags.appUrl ++ "/" 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 ( Route.getQueryParam "code" url, Route.getQueryParam "state" url, maybePending ) of ( Just code, Just stateParam, Just pending ) -> if stateParam == pending.state then ( { base | isLoading = True , oauthCode = code , oauthCodeVerifier = pending.codeVerifier , oauthState = pending.state , oauthTokenEndpoint = pending.tokenEndpoint , oauthPdsEndpoint = pending.pdsEndpoint , oauthDid = pending.did , oauthHandle = pending.handle } , Dpop.signFor ActionToken { htm = "POST" , htu = pending.tokenEndpoint , nonce = Nothing , accessToken = Nothing } ) else ( { base | error = Just "OAuth state mismatch" } , Ports.clearPendingOAuth () ) _ -> case maybeSession of Just session -> ( { base | page = Dashboard session , isLoading = True , pendingRequests = 2 , selectedPubRkey = Route.selectedFromRoute (Route.parseRoute url) } , Cmd.batch [ Dpop.signFor ActionListPublications (Dpop.xrpcSignInput session "listRecords") , Dpop.signFor ActionListDocuments (Dpop.xrpcSignInput session "listRecords") ] ) Nothing -> ( base, Cmd.none ) 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)) 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 initModel config jkt key clientId redirectUri = { config = config , jkt = jkt , page = LoginView , navKey = key , clientId = clientId , redirectUri = redirectUri , handleInput = "" , error = Nothing , notification = Nothing , isLoading = False , pendingRequests = 0 , exampleIndex = 0 , examplePhase = Idle , publications = [] , selectedPubRkey = Nothing , draftPublication = Nothing , documents = [] , publicationsCursor = Nothing , documentsCursor = Nothing , pendingIconFile = Nothing , pendingActionId = Nothing , oauthCode = "" , oauthCodeVerifier = "" , oauthCodeChallenge = "" , oauthState = "" , oauthDid = "" , oauthHandle = "" , oauthPdsEndpoint = "" , oauthAuthorizationEndpoint = "" , oauthTokenEndpoint = "" , oauthParEndpoint = "" , oauthIssuer = "" , nonces = Dict.empty } -- Subscriptions subscriptions : Model -> Sub Msg subscriptions model = Sub.batch [ Ports.onDpopSigned DpopSigned , Ports.onSha256 Sha256Computed , case model.page of LoginView -> Time.every 3000 (\_ -> RotateExample) Dashboard _ -> Sub.none ] -- Msg type Msg = UpdateHandle String | StartLogin | StateGenerated String | VerifierGenerated String | Sha256Computed Decode.Value | HandleResolvedDoh (Result Http.Error String) | HandleResolvedWellKnown (Result Http.Error String) | HandleResolvedAppview (Result Http.Error String) | DidDocumentFetched (Result Http.Error String) | AuthServerFound (Result Http.Error String) | AuthMetadataFetched (Result Http.Error String) | DpopSigned Decode.Value | SignedResponse String (Result String HttpResponse) | SelectPublication (Maybe String) | InitPublication | UpdatePubName String | UpdatePubUrl String | UpdatePubDescription 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 -- Update update : Msg -> Model -> ( Model, Cmd Msg ) update msg model = case msg of UpdateHandle v -> ( { model | handleInput = v }, Cmd.none ) StartLogin -> let handle : String handle = normalizeHandle model.handleInput in if String.isEmpty handle then ( model, Cmd.none ) else ( { model | isLoading = True, error = Nothing, oauthHandle = handle } , Cmd.batch [ Random.generate VerifierGenerated Oauth.codeVerifierGenerator , Random.generate StateGenerated Oauth.stateGenerator ] ) StateGenerated s -> ( { model | oauthState = s }, Cmd.none ) VerifierGenerated v -> ( { model | oauthCodeVerifier = v } , Cmd.batch [ Ports.sha256 (Encode.object [ ( "id", Encode.string "challenge" ), ( "input", Encode.string v ) ]) , Oauth.resolveHandleViaDoh model.config.dohUrl model.oauthHandle HandleResolvedDoh ] ) Sha256Computed value -> case Decode.decodeValue Dpop.sha256Decoder value of Ok { id, v } -> if id == "challenge" then ( { model | oauthCodeChallenge = v }, Cmd.none ) else ( model, Cmd.none ) Err _ -> ( model, Cmd.none ) HandleResolvedDoh (Ok did) -> ( { model | oauthDid = String.trim did } , Oauth.fetchDidDocument model.config.plcDirectoryUrl (String.trim did) DidDocumentFetched ) HandleResolvedDoh (Err _) -> ( model, Oauth.resolveHandleViaWellKnown model.oauthHandle HandleResolvedWellKnown ) HandleResolvedWellKnown (Ok did) -> ( { model | oauthDid = String.trim did } , Oauth.fetchDidDocument model.config.plcDirectoryUrl (String.trim did) DidDocumentFetched ) HandleResolvedWellKnown (Err _) -> ( model, Oauth.resolveHandleViaAppview model.config.bskyAppviewUrl model.oauthHandle HandleResolvedAppview ) HandleResolvedAppview (Ok 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 Oauth.extractPdsEndpoint body of Ok ( pdsEndpoint, maybeAuthServer ) -> case maybeAuthServer of Just authServer -> ( { model | oauthPdsEndpoint = pdsEndpoint, oauthIssuer = authServer } , Oauth.fetchAuthMetadata authServer AuthMetadataFetched ) Nothing -> ( { model | oauthPdsEndpoint = pdsEndpoint } , Oauth.fetchProtectedResource pdsEndpoint AuthServerFound ) Err decodeErr -> ( stopLoadingWithError ("Failed to parse DID document: " ++ decodeErr) model, Cmd.none ) DidDocumentFetched (Err err) -> ( stopLoadingWithError ("Failed to fetch DID document: " ++ httpErrorToString err) model, Cmd.none ) AuthServerFound (Ok body) -> case Oauth.extractAuthServerUrl body of Ok authServer -> ( { model | oauthIssuer = authServer }, Oauth.fetchAuthMetadata authServer AuthMetadataFetched ) Err decodeErr -> ( stopLoadingWithError ("Failed to find authorization server: " ++ decodeErr) model, Cmd.none ) AuthServerFound (Err err) -> ( stopLoadingWithError ("Failed to discover authorization server: " ++ httpErrorToString err) model, Cmd.none ) AuthMetadataFetched (Ok body) -> case Oauth.extractAuthEndpoints body of Ok endpoints -> let updated : Model updated = { model | oauthAuthorizationEndpoint = endpoints.authorizationEndpoint , oauthTokenEndpoint = endpoints.tokenEndpoint , oauthParEndpoint = endpoints.parEndpoint , oauthIssuer = endpoints.issuer } in ( updated , Dpop.signFor ActionPAR { htm = "POST" , htu = endpoints.parEndpoint , nonce = Dict.get (originOf endpoints.parEndpoint) model.nonces , accessToken = Nothing } ) Err decodeErr -> ( stopLoadingWithError ("Failed to parse auth metadata: " ++ decodeErr) model, Cmd.none ) AuthMetadataFetched (Err err) -> ( stopLoadingWithError ("Failed to fetch auth metadata: " ++ httpErrorToString err) model, Cmd.none ) DpopSigned value -> case Decode.decodeValue Dpop.dpopDecoder value of Ok (Ok { id, jwt }) -> dispatchSigned id jwt model Ok (Err err) -> ( stopLoadingWithError ("DPoP sign error: " ++ err) model, Cmd.none ) Err decodeErr -> ( stopLoadingWithError ("DPoP port error: " ++ Decode.errorToString decodeErr) model, Cmd.none ) SignedResponse id result -> case ( Dpop.actionFromId id, result ) of ( Just action, Ok resp ) -> let updated : Model updated = storeNonce (originOf (htuFor action model)) resp model in 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 else ( stopLoadingWithError (errorFromBody resp) updated, Cmd.none ) ( _, Err err ) -> ( stopLoadingWithError err model, Cmd.none ) ( Nothing, _ ) -> ( stopLoadingWithError ("Unknown signed-response id: " ++ id) model, Cmd.none ) SelectPublication maybeRkey -> let route : Route route = case maybeRkey of Just rkey -> if String.isEmpty rkey then RouteNewPub else RoutePub rkey 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, draftPublication = draft } , Nav.pushUrl model.navKey (Route.routeToPath model.config.basePath route) ) InitPublication -> ( { model | draftPublication = Just emptyPublication , selectedPubRkey = Just "" } , Nav.pushUrl model.navKey (Route.routeToPath model.config.basePath RouteNewPub) ) UpdatePubName v -> updatePub (\p -> { p | name = v }) model UpdatePubUrl v -> updatePub (\p -> { p | url = v }) model UpdatePubDescription v -> updatePub (\p -> { p | description = if String.isEmpty v then Nothing else Just v } ) model UpdatePubThemeColor field hex -> case hexToRgb hex of Just rgb -> updatePub (\p -> { p | basicTheme = Just (setThemeField field rgb (Maybe.withDefault defaultBasicTheme p.basicTheme)) }) model Nothing -> ( model, Cmd.none ) SetDefaultTheme -> updatePub (\p -> { p | basicTheme = Just defaultBasicTheme }) model 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 = 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) ) FadeOutComplete -> ( { model | exampleIndex = remainderBy (List.length examples) (model.exampleIndex + 1) , examplePhase = FadingIn } , Task.perform (\_ -> FadeInComplete) (Process.sleep 250) ) FadeInComplete -> ( { model | examplePhase = Idle }, Cmd.none ) 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 = "" , oauthCodeVerifier = "" , oauthCodeChallenge = "" , oauthState = "" , oauthDid = "" , oauthHandle = "" , oauthPdsEndpoint = "" , oauthAuthorizationEndpoint = "" , oauthTokenEndpoint = "" , oauthParEndpoint = "" } , Cmd.batch [ Ports.clearSession (), Nav.pushUrl model.navKey (Route.routeToPath model.config.basePath RouteHome) ] ) LinkClicked urlRequest -> case urlRequest of Browser.Internal url -> ( model, Nav.pushUrl model.navKey (Url.toString url) ) Browser.External href -> ( model, Nav.load href ) UrlChanged url -> let selected : Maybe String selected = Route.selectedFromRoute (Route.parseRoute url) draft : Maybe Publication draft = if selected == Just "" then case model.draftPublication of Just _ -> model.draftPublication Nothing -> Just emptyPublication else Nothing in ( { model | selectedPubRkey = selected, draftPublication = draft }, Cmd.none ) -- Dispatch: fire the actual HTTP request using the JWT we just received. dispatchSigned : String -> String -> Model -> ( Model, Cmd Msg ) dispatchSigned id jwt model = case Dpop.actionFromId id of Just ActionPAR -> ( 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 , 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, Xrpc.listRecords session "site.standard.publication" model.publicationsCursor jwt (SignedResponse id) ) LoginView -> ( stopLoadingWithError "listRecords dispatch dropped: not on dashboard" model, Cmd.none ) Just ActionListDocuments -> case model.page of Dashboard session -> ( model, Xrpc.listRecords session "site.standard.document" model.documentsCursor jwt (SignedResponse id) ) LoginView -> ( stopLoadingWithError "listRecords dispatch dropped: not on dashboard" model, Cmd.none ) Just ActionCreatePublication -> case ( model.page, getSelectedPub model ) of ( Dashboard session, Just pub ) -> ( model, Xrpc.createRecord session "site.standard.publication" (publicationRecordEncoder pub) jwt (SignedResponse id) ) _ -> ( stopLoadingWithError "createRecord dispatch dropped: selection lost" model, Cmd.none ) Just (ActionPutPublication rkey) -> case ( model.page, getSelectedPub model ) of ( Dashboard session, Just pub ) -> ( model, Xrpc.putRecord session "site.standard.publication" rkey (publicationRecordEncoder pub) jwt (SignedResponse id) ) _ -> ( 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 -> ( stopLoadingWithError ("Unknown DPoP action id: " ++ id) model, Cmd.none ) -- Success path per action. handleSuccess : PendingAction -> String -> Model -> ( Model, Cmd Msg ) handleSuccess action body model = case action of ActionPAR -> case Oauth.extractRequestUri body of Ok requestUri -> let authUrl : String authUrl = model.oauthAuthorizationEndpoint ++ "?client_id=" ++ Url.percentEncode model.clientId ++ "&request_uri=" ++ Url.percentEncode requestUri pending : Encode.Value pending = Encode.object [ ( "state", Encode.string model.oauthState ) , ( "codeVerifier", Encode.string model.oauthCodeVerifier ) , ( "tokenEndpoint", Encode.string model.oauthTokenEndpoint ) , ( "pdsEndpoint", Encode.string model.oauthPdsEndpoint ) , ( "did", Encode.string model.oauthDid ) , ( "handle", Encode.string model.oauthHandle ) ] in ( model, Cmd.batch [ Ports.savePendingOAuth pending, Nav.load authUrl ] ) Err decodeErr -> ( stopLoadingWithError ("Failed to parse PAR response: " ++ decodeErr) model, Cmd.none ) ActionToken -> case Oauth.extractToken body of Ok { accessToken, refreshToken, sub } -> let session : Session session = { did = sub , handle = model.oauthHandle , pdsEndpoint = model.oauthPdsEndpoint , tokenEndpoint = model.oauthTokenEndpoint , accessToken = accessToken , refreshToken = refreshToken } in ( { model | page = Dashboard session , isLoading = True , pendingRequests = 2 , publications = [] , documents = [] , publicationsCursor = Nothing , documentsCursor = Nothing , oauthCode = "" , oauthCodeVerifier = "" , oauthState = "" } , Cmd.batch [ Ports.saveSession (Dpop.sessionEncoder session) , Ports.clearPendingOAuth () , 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 -> let pubs : List Publication pubs = List.filterMap identity maybePubs skipped : Int skipped = List.length maybePubs - List.length pubs updated : Model updated = { model | publications = model.publications ++ pubs , publicationsCursor = extractCursor body , notification = if skipped > 0 then Just ("Skipped " ++ String.fromInt skipped ++ " invalid publication record(s)") else model.notification } in continueOrFinish ActionListPublications updated Err decodeErr -> ( decrementPending { model | error = Just ("Failed to decode publications: " ++ Decode.errorToString decodeErr) } , Cmd.none ) ActionListDocuments -> case Decode.decodeString (Decode.field "records" (Decode.list (Decode.maybe (Decode.field "value" documentDecoder)))) body of Ok maybeDocs -> 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) } , Cmd.none ) ActionCreatePublication -> updateSavedRkey 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. -} continueOrFinish : PendingAction -> Model -> ( Model, Cmd Msg ) continueOrFinish action model = let cursor : Maybe String cursor = case action of ActionListPublications -> model.publicationsCursor ActionListDocuments -> model.documentsCursor _ -> Nothing in case ( model.page, cursor ) of ( Dashboard session, Just _ ) -> ( 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 Ok c -> if String.isEmpty c then Nothing else Just c Err _ -> Nothing updateSavedRkey : String -> Model -> ( Model, Cmd Msg ) updateSavedRkey body model = case Decode.decodeString (Decode.field "uri" Decode.string) body of Ok uri -> let rkey : String rkey = uri |> String.split "/" |> List.reverse |> List.head |> Maybe.withDefault "" previousRkey : String previousRkey = Maybe.withDefault "" model.selectedPubRkey 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 List.map (\p -> if p.rkey == previousRkey then { p | rkey = rkey } else p ) model.publications cmd : Cmd Msg cmd = if previousRkey == rkey then Cmd.none else Nav.replaceUrl model.navKey (Route.routeToPath model.config.basePath (RoutePub rkey)) in ( { model | publications = publications , draftPublication = if wasCreate then Nothing else model.draftPublication , selectedPubRkey = Just rkey , isLoading = False , notification = Just "Publication saved!" } , cmd ) Err decodeErr -> ( stopLoadingWithError ("Save returned an unexpected response: " ++ Decode.errorToString decodeErr ++ " — body: " ++ body) model, Cmd.none ) -- Re-sign with the new DPoP-Nonce and retry the request. retrySigned : PendingAction -> Model -> HttpResponse -> Cmd Msg retrySigned action model resp = let htu : String htu = htuFor action model nonce : Maybe String nonce = case Dict.get "dpop-nonce" resp.headers of Just n -> Just n Nothing -> Dict.get (originOf htu) model.nonces in Dpop.signFor action { htm = htmFor action , htu = htu , nonce = nonce , accessToken = accessTokenForAction action model } htmFor : PendingAction -> String htmFor action = case action of ActionListPublications -> "GET" ActionListDocuments -> "GET" _ -> "POST" htuFor : PendingAction -> Model -> String htuFor action model = case action of ActionPAR -> model.oauthParEndpoint ActionToken -> model.oauthTokenEndpoint ActionRefresh -> case model.page of Dashboard s -> s.tokenEndpoint LoginView -> model.oauthTokenEndpoint ActionListPublications -> sessionPds model ++ "/xrpc/com.atproto.repo.listRecords" ActionListDocuments -> sessionPds model ++ "/xrpc/com.atproto.repo.listRecords" ActionCreatePublication -> sessionPds model ++ "/xrpc/com.atproto.repo.createRecord" ActionPutPublication _ -> sessionPds model ++ "/xrpc/com.atproto.repo.putRecord" ActionUploadIcon -> sessionPds model ++ "/xrpc/com.atproto.repo.uploadBlob" sessionPds : Model -> String sessionPds model = case model.page of Dashboard s -> s.pdsEndpoint LoginView -> model.oauthPdsEndpoint accessTokenForAction : PendingAction -> Model -> Maybe String accessTokenForAction action model = case ( action, model.page ) of ( ActionPAR, _ ) -> Nothing ( ActionToken, _ ) -> Nothing ( ActionRefresh, _ ) -> Nothing ( _, Dashboard session ) -> Just session.accessToken ( _, LoginView ) -> Nothing -- Helpers normalizeHandle : String -> String normalizeHandle raw = let trimmed : String trimmed = String.trim raw in if String.startsWith "@" trimmed then String.dropLeft 1 trimmed else trimmed originOf : String -> String originOf url = case Url.fromString url of Just u -> let scheme : String scheme = case u.protocol of Url.Http -> "http" Url.Https -> "https" portStr : String portStr = case u.port_ of Just p -> ":" ++ String.fromInt p Nothing -> "" in scheme ++ "://" ++ u.host ++ portStr Nothing -> url storeNonce : String -> HttpResponse -> Model -> Model storeNonce origin resp model = case Dict.get "dpop-nonce" resp.headers of Just nonce -> { model | nonces = Dict.insert origin nonce model.nonces } Nothing -> 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) && (case Decode.decodeString (Decode.field "error" Decode.string) resp.body of Ok "use_dpop_nonce" -> True _ -> False ) errorFromBody : HttpResponse -> String errorFromBody resp = case Decode.decodeString (Decode.field "error_description" Decode.string) resp.body of Ok msg -> "HTTP " ++ String.fromInt resp.status ++ ": " ++ msg Err _ -> case Decode.decodeString (Decode.field "message" Decode.string) resp.body of Ok msg -> "HTTP " ++ String.fromInt resp.status ++ ": " ++ msg Err _ -> "HTTP " ++ String.fromInt resp.status decrementPending : { r | pendingRequests : Int, isLoading : Bool } -> { r | pendingRequests : Int, isLoading : Bool } decrementPending model = let next : Int next = max 0 (model.pendingRequests - 1) in { model | pendingRequests = next, isLoading = next > 0 } stopLoadingWithError : String -> Model -> Model stopLoadingWithError err model = { model | error = Just err, isLoading = False, pendingRequests = 0 } 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 Nothing -> Nothing {-| A document belongs to a publication when its `site` field either matches the publication URL (legacy/loose documents) or the publication's at-uri `at:///site.standard.publication/`. -} docMatchesPub : String -> Publication -> Document -> Bool docMatchesPub did pub doc = (doc.site == pub.url) || (doc.site == "at://" ++ did ++ "/site.standard.publication/" ++ pub.rkey) {-| 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 = case doc.url of Just u -> u Nothing -> let base : String base = if String.endsWith "/" pub.url then String.dropRight 1 pub.url else pub.url in case doc.path of Just p -> if String.startsWith "/" p then base ++ p else 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 apply p = if p.rkey == rkey then fn p else p in { model | publications = List.map apply model.publications } Nothing -> model 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 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 } ) _ -> ( model, Cmd.none ) httpErrorToString : Http.Error -> String httpErrorToString err = case err of Http.BadUrl url -> "Invalid URL: " ++ url Http.Timeout -> "Request timed out" Http.NetworkError -> "Network error" Http.BadStatus status -> "HTTP " ++ String.fromInt status Http.BadBody msg -> "Bad response: " ++ msg