diff options
Diffstat (limited to 'lib/Server.hs')
| -rw-r--r-- | lib/Server.hs | 39 |
1 files changed, 20 insertions, 19 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 |