$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; } <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 ] [] 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>_{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>_{MsgStops} <ol> $forall Stop{..} <- tripStops <li> #{stopArrival} #{stationName stopStation} <section> <h2>Vehicle Position <div> Todo! |] 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) 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)

{-# 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_) 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.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 (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.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.ProtocolBuffers (Default (defaultValue)) import Text.Read (readMaybe) import Text.Shakespeare.Text import Yesod import Yesod.Form import GTFS data ControlRoom = ControlRoom { getBaseurl :: Text , 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 /trips TripsViewR GET /trip/#TripID TripViewR GET |] emptyMarkup :: MarkupM a -> Bool emptyMarkup (Empty _) = True emptyMarkup _ = False instance Yesod ControlRoom where approot = ApprootMaster (\cr -> getBaseurl cr) 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; } <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 ] [] 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>_{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>_{MsgStops} <ol> $forall Stop{..} <- tripStops <li> #{stopArrival} #{stationName stopStation} <section> <h2>Vehicle Position <div> Todo! |] 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) 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)