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 +++++++++++++++++++----
 1 file changed, 19 insertions(+), 4 deletions(-)

(limited to 'lib/API.hs')

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" ]
+        }
+      }
+    }
-- 
cgit v1.2.3