aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
authorstuebinm2022-07-11 23:33:01 +0200
committerstuebinm2022-07-11 23:33:01 +0200
commit498ae348d120f156c65a89c87d9852393b23e2f4 (patch)
treea6882a4f3e0759be0521407290d34bb83ebb23e4 /lib
parent25a672a436eec65f2de097a1187ba8a3b8b6165a (diff)
somewhat functioning control room
tbh i've kinda lost track at what has all been changed in this, but the control room form handling now works, and i can write announcements into the database. Now on to making it do useful things!
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs2
-rw-r--r--lib/GTFS.hs2
-rw-r--r--lib/Lucid/Forms.hs32
-rw-r--r--lib/Persist.hs2
-rw-r--r--lib/Server.hs2
-rw-r--r--lib/Server/ControlRoom.hs111
-rw-r--r--lib/Server/GTFS_RT.hs2
7 files changed, 117 insertions, 36 deletions
diff --git a/lib/API.hs b/lib/API.hs
index e491812..9ed2846 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -69,7 +69,7 @@ type AdminAPI =
-- documented, which would be silly and way to verbose.
type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
:<|> API
- :<|> "control" :> ControlRoomAPI
+ :<|> "cr" :> ControlRoomAPI
-- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index cf4c939..539f69f 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -211,6 +211,8 @@ data Trip (deep :: Depth) (shape :: Depth)= Trip
, tripStops :: Optional deep (Vector (Stop deep))
} deriving Generic
+tripForgetShape :: Trip Deep Deep -> Trip Deep Shallow
+tripForgetShape trip = trip { tripShape = shapeId (tripShape trip) }
deriving instance Show (Trip Shallow Shallow)
deriving instance Show (Trip Deep Deep)
diff --git a/lib/Lucid/Forms.hs b/lib/Lucid/Forms.hs
index 26be845..918c942 100644
--- a/lib/Lucid/Forms.hs
+++ b/lib/Lucid/Forms.hs
@@ -11,7 +11,12 @@
{-# LANGUAGE TypeOperators #-}
-module Lucid.Forms (GToHtmlForm(..), GToHtmlFormInput(..), ToHtmlForm(..), ToHtmlFormInput(..)) where
+module Lucid.Forms ( GToHtmlForm(..)
+ , GToHtmlFormInput(..)
+ , ToHtmlForm(..)
+ , ToHtmlFormInput(..)
+ , HtmlFormOptions(..)
+ ) where
import Data.Maybe (maybeToList)
import Data.Proxy (Proxy (..))
@@ -21,10 +26,11 @@ import Data.Time (Day)
import GHC.Generics (C1, D1, Generic (Rep), K1, Meta (..),
Rec0, S1, U1, type (:*:), type (:+:))
import GHC.TypeLits (KnownSymbol, symbolVal)
-import Lucid (Html, ToHtml (toHtml), action_, div_,
- for_, form_, id_, input_, label_,
+import Lucid (Html, HtmlT, ToHtml (toHtml), action_,
+ div_, for_, form_, id_, input_, label_,
method_, name_, placeholder_, type_,
value_)
+import Lucid.Base (relaxHtmlT)
import Text.ProtocolBuffers (Default (defaultValue))
class GToHtmlFormInput a where
@@ -57,6 +63,10 @@ instance ToHtmlFormInput Text where
toFormInput name _ = input_ [type_ "text", name_ name, placeholder_ name]
instance ToHtmlFormInput Day where
toFormInput name _ = input_ [type_ "text", name_ name]
+instance ToHtmlFormInput Bool where
+ toFormInput name _ = input_ [type_ "checkbox", name_ name]
+instance ToHtmlFormInput (Maybe Bool) where
+ toFormInput name _ = input_ [type_ "checkbox", name_ name]
-- | generic conversion of record data types to input forms
@@ -82,14 +92,14 @@ instance GToHtmlForm a => GToHtmlForm (C1 r a) where
-- | class for things which can be entered via html forms
class ToHtmlForm a where
- toHtmlForm :: Proxy a -> Html ()
- default toHtmlForm :: (GToHtmlForm (Rep a)) => Proxy a -> Html ()
- toHtmlForm = genericToHtmlForm defaultOptions
+ toHtmlForm :: Monad m => HtmlFormOptions -> Proxy a -> HtmlT m ()
+ default toHtmlForm :: (GToHtmlForm (Rep a), Monad m) => HtmlFormOptions -> Proxy a -> HtmlT m ()
+ toHtmlForm options = relaxHtmlT . genericToHtmlForm options
data HtmlFormOptions = HtmlFormOptions
- { htmlFormAction :: Maybe Text
- , htmlFormMethod :: Text
- , htmlFormSubmitButtonText :: Text
+ { formAction :: Maybe Text
+ , formMethod :: Text
+ , formSubmitButtonText :: Text
}
defaultOptions ::HtmlFormOptions
@@ -100,6 +110,6 @@ instance Default HtmlFormOptions where
genericToHtmlForm :: (GToHtmlForm (Rep a2)) => HtmlFormOptions -> Proxy a2 -> Html ()
genericToHtmlForm HtmlFormOptions{..} (Proxy :: Proxy a) =
- form_ ((method_ htmlFormMethod) : maybeToList (fmap action_ htmlFormAction)) $ do
+ form_ ((method_ formMethod) : maybeToList (fmap action_ formAction)) $ do
gtoHtmlForm (Proxy @(Rep a _))
- input_ [type_ "submit", value_ htmlFormSubmitButtonText]
+ input_ [type_ "submit", value_ formSubmitButtonText]
diff --git a/lib/Persist.hs b/lib/Persist.hs
index c44ae3b..f2377b6 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -68,7 +68,7 @@ RunningTrip sql=tt_tracker_token
expires UTCTime
blocked Bool
tripNumber Text
- trainset Text Maybe
+ vehicle Text Maybe
deriving Eq Show Generic
TripPing json sql=tt_trip_ping
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