From aeeaf83cf0dc72e9e39439984067563d08e57dec Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 2 Jul 2022 16:11:29 +0200
Subject: more or less functional servicealerts for gtfs rt

(kinda barebones, but the important things should be there)
---
 lib/API.hs | 56 ++++++++++++++++++++++++++++++++++++--------------------
 1 file changed, 36 insertions(+), 20 deletions(-)

(limited to 'lib/API.hs')

diff --git a/lib/API.hs b/lib/API.hs
index 34b127a..5afd041 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -5,31 +5,33 @@
 
 -- | The sole authorative definition of this server's API, given as a Servant-style
 -- Haskell type. All other descriptions of the API are generated from this one.
-module API (API, CompleteAPI, GtfsRealtimeAPI) where
+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.Time                (Day, UTCTime)
+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           GTFS
+import           GTFS.Realtime.FeedEntity
+import           GTFS.Realtime.FeedMessage (FeedMessage)
 import           Persist
-import           Servant                  (Application,
-                                           FromHttpApiData (parseUrlPiece),
-                                           Server, err401, err404, serve,
-                                           throwError, type (:>))
-import           Servant.API              (Capture, FromHttpApiData, Get, JSON,
-                                           Post, QueryParam, ReqBody,
-                                           type (:<|>) ((:<|>)))
-import Servant.GTFS.Realtime (Proto)
-import GTFS.Realtime.FeedEntity
-import GTFS.Realtime.FeedMessage (FeedMessage)
+import           Servant                   (Application,
+                                            FromHttpApiData (parseUrlPiece),
+                                            Server, err401, err404, serve,
+                                            throwError, type (:>))
+import           Servant.API               (Capture, FromHttpApiData, Get, JSON,
+                                            Post, QueryParam, ReqBody,
+                                            type (:<|>) ((:<|>)))
+import           Servant.GTFS.Realtime     (Proto)
 
+import           Data.UUID                 (UUID)
 
 -- | The server's API (as it is actually intended).
 type API = "stations" :> Get '[JSON] (Map StationID Station)
-  :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep))
-  :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep)
+  :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep))
+  :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep)
   -- ingress API (put this behind BasicAuth?)
   -- TODO: perhaps require a first ping for registration?
   :<|> "train" :> "register" :> Capture "Trip ID" TripID :> Post '[JSON] Token
@@ -38,11 +40,22 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
   -- debug things
   :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
   :<|> "gtfs" :> GtfsRealtimeAPI
+  :<|> "admin" :> AdminAPI
 
 -- | The API used for publishing gtfs realtime updates
 type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
-  :<|> "tripupdates" :> Get '[Proto] FeedEntity
-  :<|> "vehiclepositions" :> Get '[Proto] FeedEntity
+  :<|> "tripupdates" :> Get '[Proto] FeedMessage
+  :<|> "vehiclepositions" :> Get '[Proto] FeedMessage
+
+-- | Admin API used for short-term timetable changes etc. ("leitstelle")
+type AdminAPI =
+  "trip" :> "announce" :> Capture "Trip ID" TripID :> QueryParam "day" Day :> ReqBody '[JSON] Text :> Post '[JSON] UUID
+  :<|> "trip" :> "announce" :> "delete" :> Capture "Announcement ID" UUID :> Post '[JSON] ()
+  :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Post '[JSON] ()
+  :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Post '[JSON] ()
+-- TODO for this to be useful there ought to be a half-deep Trip type
+-- (that has stops but not shapes)
+  :<|> "extraordinary" :> "trip" :> ReqBody '[JSON] (Trip Deep Shallow) :> Post '[JSON] ()
 
 
 -- | The server's API with an additional debug route for accessing the specification
@@ -52,9 +65,12 @@ type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
   :<|> API
 
 
+
 instance ToParamSchema (Maybe UTCTime) where
   toParamSchema _ = toParamSchema (Proxy @UTCTime)
 
+
+
 {-
 TODO:
 there should be a basic API allowing the questions:
-- 
cgit v1.2.3