aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat (limited to '')
-rw-r--r--lib/API.hs35
-rw-r--r--lib/Server.hs12
2 files changed, 31 insertions, 16 deletions
diff --git a/lib/API.hs b/lib/API.hs
index dc348d3..51c3690 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -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