From add2aecf6ce4e219f3e4e2b6b731e84e64da51a9 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 27 Jun 2022 22:30:33 +0200
Subject: optional date parameter for the timetable endpoint

(mostly to make debugging easier, but also more generially useful i guess)
---
 lib/API.hs    | 35 +++++++++++++++++++++++------------
 lib/Server.hs | 12 ++++++++----
 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
-- 
cgit v1.2.3