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,40 +330,14 @@ 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
-    normalizeCookies :: Wai.Middleware
+    makeLogWare = do
-    normalizeCookies app req respond = app req $ \res -> do
-        resHdrs' <- go $ Wai.responseHeaders res
-        respond $ Wai.mapResponseHeaders (const resHdrs') res
-      where parseSetCookie' :: ByteString -> IO (Maybe SetCookie)
-            parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
-              
-            go [] = return []
-            go (hdr@(hdrName, hdrValue) : hdrs)
-              | hdrName == hSetCookie = do
-                  mcookieHdr <- parseSetCookie' hdrValue
-                  case mcookieHdr of
-                    Nothing -> (hdr :) <$> go hdrs
-                    Just cookieHdr -> do
-                      let cookieHdrMatches hdrValue' = maybeT (return False) $ do
-                            cookieHdr' <- MaybeT $ parseSetCookie' hdrValue'
-                            -- See https://tools.ietf.org/html/rfc6265
-                            guard $ setCookiePath     cookieHdr' == setCookiePath     cookieHdr
-                            guard $ setCookieName     cookieHdr' == setCookieName     cookieHdr
-                            guard $ setCookieDomain   cookieHdr' == setCookieDomain   cookieHdr
-                            return True
-                      others <- filterM (\(hdrName', hdrValue') -> and2M (pure $ hdrName' == hSetCookie) (cookieHdrMatches hdrValue')) hdrs
-                      if | null others -> (hdr :) <$> go hdrs
-                         | otherwise   -> go hdrs
-              | otherwise = (hdr :) <$> go hdrs
-
-makeLogWare :: MonadIO m => UniWorX -> m Middleware
-makeLogWare app = do
       logWareMap <- liftIO $ newTVarIO HashMap.empty
 
       let
@@ -390,6 +364,34 @@ makeLogWare app = do
         logWare <- either mkLogWare return lookupRes
         logWare wai req fin
 
+    normalizeCookies :: Wai.Middleware
+    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)
+            parseSetCookie' = fmap (either (\(_ :: SomeException) -> Nothing) Just) . try . evaluate . force . parseSetCookie
+              
+            go [] = return []
+            go (hdr@(hdrName, hdrValue) : hdrs)
+              | hdrName == hSetCookie = do
+                  mcookieHdr <- parseSetCookie' hdrValue
+                  case mcookieHdr of
+                    Nothing -> (hdr :) <$> go hdrs
+                    Just cookieHdr -> do
+                      let cookieHdrMatches hdrValue' = maybeT (return False) $ do
+                            cookieHdr' <- MaybeT $ parseSetCookie' hdrValue'
+                            -- See https://tools.ietf.org/html/rfc6265
+                            guard $ setCookiePath     cookieHdr' == setCookiePath     cookieHdr
+                            guard $ setCookieName     cookieHdr' == setCookieName     cookieHdr
+                            guard $ setCookieDomain   cookieHdr' == setCookieDomain   cookieHdr
+                            return True
+                      others <- filterM (\(hdrName', hdrValue') -> and2M (pure $ hdrName' == hSetCookie) (cookieHdrMatches hdrValue')) hdrs
+                      if | null others -> (hdr :) <$> go hdrs
+                         | otherwise   -> go hdrs
+              | otherwise = (hdr :) <$> go hdrs
+
+
+
 -- | Warp settings for the given foundation value.
 warpSettings :: UniWorX -> Settings
 warpSettings foundation = defaultSettings

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.