fix(serversession-backend-memcached): don't throw on deleteSession

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
+makeApplication foundation = liftIO $ makeMiddleware foundation <*> toWaiAppPlain foundation
-    logWare <- makeLogWare foundation
+
-    -- Create the WAI application and apply middlewares
+makeMiddleware :: MonadIO m => UniWorX -> m Middleware
-    appPlain <- toWaiAppPlain foundation
+makeMiddleware app = do
-    return . observeHTTPRequestLatency classifyHandler . logWare . normalizeCookies $ defaultMiddlewaresNoLogging appPlain
+  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

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
   

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

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.