1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
|
{-# 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 (toJSON), FromJSON (parseJSON), ToJSONKey, genericToJSON, genericParseJSON)
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)
instance FromJSON TrainPing where
parseJSON = genericParseJSON (aesonOptions "ping")
instance ToJSON TrainPing where
toJSON = genericToJSON (aesonOptions "ping")
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?
-}
|
