fradrive/src/Handler/Utils/Memcached.hs

module Handler.Utils.Memcached
  ( memcachedAvailable
  , memcached, memcachedBy
  , memcachedHere, memcachedByHere
  , memcachedSet, memcachedGet
  , memcachedInvalidate, memcachedByInvalidate
  , memcachedByGet, memcachedBySet
  , memcachedTimeout, memcachedTimeoutBy
  , memcachedTimeoutHere, memcachedTimeoutByHere
  , memcachedLimited, memcachedLimitedKey, memcachedLimitedBy, memcachedLimitedKeyBy
  , memcachedLimitedHere, memcachedLimitedKeyHere, memcachedLimitedByHere, memcachedLimitedKeyByHere
  , memcachedLimitedTimeout, memcachedLimitedKeyTimeout, memcachedLimitedTimeoutBy, memcachedLimitedKeyTimeoutBy
  , memcachedLimitedTimeoutHere, memcachedLimitedKeyTimeoutHere, memcachedLimitedTimeoutByHere, memcachedLimitedKeyTimeoutByHere
  , memcacheAuth, memcacheAuthHere
  , memcacheAuth', memcacheAuthHere'
  , memcacheAuthMax, memcacheAuthHereMax
  , Expiry
  , MemcachedException(..), AsyncTimeoutException(..)
  ) where

import Import.NoFoundation hiding (utc, exp)
import Foundation.Type


import qualified Database.Memcached.Binary.IO as Memcached
import Data.Bits (Bits(zeroBits), toIntegralSized)

import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixSecondsToUTCTime, getPOSIXTime, POSIXTime)

import qualified Data.Binary as Binary
import qualified Data.Binary.Put as Binary
import qualified Data.Binary.Get as Binary

import Crypto.Hash.Algorithms (SHAKE256)

import qualified Data.ByteArray as BA

import Language.Haskell.TH hiding (Type)

import Data.Typeable (typeRep)
import Type.Reflection (typeOf, TypeRep)
import qualified Type.Reflection as Refl (typeRep)
import Data.Type.Equality (TestEquality(..))

import qualified Data.HashMap.Strict as HashMap

import qualified Control.Concurrent.TokenBucket as Concurrent (TokenBucket, newTokenBucket, tokenBucketTryAlloc)

import System.IO.Unsafe (unsafePerformIO)

import Control.Concurrent.STM.Delay

import qualified Crypto.Saltine.Class as Saltine
import qualified Crypto.Saltine.Internal.ByteSizes as Saltine
import qualified Crypto.Saltine.Core.AEAD as AEAD

import qualified Control.Monad.State.Class as State

import qualified Data.ByteString.Lazy as Lazy (ByteString)


type Expiry = Either UTCTime DiffTime

_MemcachedExpiry :: Prism' Expiry Memcached.Expiry
_MemcachedExpiry = prism' fromExpiry toExpiry
  where toExpiry (Left utc)
          | posix > 2592000 = toIntegralSized posix
          | otherwise = Nothing
          where posix :: Integer
                posix = ceiling $ utcTimeToPOSIXSeconds utc
        toExpiry (Right dTime)
          | 0 < dTime
          , dTime <= 2592000
          = Just $ ceiling dTime
          | otherwise
          = Nothing

        fromExpiry n
          | n <= 2592000
          = Right $ fromIntegral n
          | otherwise
          = Left . posixSecondsToUTCTime $ fromIntegral n

data MemcachedValue = MemcachedValue
  { mNonce :: AEAD.Nonce
  , mExpiry :: Maybe POSIXTime
  , mCiphertext :: ByteString
  } deriving (Generic, Typeable)

putExpiry :: Maybe POSIXTime -> Binary.Put
putExpiry mExp = Binary.put $ fromMaybe 0 expEnc
  where
    expEnc :: Maybe Word64
    expEnc = mExp <&> \exp ->
      let expEnc' :: Integer
          expEnc' = ceiling exp
       in if | 0 < expEnc', expEnc' < fromIntegral (maxBound :: Word64)
               -> fromIntegral expEnc'
             | otherwise
               -> error "Expiry cannot be represented in 64 unsigned bits"

getExpiry :: Binary.Get (Maybe POSIXTime)
getExpiry = Binary.label "expiry" $ do
  mExpiry' <- Binary.get :: Binary.Get Word64
  return $ if
    | mExpiry' == 0 -> Nothing
    | otherwise     -> Just $ fromIntegral mExpiry'

putMemcachedValue :: MemcachedValue -> Binary.Put
putMemcachedValue MemcachedValue{..} = do
  Binary.putByteString $ Saltine.encode mNonce
  putExpiry mExpiry
  Binary.putByteString mCiphertext

getMemcachedValue :: Binary.Get MemcachedValue
getMemcachedValue = do
  Binary.lookAhead . Binary.label "length check" $ do
    void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac
  mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
  mExpiry <- getExpiry
  mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString
  return MemcachedValue{..}

getMemcachedValueNoExpiry :: Binary.Get MemcachedValue
getMemcachedValueNoExpiry = do
  Binary.lookAhead . Binary.label "length check" $ do
    void . Binary.getByteString $ Saltine.secretBoxNonce + 4 + Saltine.secretBoxMac
  mNonce <- Binary.label "nonce" $ Binary.getByteString Saltine.secretBoxNonce >>= hoistMaybe . Saltine.decode
  let mExpiry = Nothing
  mCiphertext <- Binary.label "ciphertext" $ toStrict <$> Binary.getRemainingLazyByteString
  return MemcachedValue{..}


memcachedAvailable :: ( MonadHandler m, HandlerSite m ~ UniWorX
                      )
                   => m Bool
memcachedAvailable = getsYesod $ is _Just . appMemcached


data MemcachedException = MemcachedException Memcached.MemcachedException
                        | MemcachedInvalidExpiry Expiry
  deriving (Show, Typeable)
  deriving anyclass (Exception)


memcachedKey :: Typeable a
             => AEAD.Key -> Proxy a -> Lazy.ByteString -> ByteString
memcachedKey (Saltine.encode -> kmacKey) p = BA.convert . kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey

memcachedAAD :: ByteString -> Maybe POSIXTime -> ByteString
memcachedAAD cKey mExpiry = toStrict . Binary.runPut $ do
  Binary.putByteString cKey
  putExpiry mExpiry

memcachedByGet :: forall a k m.
                  ( MonadHandler m, HandlerSite m ~ UniWorX
                  , Typeable a, Binary a
                  , Binary k
                  )
               => k -> m (Maybe a)
memcachedByGet (Binary.encode -> k) = runMaybeT $ requestCache <|> memcache
  where
    requestCache = MaybeT . cacheByGet $ toStrict k
    memcache = do
      (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
      let cKey = memcachedKey aeadKey (Proxy @a) k

      encVal <- fmap toStrict . hoist liftIO . catchMaybeT (Proxy @Memcached.MemcachedException) $ Memcached.get_ cKey conn

      $logDebugS "memcached" "Cache hit"

      let withExp doExp = do
            MemcachedValue{..} <- hoistMaybe . flip runGetMaybe encVal $ bool getMemcachedValueNoExpiry getMemcachedValue doExp
            $logDebugS "memcached" "Decode valid"
            for_ mExpiry $ \expiry -> do
              now <- liftIO getPOSIXTime
              guard $ expiry > now + clockLeniency
            $logDebugS "memcached" $ "Expiry valid: " <> tshow mExpiry
            let aad = memcachedAAD cKey mExpiry
            decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey mNonce mCiphertext aad

            $logDebugS "memcached" $ "Decryption valid " <> bool "without" "with" doExp <> " expiration"

            hoistMaybe $ runGetMaybe Binary.get decrypted

      withExp True <|> withExp False
      where
        runGetMaybe p (fromStrict -> bs) = case Binary.runGetOrFail p bs of
          Right (bs', _, x) | null bs' -> Just x
          _other -> Nothing
        clockLeniency :: NominalDiffTime
        clockLeniency = 2

memcachedBySet :: forall a k m.
                  ( MonadHandler m, HandlerSite m ~ UniWorX
                  , MonadThrow m
                  , Typeable a, Binary a
                  , Binary k
                  )
               => Maybe Expiry -> k -> a -> m ()
memcachedBySet mExp (Binary.encode -> k) v = do
  mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry
  mConn <- getsYesod appMemcached
  for_ mConn $ \(aeadKey, conn) -> do
    mNonce <- liftIO AEAD.newNonce
    mExpiry <- for mExp $ \case
      Left uTime -> return $ utcTimeToPOSIXSeconds uTime
      Right diff -> liftIO $ (+ realToFrac diff) <$> getPOSIXTime
    let cKey = memcachedKey aeadKey (Proxy @a) k
        aad = memcachedAAD cKey mExpiry
        mCiphertext = AEAD.aead aeadKey mNonce (toStrict $ Binary.encode v) aad
    liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (Binary.runPut $ putMemcachedValue MemcachedValue{..}) conn
    cacheBySet (toStrict k) v
    $logDebugS "memcached" $ "Cache store: " <> tshow mExpiry

memcachedByInvalidate :: forall a k m p.
                         ( MonadHandler m, HandlerSite m ~ UniWorX
                         , Typeable a
                         , Binary k
                         )
                      => k -> p a -> m ()
memcachedByInvalidate (Binary.encode -> k) _ = maybeT_ $ do
  (aeadKey, conn) <- MaybeT $ getsYesod appMemcached
  let cKey = memcachedKey aeadKey (Proxy @a) k
  hoist liftIO . catchIfMaybeT Memcached.isKeyNotFound $ Memcached.delete cKey conn


newtype MemcachedUnkeyed a = MemcachedUnkeyed { unMemcachedUnkeyed :: a }
  deriving (Typeable)
  deriving newtype (Eq, Ord, Show, Binary)

memcachedGet :: ( MonadHandler m, HandlerSite m ~ UniWorX
                , Typeable a, Binary a
                )
             => m (Maybe a)
memcachedGet = fmap unMemcachedUnkeyed <$> memcachedByGet ()

memcachedSet :: ( MonadHandler m, HandlerSite m ~ UniWorX
                , MonadThrow m
                , Typeable a, Binary a
                )
             => Maybe Expiry -> a -> m ()
memcachedSet mExp = memcachedBySet mExp () . MemcachedUnkeyed

memcachedInvalidate :: forall (a :: Type) m p.
                       ( MonadHandler m, HandlerSite m ~ UniWorX
                       , Typeable a
                       )
                    => p a -> m ()
memcachedInvalidate _ = memcachedByInvalidate () $ Proxy @(MemcachedUnkeyed a)


memcachedWith :: Monad m
              => (m (Maybe b), a -> m b) -> m a -> m b
memcachedWith (doGet, doSet) act = do
  pRes <- doGet
  maybe id (const . return) pRes $ do
    res <- act
    doSet res

memcached :: ( MonadHandler m, HandlerSite m ~ UniWorX
             , MonadThrow m
             , Typeable a, Binary a
             )
          => Maybe Expiry -> m a -> m a
memcached mExp = memcachedWith (memcachedGet, \x -> x <$ memcachedSet mExp x)

memcachedBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
               , MonadThrow m
               , Typeable a, Binary a
               , Binary k
               )
            => Maybe Expiry -> k -> m a -> m a
memcachedBy mExp k = memcachedWith (memcachedByGet k, \x -> x <$ memcachedBySet mExp k x)


newtype MemcachedUnkeyedLoc a = MemcachedUnkeyedLoc { unMemcachedUnkeyedLoc :: a }
  deriving (Typeable)
  deriving newtype (Eq, Ord, Show, Binary)

memcachedHere :: Q Exp
memcachedHere = do
  loc <- location
  [e| \mExp -> fmap unMemcachedUnkeyedLoc . memcachedBy mExp loc . fmap MemcachedUnkeyedLoc |]

newtype MemcachedKeyedLoc a = MemcachedKeyedLoc { unMemcachedKeyedLoc :: a }
  deriving (Typeable)
  deriving newtype (Eq, Ord, Show, Binary)

memcachedByHere :: Q Exp
memcachedByHere = do
  loc <- location
  [e| \mExp k -> fmap unMemcachedKeyedLoc . memcachedBy mExp (loc, k) . fmap MemcachedKeyedLoc |]


data HashableDynamic = forall a. (Hashable a, Eq a) => HashableDynamic !(TypeRep a) !a

instance Hashable HashableDynamic where
  hashWithSalt s (HashableDynamic tRep v) = s `hashWithSalt` tRep `hashWithSalt` v
instance Eq HashableDynamic where
  (HashableDynamic tRep v) == (HashableDynamic tRep' v') = case testEquality tRep tRep' of
    Just Refl -> v == v'
    Nothing   -> False

hashableDynamic :: forall a.
                   ( Typeable a, Hashable a, Eq a )
                => a -> HashableDynamic
hashableDynamic v = HashableDynamic (typeOf v) v

memcachedLimit :: TVar (HashMap HashableDynamic Concurrent.TokenBucket)
memcachedLimit = unsafePerformIO . newTVarIO $ HashMap.empty
{-# NOINLINE memcachedLimit #-}

memcachedLimitedWith :: ( MonadIO m
                        , MonadLogger m
                        , Typeable k', Hashable k', Eq k'
                        )
                     => (m (Maybe a), a -> m ())
                     -> (m a -> MaybeT m a) -- ^ Wrap execution on cache miss
                     -> k' -- ^ Key for limiting
                     -> Word64 -- ^ burst-size (tokens)
                     -> Word64 -- ^ avg. inverse rate (usec/token)
                     -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                     -> m a
                     -> m (Maybe a)
memcachedLimitedWith (doGet, doSet) liftAct (hashableDynamic -> lK) burst rate tokens act = runMaybeT $ do
  pRes <- lift doGet
  maybe id (const . return) pRes $ do
    mBucket <- fmap (HashMap.lookup lK) . liftIO $ readTVarIO memcachedLimit
    bucket <- case mBucket of
      Just bucket -> return bucket
      Nothing -> liftIO $ do
        bucket <- Concurrent.newTokenBucket
        atomically $ do
          hm <- readTVar memcachedLimit
          let hm' = HashMap.insertWith (const id) lK bucket hm
          writeTVar memcachedLimit $! hm'
          return $ HashMap.lookupDefault (error "could not insert new token bucket") lK hm'
    sufficientTokens <- liftIO $ Concurrent.tokenBucketTryAlloc bucket burst rate tokens
    $logDebugS "memcachedLimitedWith" $ "Sufficient tokens: " <> tshow sufficientTokens
    guard sufficientTokens

    liftAct $ do
      res <- act
      doSet res
      return res

memcachedLimited :: forall a m.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadThrow m
                    , Typeable a, Binary a
                    )
                 => Word64 -- ^ burst-size (tokens)
                 -> Word64 -- ^ avg. inverse rate (usec/token)
                 -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                 -> Maybe Expiry
                 -> m a
                 -> m (Maybe a)
memcachedLimited burst rate tokens mExp = memcachedLimitedWith (memcachedGet, memcachedSet mExp) lift (Proxy @a) burst rate tokens

memcachedLimitedKey :: forall a k' m.
                       ( MonadHandler m, HandlerSite m ~ UniWorX
                       , MonadThrow m
                       , Typeable a, Binary a
                       , Typeable k', Hashable k', Eq k'
                       )
                    => k'
                    -> Word64 -- ^ burst-size (tokens)
                    -> Word64 -- ^ avg. inverse rate (usec/token)
                    -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                    -> Maybe Expiry
                    -> m a
                    -> m (Maybe a)
memcachedLimitedKey lK burst rate tokens mExp = memcachedLimitedWith (memcachedGet, memcachedSet mExp) lift lK burst rate tokens

memcachedLimitedBy :: forall a k m.
                     ( MonadHandler m, HandlerSite m ~ UniWorX
                      , MonadThrow m
                      , Typeable a, Binary a
                      , Binary k
                      )
                   => Word64 -- ^ burst-size (tokens)
                   -> Word64 -- ^ avg. inverse rate (usec/token)
                   -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                   -> Maybe Expiry
                   -> k
                   -> m a
                   -> m (Maybe a)
memcachedLimitedBy burst rate tokens mExp k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) lift (Proxy @a) burst rate tokens

memcachedLimitedKeyBy :: forall a k' k m.
                         ( MonadHandler m, HandlerSite m ~ UniWorX
                         , MonadThrow m
                         , Typeable a, Binary a
                         , Typeable k', Hashable k', Eq k'
                         , Binary k
                         )
                      => k'
                      -> Word64 -- ^ burst-size (tokens)
                      -> Word64 -- ^ avg. inverse rate (usec/token)
                      -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                      -> Maybe Expiry
                      -> k
                      -> m a
                      -> m (Maybe a)
memcachedLimitedKeyBy lK burst rate tokens mExp k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) lift lK burst rate tokens

memcachedLimitedHere :: Q Exp
memcachedLimitedHere = do
  loc <- location
  [e| \burst rate tokens mExp -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedBy burst rate tokens mExp loc . fmap MemcachedUnkeyedLoc |]

memcachedLimitedKeyHere :: Q Exp
memcachedLimitedKeyHere = do
  loc <- location
  [e| \lK burst rate tokens mExp -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedKeyBy lK burst rate tokens mExp loc . fmap MemcachedUnkeyedLoc |]

memcachedLimitedByHere :: Q Exp
memcachedLimitedByHere = do
  loc <- location
  [e| \burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedBy burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |]

memcachedLimitedKeyByHere :: Q Exp
memcachedLimitedKeyByHere = do
  loc <- location
  [e| \lK burst rate tokens mExp k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedKeyBy lK burst rate tokens mExp (loc, k) . fmap MemcachedKeyedLoc |]


memcacheAuth :: forall m k a.
                ( MonadHandler m, HandlerSite m ~ UniWorX
                , MonadThrow m
                , Typeable a, Binary a
                , Binary k
                )
             => k
             -> WriterT (Maybe (Min Expiry)) m a
             -> m a
memcacheAuth k mx = cachedByBinary k $ do
  mayCache <- getsYesod $ view _appMemcacheAuth
  if | mayCache
       -> memcachedWith
            ( memcachedByGet k
            , \(x, mExp) -> x <$ case mExp of
                Nothing        -> return ()
                Just (Min exp) -> memcachedBySet (Just exp) k x
            ) $ runWriterT mx
     | otherwise
       -> evalWriterT mx

memcacheAuth' :: forall m k a.
                 ( MonadHandler m, HandlerSite m ~ UniWorX
                 , MonadThrow m
                 , Typeable a, Binary a
                 , Binary k
                 )
              => Expiry
              -> k
              -> m a
              -> m a
memcacheAuth' exp k = memcacheAuth k . (<* tell (Just $ Min exp)) . lift
  
memcacheAuthMax :: forall m k a.
                   ( MonadHandler m, HandlerSite m ~ UniWorX
                   , MonadThrow m
                   , Typeable a, Binary a
                   , Binary k
                   )
                => Expiry
                -> k
                -> WriterT (Maybe (Min Expiry)) m a
                -> m a
memcacheAuthMax exp k = memcacheAuth k . (tell (Just $ Min exp) *>)

memcacheAuthHere :: Q Exp
memcacheAuthHere = do
  loc <- location
  [e| \k -> fmap unMemcachedKeyedLoc . memcacheAuth (loc, k) . fmap MemcachedKeyedLoc |]

memcacheAuthHere' :: Q Exp
memcacheAuthHere' = do
  loc <- location
  [e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuth' exp (loc, k) . fmap MemcachedKeyedLoc |]
  
memcacheAuthHereMax :: Q Exp
memcacheAuthHereMax = do
  loc <- location
  [e| \exp k -> fmap unMemcachedKeyedLoc . memcacheAuthMax exp (loc, k) . fmap MemcachedKeyedLoc |]



data AsyncTimeoutException = AsyncTimeoutReturnTypeDoesNotMatchComputationKey
  deriving (Show, Typeable)
  deriving anyclass (Exception)

data DynamicAsync = forall a. DynamicAsync !(TypeRep a) !(Async a)

instance Eq DynamicAsync where
  (DynamicAsync tRep v) == (DynamicAsync tRep' v') = case testEquality tRep tRep' of
    Just Refl -> v == v'
    Nothing   -> False

memcachedAsync :: TVar (HashMap HashableDynamic DynamicAsync)
memcachedAsync = unsafePerformIO . newTVarIO $ HashMap.empty
{-# NOINLINE memcachedAsync #-}

liftAsyncTimeout :: forall k'' a m.
                    ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadUnliftIO m
                    , MonadThrow m
                    , Typeable k'', Hashable k'', Eq k''
                    , Typeable a
                    )
                 => DiffTime
                 -> k''
                 -> m a -> MaybeT m a
liftAsyncTimeout dt (hashableDynamic -> cK) act = ifNotM memcachedAvailable (lift act) $ do
  delay <- liftIO . newDelay . round $ toRational dt * 1e6

  act' <- lift $ do
    existing <- traverse castDynamicAsync . HashMap.lookup cK <=< liftIO $ readTVarIO memcachedAsync
    case existing of
      Just act' -> return act'
      Nothing -> do
        startAct <- liftIO newEmptyTMVarIO
        act' <- async $ do
          $logDebugS "liftAsyncTimeout" "Waiting for confirmation..."
          atomically $ takeTMVar startAct
          $logDebugS "liftAsyncTimeout" "Confirmed."
          act
        act'' <- atomically $ do
          hm <- readTVar memcachedAsync
          let new = DynamicAsync (Refl.typeRep @a) act'
              go mOld = case mOld of
                Just old' -> do
                  old <- castDynamicAsync old'
                  resolved <- lift $ is _Just <$> pollSTM old

                  if | resolved -> return $ Just new
                     | otherwise -> do
                         State.put old
                         return $ Just old'
                Nothing -> return $ Just new

          (hm', act'') <- runStateT (HashMap.alterF go cK hm) act'
          writeTVar memcachedAsync $! hm'
          return act''
        if | act' == act'' -> atomically $ putTMVar startAct ()
           | otherwise     -> cancel act'
        return act''

  MaybeT . atomically $ (Nothing <$ waitDelay delay) <|> (Just <$> waitSTM act')
  where
    castDynamicAsync :: forall m'. MonadThrow m' => DynamicAsync -> m' (Async a)
    castDynamicAsync (DynamicAsync tRep v)
      | Just Refl <- testEquality tRep (Refl.typeRep @a)
      = return v
      | otherwise
      = throwM AsyncTimeoutReturnTypeDoesNotMatchComputationKey

memcachedTimeoutWith :: ( MonadHandler m, HandlerSite m ~ UniWorX
                        , MonadUnliftIO m
                        , MonadThrow m
                        , Typeable k'', Hashable k'', Eq k''
                        , Typeable a
                        )
                     => (m (Maybe a), a -> m ()) -> DiffTime -> k'' -> m a -> m (Maybe a)
memcachedTimeoutWith (doGet, doSet) dt cK act = runMaybeT $ do
  pRes <- lift doGet
  maybe id (const . return) pRes $
    liftAsyncTimeout dt cK $ do
      res <- act
      doSet res
      return res

memcachedTimeout :: ( MonadHandler m, HandlerSite m ~ UniWorX
                    , MonadThrow m
                    , MonadUnliftIO m
                    , Typeable k'', Hashable k'', Eq k''
                    , Typeable a, Binary a
                    )
                 => Maybe Expiry -> DiffTime -> k'' -> m a -> m (Maybe a)
memcachedTimeout mExp = memcachedTimeoutWith (memcachedGet, memcachedSet mExp)

memcachedTimeoutBy :: ( MonadHandler m, HandlerSite m ~ UniWorX
                      , MonadThrow m
                      , MonadUnliftIO m
                      , Typeable k'', Hashable k'', Eq k''
                      , Typeable a, Binary a
                      , Binary k
                      )
                   => Maybe Expiry -> DiffTime -> k'' -> k -> m a -> m (Maybe a)
memcachedTimeoutBy mExp dt cK k = memcachedTimeoutWith (memcachedByGet k, memcachedBySet mExp k) dt cK

memcachedTimeoutHere :: Q Exp
memcachedTimeoutHere = do
  loc <- location
  [e| \mExp dt cK -> fmap unMemcachedUnkeyedLoc . memcachedTimeoutBy mExp dt cK loc . fmap MemcachedUnkeyedLoc |]

memcachedTimeoutByHere :: Q Exp
memcachedTimeoutByHere = do
  loc <- location
  [e| \mExp dt cK k -> fmap unMemcachedKeyedLoc . memcachedBy mExp dt cK (loc, k) . fmap MemcachedKeyedLoc |]

memcachedLimitedTimeout :: forall a k'' m.
                           ( MonadHandler m, HandlerSite m ~ UniWorX
                           , MonadThrow m
                           , MonadUnliftIO m
                           , Typeable k'', Hashable k'', Eq k''
                           , Typeable a, Binary a
                           )
                        => Word64 -- ^ burst-size (tokens)
                        -> Word64 -- ^ avg. inverse rate (usec/token)
                        -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                        -> Maybe Expiry
                        -> DiffTime
                        -> k''
                        -> m a
                        -> m (Maybe a)
memcachedLimitedTimeout burst rate tokens mExp dt cK = memcachedLimitedWith (memcachedGet, memcachedSet mExp) (liftAsyncTimeout dt cK) (Proxy @a) burst rate tokens

memcachedLimitedKeyTimeout :: forall a k' k'' m.
                              ( MonadHandler m, HandlerSite m ~ UniWorX
                              , MonadThrow m
                              , MonadUnliftIO m
                              , Typeable k'', Hashable k'', Eq k''
                              , Typeable a, Binary a
                              , Typeable k', Hashable k', Eq k'
                              )
                           => k'
                           -> Word64 -- ^ burst-size (tokens)
                           -> Word64 -- ^ avg. inverse rate (usec/token)
                           -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                           -> Maybe Expiry
                           -> DiffTime
                           -> k''
                           -> m a
                           -> m (Maybe a)
memcachedLimitedKeyTimeout lK burst rate tokens mExp dt cK = memcachedLimitedWith (memcachedGet, memcachedSet mExp) (liftAsyncTimeout dt cK) lK burst rate tokens

memcachedLimitedTimeoutBy :: forall a k'' k m.
                             ( MonadHandler m, HandlerSite m ~ UniWorX
                             , MonadThrow m
                             , MonadUnliftIO m
                             , Typeable k'', Hashable k'', Eq k''
                             , Typeable a, Binary a
                             , Binary k
                             )
                          => Word64 -- ^ burst-size (tokens)
                          -> Word64 -- ^ avg. inverse rate (usec/token)
                          -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                          -> Maybe Expiry
                          -> DiffTime
                          -> k''
                          -> k
                          -> m a
                          -> m (Maybe a)
memcachedLimitedTimeoutBy burst rate tokens mExp dt cK k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) (liftAsyncTimeout dt cK) (Proxy @a) burst rate tokens

memcachedLimitedKeyTimeoutBy :: forall a k' k'' k m.
                                ( MonadHandler m, HandlerSite m ~ UniWorX
                                , MonadThrow m
                                , MonadUnliftIO m
                                , Typeable k'', Hashable k'', Eq k''
                                , Typeable a, Binary a
                                , Typeable k', Hashable k', Eq k'
                                , Binary k
                                )
                             => k'
                             -> Word64 -- ^ burst-size (tokens)
                             -> Word64 -- ^ avg. inverse rate (usec/token)
                             -> Word64 -- ^ tokens to allocate; corresponds to expected cost of operation to perform
                             -> Maybe Expiry
                             -> DiffTime
                             -> k''
                             -> k
                             -> m a
                             -> m (Maybe a)
memcachedLimitedKeyTimeoutBy lK burst rate tokens mExp dt cK k = memcachedLimitedWith (memcachedByGet k, memcachedBySet mExp k) (liftAsyncTimeout dt cK) lK burst rate tokens

memcachedLimitedTimeoutHere :: Q Exp
memcachedLimitedTimeoutHere = do
  loc <- location
  [e| \burst rate tokens mExp dt cK -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedTimeoutBy burst rate tokens mExp dt cK loc . fmap MemcachedUnkeyedLoc |]

memcachedLimitedKeyTimeoutHere :: Q Exp
memcachedLimitedKeyTimeoutHere = do
  loc <- location
  [e| \lK burst rate tokens mExp dt cK -> fmap (fmap unMemcachedUnkeyedLoc) . memcachedLimitedKeyTimeoutBy lK burst rate tokens mExp dt cK loc . fmap MemcachedUnkeyedLoc |]

memcachedLimitedTimeoutByHere :: Q Exp
memcachedLimitedTimeoutByHere = do
  loc <- location
  [e| \burst rate tokens mExp dt cK k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedTimeoutBy burst rate tokens mExp dt cK (loc, k) . fmap MemcachedKeyedLoc |]

memcachedLimitedKeyTimeoutByHere :: Q Exp
memcachedLimitedKeyTimeoutByHere = do
  loc <- location
  [e| \lK burst rate tokens mExp dt cK k -> fmap (fmap unMemcachedKeyedLoc) . memcachedLimitedKeyTimeoutBy lK burst rate tokens mExp dt cK (loc, k) . fmap MemcachedKeyedLoc |]