aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Server/ControlRoom.hs48
-rw-r--r--tracktrain.cabal1
2 files changed, 31 insertions, 18 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 0e3f01e..e3af33f 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -14,7 +14,6 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE ViewPatterns #-}
module Server.ControlRoom (ControlRoom(..)) where
@@ -76,18 +75,34 @@ mkYesod "ControlRoom" [parseRoutes|
instance Yesod ControlRoom where
approot = ApprootMaster (\cr -> getBaseurl cr)
+ defaultLayout w = do
+ p <- widgetToPageContent w
+ msgs <- getMessages
+ withUrlRenderer [hamlet|
+ $newline never
+ $doctype 5
+ <html>
+ <head>
+ <title>Tracktrain #{pageTitle p}
+ $maybe description <- pageDescription p
+ <meta name="description" content="#{description}">
+ ^{pageHead p}
+ <body>
+ $forall (status, msg) <- msgs
+ <p class="message #{status}">#{msg}
+ ^{pageBody p}
+ |]
+
+
instance RenderMessage ControlRoom FormMessage where
renderMessage _ _ = defaultFormMessage
--- which backend we're using and how to run an action.
instance YesodPersist ControlRoom where
type YesodPersistBackend ControlRoom = SqlBackend
runDB action = do
pool <- getYesod <&> getPool
runSqlPool action pool
-
-
getRootR :: Handler Html
getRootR = redirect (TrainsR)
@@ -99,8 +114,9 @@ getTrainsR = do
day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay)
gtfs <- getYesod <&> getGtfs
let trips = tripsOnDay gtfs day
- defaultLayout [whamlet|
-<h1>Trains on #{iso8601Show day}
+ defaultLayout $ do
+ [whamlet|
+<h1>Trains on #{day}
<ol>
$forall Trip{..} <- trips
<li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</a>
@@ -116,7 +132,7 @@ getTrainViewR trip day = do
Just res@Trip{..} -> do
anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] []
defaultLayout [whamlet|
-<h1><a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{iso8601Show day}</a>
+<h1><a href="@{TripViewR tripTripID}">#{tripTripID}</a> _{Msgon} <a href="@?{(TrainsR, [("day", T.pack (iso8601Show day))])}">#{day}</a>
<h2>_{MsgAnnouncements}
<ul>
$forall Entity (AnnouncementKey uuid) Announcement{..} <- anns
@@ -192,17 +208,6 @@ getDelAnnounceR uuid = do
Just Announcement{..} ->
redirect (TrainViewR announcementTrip announcementDay)
-instance ToMarkup Time where
- toMarkup time =
- toMarkup (show time)
-
-data TrainAnnounceF = TrainAnnounceF
- { taHeader :: Text
- , taMsg :: Text
- , taLogTime :: Bool
- } deriving (Show)
-
-
announceForm :: Day -> TripID -> Html -> MForm Handler (FormResult Announcement, Widget)
announceForm day tripId = renderDivs $ Announcement
@@ -215,3 +220,10 @@ announceForm day tripId = renderDivs $ Announcement
+--- 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)
diff --git a/tracktrain.cabal b/tracktrain.cabal
index 4484247..b02e9a5 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -107,6 +107,7 @@ library
default-language: Haskell2010
default-extensions: OverloadedStrings
, ScopedTypeVariables
+ , ViewPatterns
library gtfs
build-depends: base ^>=4.14.3.0