generate OpenAPI docs

lots of lenses in this stuff :(

2 files changed, 170 insertions, 117 deletions

diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index 9ad01f1..a77a487 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -1,69 +1,80 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE KindSignatures #-}
-{-# LANGUAGE StandaloneKindSignatures #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE UndecidableInstances #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE LambdaCase                 #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE StandaloneKindSignatures   #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE UndecidableInstances       #-}
 
 
 module GTFS where
 
 
-import qualified Data.ByteString.Lazy as LB
-import qualified Data.ByteString as BS
-import qualified Data.Csv as CSV
-import Data.Csv ((.:))
-import qualified Codec.Archive.Zip as Zip
-import qualified Data.Vector as V
-import Data.Vector (Vector)
-import Text.Regex.TDFA ( (=~) )
-import Data.Text (Text)
-import Fmt ( (+|), (|+) )
-import Data.Kind (Type)
-import Data.Maybe (fromMaybe, fromJust)
-import Data.Functor ((<&>))
+import qualified Codec.Archive.Zip              as Zip
+import           Data.Aeson                     (FromJSON,
+                                                 Options (fieldLabelModifier),
+                                                 ToJSON, defaultOptions,
+                                                 genericParseJSON,
+                                                 genericToJSON)
+import qualified Data.Aeson                     as A
+import qualified Data.ByteString                as BS
+import qualified Data.ByteString.Lazy           as LB
+import           Data.Csv                       ((.:))
+import qualified Data.Csv                       as CSV
+import           Data.Functor                   ((<&>))
+import           Data.Kind                      (Type)
+import           Data.Maybe                     (fromJust, fromMaybe)
+import           Data.Text                      (Text)
+import           Data.Time                      (UTCTime (utctDay), dayOfWeek,
+                                                 getCurrentTime)
+import           Data.Time.Calendar             (Day, DayOfWeek (..))
+import           Data.Time.Calendar.MonthDay    (monthAndDayToDayOfYearValid)
 import qualified Data.Time.Calendar.OrdinalDate as Day
-import Data.Time.Calendar (Day, DayOfWeek(..))
-import Data.Time.Calendar.MonthDay (monthAndDayToDayOfYearValid)
-import Data.Time (getCurrentTime, UTCTime (utctDay), dayOfWeek)
-import Data.Aeson
-    ( ToJSON,
-      FromJSON,
-      Options(fieldLabelModifier),
-      genericParseJSON,
-      genericToJSON,
-      defaultOptions )
-import qualified Data.Aeson as A
-import GHC.Generics (Generic)
+import           Data.Vector                    (Vector)
+import qualified Data.Vector                    as V
+import           Fmt                            ((+|), (|+))
+import           GHC.Generics                   (Generic)
+import           Text.Regex.TDFA                ((=~))
 -- import Data.Aeson.Generic (Options(fieldLabelModifier), deriveJSON, defaultOptions)
-import qualified Data.Text as T
-import Data.Char (toLower)
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Foldable (Foldable(fold))
+import           Control.Lens
+import           Data.Char                      (toLower)
+import           Data.Foldable                  (Foldable (fold))
+import           Data.Map                       (Map)
+import qualified Data.Map                       as M
+import           Data.Proxy                     (Proxy (Proxy))
+import           Data.Swagger                   (ParamSchema (..),
+                                                 SchemaOptions,
+                                                 ToSchema (declareNamedSchema),
+                                                 defaultSchemaOptions,
+                                                 genericDeclareNamedSchema)
+import qualified Data.Swagger                   as S
+import qualified Data.Text                      as T
 
 aesonOptions prefix =
   defaultOptions { fieldLabelModifier = fieldModifier (T.length prefix) }
   where fieldModifier n label = case drop n label of
          c:rest -> toLower c : rest
-         "" -> ""
+         ""     -> ""
+
+swaggerOptions :: Text -> SchemaOptions
+swaggerOptions prefix =
+  defaultSchemaOptions { S.fieldLabelModifier = fieldModifier (T.length prefix) }
+  where fieldModifier n label = case drop n label of
+         c:rest -> toLower c : rest
+         ""     -> ""
 
 newtype Time = Time { toSeconds :: Int }
   deriving newtype (ToJSON, FromJSON)
+  deriving (Generic)
 
 instance CSV.FromField Time where
   parseField f = do
@@ -72,7 +83,7 @@ instance CSV.FromField Time where
           :: (String, String, String, [String])
     case subs of
       [hh,mm,ss] -> pure $ Time $ read hh * 3600 + read mm * 60 + read ss
-      _ -> fail $ "encountered an invalid date: " <> text
+      _          -> fail $ "encountered an invalid date: " <> text
 
 instance Show Time where
   show (Time seconds) = ""
@@ -91,6 +102,10 @@ instance CSV.FromField Day where
         pure $ Day.fromOrdinalDate (read yyyy) dayOfYear
       _ -> fail $ "invalid date encountered: " <> show f
 
+instance ToSchema Time where
+  declareNamedSchema _ = do
+    dings <- declareNamedSchema (Proxy @Int)
+    pure $ (set (S.schema . S.description) (Just "Zeit in Sekunden seit Tagesanfang") dings)
 
 
 data Depth = Shallow | Deep
@@ -109,12 +124,14 @@ type ServiceID = Text
 
 -- | This is what's called a Stop in GTFS
 data Station = Station
-  { stationId :: StationID
+  { stationId   :: StationID
   , stationName :: Text
-  , stationLat :: Float
-  , stationLon :: Float
+  , stationLat  :: Float
+  , stationLon  :: Float
   } deriving (Show, Generic)
 
+instance ToSchema Station where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "station")
 instance FromJSON Station where
   parseJSON = genericParseJSON (aesonOptions "station")
 instance ToJSON Station where
@@ -123,11 +140,11 @@ instance ToJSON Station where
 
 -- | This is what's called a stop time in GTFS
 data Stop (deep :: Depth) = Stop
-  { stopTrip :: TripID
-  , stopArrival :: Time
+  { stopTrip      :: TripID
+  , stopArrival   :: Time
   , stopDeparture :: Time
-  , stopStation :: Switch deep Station StationID
-  , stopSequence :: Int
+  , stopStation   :: Switch deep Station StationID
+  , stopSequence  :: Int
   } deriving Generic
 
 deriving instance Show (Stop 'Shallow)
@@ -136,18 +153,20 @@ instance FromJSON (Switch a Station StationID) => FromJSON (Stop a) where
   parseJSON = genericParseJSON (aesonOptions "stop")
 instance ToJSON (Switch a Station StationID) => ToJSON (Stop a) where
   toJSON = genericToJSON (aesonOptions "stop")
+instance ToSchema (Stop Deep)where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "stop")
 
 data Calendar = Calendar
   { calServiceId :: Text
-  , calMonday :: Bool
-  , calTuesday :: Bool
+  , calMonday    :: Bool
+  , calTuesday   :: Bool
   , calWednesday :: Bool
-  , calThursday :: Bool
-  , calFriday :: Bool
-  , calSaturday :: Bool
-  , calSunday :: Bool
+  , calThursday  :: Bool
+  , calFriday    :: Bool
+  , calSaturday  :: Bool
+  , calSunday    :: Bool
   , calStartDate :: Day
-  , calEndDate :: Day
+  , calEndDate   :: Day
   } deriving (Show, Generic)
 
 
@@ -156,8 +175,8 @@ data CalendarExceptionType = ServiceAdded | ServiceRemoved
   deriving (Show, Eq, Generic, ToJSON, FromJSON)
 
 data CalendarDate = CalendarDate
-  { caldateServiceId :: Text
-  , caldateDate :: Day
+  { caldateServiceId     :: Text
+  , caldateDate          :: Day
   , caldateExceptionType :: CalendarExceptionType
   } deriving (Show, Generic)
 
@@ -167,17 +186,17 @@ instance ToJSON CalendarDate where
   toJSON = genericToJSON (aesonOptions "caldate")
 
 data Trip (deep :: Depth) = Trip
-  { tripRoute :: Text
-  , tripTripID :: TripID
-  , tripHeadsign :: Maybe Text
+  { tripRoute     :: Text
+  , tripTripID    :: TripID
+  , tripHeadsign  :: Maybe Text
   , tripShortName :: Maybe Text
   , tripDirection :: Maybe Bool
   -- NOTE: there's also block_id, which we're unlikely to ever need
   , tripServiceId :: Text
   -- , tripWheelchairAccessible :: Bool
   -- , tripBikesAllowed :: Bool
-  , tripShapeId :: Text
-  , tripStops :: Optional deep (Vector (Stop deep))
+  , tripShapeId   :: Text
+  , tripStops     :: Optional deep (Vector (Stop deep))
   } deriving Generic
 
 
@@ -187,6 +206,8 @@ instance FromJSON (Optional d (Vector (Stop d))) => FromJSON (Trip d) where
   parseJSON = genericParseJSON (aesonOptions "trip")
 instance ToJSON (Optional d (Vector (Stop d))) => ToJSON (Trip d) where
   toJSON = genericToJSON (aesonOptions "trip")
+instance ToSchema (Trip Deep) where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "trip")
 
 -- | helper function to find things in Vectors of things
 tableLookup :: Eq key => (a -> key) -> key -> Vector a -> Maybe a
@@ -261,18 +282,18 @@ instance CSV.FromNamedRecord (Trip Shallow) where
     <*> pure ()
 
 data RawGTFS = RawGTFS
-  { rawStations :: Vector Station
-  , rawStops :: Vector (Stop Shallow)
-  , rawTrips :: Vector (Trip Shallow)
-  , rawCalendar :: Maybe (Vector Calendar)
+  { rawStations      :: Vector Station
+  , rawStops         :: Vector (Stop Shallow)
+  , rawTrips         :: Vector (Trip Shallow)
+  , rawCalendar      :: Maybe (Vector Calendar)
   , rawCalendarDates :: Maybe (Vector CalendarDate)
   }
 
 
 data GTFS = GTFS
-  { stations :: Map StationID Station
-  , trips :: Map TripID (Trip Deep)
-  , calendar :: Map DayOfWeek (Vector Calendar)
+  { stations      :: Map StationID Station
+  , trips         :: Map TripID (Trip Deep)
+  , calendar      :: Map DayOfWeek (Vector Calendar)
   , calendarDates :: Map Day (Vector CalendarDate)
 
   , fancyCalendar :: Day -> (Vector ServiceID, Vector (Trip Deep))
@@ -301,7 +322,7 @@ loadRawGtfs path = do
       decodeTable' path zip =
         decodeTable path zip >>= \case
           Nothing -> fail $ "required file "+|path|+" not found in gtfs.zip"
-          Just a -> pure a
+          Just a  -> pure a
 
 loadGtfs :: FilePath -> IO GTFS
 loadGtfs path = do
diff --git a/lib/Server.hs b/lib/Server.hs
index f9bf36b..d22be59 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,44 +1,65 @@
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE TypeApplications #-}
-{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DeriveAnyClass             #-}
+{-# LANGUAGE DeriveGeneric              #-}
+{-# LANGUAGE DerivingStrategies         #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE DeriveGeneric #-}
-{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeOperators              #-}
+{-# LANGUAGE TypeSynonymInstances       #-}
 
 
 module Server where
-import Servant (type (:>), Server, serve, err404, throwError, FromHttpApiData (parseUrlPiece), Application)
-import Servant.API (Capture, Get, JSON, type (:<|>) ((:<|>)), FromHttpApiData, ReqBody, Post)
-
-import qualified Data.Map as M
-import Data.Map (Map)
-import Data.Functor ((<&>))
-import Data.Time (getCurrentTime, UTCTime (utctDay), dayOfWeek)
-import GTFS
-import Data.Proxy (Proxy(Proxy))
-import Data.Vector (Vector)
-import Control.Monad.IO.Class (MonadIO(liftIO))
-import Data.Text (Text)
-import qualified Data.UUID.V4 as UUID
-import qualified Data.UUID as UUID
-import Data.UUID (UUID)
-import Control.Concurrent.STM
-import Data.Aeson (ToJSON (toJSON), FromJSON (parseJSON), ToJSONKey, genericToJSON, genericParseJSON)
-import Servant.Server (Handler)
-import GHC.Generics (Generic)
-import GHC.Foreign (withCStringsLen)
+import           Servant                (Application,
+                                         FromHttpApiData (parseUrlPiece),
+                                         Server, err404, serve, throwError,
+                                         type (:>))
+import           Servant.API            (Capture, FromHttpApiData, Get, JSON,
+                                         Post, ReqBody, type (:<|>) ((:<|>)))
+import           Servant.Docs           (DocCapture (..), DocQueryParam (..),
+                                         ParamKind (..), ToCapture (..),
+                                         ToParam (..))
+
+import           Control.Concurrent.STM
+import           Control.Monad.IO.Class (MonadIO (liftIO))
+import           Data.Aeson             (FromJSON (parseJSON), ToJSON (toJSON),
+                                         ToJSONKey, genericParseJSON,
+                                         genericToJSON)
+import qualified Data.Aeson             as A
+import           Data.Functor           ((<&>))
+import           Data.Map               (Map)
+import qualified Data.Map               as M
+import           Data.Proxy             (Proxy (Proxy))
+import           Data.Swagger
+import           Data.Text              (Text)
+import           Data.Time              (UTCTime (utctDay), dayOfWeek,
+                                         getCurrentTime)
+import           Data.UUID              (UUID)
+import qualified Data.UUID              as UUID
+import qualified Data.UUID.V4           as UUID
+import           Data.Vector            (Vector)
+import           GHC.Foreign            (withCStringsLen)
+import           GHC.Generics           (Generic)
+import           GTFS
+import           Servant.Server         (Handler)
+import           Servant.Swagger        (toSwagger)
+
+
 
 newtype Token = Token UUID
   deriving newtype (Show, ToJSON, Eq, Ord, FromHttpApiData, ToJSONKey)
+instance ToSchema Token where
+  declareNamedSchema _ = declareNamedSchema (Proxy @String)
+instance ToParamSchema Token where
+  toParamSchema _ = toParamSchema (Proxy @String)
 
 -- TODO: perhaps wrap into server-side struct to add network delay stats?
 data TrainPing = TrainPing
-  { pingLat :: Float
-  , pingLong :: Float
-  , pingDelay :: Int
+  { pingLat       :: Float
+  , pingLong      :: Float
+  , pingDelay     :: Int
   , pingTimestamp :: Time
   } deriving (Generic)
 
@@ -46,7 +67,8 @@ instance FromJSON TrainPing where
   parseJSON = genericParseJSON (aesonOptions "ping")
 instance ToJSON TrainPing where
   toJSON = genericToJSON (aesonOptions "ping")
-
+instance ToSchema TrainPing where
+  declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
 
 type KnownTrips = TVar (Map Token [TrainPing])
 
@@ -55,14 +77,20 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
   :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep)
   -- ingress API (put this behind BasicAuth?)
   -- TODO: perhaps require a first ping for registration?
-  :<|> "trainregister" :> Capture "Trip ID" TripID :> Get '[JSON] Token
+  :<|> "trainregister" :> Capture "Trip ID" TripID :> Post '[JSON] Token
   -- TODO: perhaps a websocket instead?
   :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TrainPing :> Post '[JSON] ()
   -- debug things
   :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TrainPing])
+type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
+  :<|> API
+
+
 
-server :: GTFS -> KnownTrips -> Server API
-server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> handleTrip
+
+
+server :: GTFS -> KnownTrips -> Server CompleteAPI
+server gtfs@GTFS{..} knownTrains = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
   :<|> handleRegister :<|> handleTrainPing :<|> handleDebugState
   where handleStations = pure stations
         handleTimetable station = do
@@ -70,7 +98,7 @@ server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> hand
           pure $ tripsOnDay gtfs today
         handleTrip trip = case M.lookup trip trips of
           Just res -> pure res
-          Nothing -> throwError err404
+          Nothing  -> throwError err404
         handleRegister tripID = liftIO $ do
           token <- UUID.nextRandom <&> Token
           atomically $ modifyTVar knownTrains (M.insert token [])
@@ -79,11 +107,15 @@ server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> hand
             modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token)
             pure ()
         handleDebugState = liftIO $ readTVarIO knownTrains
+        handleDebugAPI = pure $ toSwagger (Proxy @API)
 
 application :: GTFS -> IO Application
 application gtfs = do
   knownTrips <- newTVarIO mempty
-  pure $ serve (Proxy @API) $ server gtfs knownTrips
+  pure $ serve (Proxy @CompleteAPI) $ server gtfs knownTrips
+
+
+
 
 {-
 TODO: