diff options
| -rw-r--r-- | lib/API.hs | 2 | ||||
| -rw-r--r-- | lib/GTFS.hs | 2 | ||||
| -rw-r--r-- | lib/Lucid/Forms.hs | 32 | ||||
| -rw-r--r-- | lib/Persist.hs | 2 | ||||
| -rw-r--r-- | lib/Server.hs | 2 | ||||
| -rw-r--r-- | lib/Server/ControlRoom.hs | 111 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 2 | ||||
| -rw-r--r-- | tracktrain.cabal | 1 |
8 files changed, 118 insertions, 36 deletions
@@ -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 diff --git a/tracktrain.cabal b/tracktrain.cabal index 91b8adf..253999b 100644 --- a/tracktrain.cabal +++ b/tracktrain.cabal @@ -103,6 +103,7 @@ library , PersistOrphans , Persist , API + other-modules: Server.Util default-language: Haskell2010 default-extensions: OverloadedStrings , ScopedTypeVariables |