From 30324fc535b73e18f576bb12fe3a421d404c19ff Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 11 Sep 2022 00:50:43 +0200
Subject: correct the generated openapi description

---
 lib/API.hs     | 23 +++++++++++++++++++----
 lib/Persist.hs |  4 +++-
 2 files changed, 22 insertions(+), 5 deletions(-)

(limited to 'lib')

diff --git a/lib/API.hs b/lib/API.hs
index 4a72d6c..4c80535 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,7 +1,6 @@
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE TypeApplications  #-}
 {-# LANGUAGE TypeOperators     #-}
 
 -- | The sole authorative definition of this server's API, given as a Servant-style
@@ -10,7 +9,11 @@ module API (API, CompleteAPI, GtfsRealtimeAPI, RegisterJson(..)) where
 
 import           Data.Map                    (Map)
 import           Data.Proxy                  (Proxy (..))
-import           Data.Swagger                (Swagger, ToSchema (..),
+import           Data.Swagger                (MimeList (MimeList),
+                                              Operation (..),
+                                              PathItem (_pathItemGet),
+                                              Scheme (Wss), Swagger,
+                                              ToSchema (..), _swaggerPaths,
                                               genericDeclareNamedSchema)
 import           Data.Swagger.ParamSchema    (ToParamSchema (..))
 import           Data.Text                   (Text)
@@ -27,7 +30,9 @@ import           Servant.GTFS.Realtime       (Proto)
 import           Servant.Swagger             (HasSwagger (..))
 import           Web.Internal.FormUrlEncoded (Form)
 
+import           Control.Lens                (At (at), (&), (?~))
 import           Data.Aeson                  (FromJSON (..), genericParseJSON)
+import           Data.HashMap.Strict.InsOrd  (singleton)
 import           GHC.Generics                (Generic)
 import           GTFS
 import           GTFS.Realtime.FeedEntity
@@ -41,7 +46,7 @@ newtype RegisterJson = RegisterJson
 instance FromJSON RegisterJson where
   parseJSON = genericParseJSON (aesonOptions "register")
 instance ToSchema RegisterJson where
-  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register")
 
 -- | The server's API (as it is actually intended).
 type API = "stations" :> Get '[JSON] (Map StationID Station)
@@ -76,4 +81,14 @@ type CompleteAPI =
 
 -- 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))
+  toSwagger _ = mempty
+    { _swaggerPaths = singleton "/" $ mempty
+      { _pathItemGet = Just $ mempty
+        { _operationSummary = Just "this is a websocket endpoint!"
+        , _operationDescription = Just "this is a websocket endpoint meant for continious operations, e.g. sending many trainPings one after the other. Unfortunately OpenAPI 2.0 is not suitable to thoroughly model it (hence this text)."
+        , _operationSchemes = Just [ Wss ]
+        , _operationConsumes = Just $ MimeList [ "application/json" ]
+        , _operationProduces  = Just $ MimeList [ "application/json" ]
+        }
+      }
+    }
diff --git a/lib/Persist.hs b/lib/Persist.hs
index aa040cf..769db2a 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -87,7 +87,7 @@ TrainPing json sql=tt_trip_ping
   lat Double
   long Double
   timestamp UTCTime
-  deriving Show Generic Eq ToSchema
+  deriving Show Generic Eq
 
 -- status of a train somewhen in time (may be in the future),
 -- inferred from trainpings / entered via controlRoom
@@ -123,6 +123,8 @@ ScheduleAmendment json sql=tt_schedule_amendement
 
 instance ToSchema RunningId where
   declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
+instance ToSchema TrainPing where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trainPing")
 
 runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
 runSql pool = liftIO . flip runSqlPersistMPool pool
-- 
cgit v1.2.3