From b4f267ce14c753e952508e6313eec0ff9a99a879 Mon Sep 17 00:00:00 2001
From: stuebinm
Date: Sun, 3 Jul 2022 00:21:25 +0200
Subject: add service monad (with built-in logging)

---
 lib/Server.hs         | 39 ++++++++++++++++++++-------------------
 lib/Server/GTFS_RT.hs |  3 ++-
 lib/Server/Util.hs    | 13 +++++++++++++
 3 files changed, 35 insertions(+), 20 deletions(-)
 create mode 100644 lib/Server/Util.hs

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
-- 
cgit v1.2.3