From 2162a4caaa703a05f764b2156b50a33e14742c35 Mon Sep 17 00:00:00 2001 From: James Hillyerd Date: Sat, 12 Sep 2020 19:45:14 -0700 Subject: [PATCH] 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. --- ui/src/Api.elm | 4 +- ui/src/Effect.elm | 304 ++++++++++++++++++++++++++++++++++++++++ ui/src/Main.elm | 100 +++++++------ ui/src/Page/Home.elm | 16 +-- ui/src/Page/Mailbox.elm | 146 +++++++++---------- ui/src/Page/Monitor.elm | 24 ++-- ui/src/Page/Status.elm | 31 ++-- ui/src/Timer.elm | 2 + 8 files changed, 460 insertions(+), 167 deletions(-) create mode 100644 ui/src/Effect.elm diff --git a/ui/src/Api.elm b/ui/src/Api.elm index 2edd3cb..669f49a 100644 --- a/ui/src/Api.elm +++ b/ui/src/Api.elm @@ -1,5 +1,7 @@ module Api exposing - ( deleteMessage + ( DataResult + , HttpResult + , deleteMessage , getGreeting , getHeaderList , getMessage diff --git a/ui/src/Effect.elm b/ui/src/Effect.elm new file mode 100644 index 0000000..818e960 --- /dev/null +++ b/ui/src/Effect.elm @@ -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) diff --git a/ui/src/Main.elm b/ui/src/Main.elm index 30a9698..e7c1e2c 100644 --- a/ui/src/Main.elm +++ b/ui/src/Main.elm @@ -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 ) diff --git a/ui/src/Page/Home.elm b/ui/src/Page/Home.elm index b85d291..e3572dd 100644 --- a/ui/src/Page/Home.elm +++ b/ui/src/Page/Home.elm @@ -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) ) diff --git a/ui/src/Page/Mailbox.elm b/ui/src/Page/Mailbox.elm index 7ef4ac4..3153b05 100644 --- a/ui/src/Page/Mailbox.elm +++ b/ui/src/Page/Mailbox.elm @@ -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 + ] ) diff --git a/ui/src/Page/Monitor.elm b/ui/src/Page/Monitor.elm index 86cd699..07fff3c 100644 --- a/ui/src/Page/Monitor.elm +++ b/ui/src/Page/Monitor.elm @@ -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 ) diff --git a/ui/src/Page/Status.elm b/ui/src/Page/Status.elm index e1b6781..3e81723 100644 --- a/ui/src/Page/Status.elm +++ b/ui/src/Page/Status.elm @@ -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. diff --git a/ui/src/Timer.elm b/ui/src/Timer.elm index fc82d44..1787950 100644 --- a/ui/src/Timer.elm +++ b/ui/src/Timer.elm @@ -49,6 +49,8 @@ cancel previous = previous +{-| Increments the timer identity, preventing integer overflow. +-} next : Int -> Int next index = if index > 2 ^ 30 then