aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--lib/API.hs37
-rw-r--r--lib/GTFS.hs10
-rw-r--r--lib/Server.hs2
-rw-r--r--lib/Server/ControlRoom.hs53
-rw-r--r--todo.org16
-rw-r--r--tracktrain.cabal4
6 files changed, 104 insertions, 18 deletions
diff --git a/lib/API.hs b/lib/API.hs
index a04e131..f95132a 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -7,27 +7,29 @@
-- Haskell type. All other descriptions of the API are generated from this one.
module API (API, CompleteAPI, GtfsRealtimeAPI, AdminAPI) where
-import Data.Map (Map)
-import Data.Proxy (Proxy (..))
-import Data.Swagger (Swagger)
-import Data.Swagger.ParamSchema (ToParamSchema (..))
-import Data.Text (Text)
-import Data.Time (Day, UTCTime)
-import Data.UUID (UUID)
-import Servant (Application,
- FromHttpApiData (parseUrlPiece),
- Server, err401, err404, type (:>))
-import Servant.API (Capture, Get, JSON, NoContent, Post,
- QueryParam, ReqBody,
- type (:<|>) ((:<|>)))
-import Servant.API.WebSocket (WebSocket)
-import Servant.GTFS.Realtime (Proto)
-import Servant.Swagger (HasSwagger (..))
+import Data.Map (Map)
+import Data.Proxy (Proxy (..))
+import Data.Swagger (Swagger)
+import Data.Swagger.ParamSchema (ToParamSchema (..))
+import Data.Text (Text)
+import Data.Time (Day, UTCTime)
+import Data.UUID (UUID)
+import Servant (Application, FormUrlEncoded,
+ FromHttpApiData (parseUrlPiece),
+ Server, err401, err404, type (:>))
+import Servant.API (Capture, Get, JSON, NoContent,
+ PlainText, Post, QueryParam,
+ ReqBody, type (:<|>) ((:<|>)))
+import Servant.API.WebSocket (WebSocket)
+import Servant.GTFS.Realtime (Proto)
+import Servant.Swagger (HasSwagger (..))
+import Web.Internal.FormUrlEncoded (Form)
import GTFS
import GTFS.Realtime.FeedEntity
-import GTFS.Realtime.FeedMessage (FeedMessage)
+import GTFS.Realtime.FeedMessage (FeedMessage)
import Persist
+import Server.ControlRoom
-- | The server's API (as it is actually intended).
@@ -45,6 +47,7 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
:<|> "gtfs" :> GtfsRealtimeAPI
-- TODO: this should be behind auth / OpenID or something
:<|> "admin" :> AdminAPI
+ :<|> "control" :> ControlRoomAPI
-- | The API used for publishing gtfs realtime updates
type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 68d92dc..cf4c939 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -19,7 +19,6 @@
-- (i.e. parsing, querying, Aeson instances, etc.)
module GTFS where
-
import qualified Codec.Archive.Zip as Zip
import Control.Monad.ST (runST)
import Data.Aeson (FromJSON,
@@ -48,6 +47,8 @@ import qualified Data.Vector.Algorithms.Intro as V
import Fmt ((+|), (|+))
import GHC.Generics (Generic)
import Text.Regex.TDFA ((=~))
+import Web.Internal.FormUrlEncoded (FromForm (..))
+import Web.Internal.HttpApiData (FromHttpApiData (..))
-- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
import Control.Lens
import Data.Char (toLower)
@@ -178,6 +179,12 @@ data Calendar = Calendar
data CalendarExceptionType = ServiceAdded | ServiceRemoved
deriving (Show, Eq, Generic, ToJSON, FromJSON)
+instance FromHttpApiData CalendarExceptionType where
+ parseUrlPiece = \case
+ "added" -> Right ServiceAdded
+ "removed" -> Right ServiceRemoved
+ unknown -> Left ("unknown CalendarExceptionType: "<>unknown)
+
data CalendarDate = CalendarDate
{ caldateServiceId :: Text
, caldateDate :: Day
@@ -188,6 +195,7 @@ instance FromJSON CalendarDate where
parseJSON = genericParseJSON (aesonOptions "caldate")
instance ToJSON CalendarDate where
toJSON = genericToJSON (aesonOptions "caldate")
+instance FromForm CalendarDate
data Trip (deep :: Depth) (shape :: Depth)= Trip
{ tripRoute :: Text
diff --git a/lib/Server.hs b/lib/Server.hs
index a5a5ff9..539e3ce 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -44,6 +44,7 @@ import Servant.Swagger (toSwagger)
import API
import GTFS
import Persist
+import Server.ControlRoom
import Server.GTFS_RT (gtfsRealtimeServer)
import Server.Util (Service, ServiceM, runService)
@@ -64,6 +65,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime
:<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|>
gtfsRealtimeServer gtfs dbpool
:<|> adminServer gtfs dbpool
+ :<|> controlRoomServer
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
new file mode 100644
index 0000000..6f5999f
--- /dev/null
+++ b/lib/Server/ControlRoom.hs
@@ -0,0 +1,53 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeOperators #-}
+
+module Server.ControlRoom where
+
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Data.Swagger (ToSchema (..))
+import Data.Text (Text)
+import GTFS
+import Lucid
+import Servant
+import Servant.API (Capture, Get, JSON, NoContent,
+ PlainText, Post, QueryParam,
+ ReqBody, type (:<|>) ((:<|>)))
+import Servant.HTML.Lucid (HTML)
+import Server.Util
+import Web.Internal.FormUrlEncoded (Form)
+
+data TripList = TripList
+ { tripListHeader :: Text
+ , tripListType :: Text
+ , tripListTrips :: [TripID]
+ }
+
+type ControlRoomAPI =
+ Get '[HTML] TripList
+ :<|> "irgendwo" :> ReqBody '[FormUrlEncoded] CalendarDate :> Post '[PlainText] Text
+
+controlRoomServer :: Service ControlRoomAPI
+controlRoomServer =
+ (pure (TripList "hallo" "welt" []))
+ :<|> (\text -> do
+ liftIO $ putStrLn (show text)
+ pure "hello"
+ )
+
+instance ToHtml TripList where
+ toHtml TripList{..} = form_ [action_ "./irgendwo", method_ "post"] $ do
+ input_ [type_ "text", name_ "caldateServiceId"]
+ input_ [type_ "text", name_ "caldateDate"]
+ input_ [type_ "text", name_ "caldateExceptionType"]
+ input_ [type_ "submit", value_ "hallo!"]
+
+instance ToSchema Form where
+ declareNamedSchema _ = undefined
+instance ToSchema TripList where
+ declareNamedSchema _ = undefined
+instance ToSchema CalendarDate where
+ declareNamedSchema _ = undefined
diff --git a/todo.org b/todo.org
index be21561..f4285ed 100644
--- a/todo.org
+++ b/todo.org
@@ -14,7 +14,23 @@
** TODO implement trip updates
* TODO frontend stuff ("leitstelle")
** TODO write a webform API
+- cancel trip
+- add announcement to trip
+- add trip
+- add delay (only "now", not per-station?)
+- edit trip metainfo
+- add extra train number not in gtfs (optional)
+-
** TODO static pages frontend
+needed pages:
+ - auth (openID?)
+ - trips, filterable by: everything, currently running
+ - actions: cancel trip, add trip date
+ - single trip view
+ - actions: add announcement, cancel
+ - self-reload page to keep up to date?
+ - potentially more (e.g. accessability info for gtfs-rt)
+ - (optional) add extraordinary trip
** TODO auth (openID? How to test?)
** TODO dynamic content via logging/monitoring etc.
* TODO find out if we need to support VDV standards
diff --git a/tracktrain.cabal b/tracktrain.cabal
index fe8ba49..7f89cb9 100644
--- a/tracktrain.cabal
+++ b/tracktrain.cabal
@@ -77,6 +77,8 @@ library
, servant-swagger
, servant-docs
, servant-websockets
+ , servant-lucid
+ , lucid
, websockets
, lens
, persistent
@@ -86,6 +88,7 @@ library
, unliftio-core
, conduit
, path-pieces
+ , http-api-data
, either
, resource-pool
, transformers
@@ -95,6 +98,7 @@ library
exposed-modules: GTFS
, Server
, Server.GTFS_RT
+ , Server.ControlRoom
, PersistOrphans
, Persist
, API
generated by cgit v1.2.3 (git 2.25.1) at 2024-12-22 09:07:09 +0000