diff options
Diffstat (limited to '')
| -rw-r--r-- | lib/Server.hs | 39 | ||||
| -rw-r--r-- | lib/Server/GTFS_RT.hs | 3 | ||||
| -rw-r--r-- | lib/Server/Util.hs | 13 |
3 files changed, 35 insertions, 20 deletions
diff --git a/lib/Server.hs b/lib/Server.hs index 8a6022c..e84be7d 100644 --- a/lib/Server.hs +++ b/lib/Server.hs @@ -1,22 +1,21 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE ExplicitNamespaces #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedLists #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE PartialTypeSignatures #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeApplications #-} -- Implementation of the API. This module is the main point of the program. module Server (application) where import Conduit (MonadTrans (lift), ResourceT) -import Control.Concurrent.STM import Control.Monad (forever, void, when) import Control.Monad.Extra (maybeM, whenM) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (NoLoggingT, logWarnN, - runStderrLoggingT) +import Control.Monad.Logger (NoLoggingT, logWarnN) import Control.Monad.Reader (forM) import Control.Monad.Trans.Maybe (MaybeT (..)) import Data.Aeson (FromJSON (parseJSON), @@ -58,18 +57,19 @@ import Servant.Docs (DocCapture (..), DocQueryParam (..), ParamKind (..), ToCapture (..), ToParam (..)) -import Servant.Server (Handler) +import Servant.Server (Handler, ServerT, hoistServer) import Servant.Swagger (toSwagger) import Web.PathPieces (PathPiece) import API import Persist import Server.GTFS_RT (gtfsRealtimeServer) +import Server.Util (Service, ServiceM, runService) application :: GTFS -> Pool SqlBackend -> IO Application application gtfs dbpool = do doMigration dbpool - pure $ serve (Proxy @CompleteAPI) $ server gtfs dbpool + pure $ serve (Proxy @CompleteAPI) $ hoistServer (Proxy @CompleteAPI) runService $ server gtfs dbpool -- databaseMigration :: ConnectionString -> IO () doMigration pool = runSql pool $ @@ -78,9 +78,10 @@ doMigration pool = runSql pool $ -- returns an empty list runMigration migrateAll -server :: GTFS -> Pool SqlBackend -> Server CompleteAPI +server :: GTFS -> Pool SqlBackend -> Service CompleteAPI server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip - :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|> gtfsRealtimeServer gtfs dbpool + :<|> handleRegister :<|> handleTripPing :<|> handleWS :<|> handleDebugState :<|> + gtfsRealtimeServer gtfs dbpool :<|> adminServer gtfs dbpool where handleStations = pure stations handleTimetable station maybeDay = do @@ -99,7 +100,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID Nothing) pure token handleTripPing ping = do - checkTokenValid dbpool (coerce $ tripPingToken ping) + lift $ checkTokenValid dbpool (coerce $ tripPingToken ping) -- TODO: are these always inserted in order? runSql dbpool $ insert ping pure NoContent @@ -109,11 +110,11 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime forever $ do msg <- liftIO $ WS.receiveData conn case A.eitherDecode msg of - Left err -> runStderrLoggingT $ do + Left err -> do logWarnN ("stray websocket message: "+|show msg|+" (could not decode: "+|err|+")") liftIO $ WS.sendClose conn (C8.pack err) Right ping -> do - checkTokenValid dbpool (coerce $ tripPingToken ping) + lift $ checkTokenValid dbpool (coerce $ tripPingToken ping) void $ runSql dbpool $ insert ping handleDebugState = do now <- liftIO getCurrentTime @@ -126,7 +127,7 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime handleDebugAPI = pure $ toSwagger (Proxy @API) -adminServer :: GTFS -> Pool SqlBackend -> Server AdminAPI +adminServer :: GTFS -> Pool SqlBackend -> Service AdminAPI adminServer gtfs dbpool = addAnnounce :<|> delAnnounce :<|> modTripDate Added Cancelled :<|> modTripDate Cancelled Added :<|> extraTrip diff --git a/lib/Server/GTFS_RT.hs b/lib/Server/GTFS_RT.hs index e2b23e0..85ea8cd 100644 --- a/lib/Server/GTFS_RT.hs +++ b/lib/Server/GTFS_RT.hs @@ -65,6 +65,7 @@ import Servant.API ((:<|>) (..)) import Servant.Server (Handler (Handler), Server) +import Server.Util (Service) uuidUtf8 :: UUID.UUID -> Utf8 uuidUtf8 = Utf8 . fromStrict . UUID.toASCIIBytes @@ -86,7 +87,7 @@ toStupidDate date = toUtf8 toStupidTime :: UTCTime -> Word64 toStupidTime = fromIntegral . systemSeconds . utcToSystemTime -gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Server GtfsRealtimeAPI +gtfsRealtimeServer :: GTFS -> Pool SqlBackend -> Service GtfsRealtimeAPI gtfsRealtimeServer gtfs dbpool = handleServiceAlerts :<|> handleTripUpdates :<|> handleVehiclePositions where handleServiceAlerts = runSql dbpool $ do -- TODO filter: only select current & future days diff --git a/lib/Server/Util.hs b/lib/Server/Util.hs new file mode 100644 index 0000000..45c2477 --- /dev/null +++ b/lib/Server/Util.hs @@ -0,0 +1,13 @@ + + +-- | mostly the monad the service runs in +module Server.Util (Service, ServiceM, runService) where + +import Control.Monad.Logger (LoggingT, runStderrLoggingT) +import Servant (Handler, ServerT) + +type ServiceM = LoggingT Handler +type Service api = ServerT api ServiceM + +runService :: ServiceM a -> Handler a +runService = runStderrLoggingT |