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
  , 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)

import qualified Data.Binary 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


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


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
                , Binary k
                )
             => AEAD.Key -> Proxy a -> k -> ByteString
memcachedKey (Saltine.encode -> kmacKey) p k = Binary.encode k
  & kmaclazy @(SHAKE256 256) (encodeUtf8 . tshow $ typeRep p) kmacKey
  & BA.convert

memcachedByGet :: forall a k m.
                  ( MonadHandler m, HandlerSite m ~ UniWorX
                  , Typeable a, Binary a
                  , Binary k
                  )
               => k -> m (Maybe a)
memcachedByGet k = runMaybeT $ 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"

  guard $ length encVal >= Saltine.secretBoxNonce + Saltine.secretBoxMac
  let (nonceBS, encrypted) = splitAt Saltine.secretBoxNonce encVal
  nonce <- hoistMaybe $ Saltine.decode nonceBS
  decrypted <- hoistMaybe $ AEAD.aeadOpen aeadKey nonce encrypted cKey

  $logDebugS "memcached" "Decryption valid"

  case Binary.decodeOrFail $ fromStrict decrypted of
    Right (unconsumed, _, v)
      | null unconsumed -> do
          $logDebugS "memcached" "Deserialization valid"
          return v
    _other -> mzero

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 k v = do
  mExp' <- for mExp $ \exp -> maybe (throwM $ MemcachedInvalidExpiry exp) return $ exp ^? _MemcachedExpiry
  mConn <- getsYesod appMemcached
  for_ mConn $ \(aeadKey, conn) -> do
    nonce <- liftIO AEAD.newNonce
    let cKey = memcachedKey aeadKey (Proxy @a) k
        encVal = Saltine.encode nonce <> AEAD.aead aeadKey nonce (toStrict $ Binary.encode v) cKey
    liftIO $ Memcached.set zeroBits (fromMaybe zeroBits mExp') cKey (fromStrict encVal) conn
    $logDebugS "memcached" "Cache store"

memcachedByInvalidate :: forall a k m p.
                         ( MonadHandler m, HandlerSite m ~ UniWorX
                         , Typeable a
                         , Binary k
                         )
                      => k -> p a -> m ()
memcachedByInvalidate 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 a), a -> m ()) -> m a -> m a
memcachedWith (doGet, doSet) act = do
  pRes <- doGet
  maybe id (const . return) pRes $ do
    res <- act
    doSet res
    return res

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

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, memcachedBySet mExp k)


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 (flip const) 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 |]


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 |]