aboutsummaryrefslogtreecommitdiff
path: root/lib/Server
diff options
context:
space:
mode:
Diffstat (limited to 'lib/Server')
-rw-r--r--lib/Server/ControlRoom.hs99
-rw-r--r--lib/Server/Util.hs11
2 files changed, 79 insertions, 31 deletions
diff --git a/lib/Server/ControlRoom.hs b/lib/Server/ControlRoom.hs
index 7a5bdb2..e4b69c2 100644
--- a/lib/Server/ControlRoom.hs
+++ b/lib/Server/ControlRoom.hs
@@ -13,21 +13,25 @@
module Server.ControlRoom (ControlRoomAPI, controlRoomServer) where
+import Control.Monad (unless, when)
import Control.Monad.IO.Class (MonadIO (liftIO))
+import qualified Data.ByteString.Char8 as C8
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_, div_, for_, form_, h1_,
- h2_, href_, id_, input_, label_,
- li_, main_, method_, name_, ol_,
- placeholder_, type_, value_)
+ 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, JSON, NoContent, PlainText,
- Post, Proxy (Proxy), QueryParam,
- ReqBody, err404, err302,
- errHeaders, throwError,
+ Get, Handler, JSON,
+ NoContent (..), PlainText, Post,
+ Proxy (Proxy), QueryParam,
+ ReqBody, ServerError, err302,
+ err404, errHeaders, throwError,
type (:<|>) (..), type (:>))
import Servant.HTML.Lucid (HTML)
import Web.FormUrlEncoded (ToForm)
@@ -41,28 +45,39 @@ 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 Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import Database.Persist (Entity (..), delete, entityVal,
+ get, insert, selectList, (==.))
import Database.Persist.Sql (SqlBackend)
import GHC.Generics (Generic)
import Lucid.Forms (ToHtmlForm (..),
ToHtmlFormInput (..), formAction)
-import Persist (Announcement (..), Key (..),
+import Persist (Announcement (..),
+ EntityField (..), Key (..),
runSql)
-import Server.Util (Service)
+import Server.Util (Service, redirect)
import Text.ProtocolBuffers (Default (defaultValue))
import Web.FormUrlEncoded (FromForm)
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))
- :<|> "trip" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] (Day, Trip Deep Deep)
- :<|> "irgendwo" :> ReqBody '[FormUrlEncoded] CalendarDate :> Post '[PlainText] Text
+ :<|> "train" :> Capture "tripID" TripID :> Capture "day" Day :> Get '[HTML] TrainView
:<|> 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" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
:<|> "train" :> "delay" :> ReqBody '[FormUrlEncoded] Form :> Post '[PlainText] NoContent
@@ -70,20 +85,20 @@ type ControlRoomCranks =
:<|> "trip" :> "new" :> ReqBody '[FormUrlEncoded] Form :> EmptyAPI
data TrainAnnounceF = TrainAnnounceF
- { taMsg :: Text
- , taHeader :: Text
+ { taHeader :: Text
+ , taMsg :: 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 …
+ 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?)
@@ -91,7 +106,7 @@ controlRoomServer gtfs@GTFS{..} dbpool = handleTimetable :<|> handleTrip
pure $ (day, tripsOnDay gtfs day)
controlRoomCranks :: Pool SqlBackend -> Service ControlRoomCranks
-controlRoomCranks dbpool = undefined :<|> handleAnnounce :<|> undefined
+controlRoomCranks dbpool = undefined :<|> handleAnnounceDel :<|> handleAnnounce :<|> undefined
where handleAnnounce tripID day TrainAnnounceF{..} = do
now <- liftIO $ getCurrentTime
AnnouncementKey uuid <- runSql dbpool $ insert $ Announcement
@@ -103,25 +118,53 @@ controlRoomCranks dbpool = undefined :<|> handleAnnounce :<|> undefined
, announcementAnnouncedAt =
fmap (const now) taLogTime
}
- throwError $ err302 { errHeaders = [("Location", "/cr/main")] }
+ 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/"<>C8.pack (T.unpack announcementTrip)<>"/"<>C8.pack (iso8601Show announcementDay))
instance ToHtmlFormInput CalendarExceptionType
instance ToHtmlForm CalendarDate
-instance ToHtml (Day, Trip Deep Deep) where
- toHtml (day, Trip{..}) = crPage tripTripID $ do
+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))
- toHtmlForm (defaultValue {formAction = Just ("/cr/train/announce/"<>tripTripID<>"/"<>(T.pack . iso8601Show) day) })
- (Proxy @TrainAnnounceF)
+
+ h2_ "Vehicle Position"
+ div_ "todo!"
+
instance ToHtml (Day, Map TripID (Trip Deep Deep)) where
- toHtml (day, trips) = crPage ("trips on " <> T.pack (iso8601Show day)) $ do
+ toHtml (day, trips) = crPage ("trips on " <> shownDay) $ do
ol_ $ forM_ trips $ \Trip{..} -> li_ $ do
- a_ [href_ ("/cr/trip/"<>tripTripID<>"/"<>T.pack (iso8601Show day))] (toHtml tripTripID)
+ 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 ()
diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs
index 45c2477..1c62663 100644
--- a/lib/Server/Util.hs
+++ b/lib/Server/Util.hs
@@ -1,13 +1,18 @@
-
+{-# LANGUAGE FlexibleContexts #-}
-- | mostly the monad the service runs in
-module Server.Util (Service, ServiceM, runService) where
+module Server.Util (Service, ServiceM, runService, redirect) where
import Control.Monad.Logger (LoggingT, runStderrLoggingT)
-import Servant (Handler, ServerT)
+import Data.ByteString (ByteString)
+import Servant (Handler, ServerError, ServerT, err302,
+ errHeaders, throwError)
type ServiceM = LoggingT Handler
type Service api = ServerT api ServiceM
runService :: ServiceM a -> Handler a
runService = runStderrLoggingT
+
+redirect :: ByteString -> ServiceM a
+redirect path = throwError $ err302 { errHeaders = [("Location", path)] }
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-23 00:50:28 +0000