1
0
mirror of https://github.com/jhillyerd/inbucket.git synced 2025-12-17 17:47:03 +00:00

ui: Add an Effect system to handle global state and Elm Cmds (#176)

All pages now leverage Effects for most of their Session and Cmd requests. More work required for routing and other lingering Cmd use.
This commit is contained in:
James Hillyerd
2020-09-12 19:45:14 -07:00
committed by GitHub
parent cf4c5a29bb
commit 2162a4caaa
8 changed files with 460 additions and 167 deletions

View File

@@ -1,5 +1,7 @@
module Api exposing
( deleteMessage
( DataResult
, HttpResult
, deleteMessage
, getGreeting
, getHeaderList
, getMessage

304
ui/src/Effect.elm Normal file
View File

@@ -0,0 +1,304 @@
module Effect exposing
( Effect
, addRecent
, batch
, deleteMessage
, disableRouting
, enableRouting
, getGreeting
, getHeaderList
, getMessage
, getServerConfig
, getServerMetrics
, map
, markMessageSeen
, none
, perform
, posixTime
, purgeMailbox
, schedule
, showFlash
, wrap
)
import Api exposing (DataResult, HttpResult)
import Data.Message exposing (Message)
import Data.MessageHeader exposing (MessageHeader)
import Data.Metrics exposing (Metrics)
import Data.ServerConfig exposing (ServerConfig)
import Data.Session as Session exposing (Session)
import Task
import Time
import Timer exposing (Timer)
type Effect msg
= None
| Batch (List (Effect msg))
| Command (Cmd msg)
| PosixTime (Time.Posix -> msg)
| ScheduleTimer (Timer -> msg) Timer Float
| ApiEffect (ApiEffect msg)
| SessionEffect SessionEffect
type ApiEffect msg
= DeleteMessage (HttpResult msg) String String
| GetGreeting (DataResult msg String)
| GetServerConfig (DataResult msg ServerConfig)
| GetServerMetrics (DataResult msg Metrics)
| GetHeaderList (DataResult msg (List MessageHeader)) String
| GetMessage (DataResult msg Message) String String
| MarkMessageSeen (HttpResult msg) String String
| PurgeMailbox (HttpResult msg) String
type SessionEffect
= FlashClear
| FlashShow Session.Flash
| RecentAdd String
| RoutingDisable
| RoutingEnable
{-| Packs a List of Effects into a single Effect
-}
batch : List (Effect msg) -> Effect msg
batch effects =
Batch effects
{-| Transform message types produced by an effect.
-}
map : (a -> b) -> Effect a -> Effect b
map f effect =
case effect of
None ->
None
Batch effects ->
Batch <| List.map (map f) effects
Command cmd ->
Command <| Cmd.map f cmd
PosixTime toMsg ->
PosixTime <| toMsg >> f
ScheduleTimer toMsg timer millis ->
ScheduleTimer (toMsg >> f) timer millis
ApiEffect apiEffect ->
ApiEffect <| mapApi f apiEffect
SessionEffect sessionEffect ->
SessionEffect sessionEffect
mapApi : (a -> b) -> ApiEffect a -> ApiEffect b
mapApi f effect =
case effect of
DeleteMessage result mailbox id ->
DeleteMessage (result >> f) mailbox id
GetGreeting result ->
GetGreeting (result >> f)
GetServerConfig result ->
GetServerConfig (result >> f)
GetServerMetrics result ->
GetServerMetrics (result >> f)
GetHeaderList result mailbox ->
GetHeaderList (result >> f) mailbox
GetMessage result mailbox id ->
GetMessage (result >> f) mailbox id
MarkMessageSeen result mailbox id ->
MarkMessageSeen (result >> f) mailbox id
PurgeMailbox result mailbox ->
PurgeMailbox (result >> f) mailbox
{-| Applies an effect by updating the session and/or producing a Cmd.
-}
perform : ( Session, Effect msg ) -> ( Session, Cmd msg )
perform ( session, effect ) =
case effect of
None ->
( session, Cmd.none )
Batch effects ->
List.foldl batchPerform ( session, [] ) effects
|> Tuple.mapSecond Cmd.batch
Command cmd ->
( session, cmd )
PosixTime toMsg ->
( session, Task.perform toMsg Time.now )
ScheduleTimer toMsg timer millis ->
( session, Timer.schedule toMsg timer millis )
ApiEffect apiEffect ->
performApi ( session, apiEffect )
SessionEffect sessionEffect ->
performSession ( session, sessionEffect )
performApi : ( Session, ApiEffect msg ) -> ( Session, Cmd msg )
performApi ( session, effect ) =
case effect of
DeleteMessage toMsg mailbox id ->
( session, Api.deleteMessage session toMsg mailbox id )
GetGreeting toMsg ->
( session, Api.getGreeting session toMsg )
GetServerConfig toMsg ->
( session, Api.getServerConfig session toMsg )
GetServerMetrics toMsg ->
( session, Api.getServerMetrics session toMsg )
GetHeaderList toMsg mailbox ->
( session, Api.getHeaderList session toMsg mailbox )
GetMessage toMsg mailbox id ->
( session, Api.getMessage session toMsg mailbox id )
MarkMessageSeen toMsg mailbox id ->
( session, Api.markMessageSeen session toMsg mailbox id )
PurgeMailbox toMsg mailbox ->
( session, Api.purgeMailbox session toMsg mailbox )
performSession : ( Session, SessionEffect ) -> ( Session, Cmd msg )
performSession ( session, effect ) =
case effect of
RecentAdd mailbox ->
( Session.addRecent mailbox session, Cmd.none )
FlashClear ->
( Session.clearFlash session, Cmd.none )
FlashShow flash ->
( Session.showFlash flash session, Cmd.none )
RoutingDisable ->
( Session.disableRouting session, Cmd.none )
RoutingEnable ->
( Session.enableRouting session, Cmd.none )
-- EFFECT CONSTRUCTORS
none : Effect msg
none =
None
{-| Adds specified mailbox to the recently viewed list
-}
addRecent : String -> Effect msg
addRecent mailbox =
SessionEffect (RecentAdd mailbox)
disableRouting : Effect msg
disableRouting =
SessionEffect RoutingDisable
enableRouting : Effect msg
enableRouting =
SessionEffect RoutingEnable
clearFlash : Effect msg
clearFlash =
SessionEffect FlashClear
showFlash : Session.Flash -> Effect msg
showFlash flash =
SessionEffect (FlashShow flash)
deleteMessage : HttpResult msg -> String -> String -> Effect msg
deleteMessage toMsg mailboxName id =
ApiEffect (DeleteMessage toMsg mailboxName id)
getGreeting : DataResult msg String -> Effect msg
getGreeting toMsg =
ApiEffect (GetGreeting toMsg)
getHeaderList : DataResult msg (List MessageHeader) -> String -> Effect msg
getHeaderList toMsg mailboxName =
ApiEffect (GetHeaderList toMsg mailboxName)
getServerConfig : DataResult msg ServerConfig -> Effect msg
getServerConfig toMsg =
ApiEffect (GetServerConfig toMsg)
getServerMetrics : DataResult msg Metrics -> Effect msg
getServerMetrics toMsg =
ApiEffect (GetServerMetrics toMsg)
getMessage : DataResult msg Message -> String -> String -> Effect msg
getMessage toMsg mailboxName id =
ApiEffect (GetMessage toMsg mailboxName id)
markMessageSeen : HttpResult msg -> String -> String -> Effect msg
markMessageSeen toMsg mailboxName id =
ApiEffect (MarkMessageSeen toMsg mailboxName id)
posixTime : (Time.Posix -> msg) -> Effect msg
posixTime toMsg =
PosixTime toMsg
purgeMailbox : HttpResult msg -> String -> Effect msg
purgeMailbox toMsg mailboxName =
ApiEffect (PurgeMailbox toMsg mailboxName)
{-| Schedules a Timer to fire after the specified delay.
-}
schedule : (Timer -> msg) -> Timer -> Float -> Effect msg
schedule toMsg timer millis =
ScheduleTimer toMsg timer millis
{-| Wrap a Cmd into an Effect. This is a temporary function to aid in the transition to the effect
pattern.
-}
wrap : Cmd msg -> Effect msg
wrap cmd =
Command cmd
-- UTILITY
batchPerform : Effect msg -> ( Session, List (Cmd msg) ) -> ( Session, List (Cmd msg) )
batchPerform effect ( session, cmds ) =
perform ( session, effect )
|> Tuple.mapSecond (\cmd -> cmd :: cmds)

View File

@@ -4,6 +4,7 @@ import Browser exposing (Document, UrlRequest)
import Browser.Navigation as Nav
import Data.AppConfig as AppConfig exposing (AppConfig)
import Data.Session as Session exposing (Session)
import Effect exposing (Effect)
import Html exposing (Html)
import Json.Decode as D exposing (Value)
import Layout
@@ -58,6 +59,8 @@ init configValue location key =
Session.initError key location (D.errorToString error)
( subModel, _ ) =
-- Home.init effect is discarded because this subModel will be immediately replaced
-- when we change routes to the specified location.
Home.init session
initModel =
@@ -67,11 +70,9 @@ init configValue location key =
route =
session.router.fromUrl location
( model, cmd ) =
changeRouteTo route initModel
in
( model, Cmd.batch [ cmd, Task.perform TimeZoneLoaded Time.here ] )
changeRouteTo route initModel
|> Tuple.mapSecond (\cmd -> Cmd.batch [ cmd, Task.perform TimeZoneLoaded Time.here ])
type Msg
@@ -206,12 +207,12 @@ updateMain msg model session =
)
_ ->
updatePage msg model
updatePage msg model |> performEffects
{-| Delegate incoming messages to their respective sub-pages.
-}
updatePage : Msg -> Model -> ( Model, Cmd Msg )
updatePage : Msg -> Model -> ( Model, Effect Msg )
updatePage msg model =
case ( msg, model.page ) of
( HomeMsg subMsg, Home subModel ) ->
@@ -232,61 +233,70 @@ updatePage msg model =
( _, _ ) ->
-- Disregard messages destined for the wrong page.
( model, Cmd.none )
( model, Effect.none )
changeRouteTo : Route -> Model -> ( Model, Cmd Msg )
changeRouteTo route model =
let
session =
getSession model |> Session.clearFlash
Session.clearFlash (getSession model)
newModel =
{ model | layout = Layout.reset model.layout }
in
case route of
Route.Home ->
Home.init session
|> updateWith Home HomeMsg newModel
performEffects <|
case route of
Route.Home ->
Home.init session
|> updateWith Home HomeMsg newModel
Route.Mailbox name ->
Mailbox.init session name Nothing
|> updateWith Mailbox MailboxMsg newModel
Route.Mailbox name ->
Mailbox.init session name Nothing
|> updateWith Mailbox MailboxMsg newModel
Route.Message mailbox id ->
Mailbox.init session mailbox (Just id)
|> updateWith Mailbox MailboxMsg newModel
Route.Message mailbox id ->
Mailbox.init session mailbox (Just id)
|> updateWith Mailbox MailboxMsg newModel
Route.Monitor ->
if session.config.monitorVisible then
Monitor.init session
|> updateWith Monitor MonitorMsg newModel
Route.Monitor ->
if session.config.monitorVisible then
Monitor.init session
|> updateWith Monitor MonitorMsg newModel
else
else
let
flash =
{ title = "Disabled route requested"
, table = [ ( "Error", "Monitor disabled by configuration." ) ]
}
in
( applyToModelSession (Session.showFlash flash) newModel
, Effect.none
)
Route.Status ->
Status.init session
|> updateWith Status StatusMsg newModel
Route.Unknown path ->
-- Unknown routes display Home with an error flash.
let
flash =
{ title = "Disabled route requested"
, table = [ ( "Error", "Monitor disabled by configuration." ) ]
{ title = "Unknown route requested"
, table = [ ( "Path", path ) ]
}
in
( applyToModelSession (Session.showFlash flash) newModel
, Cmd.none
)
Home.init (Session.showFlash flash session)
|> updateWith Home HomeMsg newModel
Route.Status ->
Status.init session
|> updateWith Status StatusMsg newModel
Route.Unknown path ->
-- Unknown routes display Home with an error flash.
let
flash =
{ title = "Unknown route requested"
, table = [ ( "Path", path ) ]
}
in
Home.init (Session.showFlash flash session)
|> updateWith Home HomeMsg newModel
{-| Perform effects by updating model and/or producing Cmds to be executed.
-}
performEffects : ( Model, Effect Msg ) -> ( Model, Cmd Msg )
performEffects ( model, effect ) =
Effect.perform ( getSession model, effect )
|> Tuple.mapFirst (\newSession -> updateSession model newSession)
getSession : Model -> Session
@@ -332,11 +342,11 @@ updateWith :
(subModel -> PageModel)
-> (subMsg -> Msg)
-> Model
-> ( subModel, Cmd subMsg )
-> ( Model, Cmd Msg )
updateWith toPage toMsg model ( subModel, subCmd ) =
-> ( subModel, Effect subMsg )
-> ( Model, Effect Msg )
updateWith toPage toMsg model ( subModel, subEffect ) =
( { model | page = toPage subModel }
, Cmd.map toMsg subCmd
, Effect.map toMsg subEffect
)

View File

@@ -1,7 +1,7 @@
module Page.Home exposing (Model, Msg, init, update, view)
import Api
import Data.Session as Session exposing (Session)
import Data.Session exposing (Session)
import Effect exposing (Effect)
import Html exposing (Html)
import Html.Attributes exposing (class, property)
import HttpUtil
@@ -18,9 +18,9 @@ type alias Model =
}
init : Session -> ( Model, Cmd Msg )
init : Session -> ( Model, Effect Msg )
init session =
( Model session "", Api.getGreeting session GreetingLoaded )
( Model session "", Effect.getGreeting GreetingLoaded )
@@ -31,16 +31,14 @@ type Msg
= GreetingLoaded (Result HttpUtil.Error String)
update : Msg -> Model -> ( Model, Cmd Msg )
update : Msg -> Model -> ( Model, Effect Msg )
update msg model =
case msg of
GreetingLoaded (Ok greeting) ->
( { model | greeting = greeting }, Cmd.none )
( { model | greeting = greeting }, Effect.none )
GreetingLoaded (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )

View File

@@ -1,12 +1,13 @@
module Page.Mailbox exposing (Model, Msg, init, load, subscriptions, update, view)
module Page.Mailbox exposing (Model, Msg, init, subscriptions, update, view)
import Api
import Browser.Navigation as Nav
import Data.Message as Message exposing (Message)
import Data.MessageHeader exposing (MessageHeader)
import Data.Session as Session exposing (Session)
import Data.Session exposing (Session)
import DateFormat as DF
import DateFormat.Relative as Relative
import Effect exposing (Effect)
import Html
exposing
( Attribute
@@ -54,7 +55,6 @@ import Json.Decode as D
import Json.Encode as E
import Modal
import Route
import Task
import Time exposing (Posix)
import Timer exposing (Timer)
@@ -103,7 +103,7 @@ type alias Model =
}
init : Session -> String -> Maybe MessageID -> ( Model, Cmd Msg )
init : Session -> String -> Maybe MessageID -> ( Model, Effect Msg )
init session mailboxName selection =
( { session = session
, mailboxName = mailboxName
@@ -114,16 +114,11 @@ init session mailboxName selection =
, markSeenTimer = Timer.empty
, now = Time.millisToPosix 0
}
, load session mailboxName
)
load : Session -> String -> Cmd Msg
load session mailboxName =
Cmd.batch
[ Task.perform Tick Time.now
, Api.getHeaderList session ListLoaded mailboxName
, Effect.batch
[ Effect.posixTime Tick
, Effect.getHeaderList ListLoaded mailboxName
]
)
@@ -159,38 +154,38 @@ type Msg
| ModalFocused Modal.Msg
update : Msg -> Model -> ( Model, Cmd Msg )
update : Msg -> Model -> ( Model, Effect Msg )
update msg model =
case msg of
ClickMessage id ->
( updateSelected { model | session = Session.disableRouting model.session } id
, Cmd.batch
( updateSelected model id
, Effect.batch
[ -- Update browser location.
Route.Message model.mailboxName id
Effect.disableRouting
, Route.Message model.mailboxName id
|> model.session.router.toPath
|> Nav.replaceUrl model.session.key
, Api.getMessage model.session MessageLoaded model.mailboxName id
|> Effect.wrap
, Effect.getMessage MessageLoaded model.mailboxName id
]
)
CloseMessage ->
case model.state of
ShowingList list _ ->
( { model | state = ShowingList list NoMessage }, Cmd.none )
( { model | state = ShowingList list NoMessage }, Effect.none )
_ ->
( model, Cmd.none )
( model, Effect.none )
DeleteMessage message ->
updateDeleteMessage model message
DeletedMessage (Ok _) ->
( model, Cmd.none )
( model, Effect.none )
DeletedMessage (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )
ListKeyPress id keyCode ->
case keyCode of
@@ -198,7 +193,7 @@ update msg model =
updateOpenMessage model id
_ ->
( model, Cmd.none )
( model, Effect.none )
ListLoaded (Ok headers) ->
case model.state of
@@ -214,63 +209,51 @@ update msg model =
updateOpenMessage newModel id
Nothing ->
( { newModel
| session = Session.addRecent model.mailboxName model.session
}
, Cmd.none
)
( newModel, Effect.addRecent newModel.mailboxName )
_ ->
( model, Cmd.none )
( model, Effect.none )
ListLoaded (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )
MarkSeenLoaded (Ok _) ->
( model, Cmd.none )
( model, Effect.none )
MarkSeenLoaded (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )
MessageLoaded (Ok message) ->
updateMessageResult model message
MessageLoaded (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )
MessageBody bodyMode ->
( { model | bodyMode = bodyMode }, Cmd.none )
( { model | bodyMode = bodyMode }, Effect.none )
ModalFocused message ->
( { model | session = Modal.updateSession message model.session }
, Cmd.none
, Effect.none
)
OnSearchInput searchInput ->
updateSearchInput model searchInput
PurgeMailboxPrompt ->
( { model | promptPurge = True }, Modal.resetFocusCmd ModalFocused )
( { model | promptPurge = True }, Modal.resetFocusCmd ModalFocused |> Effect.wrap )
PurgeMailboxCanceled ->
( { model | promptPurge = False }, Cmd.none )
( { model | promptPurge = False }, Effect.none )
PurgeMailboxConfirmed ->
updateTriggerPurge model
PurgedMailbox (Ok _) ->
( model, Cmd.none )
( model, Effect.none )
PurgedMailbox (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )
MarkSeenTriggered timer ->
if timer == model.markSeenTimer then
@@ -278,15 +261,15 @@ update msg model =
updateMarkMessageSeen model
else
( model, Cmd.none )
( model, Effect.none )
Tick now ->
( { model | now = now }, Cmd.none )
( { model | now = now }, Effect.none )
{-| Replace the currently displayed message.
-}
updateMessageResult : Model -> Message -> ( Model, Cmd Msg )
updateMessageResult : Model -> Message -> ( Model, Effect Msg )
updateMessageResult model message =
let
bodyMode =
@@ -298,7 +281,7 @@ updateMessageResult model message =
in
case model.state of
LoadingList _ ->
( model, Cmd.none )
( model, Effect.none )
ShowingList list _ ->
let
@@ -314,38 +297,38 @@ updateMessageResult model message =
, markSeenTimer = newTimer
}
-- Set 1500ms delay before reporting message as seen to backend.
, Timer.schedule MarkSeenTriggered newTimer 1500
, Effect.schedule MarkSeenTriggered newTimer 1500
)
{-| Updates model and triggers commands to purge this mailbox.
-}
updateTriggerPurge : Model -> ( Model, Cmd Msg )
updateTriggerPurge : Model -> ( Model, Effect Msg )
updateTriggerPurge model =
let
cmd =
Cmd.batch
effects =
Effect.batch
[ Route.Mailbox model.mailboxName
|> model.session.router.toPath
|> Nav.replaceUrl model.session.key
, Api.purgeMailbox model.session PurgedMailbox model.mailboxName
|> Effect.wrap
, Effect.purgeMailbox PurgedMailbox model.mailboxName
]
in
case model.state of
ShowingList _ _ ->
( { model
| promptPurge = False
, session = Session.disableRouting model.session
, state = ShowingList (MessageList [] Nothing "") NoMessage
}
, cmd
, Effect.batch [ Effect.disableRouting, effects ]
)
_ ->
( model, cmd )
( model, effects )
updateSearchInput : Model -> String -> ( Model, Cmd Msg )
updateSearchInput : Model -> String -> ( Model, Effect Msg )
updateSearchInput model searchInput =
let
searchFilter =
@@ -357,14 +340,14 @@ updateSearchInput model searchInput =
in
case model.state of
LoadingList _ ->
( model, Cmd.none )
( model, Effect.none )
ShowingList list messageState ->
( { model
| searchInput = searchInput
, state = ShowingList { list | searchFilter = searchFilter } messageState
}
, Cmd.none
, Effect.none
)
@@ -396,7 +379,7 @@ updateSelected model id =
{ model | state = ShowingList newList (Transitioning visible) }
updateDeleteMessage : Model -> Message -> ( Model, Cmd Msg )
updateDeleteMessage : Model -> Message -> ( Model, Effect Msg )
updateDeleteMessage model message =
let
filter f messageList =
@@ -404,26 +387,24 @@ updateDeleteMessage model message =
in
case model.state of
ShowingList list _ ->
( { model
| session = Session.disableRouting model.session
, state =
ShowingList (filter (\x -> x.id /= message.id) list) NoMessage
}
, Cmd.batch
[ Api.deleteMessage model.session DeletedMessage message.mailbox message.id
( { model | state = ShowingList (filter (\x -> x.id /= message.id) list) NoMessage }
, Effect.batch
[ Effect.deleteMessage DeletedMessage message.mailbox message.id
, Effect.disableRouting
, Route.Mailbox model.mailboxName
|> model.session.router.toPath
|> Nav.replaceUrl model.session.key
|> Effect.wrap
]
)
_ ->
( model, Cmd.none )
( model, Effect.none )
{-| Updates both the active message, and the message list to mark the currently viewed message as seen.
-}
updateMarkMessageSeen : Model -> ( Model, Cmd Msg )
updateMarkMessageSeen : Model -> ( Model, Effect Msg )
updateMarkMessageSeen model =
case model.state of
ShowingList messages (ShowingMessage visibleMessage) ->
@@ -442,21 +423,20 @@ updateMarkMessageSeen model =
| state =
ShowingList newMessages (ShowingMessage { visibleMessage | seen = True })
}
, Api.markMessageSeen model.session MarkSeenLoaded visibleMessage.mailbox visibleMessage.id
, Effect.markMessageSeen MarkSeenLoaded visibleMessage.mailbox visibleMessage.id
)
_ ->
( model, Cmd.none )
( model, Effect.none )
updateOpenMessage : Model -> String -> ( Model, Cmd Msg )
updateOpenMessage : Model -> String -> ( Model, Effect Msg )
updateOpenMessage model id =
let
newModel =
{ model | session = Session.addRecent model.mailboxName model.session }
in
( updateSelected newModel id
, Api.getMessage model.session MessageLoaded model.mailboxName id
( updateSelected model id
, Effect.batch
[ Effect.addRecent model.mailboxName
, Effect.getMessage MessageLoaded model.mailboxName id
]
)

View File

@@ -5,6 +5,7 @@ import Browser.Navigation as Nav
import Data.MessageHeader as MessageHeader exposing (MessageHeader)
import Data.Session as Session exposing (Session)
import DateFormat as DF
import Effect exposing (Effect)
import Html
exposing
( Attribute
@@ -41,9 +42,9 @@ type alias Model =
}
init : Session -> ( Model, Cmd Msg )
init : Session -> ( Model, Effect Msg )
init session =
( Model session False [], Cmd.none )
( Model session False [], Effect.none )
@@ -58,20 +59,20 @@ type Msg
| MessageKeyPress MessageHeader Int
update : Msg -> Model -> ( Model, Cmd Msg )
update : Msg -> Model -> ( Model, Effect Msg )
update msg model =
case msg of
Connected True ->
( { model | connected = True, messages = [] }, Cmd.none )
( { model | connected = True, messages = [] }, Effect.none )
Connected False ->
( { model | connected = False }, Cmd.none )
( { model | connected = False }, Effect.none )
MessageReceived value ->
case D.decodeValue (MessageHeader.decoder |> D.at [ "detail" ]) value of
Ok header ->
( { model | messages = header :: List.take 500 model.messages }
, Cmd.none
, Effect.none
)
Err err ->
@@ -81,12 +82,10 @@ update msg model =
, table = [ ( "Error", D.errorToString err ) ]
}
in
( { model | session = Session.showFlash flash model.session }
, Cmd.none
)
( model, Effect.showFlash flash )
Clear ->
( { model | messages = [] }, Cmd.none )
( { model | messages = [] }, Effect.none )
OpenMessage header ->
openMessage header model
@@ -97,15 +96,16 @@ update msg model =
openMessage header model
_ ->
( model, Cmd.none )
( model, Effect.none )
openMessage : MessageHeader -> Model -> ( Model, Cmd Msg )
openMessage : MessageHeader -> Model -> ( Model, Effect Msg )
openMessage header model =
( model
, Route.Message header.mailbox header.id
|> model.session.router.toPath
|> Nav.replaceUrl model.session.key
|> Effect.wrap
)

View File

@@ -1,10 +1,10 @@
module Page.Status exposing (Model, Msg, init, subscriptions, update, view)
import Api
import Data.Metrics exposing (Metrics)
import Data.ServerConfig exposing (ServerConfig)
import Data.Session as Session exposing (Session)
import Data.Session exposing (Session)
import DateFormat.Relative as Relative
import Effect exposing (Effect)
import Filesize
import Html
exposing
@@ -19,7 +19,6 @@ import Html.Attributes exposing (class)
import HttpUtil
import Sparkline as Spark
import Svg.Attributes as SvgAttrib
import Task
import Time exposing (Posix)
@@ -60,7 +59,7 @@ type alias Metric =
}
init : Session -> ( Model, Cmd Msg )
init : Session -> ( Model, Effect Msg )
init session =
( { session = session
, now = Time.millisToPosix 0
@@ -82,9 +81,9 @@ init session =
, retainedCount = Metric "Stored Messages" 0 fmtInt graphZero initDataSet 60
, retainedSize = Metric "Store Size" 0 Filesize.format graphZero initDataSet 60
}
, Cmd.batch
[ Task.perform Tick Time.now
, Api.getServerConfig session ServerConfigLoaded
, Effect.batch
[ Effect.posixTime Tick
, Effect.getServerConfig ServerConfigLoaded
]
)
@@ -114,27 +113,25 @@ type Msg
| Tick Posix
update : Msg -> Model -> ( Model, Cmd Msg )
update : Msg -> Model -> ( Model, Effect Msg )
update msg model =
case msg of
MetricsReceived (Ok metrics) ->
( updateMetrics metrics model, Cmd.none )
( updateMetrics metrics model, Effect.none )
MetricsReceived (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )
ServerConfigLoaded (Ok config) ->
( { model | config = Just config }, Cmd.none )
( { model | config = Just config }, Effect.none )
ServerConfigLoaded (Err err) ->
( { model | session = Session.showFlash (HttpUtil.errorFlash err) model.session }
, Cmd.none
)
( model, Effect.showFlash (HttpUtil.errorFlash err) )
Tick time ->
( { model | now = time }, Api.getServerMetrics model.session MetricsReceived )
( { model | now = time }
, Effect.getServerMetrics MetricsReceived
)
{-| Update all metrics in Model; increment xCounter.

View File

@@ -49,6 +49,8 @@ cancel previous =
previous
{-| Increments the timer identity, preventing integer overflow.
-}
next : Int -> Int
next index =
if index > 2 ^ 30 then