From a4045a5b0a898042cd78eba9b22550c965a1bbd9 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sat, 27 Aug 2022 01:45:12 +0200
Subject: controlroom: lots of pretty little knobs

(also some database schema changes, for good measure)
---
 lib/API.hs | 55 +++++++++++++++++++++++--------------------------------
 1 file changed, 23 insertions(+), 32 deletions(-)

(limited to 'lib/API.hs')

diff --git a/lib/API.hs b/lib/API.hs
index 99e96ae..9016524 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,15 +1,17 @@
 {-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE TypeOperators     #-}
 
 -- | 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, AdminAPI) where
+module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..)) where
 
 import           Data.Map                    (Map)
 import           Data.Proxy                  (Proxy (..))
-import           Data.Swagger                (Swagger)
+import           Data.Swagger                (Swagger, ToSchema (..),
+                                              genericDeclareNamedSchema)
 import           Data.Swagger.ParamSchema    (ToParamSchema (..))
 import           Data.Text                   (Text)
 import           Data.Time                   (Day, UTCTime)
@@ -25,12 +27,22 @@ import           Servant.GTFS.Realtime       (Proto)
 import           Servant.Swagger             (HasSwagger (..))
 import           Web.Internal.FormUrlEncoded (Form)
 
+import           Data.Aeson                  (FromJSON (..), genericParseJSON)
+import           GHC.Generics                (Generic)
 import           GTFS
 import           GTFS.Realtime.FeedEntity
 import           GTFS.Realtime.FeedMessage   (FeedMessage)
 import           Persist
 import           Server.ControlRoom
 
+data RegisterJson = RegisterJson
+  { registerAgent :: Text }
+  deriving (Show, Generic)
+
+instance FromJSON RegisterJson where
+  parseJSON = genericParseJSON (aesonOptions "register")
+instance ToSchema RegisterJson where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
 
 -- | The server's API (as it is actually intended).
 type API = "stations" :> Get '[JSON] (Map StationID Station)
@@ -38,52 +50,31 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
   :<|> "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
+  :<|> "train" :> "register" :> Capture "Trip ID" TripID :> ReqBody '[JSON] RegisterJson :> Post '[JSON] Token
   -- TODO: perhaps a websocket instead?
-  :<|> "train" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] NoContent
+  :<|> "train" :> "ping" :> ReqBody '[JSON] TrainPing :> Post '[JSON] NoContent
   :<|> "train" :> "ping" :> "ws" :> WebSocket
   -- debug things
-  :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
+  :<|> "debug" :> "pings" :> Get '[JSON] (Map Token [TrainPing])
+  :<|> "debug" :> "pings" :> Capture "Trip ID" TripID :> Capture "day" Day :> Get '[JSON] [TrainPing]
+  :<|> "debug" :> "register" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] Token
   :<|> "gtfs" :> GtfsRealtimeAPI
-  -- TODO: this should be behind auth / OpenID or something
-  :<|> "admin" :> AdminAPI
 
 -- | The API used for publishing gtfs realtime updates
 type GtfsRealtimeAPI = "servicealerts" :> Get '[Proto] FeedMessage
   :<|> "tripupdates" :> Get '[Proto] FeedMessage
   :<|> "vehiclepositions" :> Get '[Proto] FeedMessage
 
--- | Admin API used for short-term timetable changes etc. ("leitstelle")
-type AdminAPI =
-  "trip" :> "announce" :> ReqBody '[JSON] Announcement :> Post '[JSON] UUID
-  :<|> "trip" :> "announce" :> "delete" :> Capture "Announcement ID" UUID :> Post '[JSON] NoContent
-  :<|> "trip" :> "date" :> "add" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent
-  :<|> "trip" :> "date" :> "cancel" :> Capture "Trip ID" TripID :> Capture "day" Day :> Post '[JSON] NoContent
--- 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] NoContent
-
 
 -- | The server's API with an additional debug route for accessing the specification
 -- itself. Split from API to prevent the API documenting the format in which it is
 -- documented, which would be silly and way to verbose.
-type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
-  :<|> API
-  :<|> "cr" :> Raw
+type CompleteAPI =
+  "api" :> "openapi" :> Get '[JSON] Swagger
+  :<|> "api" :> API
+  :<|> Raw -- hook for yesod frontend
 
 
 -- TODO write something useful here! (and if it's just "hey this is some websocket thingie")
 instance HasSwagger WebSocket where
   toSwagger _ = toSwagger (Proxy @(Post '[JSON] NoContent))
-{-
-TODO:
-there should be a basic API allowing the questions:
- - what are the next trips leaving from $station? (or $geolocation?)
- - all stops of a given tripID
-
-then the "ingress" API:
- - train ping (location, estimated delay, etc.)
- - cancel trip
- - add trip?
-
--}
-- 
cgit v1.2.3