diff --git a/src/Application.hs b/src/Application.hs index 20fc7bfc9..00bec22e9 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -5,7 +5,7 @@ module Application , appMain , develMain , makeFoundation - , makeLogWare + , makeMiddleware -- * for DevelMain , foundationStoreNum , getApplicationRepl @@ -330,14 +330,42 @@ createMemcached MemcachedConf{memcachedConnectInfo} = snd <$> allocate (Memcache -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and -- applying some additional middlewares. makeApplication :: MonadIO m => UniWorX -> m Application -makeApplication foundation = liftIO $ do - logWare <- makeLogWare foundation - -- Create the WAI application and apply middlewares - appPlain <- toWaiAppPlain foundation - return . observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies $ defaultMiddlewaresNoLogging appPlain +makeApplication foundation = liftIO $ makeMiddleware foundation <*> toWaiAppPlain foundation + +makeMiddleware :: MonadIO m => UniWorX -> m Middleware +makeMiddleware app = do + logWare <- makeLogWare + return $ observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies . defaultMiddlewaresNoLogging where + makeLogWare = do + logWareMap <- liftIO $ newTVarIO HashMap.empty + + let + mkLogWare ls@LogSettings{..} = do + logger <- readTVarIO . snd $ appLogger app + logWare <- mkRequestLogger def + { outputFormat = bool + (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader) + (Detailed True) + logDetailed + , destination = Logger $ loggerSet logger + } + atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare + return logWare + + void. liftIO $ + mkLogWare =<< readTVarIO (appLogSettings app) + + return $ \wai req fin -> do + lookupRes <- atomically $ do + ls <- readTVar $ appLogSettings app + existing <- HashMap.lookup ls <$> readTVar logWareMap + return $ maybe (Left ls) Right existing + logWare <- either mkLogWare return lookupRes + logWare wai req fin + normalizeCookies :: Wai.Middleware - normalizeCookies app req respond = app req $ \res -> do + normalizeCookies waiApp req respond = waiApp req $ \res -> do resHdrs' <- go $ Wai.responseHeaders res respond $ Wai.mapResponseHeaders (const resHdrs') res where parseSetCookie' :: ByteString -> IO (Maybe SetCookie) @@ -362,33 +390,7 @@ makeApplication foundation = liftIO $ do | otherwise -> go hdrs | otherwise = (hdr :) <$> go hdrs -makeLogWare :: MonadIO m => UniWorX -> m Middleware -makeLogWare app = do - logWareMap <- liftIO $ newTVarIO HashMap.empty - let - mkLogWare ls@LogSettings{..} = do - logger <- readTVarIO . snd $ appLogger app - logWare <- mkRequestLogger def - { outputFormat = bool - (Apache . bool FromSocket FromHeader $ app ^. _appIpFromHeader) - (Detailed True) - logDetailed - , destination = Logger $ loggerSet logger - } - atomically . modifyTVar' logWareMap $ HashMap.insert ls logWare - return logWare - - void. liftIO $ - mkLogWare =<< readTVarIO (appLogSettings app) - - return $ \wai req fin -> do - lookupRes <- atomically $ do - ls <- readTVar $ appLogSettings app - existing <- HashMap.lookup ls <$> readTVar logWareMap - return $ maybe (Left ls) Right existing - logWare <- either mkLogWare return lookupRes - logWare wai req fin -- | Warp settings for the given foundation value. warpSettings :: UniWorX -> Settings diff --git a/src/Utils/Sql.hs b/src/Utils/Sql.hs index 7ced39ddf..47f90a449 100644 --- a/src/Utils/Sql.hs +++ b/src/Utils/Sql.hs @@ -1,5 +1,5 @@ module Utils.Sql - ( setSerializable + ( setSerializable, setSerializable' ) where import ClassyPrelude.Yesod @@ -17,13 +17,13 @@ import Control.Lens ((&)) setSerializable :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => ReaderT SqlBackend m a -> ReaderT SqlBackend m a -setSerializable act = do +setSerializable = setSerializable' $ fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 + +setSerializable' :: forall m a. (MonadLogger m, MonadMask m, MonadIO m) => RetryPolicyM (ReaderT SqlBackend m) -> ReaderT SqlBackend m a -> ReaderT SqlBackend m a +setSerializable' policy act = do didCommit <- newTVarIO False recovering policy (skipAsyncExceptions `snoc` logRetries suggestRetry logRetry) $ act' didCommit where - policy :: RetryPolicyM (ReaderT SqlBackend m) - policy = fullJitterBackoff 1e3 & limitRetriesByCumulativeDelay 10e6 - suggestRetry :: SqlError -> ReaderT SqlBackend m Bool suggestRetry = return . isSerializationError diff --git a/src/Web/ServerSession/Backend/Persistent/Memcached.hs b/src/Web/ServerSession/Backend/Persistent/Memcached.hs index 3945fcd52..a10be734e 100644 --- a/src/Web/ServerSession/Backend/Persistent/Memcached.hs +++ b/src/Web/ServerSession/Backend/Persistent/Memcached.hs @@ -135,7 +135,7 @@ instance (IsSessionData sess, Binary (Decomposed sess)) => Storage (MemcachedSql where expiry = maybe 0 ceiling mcdSqlMemcachedExpiration deleteSession MemcachedSqlStorage{..} sessId - = liftIO $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached + = liftIO . handleIf Memcached.isKeyNotFound (const $ return ()) $ Memcached.delete (memcachedSqlSessionId # sessId) mcdSqlMemcached deleteAllSessionsOfAuthId MemcachedSqlStorage{..} authId = do now <- liftIO getCurrentTime diff --git a/test/TestImport.hs b/test/TestImport.hs index 123e67a24..2e897248f 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -3,7 +3,7 @@ module TestImport , module X ) where -import Application (makeFoundation, makeLogWare, shutdownApp) +import Application (makeFoundation, makeMiddleware, shutdownApp) import ClassyPrelude as X hiding ( delete, deleteBy , Handler, Index @@ -90,7 +90,7 @@ withApp = around $ \act -> runResourceT $ do foundation <- makeFoundation settings wipeDB foundation runAppLoggingT foundation $ handleJobs foundation - logWare <- makeLogWare foundation + logWare <- makeMiddleware foundation lift $ act (foundation, logWare) `finally` shutdownApp foundation -- This function will truncate all of the tables in your database.