1 files changed, 96 insertions, 0 deletions
diff --git a/lib/Server.hs b/lib/Server.hs
new file mode 100644
index 0000000..0ad451d
--- /dev/null
+++ b/lib/Server.hs
@@ -0,0 +1,96 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveAnyClass #-}
+
+
+module Server where
+import Servant (type (:>), Server, serve, err404, throwError, FromHttpApiData (parseUrlPiece), Application)
+import Servant.API (Capture, Get, JSON, type (:<|>) ((:<|>)), FromHttpApiData, ReqBody, Post)
+
+import qualified Data.Map as M
+import Data.Map (Map)
+import Data.Functor ((<&>))
+import Data.Time (getCurrentTime, UTCTime (utctDay), dayOfWeek)
+import GTFS
+import Data.Proxy (Proxy(Proxy))
+import Data.Vector (Vector)
+import Control.Monad.IO.Class (MonadIO(liftIO))
+import Data.Text (Text)
+import qualified Data.UUID.V4 as UUID
+import qualified Data.UUID as UUID
+import Data.UUID (UUID)
+import Control.Concurrent.STM
+import Data.Aeson (ToJSON, FromJSON, ToJSONKey)
+import Servant.Server (Handler)
+import GHC.Generics (Generic)
+import GHC.Foreign (withCStringsLen)
+
+newtype Token = Token UUID
+  deriving newtype (Show, ToJSON, Eq, Ord, FromHttpApiData, ToJSONKey)
+
+-- TODO: perhaps wrap into server-side struct to add network delay stats?
+data TrainPing = TrainPing
+  { pingLat :: Float
+  , pingLong :: Float
+  , pingDelay :: Int
+  , pingTimestamp :: Time
+  } deriving (Generic, FromJSON, ToJSON)
+
+
+type KnownTrips = TVar (Map Token [TrainPing])
+
+type API = "stations" :> Get '[JSON] (Vector Station)
+  :<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Vector (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?
+  :<|> "trainregister" :> Capture "Trip ID" TripID :> Get '[JSON] Token
+  -- TODO: perhaps a websocket instead?
+  :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TrainPing :> Post '[JSON] ()
+  -- debug things
+  :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TrainPing])
+
+server :: GTFS Deep -> 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
+          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
+            modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token)
+            pure ()
+        handleDebugState = liftIO $ readTVarIO knownTrains
+
+application :: GTFS Deep -> IO Application
+application gtfs = do
+  knownTrips <- newTVarIO mempty
+  pure $ serve (Proxy @API) $ server gtfs knownTrips
+
+{-
+TODO:
+there should be a basic API allowing the questions:
+ - what are the next trips leaving from $station? (or $geolocation?)
+ - all stops of a given tripID
+
+then the "ingress" API:
+ - train ping (location, estimated delay, etc.)
+ - cancel trip
+ - add trip?
+
+-}