aboutsummaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Server.hs39
-rw-r--r--lib/Server/GTFS_RT.hs3
-rw-r--r--lib/Server/Util.hs13
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