$if emptyMarkup pageTitle Tracktrain $else #{pageTitle} $maybe description <- pageDescription <meta name="description" content="#{description}"> ^{pageHead} <style> section { border: 1px solid black; padding: 1rem; margin: 2rem; padding-top: 0; } body { max-width: 50rem; margin: auto; } form { width:100%; display: grid; gap: 1rem; } label { grid-column: 1; } form div { display: grid; grid-template-columns: 50% 50%; width:100%; } input { grid-column: 2; } .blocked { background-color: red; } <body> $forall (status, msg) <- msgs <p class="message #{status}">#{msg} ^{pageBody} |] instance RenderMessage ControlRoom FormMessage where renderMessage _ _ = defaultFormMessage instance YesodPersist ControlRoom where type YesodPersistBackend ControlRoom = SqlBackend runDB action = do pool <- getYesod <&> getPool runSqlPool action pool getRootR :: Handler Html getRootR = redirect TrainsR getTrainsR :: Handler Html getTrainsR = do req <- getRequest let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) gtfs <- getYesod <&> getGtfs let trips = tripsOnDay gtfs day defaultLayout $ do [whamlet| <h1>Trains on #{day} <section><ol> $forall Trip{..} <- trips <li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</a> : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} |] getTrainViewR :: TripID -> Day -> Handler Html getTrainViewR trip day = do GTFS{..} <- getYesod <&> getGtfs (widget, enctype) <- generateFormPost (announceForm day trip) case M.lookup trip trips of Nothing -> notFound Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires] lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] <&> nonEmpty . (fmap entityVal) nowSeconds <- secondsNow day 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>_{MsgEstimatedDelay}</strong>: $maybe history <- anchors $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) $nothing <em> (_{MsgNone}) <section> <h2>_{MsgStops} <ol> $forall Stop{..} <- tripStops <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation} $maybe history <- anchors $maybe delay <- guessDelay history (int2Double stopSequence) \ (#{delay}) <section> <h2>_{MsgAnnouncements} <ul> $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">delete</a> $if null anns <li><em>(_{MsgNone})</em> <h3>_{MsgNewAnnouncement} <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> ^{widget} <button>Submit <section> <h2>_{MsgTokens} <table> <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> $if null tokens <tr><td></td><td style="text-align:center"><em>(_{MsgNone}) $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> |] where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history guessAtSeconds = extrapolateAtSeconds LinearExtrapolator getTripsViewR :: Handler Html getTripsViewR = do GTFS{..} <- getYesod <&> getGtfs defaultLayout $ do setTitle "List of Trips" [whamlet| <h1>List of Trips <section><ul> $forall Trip{..} <- trips <li><a href="@{TripViewR tripTripID}">#{tripTripID}</a> : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} |] getTripViewR :: TripID -> Handler Html getTripViewR tripId = do GTFS{..} <- getYesod <&> getGtfs case M.lookup tripId trips of Nothing -> notFound Just Trip{..} -> defaultLayout [whamlet| <h1>Trip #{tripTripID} <section> <h2>Stops <ol> $forall Stop{..} <- tripStops <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} <section> <h2>Dates <ul> TODO! |] postAnnounceR :: TripID -> Day -> Handler Html postAnnounceR trip day = do ((result, widget), enctype) <- runFormPost (announceForm day trip) case result of FormSuccess ann -> do runDB $ insert ann redirect (TrainViewR trip day) _ -> defaultLayout [whamlet| <p>Invalid input, let's try again. <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> ^{widget} <button>Submit |] getDelAnnounceR :: UUID -> Handler Html getDelAnnounceR uuid = do ann <- runDB $ do a <- get (AnnouncementKey uuid) delete (AnnouncementKey uuid) pure a case ann of Nothing -> notFound 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 getOnboardUnitMenuR :: Handler Html getOnboardUnitMenuR = do day <- liftIO getCurrentTime <&> utctDay gtfs <- getYesod <&> getGtfs let trips = tripsOnDay gtfs day defaultLayout $ do [whamlet| <h1>_{MsgOBU} <section> _{MsgChooseTrain} $forall Trip{..} <- trips <hr> <a href="@{OnboardUnitR tripTripID day}"> #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)} |] getOnboardUnitR :: TripID -> Day -> Handler Html getOnboardUnitR tripId day = defaultLayout $(whamletFile "site/obu.hamlet") announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget) announceForm day tripId = renderDivs $ Announcement <$> pure tripId <*> areq textField (fieldSettingsLabel MsgHeader) Nothing <*> areq textField (fieldSettingsLabel MsgText) Nothing <*> pure day <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing <*> lift (liftIO getCurrentTime <&> Just) --- some orphans to make hamlet easier to deal with instance ToMarkup Time where toMarkup time = toMarkup (show time) 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 instance ToMarkup Seconds where toMarkup (Seconds s) = if s > 0 then toMarkup ("+"+|s `div` 60|+""

{-# LANGUAGE DataKinds #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} module Server.ControlRoom (ControlRoom(..)) where import Control.Monad (forM_, join) import Control.Monad.Extra (maybeM) import Control.Monad.IO.Class (MonadIO (liftIO)) import qualified Data.ByteString.Char8 as C8 import Data.Functor ((<&>)) import Data.List (lookup) import Data.List.NonEmpty (nonEmpty) import Data.Map (Map) import qualified Data.Map as M import Data.Pool (Pool) import Data.Text (Text) import qualified Data.Text as T import Data.Time (UTCTime (..), getCurrentTime, utctDay) import Data.Time.Calendar (Day) import Data.Time.Format.ISO8601 (iso8601Show) import Data.UUID (UUID) import qualified Data.UUID as UUID import qualified Data.Vector as V import Database.Persist (Entity (..), delete, entityVal, get, insert, selectList, (==.)) import Database.Persist.Sql (PersistFieldSql, SqlBackend, runSqlPool) import Fmt ((+|), (|+)) import GHC.Float (int2Double) import GHC.Generics (Generic) import Server.Util (Service, secondsNow) import Text.Blaze.Html (ToMarkup (..)) import Text.Blaze.Internal (MarkupM (Empty)) import Text.ProtocolBuffers (Default (defaultValue)) import Text.Read (readMaybe) import Text.Shakespeare.Text import Yesod import Yesod.Form import Extrapolation (Extrapolator (..), LinearExtrapolator (..)) import GTFS import Numeric (showFFloat) import Persist data ControlRoom = ControlRoom { getGtfs :: GTFS , getPool :: Pool SqlBackend } mkMessage "ControlRoom" "messages" "en" mkYesod "ControlRoom" [parseRoutes| / RootR GET /trains TrainsR GET /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 /obu OnboardUnitMenuR GET /obu/#TripID/#Day OnboardUnitR GET |] emptyMarkup :: MarkupM a -> Bool emptyMarkup (Empty _) = True emptyMarkup _ = False instance Yesod ControlRoom where defaultLayout w = do PageContent{..} <- widgetToPageContent w msgs <- getMessages withUrlRenderer [hamlet| $newline never $doctype 5 $if emptyMarkup pageTitle Tracktrain $else #{pageTitle} $maybe description <- pageDescription <meta name="description" content="#{description}"> ^{pageHead} <style> section { border: 1px solid black; padding: 1rem; margin: 2rem; padding-top: 0; } body { max-width: 50rem; margin: auto; } form { width:100%; display: grid; gap: 1rem; } label { grid-column: 1; } form div { display: grid; grid-template-columns: 50% 50%; width:100%; } input { grid-column: 2; } .blocked { background-color: red; } <body> $forall (status, msg) <- msgs <p class="message #{status}">#{msg} ^{pageBody} |] instance RenderMessage ControlRoom FormMessage where renderMessage _ _ = defaultFormMessage instance YesodPersist ControlRoom where type YesodPersistBackend ControlRoom = SqlBackend runDB action = do pool <- getYesod <&> getPool runSqlPool action pool getRootR :: Handler Html getRootR = redirect TrainsR getTrainsR :: Handler Html getTrainsR = do req <- getRequest let maybeDay = lookup "day" (reqGetParams req) >>= (readMaybe . T.unpack) day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) gtfs <- getYesod <&> getGtfs let trips = tripsOnDay gtfs day defaultLayout $ do [whamlet| <h1>Trains on #{day} <section><ol> $forall Trip{..} <- trips <li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</a> : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} |] getTrainViewR :: TripID -> Day -> Handler Html getTrainViewR trip day = do GTFS{..} <- getYesod <&> getGtfs (widget, enctype) <- generateFormPost (announceForm day trip) case M.lookup trip trips of Nothing -> notFound Just res@Trip{..} -> do anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] tokens <- runDB $ selectList [ RunningTrip ==. trip, RunningDay ==. day ] [Asc RunningExpires] lastPing <- runDB $ selectFirst [ TrainPingToken <-. fmap entityKey tokens ] [Desc TrainPingTimestamp] anchors <- runDB $ selectList [ TrainAnchorTrip ==. trip, TrainAnchorDay ==. day ] [] <&> nonEmpty . (fmap entityVal) nowSeconds <- secondsNow day 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>_{MsgEstimatedDelay}</strong>: $maybe history <- anchors $maybe TrainAnchor{..} <- guessAtSeconds history nowSeconds \ #{trainAnchorDelay} (_{MsgOnStationSequence (showFFloat (Just 3) trainAnchorSequence "")}) $nothing <em> (_{MsgNone}) <section> <h2>_{MsgStops} <ol> $forall Stop{..} <- tripStops <li value="#{stopSequence}"> #{stopArrival} #{stationName stopStation} $maybe history <- anchors $maybe delay <- guessDelay history (int2Double stopSequence) \ (#{delay}) <section> <h2>_{MsgAnnouncements} <ul> $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="@{DelAnnounceR uuid}">delete</a> $if null anns <li><em>(_{MsgNone})</em> <h3>_{MsgNewAnnouncement} <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> ^{widget} <button>Submit <section> <h2>_{MsgTokens} <table> <tr><th style="width: 20%">_{MsgAgent}</th><th style="width: 50%">_{MsgToken}</th><th>_{MsgExpires}</th><th>_{MsgStatus}</th> $if null tokens <tr><td></td><td style="text-align:center"><em>(_{MsgNone}) $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> |] where guessDelay history = fmap trainAnchorDelay . extrapolateAtPosition LinearExtrapolator history guessAtSeconds = extrapolateAtSeconds LinearExtrapolator getTripsViewR :: Handler Html getTripsViewR = do GTFS{..} <- getYesod <&> getGtfs defaultLayout $ do setTitle "List of Trips" [whamlet| <h1>List of Trips <section><ul> $forall Trip{..} <- trips <li><a href="@{TripViewR tripTripID}">#{tripTripID}</a> : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} |] getTripViewR :: TripID -> Handler Html getTripViewR tripId = do GTFS{..} <- getYesod <&> getGtfs case M.lookup tripId trips of Nothing -> notFound Just Trip{..} -> defaultLayout [whamlet| <h1>Trip #{tripTripID} <section> <h2>Stops <ol> $forall Stop{..} <- tripStops <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} <section> <h2>Dates <ul> TODO! |] postAnnounceR :: TripID -> Day -> Handler Html postAnnounceR trip day = do ((result, widget), enctype) <- runFormPost (announceForm day trip) case result of FormSuccess ann -> do runDB $ insert ann redirect (TrainViewR trip day) _ -> defaultLayout [whamlet| <p>Invalid input, let's try again. <form method=post action=@{AnnounceR trip day} enctype=#{enctype}> ^{widget} <button>Submit |] getDelAnnounceR :: UUID -> Handler Html getDelAnnounceR uuid = do ann <- runDB $ do a <- get (AnnouncementKey uuid) delete (AnnouncementKey uuid) pure a case ann of Nothing -> notFound 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 getOnboardUnitMenuR :: Handler Html getOnboardUnitMenuR = do day <- liftIO getCurrentTime <&> utctDay gtfs <- getYesod <&> getGtfs let trips = tripsOnDay gtfs day defaultLayout $ do [whamlet| <h1>_{MsgOBU} <section> _{MsgChooseTrain} $forall Trip{..} <- trips <hr> <a href="@{OnboardUnitR tripTripID day}"> #{tripTripID}: #{stationName (stopStation (V.head tripStops))} #{stopDeparture (V.head tripStops)} |] getOnboardUnitR :: TripID -> Day -> Handler Html getOnboardUnitR tripId day = defaultLayout $(whamletFile "site/obu.hamlet") announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget) announceForm day tripId = renderDivs $ Announcement <$> pure tripId <*> areq textField (fieldSettingsLabel MsgHeader) Nothing <*> areq textField (fieldSettingsLabel MsgText) Nothing <*> pure day <*> aopt urlField (fieldSettingsLabel MsgMaybeWeblink) Nothing <*> lift (liftIO getCurrentTime <&> Just) --- some orphans to make hamlet easier to deal with instance ToMarkup Time where toMarkup time = toMarkup (show time) 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 instance ToMarkup Seconds where toMarkup (Seconds s) = if s > 0 then toMarkup ("+"+|s `div` 60|+"" :: Text) else toMarkup (s `div` 60)