diff options
| author | stuebinm | 2022-08-27 01:45:12 +0200 |
|---|---|---|
| committer | stuebinm | 2022-08-27 01:45:12 +0200 |
| commit | a4045a5b0a898042cd78eba9b22550c965a1bbd9 (patch) | |
| tree | 337277b15c7fba9ea857cdd388ff1b2c84d9101b /lib/Server/ControlRoom.hs | |
| parent | 6fa510d35f0ca8738df7274bf6f02ad75a987f60 (diff) | |
controlroom: lots of pretty little knobs
(also some database schema changes, for good measure)
Diffstat (limited to 'lib/Server/ControlRoom.hs')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 85 |
1 files changed, 66 insertions, 19 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index 9ebea42..4ef3784 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -28,7 +28,7 @@ import qualified Data.Map as M import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T -import Data.Time (getCurrentTime, utctDay) +import Data.Time (UTCTime, getCurrentTime, utctDay) import Data.Time.Calendar (Day) import Data.Time.Format.ISO8601 (iso8601Show) import Data.UUID (UUID) @@ -40,13 +40,9 @@ import Database.Persist.Sql (PersistFieldSql, SqlBackend, runSqlPool) import Fmt ((+|), (|+)) import GHC.Generics (Generic) -import Persist (AmendmentStatus, Announcement (..), - EntityField (..), Key (..), - ScheduleAmendment (ScheduleAmendment), - runSql) import Server.Util (Service) import Text.Blaze.Html (ToMarkup (..)) -import Text.Blaze.Internal (MarkupM(Empty)) +import Text.Blaze.Internal (MarkupM (Empty)) import Text.ProtocolBuffers (Default (defaultValue)) import Text.Read (readMaybe) import Text.Shakespeare.Text @@ -54,12 +50,12 @@ import Yesod import Yesod.Form import GTFS +import Persist data ControlRoom = ControlRoom - { getBaseurl :: Text - , getGtfs :: GTFS - , getPool :: Pool SqlBackend + { getGtfs :: GTFS + , getPool :: Pool SqlBackend } mkMessage "ControlRoom" "messages" "en" @@ -70,17 +66,16 @@ mkYesod "ControlRoom" [parseRoutes| /train/id/#TripID/#Day TrainViewR GET /train/announce/#TripID/#Day AnnounceR POST /train/del-announce/#UUID DelAnnounceR GET +/token/block/#Token TokenBlock GET /trips TripsViewR GET /trip/#TripID TripViewR GET |] emptyMarkup :: MarkupM a -> Bool emptyMarkup (Empty _) = True -emptyMarkup _ = False +emptyMarkup _ = False instance Yesod ControlRoom where - approot = ApprootMaster (\cr -> getBaseurl cr) - defaultLayout w = do PageContent{..} <- widgetToPageContent w msgs <- getMessages @@ -125,6 +120,9 @@ instance Yesod ControlRoom where input { grid-column: 2; } + .blocked { + background-color: red; + } <body> $forall (status, msg) <- msgs <p class="message #{status}">#{msg} @@ -169,12 +167,28 @@ getTrainViewR trip day = do Nothing -> notFound Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] + tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [] + lastPing <- runDB $ selectFirst [ TrainPingToken <-. (fmap entityKey tokens) ] [Desc TrainPingTimestamp] defaultLayout $ do mr <- getMessageRender setTitle (toHtml (""+|mr MsgTrip|+" "+|tripTripID|+" "+|mr Msgon|+" "+|day|+"" :: Text)) [whamlet| <h1>_{MsgTrip} <a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a> <section> + <h2>_{MsgLive} + <p><strong>_{MsgLastPing}: </strong> + $maybe Entity _ TrainPing{..} <- lastPing + _{MsgTrainPing trainPingLat trainPingLong trainPingTimestamp} + (<a href="/api/debug/pings/#{trip}/#{day}">_{Msgraw}</a>) + $nothing + <em>(_{MsgNoTrainPing}) + <p><strong>Estimated Delay</strong>: Todo! +<section> + <h2>_{MsgStops} + <ol> + $forall Stop{..} <- tripStops + <li> #{stopArrival} #{stationName stopStation} +<section> <h2>_{MsgAnnouncements} <ul> $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns @@ -186,13 +200,18 @@ getTrainViewR trip day = do ^{widget} <button>Submit <section> - <h2>_{MsgStops} - <ol> - $forall Stop{..} <- tripStops - <li> #{stopArrival} #{stationName stopStation} -<section> - <h2>Vehicle Position - <div> Todo! + <h2>_{MsgTokens} + <table> + <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> + $forall Entity (RunningKey key) Running{..} <- tokens + <tr :runningBlocked:.blocked> + <td title="#{runningAgent}">#{runningAgent} + <td title="#{key}">#{key} + <td title="#{runningExpires}">#{runningExpires} + $if runningBlocked + <td title="_{MsgUnblockToken}"><a href="@?{(TokenBlock key, [("unblock", "true")])}">_{MsgUnblockToken}</a> + $else + <td title="_{MsgBlockToken}"><a href="@{TokenBlock key}">_{MsgBlockToken}</a> |] @@ -255,6 +274,19 @@ getDelAnnounceR uuid = do Just Announcement{..} -> redirect (TrainViewR announcementTrip announcementDay) +getTokenBlock :: Token -> Handler Html +getTokenBlock token = do + YesodRequest{..} <- getRequest + let blocked = lookup "unblock" reqGetParams /= Just "true" + maybe <- runDB $ do + update (RunningKey token) [ RunningBlocked =. blocked ] + get (RunningKey token) + case maybe of + Just r@Running{..} -> do + liftIO $ print r + redirect (TrainViewR runningTrip runningDay) + Nothing -> notFound + announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget) announceForm day tripId = renderDivs $ Announcement @@ -274,3 +306,18 @@ instance ToMarkup Time where instance ToMarkup Day where toMarkup day = toMarkup (iso8601Show day) + +instance ToMessage UTCTime where + toMessage = formatW3 + +instance ToMessage Token where + toMessage (Token uuid) = UUID.toText uuid + +instance ToMarkup UTCTime where + toMarkup = toMarkup . formatW3 + +instance ToMarkup Token where + toMarkup (Token uuid) = toMarkup (UUID.toText uuid) + +instance ToMessage Double where + toMessage = T.pack . show |