aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/Server.hs2
-rw-r--r--lib/Server/ControlRoom.hs111
-rw-r--r--lib/Server/GTFS_RT.hs2
3 files changed, 92 insertions, 23 deletions
diff --git a/lib/Server.hs b/lib/Server.hs
index 544b6ae..cc86cd2 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -65,7 +65,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> (handleStations :<|> handleTim
:<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|>
gtfsRealtimeServer gtfs dbpool
:<|> adminServer gtfs dbpool)
- :<|> controlRoomServer
+ :<|> controlRoomServer 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 edfdeb3..7a5bdb2 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DefaultSignatures #-}
+{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
@@ -10,52 +11,120 @@
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}
-module Server.ControlRoom where
+module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where
import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Data.Map as M
import Data.Swagger (ToSchema (..))
import Data.Text (Text)
import qualified Data.Text as T
-import Lucid (Html, ToHtml (toHtml), action_,
- div_, for_, form_, id_, input_,
- label_, method_, name_,
+import Lucid (Html, HtmlT, ToHtml (toHtml), a_,
+ action_, div_, for_, form_, h1_,
+ h2_, href_, id_, input_, label_,
+ li_, main_, method_, name_, ol_,
placeholder_, type_, value_)
-import Servant (Capture, FormUrlEncoded, Get,
- JSON, NoContent, PlainText, Post,
- QueryParam, ReqBody,
+import Servant (Capture, EmptyAPI, FormUrlEncoded,
+ Get, JSON, NoContent, PlainText,
+ Post, Proxy (Proxy), QueryParam,
+ ReqBody, err404, err302,
+ errHeaders, throwError,
type (:<|>) (..), type (:>))
import Servant.HTML.Lucid (HTML)
import Web.FormUrlEncoded (ToForm)
import Web.Internal.FormUrlEncoded (Form)
-import GTFS (CalendarDate,
- CalendarExceptionType, TripID)
+import Control.Monad (forM_)
+import Control.Monad.Extra (maybeM, whenM)
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import Data.Pool (Pool)
+import Data.Time (getCurrentTime, utctDay)
+import Data.Time.Calendar (Day)
+import Data.Time.Format.ISO8601 (iso8601Show)
+import Database.Persist (insert)
+import Database.Persist.Sql (SqlBackend)
+import GHC.Generics (Generic)
import Lucid.Forms (ToHtmlForm (..),
- ToHtmlFormInput (..))
+ ToHtmlFormInput (..), formAction)
+import Persist (Announcement (..), Key (..),
+ runSql)
import Server.Util (Service)
+import Text.ProtocolBuffers (Default (defaultValue))
+import Web.FormUrlEncoded (FromForm)
-data TripList = TripList
- { tripListHeader :: Text
- , tripListType :: Text
- , tripListTrips :: [TripID]
- }
+import GTFS
type ControlRoomAPI =
- Get '[HTML] TripList
+ "main" :> QueryParam "day" Day :> Get '[HTML] (Day, Map TripID (Trip Deep Deep))
+ :<|> "trip" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] (Day, Trip Deep Deep)
:<|> "irgendwo" :> ReqBody '[FormUrlEncoded] CalendarDate :> Post '[PlainText] Text
+ :<|> ControlRoomCranks
-controlRoomServer :: Service ControlRoomAPI
-controlRoomServer =
- (pure (TripList "hallo" "welt" []))
+-- | train infra seems to involve turning lots of cranks, so here have some!
+type ControlRoomCranks =
+ "train" :> "cancel" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
+ :<|> "train" :> "announce" :> Capture "tripId" TripID :> Capture "day" Day :> ReqBody '[FormUrlEncoded] TrainAnnounceF :> Post '[PlainText] NoContent
+ :<|> "train" :> "date" :> ReqBody '[FormUrlEncoded] Form :> 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
+ { taMsg :: Text
+ , taHeader :: Text
+ , taLogTime :: Maybe Bool
+ } deriving (Generic, ToHtmlForm, FromForm)
+
+controlRoomServer :: GTFS -> Pool SqlBackend -> Service ControlRoomAPI
+controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
:<|> (\text -> do
liftIO $ putStrLn (show text)
pure "hello"
)
+ :<|> controlRoomCranks dbpool
+ where handleTrip trip day = case M.lookup trip trips of
+ Just res -> pure (day, res) -- 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)
+
+controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
+controlRoomCranks dbpool = undefined :<|> handleAnnounce :<|> 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
+ }
+ throwError $ err302 { errHeaders = [("Location", "/cr/main")] }
instance ToHtmlFormInput CalendarExceptionType
instance ToHtmlForm CalendarDate
-instance ToHtml TripList where
- toHtml _ = div_ "todo"
+instance ToHtml (Day, Trip Deep Deep) where
+ toHtml (day, Trip{..}) = crPage tripTripID $ do
+ h2_ "Stops"
+ ol_ $ forM_ tripStops $ \Stop{..} -> do
+ div_ (toHtml (stationName stopStation))
+ toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
+ (Proxy @TrainAnnounceF)
+
+instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
+ toHtml (day, trips) = crPage ("trips on " <> T.pack (iso8601Show day)) $ do
+ ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
+ a_ [href_ ("/cr/trip/"<>tripTripID<>"/"<>T.pack (iso8601Show day))] (toHtml tripTripID)
+
+-- | control room page
+crPage :: Monad m => Text -> HtmlT m () -> HtmlT m ()
+crPage title content = do
+ h1_ (toHtml title)
+ main_ content
diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs
index e3a07cb..d771736 100644
--- a/lib/Server/GTFS_RT.hs
+++ b/lib/Server/GTFS_RT.hs
@@ -123,7 +123,7 @@ gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|>
(dFeedEntity (toUtf8 . T.pack . show $ key))
{ FE.vehicle = Just $ VehiclePosition
{ trip = Just (dTripDescriptor runningTripTripNumber Nothing)
- , VP.vehicle = case runningTripTrainset of
+ , VP.vehicle = case runningTripVehicle of
Nothing -> Nothing
Just trainset -> Just $ VehicleDescriptor
{ VD.id = Nothing
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-02 22:32:38 +0000