diff options
| -rw-r--r-- | lib/Persist.hs | 2 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 99 | ||||
| -rw-r--r-- | lib/Server/Util.hs | 11 |
3 files changed, 80 insertions, 32 deletions
diff --git a/lib/Persist.hs b/lib/Persist.hs index f2377b6..da23dae 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -88,7 +88,7 @@ Announcement json sql=tt_announcements day Day url Text Maybe announcedAt UTCTime Maybe - deriving Generic ToSchema + deriving Generic ToSchema Show -- | this table works as calendar_dates.txt in GTFS ScheduleAmendment json sql=tt_schedule_amendement 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)] } |