diff options
Diffstat (limited to 'lib/Persist.hs')
| -rw-r--r-- | lib/Persist.hs | 38 |
1 files changed, 30 insertions, 8 deletions
diff --git a/lib/Persist.hs b/lib/Persist.hs index 7613fd9..46e5ef4 100644 --- a/lib/Persist.hs +++ b/lib/Persist.hs @@ -21,13 +21,19 @@ import Database.Persist.Sql (PersistFieldSql (..), import Database.Persist.TH import qualified GTFS import PersistOrphans -import Servant (FromHttpApiData (..), +import Servant (FromHttpApiData (..), Handler, ToHttpApiData) -import Conduit (ResourceT) +import Conduit (MonadTrans (lift), MonadUnliftIO, + ResourceT, runResourceT) +import Config (LoggingConfig) import Control.Monad.IO.Class (MonadIO (liftIO)) -import Control.Monad.Logger (NoLoggingT) -import Control.Monad.Reader (ReaderT) +import Control.Monad.Logger (LoggingT, MonadLogger, NoLoggingT, + runNoLoggingT, runStderrLoggingT) +import Control.Monad.Reader (MonadReader (ask), + ReaderT (runReaderT), runReader) +import Control.Monad.Trans.Control (MonadBaseControl (liftBaseWith), + MonadTransControl (liftWith, restoreT)) import Data.Data (Proxy (..)) import Data.Map (Map) import Data.Pool (Pool) @@ -37,10 +43,11 @@ import Data.Time (NominalDiffTime, TimeOfDay, getCurrentTime, nominalDay) import Data.Time.Calendar (Day, DayOfWeek (..)) import Data.Vector (Vector) -import Database.Persist.Postgresql (SqlBackend) +import Database.Persist.Postgresql (SqlBackend, runSqlPool) import Fmt import GHC.Generics (Generic) import MultiLangText (MultiLangText) +import Server.Util (runLogging) import Web.PathPieces (PathPiece) import Yesod (Lang) @@ -120,6 +127,7 @@ Tracker sql=tt_tracker_token expires UTCTime blocked Bool agent Text + currentTicket TicketId Maybe deriving Eq Show Generic TrackerTicket @@ -130,7 +138,7 @@ TrackerTicket -- raw frames as received from OBUs TrainPing json sql=tt_trip_ping - ticket TicketId + -- ticket TicketId token TrackerId geopos Geopos timestamp UTCTime @@ -169,5 +177,19 @@ instance ToSchema TrainAnchor where instance ToSchema Announcement where declareNamedSchema = genericDeclareNamedSchema (GTFS.swaggerOptions "announcement") -runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a -runSql pool = liftIO . flip runSqlPersistMPool pool +runSqlWithoutLog :: MonadIO m + => Pool SqlBackend + -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a + -> m a +runSqlWithoutLog pool = liftIO . flip runSqlPersistMPool pool + +-- It's a bit unfortunate that we have an extra reader here for just the +-- logging config, but since Handler is not MonadUnliftIO there seems to be (?) +-- no better way than to nest logger monads … +runSql :: (MonadLogger m, MonadIO m, MonadReader LoggingConfig m) + => Pool SqlBackend + -> ReaderT SqlBackend (LoggingT (ResourceT IO)) a + -> m a +runSql pool x = do + conf <- ask + liftIO $ runResourceT $ runLogging conf $ runSqlPool x pool |