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 ++++++++++++++++++++-------------------
 1 file changed, 20 insertions(+), 19 deletions(-)

(limited to 'lib/Server.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
-- 
cgit v1.2.3