diff options
Diffstat (limited to 'lib/Server.hs')
| -rw-r--r-- | lib/Server.hs | 106 |
1 files changed, 69 insertions, 37 deletions
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: |