From b092808a65b16688546b4f4f021a84cc120f8a8a Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Mon, 6 Jun 2022 21:51:56 +0200
Subject: restructure GTFS types

unfortunately doesn't quite get rid of all the type family still
since it's just too useful … but does reduce it somewhat.

Also, maps are much easier for looking things up than vectors!
---
 lib/Server.hs | 14 ++++++--------
 1 file changed, 6 insertions(+), 8 deletions(-)

(limited to 'lib/Server.hs')

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
-- 
cgit v1.2.3