effectful-data-cache-memcache (empty) → 0.2.1.0

raw patch · 7 files changed

+309/−0 lines, 7 filesdep +basedep +bytestringdep +clock

Dependencies added: base, bytestring, clock, effectful-core, effectful-data-cache, effectful-data-cache-memcache, hspec, memcache

Files

CHANGELOG.md +1/−0
LICENSE +26/−0
README.md +20/−0
effectful-data-cache-memcache.cabal +70/−0
src/Effectful/Cache/Memcache.hs +105/−0
test/Effectful/Cache/MemcacheSpec.hs +86/−0
test/Spec.hs +1/−0

+ CHANGELOG.md view

@@ -0,0 +1,1 @@+# Changelog

+ LICENSE view

@@ -0,0 +1,26 @@+Copyright 2026 drlkf++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1.  Redistributions of source code must retain the above copyright notice, this+    list of conditions and the following disclaimer.++2.  Redistributions in binary form must reproduce the above copyright notice,+    this list of conditions and the following disclaimer in the documentation+    and/or other materials provided with the distribution.++3.  Neither the name of the copyright holder nor the names of its contributors+    may be used to endorse or promote products derived from this software+    without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR+ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON+ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ README.md view

@@ -0,0 +1,20 @@+# effectful-data-cache-memcache++`runCacheMemcache` interprets `Cache` against memcached using the+[memcache](https://hackage.haskell.org/package/memcache) client.++```haskell+import Database.Memcache.Client (def, newClient)+import Effectful.Cache.Memcache++codec :: Codec String Int+codec = Codec BC.pack (BC.pack . show) (readMaybe . BC.unpack)++main = do+  c <- newClient [def] def+  runEff . runCacheMemcache codec c Nothing $ insert "key" (42 :: Int)+```++memcached cannot enumerate items: `keys`, `filterWithKey` and `size` throw+`MemcacheUnsupported`. `lookup'` behaves like `lookup` and `purgeExpired` is+a no-op. Expirations are rounded up to whole seconds.

+ effectful-data-cache-memcache.cabal view

@@ -0,0 +1,70 @@+cabal-version: 2.2++-- This file has been generated from package.yaml by hpack version 0.39.6.+--+-- see: https://github.com/sol/hpack++name:           effectful-data-cache-memcache+version:        0.2.1.0+synopsis:       memcached backend for effectful-data-cache+description:    Please see the README on GitHub at <https://github.com/haskell-github-trust/effectful-data-cache/tree/main/effectful-data-cache-memcache#readme>+category:       cache+homepage:       https://github.com/haskell-github-trust/effectful-data-cache#readme+bug-reports:    https://github.com/haskell-github-trust/effectful-data-cache/issues+author:         drlkf+maintainer:     drlkf <drlkf@drlkf.net>+copyright:      2026 drlkf+license:        BSD-3-Clause+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+extra-doc-files:+    CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/haskell-github-trust/effectful-data-cache++library+  exposed-modules:+      Effectful.Cache.Memcache+  other-modules:+      Paths_effectful_data_cache_memcache+  autogen-modules:+      Paths_effectful_data_cache_memcache+  hs-source-dirs:+      src+  ghc-options: -Wall -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints+  build-depends:+      base >=4.7 && <5+    , bytestring >=0.11 && <0.13+    , clock ==0.8.*+    , effectful-core >=2.3 && <3+    , effectful-data-cache ==0.2.*+    , memcache ==0.3.*+  default-language: Haskell2010++test-suite effectful-data-cache-memcache-test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      Effectful.Cache.MemcacheSpec+      Paths_effectful_data_cache_memcache+  autogen-modules:+      Paths_effectful_data_cache_memcache+  hs-source-dirs:+      test+  ghc-options: -Wall -Wextra -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-export-lists -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N+  build-tool-depends:+      hspec-discover:hspec-discover+  build-depends:+      base >=4.7 && <5+    , bytestring+    , clock+    , effectful-core+    , effectful-data-cache+    , effectful-data-cache-memcache+    , hspec+    , memcache+  default-language: Haskell2010

+ src/Effectful/Cache/Memcache.hs view

@@ -0,0 +1,105 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++-- | Interpret 'Cache' against a memcached server via "Database.Memcache.Client".+--+-- > c <- newClient [def] def+-- > runEff . runCacheMemcache codec c Nothing $ insert "a" (1 :: Int)+--+-- memcached cannot enumerate its items, so 'Keys', 'FilterWithKey' and 'Size'+-- throw 'MemcacheUnsupported'. Expired items are never returned, so 'Lookup''+-- behaves like 'Lookup', and 'PurgeExpired' is a no-op.+module Effectful.Cache.Memcache (+  Codec (..),+  MemcacheUnsupported (..),+  runCacheMemcache,+) where++import Control.Exception (Exception, throwIO)+import Control.Monad (void)+import Data.ByteString (ByteString)+import Data.IORef (IORef, newIORef, readIORef, writeIORef)+import Data.Word (Word32)+import qualified Database.Memcache.Client as M+import Effectful (Eff, IOE, MonadIO (liftIO), type (:>))+import Effectful.Cache (Cache (..))+import Effectful.Dispatch.Dynamic (interpret)+import System.Clock (Clock (Realtime), TimeSpec (..), getTime, toNanoSecs)++-- | How keys and values are stored. A value that fails to decode is a miss.+--+-- @since 0.1.0.0+data Codec k v = Codec+  { encodeKey :: k -> ByteString+  , encodeValue :: v -> ByteString+  , decodeValue :: ByteString -> Maybe v+  }++-- | Thrown by operations memcached has no equivalent for.+--+-- @since 0.1.0.0+newtype MemcacheUnsupported = MemcacheUnsupported String+  deriving Show++instance Exception MemcacheUnsupported++-- | Run against a memcached client with the given default expiration.+--+-- @since 0.1.0.0+runCacheMemcache+  :: forall k v es a+   . IOE :> es+  => Codec k v+  -> M.Client+  -> Maybe TimeSpec+  -> Eff (Cache k v : es) a+  -> Eff es a+runCacheMemcache codec c ts eff = do+  ref <- liftIO (newIORef ts)+  interpret (\_ op -> liftIO (withMemcache codec c ref op)) eff++withMemcache+  :: Codec k v+  -> M.Client+  -> IORef (Maybe TimeSpec)+  -> Cache k v m a+  -> IO a+withMemcache codec c ref = \case+  Insert k v -> readIORef ref >>= \ts -> set ts k v+  Insert' ts k v -> set ts k v+  Lookup k -> get k+  Lookup' k -> get k+  Keys -> unsupported "keys"+  Delete k -> del k+  FilterWithKey _ -> unsupported "filterWithKey"+  Purge -> M.flush c Nothing+  PurgeExpired -> pure ()+  Size -> unsupported "size"+  DefaultExpiration -> readIORef ref+  SetDefaultExpiration ts -> writeIORef ref ts+ where+  key = encodeKey codec+  get k = (>>= \(v, _, _) -> decodeValue codec v) <$> M.get c (key k)+  del k = void (M.delete c (key k) 0)+  set ts k v =+    expiration ts >>= \case+      Nothing -> del k+      Just e -> void (M.set c (key k) (encodeValue codec v) 0 e)+  unsupported op = throwIO (MemcacheUnsupported op)++-- | memcached expirations are whole seconds, 0 never expires, and values over+-- 30 days are unix timestamps. 'Nothing' means already expired.+expiration :: Maybe TimeSpec -> IO (Maybe Word32)+expiration Nothing = pure (Just 0)+expiration (Just ts)+  | secs <= 0 = pure Nothing+  | secs <= thirtyDays = pure (Just (fromInteger secs))+  | otherwise = Just . fromInteger . (+ secs) . toInteger . sec <$> getTime Realtime+ where+  secs = negate (toNanoSecs ts `div` negate 1_000_000_000)+  thirtyDays = 30 * 24 * 3600

+ test/Effectful/Cache/MemcacheSpec.hs view

@@ -0,0 +1,86 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NumericUnderscores #-}+{-# LANGUAGE TypeApplications #-}++module Effectful.Cache.MemcacheSpec (spec) where++import Control.Concurrent (threadDelay)+import Control.Exception (SomeException, try)+import qualified Data.ByteString.Char8 as BC+import qualified Database.Memcache.Client as M+import Effectful+import Effectful.Cache+import Effectful.Cache.Memcache+import System.Clock (TimeSpec (..))+import Test.Hspec+import Text.Read (readMaybe)+import Prelude hiding (lookup)++codec :: Codec String Int+codec = Codec BC.pack (BC.pack . show) (readMaybe . BC.unpack)++connect :: IO (Maybe M.Client)+connect = do+  c <- M.newClient [M.def] M.def+  r <- try @SomeException (M.version c)+  pure (c <$ either (const Nothing) Just r)++withClient :: (M.Client -> IO ()) -> Maybe M.Client -> IO ()+withClient _ Nothing = pendingWith "memcached not reachable on 127.0.0.1:11211"+withClient f (Just c) = M.flush c Nothing >> f c++run :: M.Client -> Maybe TimeSpec -> Eff '[Cache String Int, IOE] a -> IO a+run c ts = runEff . runCacheMemcache codec c ts++spec :: Spec+spec = beforeAll connect $ do+  it "looks up what it inserted" . withClient $ \c -> do+    r <- run c Nothing $ insert "a" (1 :: Int) >> lookup @String @Int "a"+    r `shouldBe` Just 1++  it "misses on an absent key" . withClient $ \c -> do+    r <- run c Nothing $ lookup @String @Int "nope"+    r `shouldBe` Nothing++  it "deletes" . withClient $ \c -> do+    r <- run c Nothing $ do+      insert "a" (1 :: Int)+      delete @String @Int "a"+      lookup @String @Int "a"+    r `shouldBe` Nothing++  it "purges" . withClient $ \c -> do+    r <- run c Nothing $ do+      insert "a" (1 :: Int)+      purge @String @Int+      lookup @String @Int "a"+    r `shouldBe` Nothing++  it "treats a non-positive expiration as already expired" . withClient $ \c -> do+    r <- run c Nothing $ do+      insert "a" (1 :: Int)+      insert' (Just (TimeSpec (-1) 0)) "a" (2 :: Int)+      lookup @String @Int "a"+    r `shouldBe` Nothing++  it "expires after the default expiration" . withClient $ \c -> do+    (d, r) <- run c (Just (TimeSpec 0 1)) $ do+      insert "a" (1 :: Int)+      liftIO (threadDelay 2_100_000)+      (,) <$> defaultExpiration @String @Int <*> lookup @String @Int "a"+    d `shouldBe` Just (TimeSpec 0 1)+    r `shouldBe` Nothing++  it "sets the default expiration" . withClient $ \c -> do+    d <- run c Nothing $ do+      setDefaultExpiration @String @Int (Just (TimeSpec 5 0))+      defaultExpiration @String @Int+    d `shouldBe` Just (TimeSpec 5 0)++  it "misses on an undecodable value" . withClient $ \c -> do+    _ <- M.set c (BC.pack "a") (BC.pack "junk") 0 0+    r <- run c Nothing $ lookup @String @Int "a"+    r `shouldBe` Nothing++  it "rejects keys" . withClient $ \c ->+    run c Nothing (keys @String @Int) `shouldThrow` \(MemcacheUnsupported _) -> True

+ test/Spec.hs view

@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}