aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/API.hs35
-rw-r--r--lib/Persist.hs85
-rw-r--r--lib/Server.hs199
3 files changed, 223 insertions, 96 deletions
diff --git a/lib/API.hs b/lib/API.hs
new file mode 100644
index 0000000..3fb4c3c
--- /dev/null
+++ b/lib/API.hs
@@ -0,0 +1,35 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+
+module API where
+
+import Data.Map (Map)
+import Data.Swagger (Swagger)
+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 (:<|>) ((:<|>)))
+
+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?
+ :<|> "trip" :> "register" :> Capture "Trip ID" TripID :> Post '[JSON] Token
+ -- TODO: perhaps a websocket instead?
+ :<|> "trip" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] ()
+ -- debug things
+ :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
+type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
+ :<|> API
diff --git a/lib/Persist.hs b/lib/Persist.hs
new file mode 100644
index 0000000..b4df1fb
--- /dev/null
+++ b/lib/Persist.hs
@@ -0,0 +1,85 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE GADTs #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE UndecidableInstances #-}
+
+
+module Persist where
+
+import Data.Aeson (FromJSON, ToJSON, ToJSONKey)
+import Data.Swagger (ToParamSchema (..), ToSchema (..),
+ genericDeclareNamedSchema)
+import Data.Text (Text)
+import Data.UUID (UUID)
+import Database.Persist
+import Database.Persist.Sql (PersistFieldSql,
+ runSqlPersistMPool)
+import Database.Persist.TH
+import GTFS
+import PersistOrphans
+import Servant (FromHttpApiData)
+
+import Conduit (ResourceT)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Logger (NoLoggingT)
+import Control.Monad.Reader (ReaderT)
+import Data.Data (Proxy (..))
+import Data.Pool (Pool)
+import Data.Time (NominalDiffTime,
+ UTCTime (utctDay), addUTCTime,
+ dayOfWeek, diffUTCTime,
+ getCurrentTime, nominalDay)
+import Database.Persist.Postgresql (SqlBackend)
+import GHC.Generics (Generic)
+import Web.PathPieces (PathPiece)
+
+
+
+newtype Token = Token UUID
+ deriving newtype
+ ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData
+ , ToJSONKey, PersistField, PersistFieldSql, PathPiece)
+instance ToSchema Token where
+ declareNamedSchema _ = declareNamedSchema (Proxy @String)
+instance ToParamSchema Token where
+ toParamSchema _ = toParamSchema (Proxy @String)
+
+
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+RunningTrip sql=tt_tracker_token
+ Id UUID default=uuid_generate_v4()
+ expires UTCTime
+ blocked Bool
+ tripNumber Text
+ deriving Eq Show Generic
+
+TripPing json sql=tt_trip_ping
+ token Token
+ latitude Double
+ longitude Double
+ delay Double
+ timestamp UTCTime
+ deriving Show Generic Eq
+
+|]
+
+instance ToSchema TripPing where
+ declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
+
+runSql :: MonadIO m => Pool SqlBackend -> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a) -> m a
+runSql pool = liftIO . flip runSqlPersistMPool pool
diff --git a/lib/Server.hs b/lib/Server.hs
index 1b79300..4a78735 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -6,11 +6,13 @@
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
@@ -18,115 +20,120 @@
{-# LANGUAGE UndecidableInstances #-}
module Server where
-import Servant (Application,
- FromHttpApiData (parseUrlPiece),
- Server, err404, serve, throwError,
- type (:>))
-import Servant.API (Capture, FromHttpApiData, Get, JSON,
- Post, ReqBody, type (:<|>) ((:<|>)))
-import Servant.Docs (DocCapture (..), DocQueryParam (..),
- ParamKind (..), ToCapture (..),
- ToParam (..))
-
+import Conduit (MonadTrans (lift), ResourceT)
import Control.Concurrent.STM
-import Control.Monad.IO.Class (MonadIO (liftIO))
-import Data.Aeson (FromJSON (parseJSON), ToJSON (toJSON),
- ToJSONKey, genericParseJSON,
- genericToJSON)
-import qualified Data.Aeson as A
-import Data.Functor ((<&>))
-import Data.Map (Map)
-import qualified Data.Map as M
-import Data.Proxy (Proxy (Proxy))
-import Data.Swagger
-import Data.Text (Text)
-import Data.Time (UTCTime (utctDay), dayOfWeek,
- getCurrentTime)
-import Data.UUID (UUID)
-import qualified Data.UUID as UUID
-import qualified Data.UUID.V4 as UUID
-import Data.Vector (Vector)
+import Control.Monad (when)
+import Control.Monad.Extra (whenM)
+import Control.Monad.IO.Class (MonadIO (liftIO))
+import Control.Monad.Logger.CallStack (NoLoggingT)
+import Control.Monad.Reader (forM)
+import Control.Monad.Trans.Maybe (MaybeT (..))
+import Data.Aeson (FromJSON (parseJSON),
+ ToJSON (toJSON), ToJSONKey,
+ genericParseJSON,
+ genericToJSON)
+import qualified Data.Aeson as A
+import Data.Coerce (coerce)
+import Data.Functor ((<&>))
+import Data.Map (Map)
+import qualified Data.Map as M
+import Data.Pool (Pool)
+import Data.Proxy (Proxy (Proxy))
+import Data.Swagger hiding (get)
+import Data.Text (Text)
+import Data.Time (NominalDiffTime,
+ UTCTime (utctDay), addUTCTime,
+ dayOfWeek, diffUTCTime,
+ getCurrentTime, nominalDay)
+import Data.UUID (UUID)
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+import Data.Vector (Vector)
import Database.Persist
-import Database.Persist.TH
-import GHC.Foreign (withCStringsLen)
-import GHC.Generics (Generic)
+import Database.Persist.Postgresql
+import GHC.Generics (Generic)
import GTFS
-import PersistOrphans
-import Servant.Server (Handler)
-import Servant.Swagger (toSwagger)
-
-newtype Token = Token UUID
- deriving newtype (Show, ToJSON, Eq, Ord, FromHttpApiData, ToJSONKey)
-instance ToSchema Token where
- declareNamedSchema _ = declareNamedSchema (Proxy @String)
-instance ToParamSchema Token where
- toParamSchema _ = toParamSchema (Proxy @String)
-
-share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
-TripToken sql=tt_tracker_token
- Id UUID default=uuid_generate_v4()
- issued UTCTime
- blocked Bool
- tripNumber Text
- deriving Eq Show Generic
-
-TripPing json sql=tt_trip_ping
- token UUID
- latitude Double
- longitude Double
- delay Double
- timestamp UTCTime
- deriving Show Generic Eq
-
-|]
-
-
-instance ToSchema TripPing where
- declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
-
-type KnownTrips = TVar (Map Token [TripPing])
-
-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?
- :<|> "trainregister" :> Capture "Trip ID" TripID :> Post '[JSON] Token
- -- TODO: perhaps a websocket instead?
- :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TripPing :> Post '[JSON] ()
- -- debug things
- :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
-type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
- :<|> API
-
-
-
-
-
-server :: GTFS -> KnownTrips -> Server CompleteAPI
-server gtfs@GTFS{..} knownTrains = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
+import Servant (Application,
+ FromHttpApiData (parseUrlPiece),
+ Server, err401, err404, serve,
+ throwError, type (:>))
+import Servant.API (Capture, FromHttpApiData, Get,
+ JSON, Post, ReqBody,
+ type (:<|>) ((:<|>)))
+import Servant.Docs (DocCapture (..),
+ DocQueryParam (..),
+ ParamKind (..), ToCapture (..),
+ ToParam (..))
+import Servant.Server (Handler)
+import Servant.Swagger (toSwagger)
+import Web.PathPieces (PathPiece)
+
+import API
+import Persist
+
+application :: GTFS -> Pool SqlBackend -> IO Application
+application gtfs dbpool = do
+ doMigration dbpool
+ pure $ serve (Proxy @CompleteAPI) $ server gtfs dbpool
+
+
+
+-- databaseMigration :: ConnectionString -> IO ()
+doMigration pool = runSql pool $
+ -- TODO: before that, check if the uuid module is enabled
+ -- in sql: check if SELECT * FROM pg_extension WHERE extname = 'uuid-ossp';
+ -- returns an empty list
+ runMigration migrateAll
+
+server :: GTFS -> Pool SqlBackend -> Server CompleteAPI
+server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
:<|> handleRegister :<|> handleTripPing :<|> handleDebugState
where handleStations = pure stations
handleTimetable station = do
+ -- TODO: resolve "overlay" trips (perhaps just additional CalendarDates?)
today <- liftIO getCurrentTime <&> utctDay
pure $ tripsOnDay gtfs today
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
- handleTripPing token ping = liftIO $ atomically $ do
- modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token)
- pure ()
- handleDebugState = liftIO $ readTVarIO knownTrains
+ handleRegister tripID = do
+ expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
+ RunningTripKey uuid <- runSql dbpool $ insert (RunningTrip expires False tripID)
+ pure (Token uuid)
+ handleTripPing ping = do
+ checkTokenValid dbpool (tripPingToken ping)
+ -- TODO: are these always inserted in order?
+ runSql dbpool $ insert ping
+ pure ()
+ handleDebugState = do
+ now <- liftIO $ getCurrentTime
+ runSql dbpool $ do
+ running <- selectList [RunningTripBlocked ==. False, RunningTripExpires >=. now] []
+ pairs <- forM running $ \(Entity (RunningTripKey uuid) _) -> do
+ entities <- selectList [TripPingToken ==. Token uuid] []
+ pure (Token uuid, fmap entityVal entities)
+ pure (M.fromList pairs)
handleDebugAPI = pure $ toSwagger (Proxy @API)
-application :: GTFS -> IO Application
-application gtfs = do
- knownTrips <- newTVarIO mempty
- pure $ serve (Proxy @CompleteAPI) $ server gtfs knownTrips
+checkTokenValid :: Pool SqlBackend -> Token -> Handler ()
+checkTokenValid dbpool token = do
+ trip <- try $ runSql dbpool $ get (coerce token)
+ when (runningTripBlocked trip)
+ $ throwError err401
+ whenM (hasExpired (runningTripExpires trip))
+ $ throwError err401
+ where try m = m >>= \case
+ Just a -> pure a
+ Nothing -> throwError err404
+
+hasExpired :: MonadIO m => UTCTime -> m Bool
+hasExpired limit = do
+ now <- liftIO getCurrentTime
+ pure (now > limit)
+
+validityPeriod :: NominalDiffTime
+validityPeriod = nominalDay
+