diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 354 |
1 files changed, 205 insertions, 149 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs index d7aee07..0971e79 100644 --- a/lib/Server/ControlRoom.hs +++ b/lib/Server/ControlRoom.hs @@ -10,8 +10,12 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE ViewPatterns #-} -module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where +module Server.ControlRoom (ControlRoom(..)) where import Control.Monad (unless, when) import Control.Monad.IO.Class (MonadIO (liftIO)) @@ -20,21 +24,6 @@ import qualified Data.Map as M import Data.Swagger (ToSchema (..)) import Data.Text (Text) import qualified Data.Text as T -import Lucid (Html, HtmlT, ToHtml (toHtml), a_, - action_, class_, div_, em_, for_, - form_, h1_, h2_, h3_, href_, id_, - input_, label_, li_, main_, - method_, name_, ol_, placeholder_, - type_, ul_, value_) -import Servant (Capture, EmptyAPI, FormUrlEncoded, - Get, Handler, JSON, - NoContent (..), PlainText, Post, - Proxy (Proxy), QueryParam, - QueryParam', ReqBody, Required, - ServerError, Strict, err302, - err404, errHeaders, throwError, - type (:<|>) (..), type (:>)) -import Servant.HTML.Lucid (HTML) import Web.FormUrlEncoded (ToForm) import Web.Internal.FormUrlEncoded (Form) @@ -50,10 +39,9 @@ import Data.UUID (UUID) import qualified Data.UUID as UUID import Database.Persist (Entity (..), delete, entityVal, get, insert, selectList, (==.)) -import Database.Persist.Sql (SqlBackend) +import Database.Persist.Sql (SqlBackend, PersistFieldSql, + runSqlPool) import GHC.Generics (Generic) -import Lucid.Forms (ToHtmlForm (..), - ToHtmlFormInput (..), formAction) import Persist (AmendmentStatus, Announcement (..), EntityField (..), Key (..), @@ -62,136 +50,204 @@ import Persist (AmendmentStatus, import Server.Util (Service, redirect) import Text.ProtocolBuffers (Default (defaultValue)) import Web.FormUrlEncoded (FromForm) - import Fmt ((+|), (|+)) +import Yesod +import Data.List (lookup) +import Text.Read (readMaybe) +import Text.Blaze.Html (ToMarkup(..)) +import qualified Data.Vector as V + import GTFS -data TrainView = TrainView - { tvDay :: Day - , tvTrip :: Trip Deep Deep - , tvAnnouncements :: [Entity Announcement] - , tvRunning :: Bool - } deriving Show - -type ControlRoomAPI = - "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep)) - :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView - :<|> "trips" :> Get '[HTML] (Map TripID (Trip Deep Deep)) - :<|> "trip" :> Capture "tripId" TripID :> Get '[HTML] (Trip Deep Deep) - :<|> ControlRoomCranks - --- | train infra seems to involve turning lots of cranks, so here have some! -type ControlRoomCranks = - "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent - :<|> "train" :> "del-announce" :> Capture "uuid" UUID :> Get '[PlainText] NoContent - :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent - :<|> "train" :> "date" :> Capture "tripId" TripID :> ReqBody '[FormUrlEncoded] TrainDateF :> Post '[PlainText] NoContent - :<|> "train" :> "date" :> Capture "tripId" TripID :> QueryParam' '[Required] "" TrainDateF :> Post '[PlainText] NoContent - :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent - :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI - :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI - -data TrainAnnounceF = TrainAnnounceF - { taHeader :: Text - , taMsg :: Text - , taLogTime :: Maybe Bool - } deriving (Generic, ToHtmlForm, FromForm) - --- | TODO: can also be "normal"? -data TrainDateF = TrainDateF - { tdDay :: Day - , tdStatus :: AmendmentStatus - } deriving (Generic, ToHtmlForm, FromForm) - - -controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI -controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrain :<|> handleTrips :<|> handleTrip - :<|> controlRoomCranks dbpool - where handleTrain trip day = case M.lookup trip trips of - Just res -> do - as <- runSql dbpool - $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] - pure (TrainView day res as True) -- TODO: can't just assume it runs that day … - Nothing -> throwError err404 - handleTimetable maybeDay = do - -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) - day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) - pure $ (day, tripsOnDay gtfs day) - handleTrips = pure trips - handleTrip tripId = case M.lookup tripId trips of - Just trip -> pure trip - Nothing -> throwError err404 - -controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks -controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> handleDate :<|> handleDate :<|> undefined - where handleAnnounce tripID day TrainAnnounceF{..} = do - now <- liftIO $ getCurrentTime - AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement - { announcementTrip = tripID - , announcementMessage = taMsg - , announcementHeader = taHeader - , announcementDay = day - , announcementUrl = Nothing - , announcementAnnouncedAt = - fmap (const now) taLogTime - } - redirect ("/cr/train/"<>C8.pack (T.unpack tripID)<>"/"<>C8.pack (iso8601Show day)) - handleAnnounceDel uuid = do - ann <- runSql dbpool $ do - a <- get (AnnouncementKey uuid) - delete (AnnouncementKey uuid) - pure a - case ann of - Nothing -> throwError err404 - Just Announcement{..} -> - redirect ("/cr/train/"+|announcementTrip|+"/"+| iso8601Show announcementDay|+"") - handleDate tripId TrainDateF{..} = do - -- TODO: check that tripId exists - runSql dbpool $ insert $ ScheduleAmendment tripId tdDay tdStatus - redirect ("/cr/train/"+|tripId|+"/"+| iso8601Show tdDay|+"") - - -instance ToHtmlFormInput CalendarExceptionType -instance ToHtmlForm CalendarDate - - -instance ToHtml TrainView where - toHtml (TrainView day Trip{..} as running) = crPage tripTripID $ do - unless running $ do - div_ [class_ "warning"] "Warning: Trip not running on this day!" - - h2_ "Announcements" - ul_ $ do - unless (null as) $ forM_ as $ \(Entity (AnnouncementKey uuid) Announcement{..}) -> do - li_ $ do - em_ (toHtml announcementHeader); ": "; toHtml announcementMessage - " "; a_ [href_ $ "/cr/train/del-announce/"<>UUID.toText uuid] "delete" - li_ $ do - "Add Announcement:" - toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) }) - (Proxy @TrainAnnounceF) - - h2_ "Stops" - ol_ $ forM_ tripStops $ \Stop{..} -> do - div_ (toHtml (stationName stopStation)) - - h2_ "Vehicle Position" - div_ "todo!" - - h2_ "Cancellation Status" - a_ [href_ ("/cr/train/date/"+|tripTripID|+"?tdDate="+|iso8601Show day|+"&tdStatus=Cancelled")] "Cancel" - - -instance ToHtml (Day, Map TripID (Trip Deep Deep)) where - toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do - ol_ $ forM_ trips $ \Trip{..} -> li_ $ do - a_ [href_ ("/cr/train/"<>tripTripID<>"/"<>shownDay)] (toHtml tripTripID) - when (null trips) $ do - em_ "(none)" - where shownDay = T.pack (iso8601Show day) - --- | control room page -crPage :: Monad m => Text -> HtmlT m () -> HtmlT m () -crPage title content = do - h1_ (toHtml title) - main_ content + +data ControlRoom = ControlRoom + { getBaseurl :: Text + , getGtfs :: GTFS + , getPool :: Pool SqlBackend + } + +mkYesod "ControlRoom" [parseRoutes| +/main MainR GET +/train/#TripID/#Day TrainViewR GET +|] + +instance Yesod ControlRoom where + approot = ApprootMaster (\cr -> getBaseurl cr) + +-- 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 + +getMainR :: Handler Html +getMainR = 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 [whamlet| +<h1>Trips on #{iso8601Show day} +<ol> + $forall Trip{..} <- trips + <li><a href="@{TrainViewR tripTripID day}">#{tripTripID}</a> + : #{stopDeparture (V.head tripStops)} #{stationName (stopStation (V.head tripStops))} +|] -- TODO: display stuff + +getTrainViewR :: TripID -> Day -> Handler Html +getTrainViewR trip day = do + GTFS{..} <- getYesod <&> getGtfs + case M.lookup trip trips of + Nothing -> notFound + Just res@Trip{..} -> do + anns <- runDB $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] + defaultLayout [whamlet| +<h1>#{tripTripID} on #{iso8601Show day} +<h2>Announcements +<ul> + $forall Entity (AnnouncementKey uuid) Announcement{..} <- anns + <li><em>#{announcementHeader}: #{announcementMessage}</em> <a href="">delete</a> + $if null anns + <li><em>(none)</em> + <li><a href="">Add Announcement</a> +<h2>Stops +<ol> + $forall Stop{..} <- tripStops + <div>(#{stopSequence}) #{stopArrival} #{stationName stopStation} + +<h2>Vehicle Position +<div> Todo! +|] + + + +instance ToMarkup Time where + toMarkup time = + toMarkup (show time) + +-- type ControlRoomAPI = +-- "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep)) +-- :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView +-- :<|> "trips" :> Get '[HTML] (Map TripID (Trip Deep Deep)) +-- :<|> "trip" :> Capture "tripId" TripID :> Get '[HTML] (Trip Deep Deep) +-- :<|> ControlRoomCranks + +-- -- | train infra seems to involve turning lots of cranks, so here have some! +-- type ControlRoomCranks = +-- "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent +-- :<|> "train" :> "del-announce" :> Capture "uuid" UUID :> Get '[PlainText] NoContent +-- :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent +-- :<|> "train" :> "date" :> Capture "tripId" TripID :> ReqBody '[FormUrlEncoded] TrainDateF :> Post '[PlainText] NoContent +-- :<|> "train" :> "date" :> Capture "tripId" TripID :> QueryParam' '[Required] "" TrainDateF :> Post '[PlainText] NoContent +-- :<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent +-- :<|> "train" :> "metainfo" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI +-- :<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI + +-- data TrainAnnounceF = TrainAnnounceF +-- { taHeader :: Text +-- , taMsg :: Text +-- , taLogTime :: Maybe Bool +-- } deriving (Generic, ToHtmlForm, FromForm) + +-- -- | TODO: can also be "normal"? +-- data TrainDateF = TrainDateF +-- { tdDay :: Day +-- , tdStatus :: AmendmentStatus +-- } deriving (Generic, ToHtmlForm, FromForm) + + +-- controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI +-- controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrain :<|> handleTrips :<|> handleTrip +-- :<|> controlRoomCranks dbpool +-- where handleTrain trip day = case M.lookup trip trips of +-- Just res -> do +-- as <- runSql dbpool +-- $ selectList [ AnnouncementTrip ==. trip, AnnouncementDay ==. day ] [] +-- pure (TrainView day res as True) -- TODO: can't just assume it runs that day … +-- Nothing -> throwError err404 +-- handleTimetable maybeDay = do +-- -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) +-- day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) +-- pure $ (day, tripsOnDay gtfs day) +-- handleTrips = pure trips +-- handleTrip tripId = case M.lookup tripId trips of +-- Just trip -> pure trip +-- Nothing -> throwError err404 + +-- controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks +-- controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> handleDate :<|> handleDate :<|> undefined +-- where handleAnnounce tripID day TrainAnnounceF{..} = do +-- now <- liftIO $ getCurrentTime +-- AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement +-- { announcementTrip = tripID +-- , announcementMessage = taMsg +-- , announcementHeader = taHeader +-- , announcementDay = day +-- , announcementUrl = Nothing +-- , announcementAnnouncedAt = +-- fmap (const now) taLogTime +-- } +-- redirect ("/cr/train/"<>C8.pack (T.unpack tripID)<>"/"<>C8.pack (iso8601Show day)) +-- handleAnnounceDel uuid = do +-- ann <- runSql dbpool $ do +-- a <- get (AnnouncementKey uuid) +-- delete (AnnouncementKey uuid) +-- pure a +-- case ann of +-- Nothing -> throwError err404 +-- Just Announcement{..} -> +-- redirect ("/cr/train/"+|announcementTrip|+"/"+| iso8601Show announcementDay|+"") +-- handleDate tripId TrainDateF{..} = do +-- -- TODO: check that tripId exists +-- runSql dbpool $ insert $ ScheduleAmendment tripId tdDay tdStatus +-- redirect ("/cr/train/"+|tripId|+"/"+| iso8601Show tdDay|+"") + + +-- instance ToHtmlFormInput CalendarExceptionType +-- instance ToHtmlForm CalendarDate + + +-- instance ToHtml TrainView where +-- toHtml (TrainView day Trip{..} as running) = crPage tripTripID $ do +-- unless running $ do +-- div_ [class_ "warning"] "Warning: Trip not running on this day!" + +-- h2_ "Announcements" +-- ul_ $ do +-- unless (null as) $ forM_ as $ \(Entity (AnnouncementKey uuid) Announcement{..}) -> do +-- li_ $ do +-- em_ (toHtml announcementHeader); ": "; toHtml announcementMessage +-- " "; a_ [href_ $ "/cr/train/del-announce/"<>UUID.toText uuid] "delete" +-- li_ $ do +-- "Add Announcement:" +-- toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) }) +-- (Proxy @TrainAnnounceF) + +-- h2_ "Stops" +-- ol_ $ forM_ tripStops $ \Stop{..} -> do +-- div_ (toHtml (stationName stopStation)) + +-- h2_ "Vehicle Position" +-- div_ "todo!" + +-- h2_ "Cancellation Status" +-- a_ [href_ ("/cr/train/date/"+|tripTripID|+"?tdDate="+|iso8601Show day|+"&tdStatus=Cancelled")] "Cancel" + + +-- instance ToHtml (Day, Map TripID (Trip Deep Deep)) where +-- toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do +-- ol_ $ forM_ trips $ \Trip{..} -> li_ $ do +-- a_ [href_ ("/cr/train/"<>tripTripID<>"/"<>shownDay)] (toHtml tripTripID) +-- when (null trips) $ do +-- em_ "(none)" +-- where shownDay = T.pack (iso8601Show day) + +-- -- | control room page +-- crPage :: Monad m => Text -> HtmlT m () -> HtmlT m () +-- crPage title content = do +-- h1_ (toHtml title) +-- main_ content |