ui: Add request context for error flash

- webui: Update mailbox, attachment paths

pkg/webui/routes.go

@@ -12,12 +12,12 @@ func SetupRoutes(r *mux.Router) {
 		web.Handler(RootGreeting)).Name("RootGreeting").Methods("GET")
 	r.Path("/status").Handler(
 		web.Handler(RootStatus)).Name("RootStatus").Methods("GET")
-	r.Path("/m/{name}/{id}").Handler(
+	r.Path("/mailbox/{name}/{id}").Handler(
 		web.Handler(MailboxMessage)).Name("MailboxMessage").Methods("GET")
-	r.Path("/m/{name}/{id}/html").Handler(
+	r.Path("/mailbox/{name}/{id}/html").Handler(
 		web.Handler(MailboxHTML)).Name("MailboxHTML").Methods("GET")
-	r.Path("/m/{name}/{id}/source").Handler(
+	r.Path("/mailbox/{name}/{id}/source").Handler(
 		web.Handler(MailboxSource)).Name("MailboxSource").Methods("GET")
-	r.Path("/m/attach/{name}/{id}/{num}/{file}").Handler(
+	r.Path("/mailbox/{name}/{id}/attach/{num}/{file}").Handler(
 		web.Handler(MailboxViewAttach)).Name("MailboxViewAttach").Methods("GET")
 }

ui/package-lock.json

@@ -3224,7 +3224,8 @@
         "ansi-regex": {
           "version": "2.1.1",
           "bundled": true,
-          "dev": true
+          "dev": true,
+          "optional": true
         },
         "aproba": {
           "version": "1.2.0",
@@ -3639,7 +3640,8 @@
         "safe-buffer": {
           "version": "5.1.1",
           "bundled": true,
-          "dev": true
+          "dev": true,
+          "optional": true
         },
         "safer-buffer": {
           "version": "2.1.2",
@@ -3695,6 +3697,7 @@
           "version": "3.0.1",
           "bundled": true,
           "dev": true,
+          "optional": true,
           "requires": {
             "ansi-regex": "^2.0.0"
           }
@@ -3738,12 +3741,14 @@
         "wrappy": {
           "version": "1.0.2",
           "bundled": true,
-          "dev": true
+          "dev": true,
+          "optional": true
         },
         "yallist": {
           "version": "3.0.2",
           "bundled": true,
-          "dev": true
+          "dev": true,
+          "optional": true
         }
       }
     },

ui/src/Api.elm

@@ -7,6 +7,7 @@ module Api exposing
     , getServerMetrics
     , markMessageSeen
     , purgeMailbox
+    , serveUrl
     )
 
 import Data.Message as Message exposing (Message)
@@ -21,11 +22,11 @@ import Url.Builder
 
 
 type alias DataResult msg data =
-    Result Http.Error data -> msg
+    Result HttpUtil.Error data -> msg
 
 
 type alias HttpResult msg =
-    Result Http.Error () -> msg
+    Result HttpUtil.Error () -> msg
 
 
 {-| Builds a public REST API URL (see wiki).
@@ -49,41 +50,71 @@ deleteMessage msg mailboxName id =
 
 getHeaderList : DataResult msg (List MessageHeader) -> String -> Cmd msg
 getHeaderList msg mailboxName =
+    let
+        context =
+            { method = "GET"
+            , url = apiV1Url [ "mailbox", mailboxName ]
+            }
+    in
     Http.get
-        { url = apiV1Url [ "mailbox", mailboxName ]
+        { url = context.url
-        , expect = Http.expectJson msg (Decode.list MessageHeader.decoder)
+        , expect = HttpUtil.expectJson context msg (Decode.list MessageHeader.decoder)
         }
 
 
 getGreeting : DataResult msg String -> Cmd msg
 getGreeting msg =
+    let
+        context =
+            { method = "GET"
+            , url = serveUrl [ "greeting" ]
+            }
+    in
     Http.get
-        { url = serveUrl [ "greeting" ]
+        { url = context.url
-        , expect = Http.expectString msg
+        , expect = HttpUtil.expectString context msg
         }
 
 
 getMessage : DataResult msg Message -> String -> String -> Cmd msg
 getMessage msg mailboxName id =
+    let
+        context =
+            { method = "GET"
+            , url = serveUrl [ "mailbox", mailboxName, id ]
+            }
+    in
     Http.get
-        { url = serveUrl [ "m", mailboxName, id ]
+        { url = context.url
-        , expect = Http.expectJson msg Message.decoder
+        , expect = HttpUtil.expectJson context msg Message.decoder
         }
 
 
 getServerConfig : DataResult msg ServerConfig -> Cmd msg
 getServerConfig msg =
+    let
+        context =
+            { method = "GET"
+            , url = serveUrl [ "status" ]
+            }
+    in
     Http.get
-        { url = serveUrl [ "status" ]
+        { url = context.url
-        , expect = Http.expectJson msg ServerConfig.decoder
+        , expect = HttpUtil.expectJson context msg ServerConfig.decoder
         }
 
 
 getServerMetrics : DataResult msg Metrics -> Cmd msg
 getServerMetrics msg =
+    let
+        context =
+            { method = "GET"
+            , url = Url.Builder.absolute [ "debug", "vars" ] []
+            }
+    in
     Http.get
-        { url = Url.Builder.absolute [ "debug", "vars" ] []
+        { url = context.url
-        , expect = Http.expectJson msg Metrics.decoder
+        , expect = HttpUtil.expectJson context msg Metrics.decoder
         }
 
 

ui/src/Data/Session.elm

@@ -1,5 +1,6 @@
 module Data.Session exposing
-    ( Msg(..)
+    ( Flash
+    , Msg(..)
     , Persistent
     , Session
     , decodeValueWithDefault
@@ -10,6 +11,7 @@ module Data.Session exposing
     )
 
 import Browser.Navigation as Nav
+import Html exposing (Html)
 import Json.Decode as D
 import Json.Decode.Pipeline exposing (..)
 import Json.Encode as E
@@ -21,13 +23,19 @@ import Url exposing (Url)
 type alias Session =
     { key : Nav.Key
     , host : String
-    , flash : String
+    , flash : Maybe Flash
     , routing : Bool
     , zone : Time.Zone
     , persistent : Persistent
     }
 
 
+type alias Flash =
+    { title : String
+    , table : List ( String, String )
+    }
+
+
 type alias Persistent =
     { recentMailboxes : List String
     }
@@ -35,7 +43,7 @@ type alias Persistent =
 
 type Msg
     = None
-    | SetFlash String
+    | SetFlash Flash
     | ClearFlash
     | DisableRouting
     | EnableRouting
@@ -46,7 +54,7 @@ init : Nav.Key -> Url -> Persistent -> Session
 init key location persistent =
     { key = key
     , host = location.host
-    , flash = ""
+    , flash = Nothing
     , routing = True
     , zone = Time.utc
     , persistent = persistent
@@ -62,10 +70,10 @@ update msg session =
                     session
 
                 SetFlash flash ->
-                    { session | flash = flash }
+                    { session | flash = Just flash }
 
                 ClearFlash ->
-                    { session | flash = "" }
+                    { session | flash = Nothing }
 
                 DisableRouting ->
                     { session | routing = False }

ui/src/HttpUtil.elm

@@ -1,48 +1,133 @@
-module HttpUtil exposing (delete, errorString, patch)
+module HttpUtil exposing (Error, RequestContext, delete, errorFlash, expectJson, expectString, patch)
 
+import Data.Session as Session
+import Html exposing (Html, div, text)
 import Http
+import Json.Decode as Decode
 
 
-delete : (Result Http.Error () -> msg) -> String -> Cmd msg
+type alias Error =
+    { error : Http.Error
+    , request : RequestContext
+    }
+
+
+type alias RequestContext =
+    { method : String
+    , url : String
+    }
+
+
+delete : (Result Error () -> msg) -> String -> Cmd msg
 delete msg url =
-    Http.request
+    let
+        context =
             { method = "DELETE"
+            , url = url
+            }
+    in
+    Http.request
+        { method = context.method
         , headers = []
         , url = url
         , body = Http.emptyBody
-        , expect = Http.expectWhatever msg
+        , expect = expectWhatever context msg
         , timeout = Nothing
         , tracker = Nothing
         }
 
 
-patch : (Result Http.Error () -> msg) -> String -> Http.Body -> Cmd msg
+patch : (Result Error () -> msg) -> String -> Http.Body -> Cmd msg
 patch msg url body =
-    Http.request
+    let
+        context =
             { method = "PATCH"
+            , url = url
+            }
+    in
+    Http.request
+        { method = context.method
         , headers = []
         , url = url
         , body = body
-        , expect = Http.expectWhatever msg
+        , expect = expectWhatever context msg
         , timeout = Nothing
         , tracker = Nothing
         }
 
 
-errorString : Http.Error -> String
+errorFlash : Error -> Session.Flash
-errorString error =
+errorFlash error =
-    case error of
+    let
+        requestContext flash =
+            { flash
+                | table =
+                    flash.table
+                        ++ [ ( "Method", error.request.method )
+                           , ( "URL", error.request.url )
+                           ]
+            }
+    in
+    requestContext <|
+        case error.error of
             Http.BadUrl str ->
-            "Bad URL: " ++ str
+                { title = "Bad URL"
+                , table = [ ( "URL", str ) ]
+                }
 
             Http.Timeout ->
-            "HTTP timeout"
+                { title = "HTTP timeout"
+                , table = []
+                }
 
             Http.NetworkError ->
-            "HTTP Network error"
+                { title = "HTTP Network error"
+                , table = []
+                }
 
             Http.BadStatus res ->
-            "Bad HTTP status: " ++ String.fromInt res
+                { title = "Bad HTTP status"
+                , table = [ ( "Response Code", String.fromInt res ) ]
+                }
 
-        Http.BadBody msg ->
+            Http.BadBody body ->
-            "Bad HTTP body: " ++ msg
+                { title = "Bad HTTP body"
+                , table = [ ( "Body", body ) ]
+                }
+
+
+expectJson : RequestContext -> (Result Error a -> msg) -> Decode.Decoder a -> Http.Expect msg
+expectJson context toMsg decoder =
+    Http.expectStringResponse toMsg <|
+        resolve context <|
+            \string ->
+                Result.mapError Decode.errorToString (Decode.decodeString decoder string)
+
+
+expectString : RequestContext -> (Result Error String -> msg) -> Http.Expect msg
+expectString context toMsg =
+    Http.expectStringResponse toMsg (resolve context Ok)
+
+
+expectWhatever : RequestContext -> (Result Error () -> msg) -> Http.Expect msg
+expectWhatever context toMsg =
+    Http.expectBytesResponse toMsg (resolve context (\_ -> Ok ()))
+
+
+resolve : RequestContext -> (body -> Result String a) -> Http.Response body -> Result Error a
+resolve context toResult response =
+    case response of
+        Http.BadUrl_ url ->
+            Err (Error (Http.BadUrl url) context)
+
+        Http.Timeout_ ->
+            Err (Error Http.Timeout context)
+
+        Http.NetworkError_ ->
+            Err (Error Http.NetworkError context)
+
+        Http.BadStatus_ metadata _ ->
+            Err (Error (Http.BadStatus metadata.statusCode) context)
+
+        Http.GoodStatus_ _ body ->
+            Result.mapError (\x -> Error (Http.BadBody x) context) (toResult body)

ui/src/Main.elm

@@ -156,7 +156,10 @@ update msg model =
             SessionUpdated (Err error) ->
                 ( model
                 , Cmd.none
-                , Session.SetFlash ("Error decoding session:\n" ++ D.errorToString error)
+                , Session.SetFlash
+                    { title = "Error decoding session"
+                    , table = [ ( "Error", D.errorToString error ) ]
+                    }
                 )
 
             TimeZoneLoaded zone ->
@@ -214,7 +217,13 @@ changeRouteTo route model =
         ( newModel, newCmd, newSession ) =
             case route of
                 Route.Unknown path ->
-                    ( model, Cmd.none, Session.SetFlash ("Unknown route requested: " ++ path) )
+                    ( model
+                    , Cmd.none
+                    , Session.SetFlash
+                        { title = "Unknown route requested"
+                        , table = [ ( "Path", path ) ]
+                        }
+                    )
 
                 Route.Home ->
                     Home.init

ui/src/Page/Home.elm

@@ -28,7 +28,7 @@ init =
 
 
 type Msg
-    = GreetingLoaded (Result Http.Error String)
+    = GreetingLoaded (Result HttpUtil.Error String)
 
 
 update : Session -> Msg -> Model -> ( Model, Cmd Msg, Session.Msg )
@@ -38,7 +38,7 @@ update session msg model =
             ( Model greeting, Cmd.none, Session.none )
 
         GreetingLoaded (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
 
 

ui/src/Page/Mailbox.elm

@@ -125,20 +125,20 @@ subscriptions model =
 
 
 type Msg
-    = ListLoaded (Result Http.Error (List MessageHeader))
+    = ListLoaded (Result HttpUtil.Error (List MessageHeader))
     | ClickMessage MessageID
     | OpenMessage MessageID
-    | MessageLoaded (Result Http.Error Message)
+    | MessageLoaded (Result HttpUtil.Error Message)
     | MessageBody Body
     | OpenedTime Posix
     | MarkSeenTick Posix
-    | MarkedSeen (Result Http.Error ())
+    | MarkedSeen (Result HttpUtil.Error ())
     | DeleteMessage Message
-    | DeletedMessage (Result Http.Error ())
+    | DeletedMessage (Result HttpUtil.Error ())
     | PurgeMailboxPrompt
     | PurgeMailboxCanceled
     | PurgeMailboxConfirmed
-    | PurgedMailbox (Result Http.Error ())
+    | PurgedMailbox (Result HttpUtil.Error ())
     | OnSearchInput String
     | Tick Posix
 
@@ -166,7 +166,7 @@ update session msg model =
             ( model, Cmd.none, Session.none )
 
         DeletedMessage (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
         ListLoaded (Ok headers) ->
             case model.state of
@@ -188,19 +188,19 @@ update session msg model =
                     ( model, Cmd.none, Session.none )
 
         ListLoaded (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
         MarkedSeen (Ok _) ->
             ( model, Cmd.none, Session.none )
 
         MarkedSeen (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
         MessageLoaded (Ok message) ->
             updateMessageResult model message
 
         MessageLoaded (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
         MessageBody bodyMode ->
             ( { model | bodyMode = bodyMode }, Cmd.none, Session.none )
@@ -249,7 +249,7 @@ update session msg model =
             ( model, Cmd.none, Session.none )
 
         PurgedMailbox (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
         MarkSeenTick now ->
             case model.state of
@@ -533,7 +533,7 @@ viewMessage : Time.Zone -> Message -> Body -> Html Msg
 viewMessage zone message bodyMode =
     let
         sourceUrl =
-            "/serve/m/" ++ message.mailbox ++ "/" ++ message.id ++ "/source"
+            Api.serveUrl [ "mailbox", message.mailbox, message.id, "source" ]
     in
     div []
         [ div [ class "button-bar" ]
@@ -596,22 +596,25 @@ messageBody message bodyMode =
 
 attachments : Message -> Html Msg
 attachments message =
-    let
-        baseUrl =
-            "/serve/m/attach/" ++ message.mailbox ++ "/" ++ message.id ++ "/"
-    in
     if List.isEmpty message.attachments then
         div [] []
 
     else
-        table [ class "attachments well" ] (List.map (attachmentRow baseUrl) message.attachments)
+        table [ class "attachments well" ] (List.map (attachmentRow message) message.attachments)
 
 
-attachmentRow : String -> Message.Attachment -> Html Msg
+attachmentRow : Message -> Message.Attachment -> Html Msg
-attachmentRow baseUrl attach =
+attachmentRow message attach =
     let
         url =
-            baseUrl ++ attach.id ++ "/" ++ attach.fileName
+            Api.serveUrl
+                [ "mailbox"
+                , message.mailbox
+                , message.id
+                , "attach"
+                , attach.id
+                , attach.fileName
+                ]
     in
     tr []
         [ td []

ui/src/Page/Monitor.elm

@@ -69,7 +69,13 @@ update session msg model =
             ( { model | messages = header :: model.messages }, Cmd.none, Session.none )
 
         MessageReceived (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (D.errorToString err) )
+            ( model
+            , Cmd.none
+            , Session.SetFlash
+                { title = "Decoding failed"
+                , table = [ ( "Error", D.errorToString err ) ]
+                }
+            )
 
         OpenMessage header ->
             ( model

ui/src/Page/Status.elm

@@ -101,8 +101,8 @@ subscriptions model =
 
 
 type Msg
-    = MetricsReceived (Result Http.Error Metrics)
+    = MetricsReceived (Result HttpUtil.Error Metrics)
-    | ServerConfigLoaded (Result Http.Error ServerConfig)
+    | ServerConfigLoaded (Result HttpUtil.Error ServerConfig)
     | Tick Posix
 
 
@@ -113,13 +113,13 @@ update session msg model =
             ( updateMetrics metrics model, Cmd.none, Session.none )
 
         MetricsReceived (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
         ServerConfigLoaded (Ok config) ->
             ( { model | config = Just config }, Cmd.none, Session.none )
 
         ServerConfigLoaded (Err err) ->
-            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorString err) )
+            ( model, Cmd.none, Session.SetFlash (HttpUtil.errorFlash err) )
 
         Tick time ->
             ( { model | now = time }, Api.getServerMetrics MetricsReceived, Session.none )

ui/src/Views/Page.elm

@@ -87,18 +87,27 @@ frameModal maybeModal =
             text ""
 
 
-errorFlash : FrameControls msg -> String -> Html msg
+errorFlash : FrameControls msg -> Maybe Session.Flash -> Html msg
-errorFlash controls message =
+errorFlash controls maybeFlash =
-    if message == "" then
+    let
+        row ( heading, message ) =
+            pre []
+                [ text heading
+                , text ": "
+                , text message
+                ]
+    in
+    case maybeFlash of
+        Nothing ->
             text ""
 
-    else
+        Just flash ->
             div [ class "error" ]
                 [ div [ class "flash-header" ]
-                [ h2 [] [ text "Error" ]
+                    [ h2 [] [ text flash.title ]
                     , a [ href "#", Events.onClick controls.clearFlash ] [ text "Close" ]
                     ]
-            , pre [] [ text message ]
+                , div [ class "flash-table" ] (List.map row flash.table)
                 ]
 
 

ui/src/main.css

@@ -158,6 +158,11 @@ h1 {
   justify-content: space-between;
 }
 
+.flash-table {
+  max-width: 90vw;
+  overflow: auto;
+}
+
 .greeting {
   max-width: 1000px;
 }