aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Server.hs5
-rw-r--r--lib/Server/ControlRoom.hs354
2 files changed, 209 insertions, 150 deletions
diff --git a/lib/Server.hs b/lib/Server.hs
index cc86cd2..24f29f9 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -47,6 +47,9 @@ import Persist
import Server.ControlRoom
import Server.GTFS_RT (gtfsRealtimeServer)
import Server.Util (Service, ServiceM, runService)
+import Yesod (toWaiAppPlain)
+
+import System.IO.Unsafe
application :: GTFS -> Pool SqlBackend -> IO Application
application gtfs dbpool = do
@@ -65,7 +68,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
:<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|>
gtfsRealtimeServer gtfs dbpool
:<|> adminServer gtfs dbpool)
- :<|> controlRoomServer gtfs dbpool
+ :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom "http://localhost:4000/cr" gtfs dbpool)))
where handleStations = pure stations
handleTimetable station maybeDay = do
-- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-10 22:34:00 +0000