diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/API.hs | 35 | ||||
| -rw-r--r-- | lib/Server.hs | 12 |
2 files changed, 31 insertions, 16 deletions
@@ -1,29 +1,36 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} -- | The sole authorative definition of this server's API, given as a Servant-style -- Haskell type. All other descriptions of the API are generated from this one. module API (API, CompleteAPI) where -import Data.Map (Map) -import Data.Swagger (Swagger) +import Data.Map (Map) +import Data.Proxy (Proxy (..)) +import Data.Swagger (Swagger) +import Data.Swagger.ParamSchema (ToParamSchema (..)) +import Data.Time (Day, UTCTime) import GTFS import Persist -import Servant (Application, FromHttpApiData (parseUrlPiece), - Server, err401, err404, serve, throwError, - type (:>)) -import Servant.API (Capture, FromHttpApiData, Get, JSON, Post, - ReqBody, type (:<|>) ((:<|>))) +import Servant (Application, + FromHttpApiData (parseUrlPiece), + Server, err401, err404, serve, + throwError, type (:>)) +import Servant.API (Capture, FromHttpApiData, Get, JSON, + Post, QueryParam, ReqBody, + type (:<|>) ((:<|>))) -- | The server's API (as it is actually intended). type API = "stations" :> Get '[JSON] (Map StationID Station) - :<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Map TripID (Trip Deep)) + :<|> "timetable" :> Capture "Station ID" StationID :> QueryParam "day" Day :> Get '[JSON] (Map TripID (Trip Deep)) :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep) -- ingress API (put this behind BasicAuth?) -- TODO: perhaps require a first ping for registration? - :<|> "trip" :> "register" :> Capture "Trip ID" TripID :> Post '[JSON] Token + :<|> "train" :> "register" :> Capture "Trip ID" TripID :> Post '[JSON] Token -- TODO: perhaps a websocket instead? - :<|> "trip" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] () + :<|> "train" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] () -- debug things :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing]) @@ -33,6 +40,10 @@ type API = "stations" :> Get '[JSON] (Map StationID Station) type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger :<|> API + +instance ToParamSchema (Maybe UTCTime) where + toParamSchema _ = toParamSchema (Proxy @UTCTime) + {- TODO: there should be a basic API allowing the questions: diff --git a/lib/Server.hs b/lib/Server.hs index 91f1f36..2375d2b 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -12,7 +12,7 @@ module Server (application) where import Conduit (MonadTrans (lift), ResourceT) import Control.Concurrent.STM import Control.Monad (when) -import Control.Monad.Extra (whenM) +import Control.Monad.Extra (whenM, maybeM) import Control.Monad.IO.Class (MonadIO (liftIO)) import Control.Monad.Logger.CallStack (NoLoggingT) import Control.Monad.Reader (forM) @@ -38,6 +38,7 @@ import Data.UUID (UUID) import qualified Data.UUID as UUID import qualified Data.UUID.V4 as UUID import Data.Vector (Vector) +import qualified Data.Vector as V import Database.Persist import Database.Persist.Postgresql import GHC.Generics (Generic) @@ -76,10 +77,13 @@ server :: GTFS -> Pool SqlBackend -> Server CompleteAPI server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip :<|> handleRegister :<|> handleTripPing :<|> handleDebugState where handleStations = pure stations - handleTimetable station = do + handleTimetable station maybeDay = do -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?) - today <- liftIO getCurrentTime <&> utctDay - pure $ tripsOnDay gtfs today + 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 handleTrip trip = case M.lookup trip trips of Just res -> pure res Nothing -> throwError err404 |