diff options
Diffstat (limited to 'lib/Server')
| -rw-r--r-- | lib/Server/ControlRoom.hs | 111 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 2 |
2 files changed, 91 insertions, 22 deletions
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 |