diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 48 | ||||
| -rw-r--r-- | tracktrain.cabal | 1 |
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 |