diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 14 |
1 files changed, 6 insertions, 8 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 7a79aa8..f9bf36b 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -50,8 +50,8 @@ instance ToJSON TrainPing where type KnownTrips = TVar (Map Token [TrainPing]) -type API = "stations" :> Get '[JSON] (Vector Station) - :<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Vector (Trip Deep)) +type API = "stations" :> Get '[JSON] (Map StationID Station) + :<|> "timetable" :> Capture "Station ID" StationID :> 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? @@ -61,28 +61,26 @@ type API = "stations" :> Get '[JSON] (Vector Station) -- debug things :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TrainPing]) -server :: GTFS Deep -> KnownTrips -> Server API +server :: GTFS -> KnownTrips -> Server API server gtfs@GTFS{..} knownTrains = handleStations :<|> handleTimetable :<|> handleTrip :<|> handleRegister :<|> handleTrainPing :<|> handleDebugState where handleStations = pure stations handleTimetable station = do today <- liftIO getCurrentTime <&> utctDay pure $ tripsOnDay gtfs today - handleTrip trip = case tableLookup tripTripID trip trips of + handleTrip trip = case M.lookup trip trips of Just res -> pure res Nothing -> throwError err404 handleRegister tripID = liftIO $ do token <- UUID.nextRandom <&> Token atomically $ modifyTVar knownTrains (M.insert token []) pure token - handleTrainPing token ping = liftIO $ do - putStrLn "got train ping" - atomically $ do + handleTrainPing token ping = liftIO $ atomically $ do modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token) pure () handleDebugState = liftIO $ readTVarIO knownTrains -application :: GTFS Deep -> IO Application +application :: GTFS -> IO Application application gtfs = do knownTrips <- newTVarIO mempty pure $ serve (Proxy @API) $ server gtfs knownTrips |