diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/API.hs | 9 | ||||
| -rw-r--r-- | lib/Server.hs | 27 |
2 files changed, 26 insertions, 10 deletions
@@ -14,7 +14,8 @@ import Data.Swagger (MimeList (MimeList), PathItem (_pathItemGet), Scheme (Wss), Swagger, ToSchema (..), _swaggerPaths, - genericDeclareNamedSchema) + genericDeclareNamedSchema, type_, + NamedSchema(..), SwaggerType (SwaggerObject)) import Data.Swagger.ParamSchema (ToParamSchema (..)) import Data.Text (Text) import Data.Time (Day, UTCTime) @@ -31,7 +32,7 @@ import Servant.Swagger (HasSwagger (..)) import Web.Internal.FormUrlEncoded (Form) import Control.Lens (At (at), (&), (?~)) -import Data.Aeson (FromJSON (..), genericParseJSON) +import Data.Aeson (FromJSON (..), genericParseJSON, Value) import Data.ByteString.Lazy (ByteString) import Data.HashMap.Strict.InsOrd (singleton) import GHC.Generics (Generic) @@ -50,10 +51,14 @@ instance FromJSON RegisterJson where parseJSON = genericParseJSON (aesonOptions "register") instance ToSchema RegisterJson where declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "register") +instance ToSchema Value where + declareNamedSchema _ = pure $ NamedSchema (Just "json") $ mempty + & type_ ?~ SwaggerObject -- | The server's API (as it is actually intended). type API = "stations" :> Get '[JSON] (Map StationID Station) :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep Deep)) + :<|> "timetable" :> "stops" :> Capture "Date" Day :> Get '[JSON] Value :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep Deep) -- ingress API (put this behind BasicAuth?) -- TODO: perhaps require a first ping for registration? diff --git a/lib/Server.hs b/lib/Server.hs index 8d81127..7fdfd71 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -7,6 +7,7 @@ {-# LANGUAGE PartialTypeSignatures #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} -- Implementation of the API. This module is the main point of the program. @@ -23,6 +24,7 @@ import Control.Monad.Logger (LoggingT, logWarnN) import Control.Monad.Reader (forM) import Control.Monad.Trans (lift) import qualified Data.Aeson as A +import Data.Aeson ((.=)) import qualified Data.ByteString.Char8 as C8 import Data.Coerce (coerce) import Data.Functor ((<&>)) @@ -85,7 +87,7 @@ doMigration pool = runSql pool $ server :: GTFS -> Metrics -> TVar (M.Map TripID [TQueue (Maybe TrainPing)]) -> Pool SqlBackend -> ServerConfig -> Service CompleteAPI server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI - :<|> (handleStations :<|> handleTimetable :<|> handleTrip + :<|> (handleStations :<|> handleTimetable :<|> handleTimetableStops :<|> handleTrip :<|> handleRegister :<|> handleTrainPing (throwError err401) :<|> handleWS :<|> handleSubscribe :<|> handleDebugState :<|> handleDebugTrain :<|> handleDebugRegister :<|> gtfsRealtimeServer gtfs dbpool) @@ -93,13 +95,22 @@ server gtfs@GTFS{..} Metrics{..} subscribers dbpool settings = handleDebugAPI :<|> serveDirectoryFileServer (serverConfigAssets settings) :<|> pure (unsafePerformIO (toWaiAppPlain (ControlRoom gtfs dbpool settings))) where handleStations = pure stations - handleTimetable station maybeDay = do - -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) - day <- liftIO $ maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) - pure - -- don't send stations ending at this station - . M.filter ((==) station . stationId . stopStation . V.last . tripStops) - $ tripsOnDay gtfs day + handleTimetable station maybeDay = + M.filter isLastStop . tripsOnDay gtfs <$> liftIO day + where isLastStop = (==) station . stationId . stopStation . V.last . tripStops + day = maybeM (getCurrentTime <&> utctDay) pure (pure maybeDay) + handleTimetableStops day = + pure . A.toJSON . fmap mkJson . M.elems $ tripsOnDay gtfs day + where mkJson :: Trip Deep Deep -> A.Value + mkJson Trip {..} = A.object + [ "trip" .= tripTripID + , "stops" .= fmap (\Stop{..} -> A.object + [ "departure" .= stopDeparture + , "station" .= stationId stopStation + , "lat" .= stationLat stopStation + , "lon" .= stationLon stopStation + ]) tripStops + ] handleTrip trip = case M.lookup trip trips of Just res -> pure res Nothing -> throwError err404 |