packages feed

freckle-memcached (empty) → 0.0.0.1

raw patch · 15 files changed

+1113/−0 lines, 15 filesdep +Blammodep +aesondep +annotated-exception

Dependencies added: Blammo, aeson, annotated-exception, base, bytestring, errors, exceptions, freckle-env, freckle-memcached, freckle-otel, hashable, hs-opentelemetry-sdk, hspec, hspec-core, hspec-expectations-lifted, lens, lens-aeson, memcache, mtl, network-uri, pureMD5, safe, serialise, text, unliftio, unordered-containers

Files

+ CHANGELOG.md view
@@ -0,0 +1,25 @@+## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-memcached-v0.0.0.1...main)++## [v0.0.0.1](https://github.com/freckle/freckle-app/compare/freckle-memcached-v0.0.0.0...freckle-memcached-v0.0.0.1)++Drop `relude` dependency++## [v0.0.0.0](https://github.com/freckle/freckle-app/tree/freckle-memcached-v0.0.0.0/freckle-memcached)++First release, sprouted from `freckle-app-1.19.0.0`.++A typeclass instance related to Yesod has been removed. To recover the original behavior,+you can add this instance:++```haskell+import Yesod.Core.Types (HandlerData, RunHandlerEnv, handlerEnv, rheSite)++instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where+  memcachedClientL = envL . siteL . memcachedClientL++envL :: Lens' (HandlerData child site) (RunHandlerEnv child site)+envL = lens handlerEnv $ \x y -> x {handlerEnv = y}++siteL :: Lens' (RunHandlerEnv child site) site+siteL = lens rheSite $ \x y -> x {rheSite = y}+```
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2022-2024 Renaissance Learning Inc++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,1 @@+# freckle-memcached
+ freckle-memcached.cabal view
@@ -0,0 +1,117 @@+cabal-version:      1.18+name:               freckle-memcached+version:            0.0.0.1+license:            MIT+license-file:       LICENSE+maintainer:         Freckle Education+homepage:           https://github.com/freckle/freckle-app#readme+bug-reports:        https://github.com/freckle/freckle-app/issues+synopsis:           ..+description:        Please see README.md+category:           Database+build-type:         Simple+extra-source-files: package.yaml+extra-doc-files:+    README.md+    CHANGELOG.md++source-repository head+    type:     git+    location: https://github.com/freckle/freckle-app++library+    exposed-modules:+        Freckle.App.Memcached+        Freckle.App.Memcached.CacheKey+        Freckle.App.Memcached.CacheTTL+        Freckle.App.Memcached.Client+        Freckle.App.Memcached.MD5+        Freckle.App.Memcached.Servers++    hs-source-dirs:     library+    other-modules:      Paths_freckle_memcached+    default-language:   GHC2021+    default-extensions:+        DataKinds DeriveAnyClass DerivingVia DerivingStrategies GADTs+        LambdaCase NoImplicitPrelude NoMonomorphismRestriction+        OverloadedStrings RecordWildCards TypeFamilies++    ghc-options:+        -fignore-optim-changes -fwrite-ide-info -Weverything+        -Wno-all-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-kind-signatures+        -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+        -Wno-monomorphism-restriction -Wno-prepositive-qualified-module+        -Wno-safe -Wno-unsafe++    build-depends:+        Blammo >=2.0.0.0,+        aeson >=2.0.3.0,+        annotated-exception >=0.2.0.4,+        base >=4.16.4.0 && <5,+        bytestring >=0.11.4.0,+        errors >=2.3.0,+        freckle-otel >=0.0.0.1,+        hashable >=1.4.2.0,+        hs-opentelemetry-sdk >=0.0.3.6,+        lens >=5.1.1,+        memcache >=0.3.0.1,+        mtl >=2.2.2,+        network-uri >=2.6.4.2,+        pureMD5 >=2.1.4,+        serialise >=0.2.6.0,+        text >=1.2.5.0,+        unliftio >=0.2.25.0,+        unordered-containers >=0.2.19.1++    if impl(ghc >=9.8)+        ghc-options:+            -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures++test-suite spec+    type:               exitcode-stdio-1.0+    main-is:            Main.hs+    hs-source-dirs:     tests+    other-modules:+        AppExample+        Freckle.App.Memcached.ServersSpec+        Freckle.App.MemcachedSpec+        Paths_freckle_memcached++    default-language:   GHC2021+    default-extensions:+        DataKinds DeriveAnyClass DerivingVia DerivingStrategies GADTs+        LambdaCase NoImplicitPrelude NoMonomorphismRestriction+        OverloadedStrings RecordWildCards TypeFamilies++    ghc-options:+        -fignore-optim-changes -fwrite-ide-info -Weverything+        -Wno-all-missed-specialisations -Wno-missing-exported-signatures+        -Wno-missing-import-lists -Wno-missing-kind-signatures+        -Wno-missing-local-signatures -Wno-missing-safe-haskell-mode+        -Wno-monomorphism-restriction -Wno-prepositive-qualified-module+        -Wno-safe -Wno-unsafe -threaded -rtsopts -with-rtsopts=-N++    build-depends:+        Blammo >=2.0.0.0,+        aeson >=2.0.3.0,+        base >=4.16.4.0 && <5,+        errors >=2.3.0,+        exceptions >=0.10.4,+        freckle-env >=0.0.1.1,+        freckle-memcached,+        hs-opentelemetry-sdk >=0.0.3.6,+        hspec >=2.10.10,+        hspec-core >=2.10.10,+        hspec-expectations-lifted >=0.10.0,+        lens >=5.1.1,+        lens-aeson >=1.2.2,+        memcache >=0.3.0.1,+        mtl >=2.2.2,+        safe >=0.3.19,+        text >=1.2.5.0,+        unliftio >=0.2.25.0++    if impl(ghc >=9.8)+        ghc-options:+            -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures
+ library/Freckle/App/Memcached.hs view
@@ -0,0 +1,185 @@+-- | App-level caching backed by Memcached+--+-- Usage:+--+-- 1. Have a Reader-like monad stack over some @App@+-- 2. Set up that @App@ with 'HasMemcachedClient'+-- 3. Give the value to cache a 'Cachable' instance+-- 4. Use 'caching'+--+-- To avoid 'Cachable', see 'cachingAs' and 'cachingAsJSON'.+module Freckle.App.Memcached+  ( Cachable (..)+  , caching+  , cachingAs+  , cachingAsJSON+  , cachingAsCBOR++    -- * Re-exports+  , module Freckle.App.Memcached.Client+  , module Freckle.App.Memcached.CacheKey+  , module Freckle.App.Memcached.CacheTTL+  , module Freckle.App.Memcached.MD5+  ) where++import Prelude++import Blammo.Logging+import Codec.Serialise (Serialise, deserialiseOrFail, serialise)+import Control.Exception.Annotated.UnliftIO+  ( AnnotatedException+  , throwWithCallStack+  )+import Control.Exception.Annotated.UnliftIO qualified as AnnotatedException+import Control.Monad.Reader (MonadReader)+import Data.Aeson+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import Data.ByteString.Lazy qualified as BSL+import Data.Text (Text)+import Data.Text.Encoding qualified as T+import Data.Text.Encoding.Error qualified as T+import Freckle.App.Memcached.CacheKey+import Freckle.App.Memcached.CacheTTL+import Freckle.App.Memcached.Client (HasMemcachedClient (..))+import Freckle.App.Memcached.Client qualified as Memcached+import Freckle.App.Memcached.MD5+import Freckle.App.OpenTelemetry+import GHC.Stack (HasCallStack, prettyCallStack)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception++class Cachable a where+  toCachable :: a -> ByteString+  fromCachable :: ByteString -> Either String a++instance Cachable ByteString where+  toCachable = id+  fromCachable = Right++instance Cachable BSL.ByteString where+  toCachable = BSL.toStrict+  fromCachable = Right . BSL.fromStrict++instance Cachable Text where+  toCachable = T.encodeUtf8+  fromCachable = Right . T.decodeUtf8With T.lenientDecode++data CachingError+  = CacheGetError SomeException+  | CacheSetError SomeException+  | CacheDeserializeError String+  deriving stock (Show)++instance Exception CachingError where+  displayException = \case+    CacheGetError ex -> "Unable to get: " <> displayException ex+    CacheSetError ex -> "Unable to set: " <> displayException ex+    CacheDeserializeError err -> "Unable to deserialize: " <> err++-- | Log any thrown 'CachingError's as warnings and return the given value+warnOnCachingError :: (MonadUnliftIO m, MonadLogger m) => a -> m a -> m a+warnOnCachingError val =+  flip catch $+    (val <$)+      . logWarnNS "caching"+      . annotatedExceptionMessage @CachingError++annotatedExceptionMessage :: Exception ex => AnnotatedException ex -> Message+annotatedExceptionMessage = annotatedExceptionMessageFrom $ const "Exception"++annotatedExceptionMessageFrom+  :: Exception ex => (ex -> Message) -> AnnotatedException ex -> Message+annotatedExceptionMessageFrom f ann = case f ex of+  msg :# series -> msg :# series <> ["error" .= errorObject]+ where+  ex = AnnotatedException.exception ann+  errorObject =+    object+      [ "message" .= displayException ex+      , "stack"+          .= (prettyCallStack <$> AnnotatedException.annotatedExceptionCallStack ann)+      ]++-- | Memoize an action using Memcached and 'Cachable'+caching+  :: ( MonadUnliftIO m+     , MonadLogger m+     , MonadTracer m+     , MonadReader env m+     , HasMemcachedClient env+     , Cachable a+     , HasCallStack+     )+  => CacheKey+  -> CacheTTL+  -> m a+  -> m a+caching = cachingAs fromCachable toCachable++-- | Like 'caching', but with explicit conversion functions+cachingAs+  :: ( MonadUnliftIO m+     , MonadLogger m+     , MonadTracer m+     , MonadReader env m+     , HasMemcachedClient env+     , HasCallStack+     )+  => (ByteString -> Either String a)+  -> (a -> ByteString)+  -> CacheKey+  -> CacheTTL+  -> m a+  -> m a+cachingAs from to key ttl f = do+  mCached <- warnOnCachingError Nothing $ traverse cacheDeserialize =<< cacheGet+  maybe store pure mCached+ where+  store = do+    a <- f+    a <$ warnOnCachingError () (cacheSet a)++  cacheGet = flip catch (throwWithCallStack . CacheGetError) $ Memcached.get key+  cacheSet a =+    flip catch (throwWithCallStack . CacheSetError) $ Memcached.set key (to a) ttl+  cacheDeserialize = either (throwWithCallStack . CacheDeserializeError) pure . from++-- | Like 'caching', but de/serializing the value as JSON+cachingAsJSON+  :: ( MonadUnliftIO m+     , MonadLogger m+     , MonadTracer m+     , MonadReader env m+     , HasMemcachedClient env+     , FromJSON a+     , ToJSON a+     , HasCallStack+     )+  => CacheKey+  -> CacheTTL+  -> m a+  -> m a+cachingAsJSON = cachingAs eitherDecodeStrict encodeStrict++-- | Cache data in memcached in CBOR format+cachingAsCBOR+  :: ( MonadUnliftIO m+     , MonadLogger m+     , MonadTracer m+     , MonadReader env m+     , HasMemcachedClient env+     , Serialise a+     , HasCallStack+     )+  => CacheKey+  -> CacheTTL+  -> m a+  -> m a+cachingAsCBOR =+  cachingAs+    (first show . deserialiseOrFail . BSL.fromStrict)+    (BSL.toStrict . serialise)++encodeStrict :: ToJSON a => a -> ByteString+encodeStrict = BSL.toStrict . encode
+ library/Freckle/App/Memcached/CacheKey.hs view
@@ -0,0 +1,55 @@+module Freckle.App.Memcached.CacheKey+  ( CacheKey+  , cacheKey+  , cacheKeyThrow+  , fromCacheKey+  ) where++import Prelude++import Control.Exception.Annotated.UnliftIO (throwWithCallStack)+import Control.Monad.IO.Class (MonadIO)+import Data.Char (isControl, isSpace)+import Data.Hashable (Hashable)+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Database.Memcache.Types (Key)+import GHC.Stack (HasCallStack)+import OpenTelemetry.Trace (ToAttribute (..))++newtype CacheKey = CacheKey Text+  deriving stock (Show)+  deriving newtype (Eq, Hashable)++unCacheKey :: CacheKey -> Text+unCacheKey (CacheKey x) = x++instance ToAttribute CacheKey where+  toAttribute = toAttribute . unCacheKey++-- | Build a 'CacheKey', ensuring it's valid for Memcached+--+-- <https://github.com/memcached/memcached/blob/master/doc/protocol.txt#L41>+--+-- @+-- Currently the length limit of a key is set at 250 characters (of course,+-- normally clients wouldn't need to use such long keys); the key must not+-- include control characters or whitespace.+-- @+cacheKey :: Text -> Either String CacheKey+cacheKey t+  | T.length t > 250 = invalid "Must be fewer than 250 characters"+  | T.any isControl t = invalid "Cannot contain control characters"+  | T.any isSpace t = invalid "Cannot contain whitespace"+  | otherwise = Right $ CacheKey t+ where+  invalid msg =+    Left $ "Not a valid memcached key:\n  " <> T.unpack t <> "\n\n" <> msg++-- | Build a 'CacheKey' and throw if invalid+cacheKeyThrow :: (MonadIO m, HasCallStack) => Text -> m CacheKey+cacheKeyThrow = either (throwWithCallStack . userError) pure . cacheKey++fromCacheKey :: CacheKey -> Key+fromCacheKey = T.encodeUtf8 . unCacheKey
+ library/Freckle/App/Memcached/CacheTTL.hs view
@@ -0,0 +1,39 @@+module Freckle.App.Memcached.CacheTTL+  ( CacheTTL+  , cacheTTL+  , fromCacheTTL+  , fiveMinuteTTL+  ) where++import Prelude++import Codec.Serialise (Serialise (..))+import Data.Word (Word32)+import Database.Memcache.Types (Expiration)+import OpenTelemetry.Trace (ToAttribute (..))++newtype CacheTTL = CacheTTL Int+  deriving stock (Show)+  deriving newtype (Eq, Ord, Enum, Num, Real, Integral, Serialise)++instance ToAttribute CacheTTL where+  toAttribute (CacheTTL x) = toAttribute x++cacheTTL :: Int -> CacheTTL+cacheTTL = CacheTTL++fromCacheTTL :: CacheTTL -> Expiration+fromCacheTTL (CacheTTL i)+  | i < fromIntegral minWord = minWord+  | i > fromIntegral maxWord = maxWord+  | otherwise = fromIntegral i+ where+  minWord :: Word32+  minWord = minBound++  maxWord :: Word32+  maxWord = maxBound++-- | Standard 5 minute time to live+fiveMinuteTTL :: CacheTTL+fiveMinuteTTL = cacheTTL $ 5 * 60
+ library/Freckle/App/Memcached/Client.hs view
@@ -0,0 +1,139 @@+module Freckle.App.Memcached.Client+  ( MemcachedClient (..)+  , newMemcachedClient+  , withMemcachedClient+  , memcachedClientDisabled+  , HasMemcachedClient (..)+  , get+  , set+  , delete+  ) where++import Prelude++import Control.Lens (Lens', view, _1)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Control.Monad.Reader (MonadReader)+import Data.Functor (void)+import Data.HashMap.Strict qualified as HashMap+import Database.Memcache.Client qualified as Memcache+import Database.Memcache.Types (Value, Version)+import Freckle.App.Memcached.CacheKey+import Freckle.App.Memcached.CacheTTL+import Freckle.App.Memcached.Servers+import Freckle.App.OpenTelemetry (byteStringToAttribute)+import OpenTelemetry.Trace (SpanKind (..), defaultSpanArguments)+import OpenTelemetry.Trace qualified as Trace+import OpenTelemetry.Trace.Monad+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (finally)++data MemcachedClient+  = MemcachedClient Memcache.Client+  | MemcachedClientDisabled++class HasMemcachedClient env where+  memcachedClientL :: Lens' env MemcachedClient++instance HasMemcachedClient MemcachedClient where+  memcachedClientL = id++newMemcachedClient :: MonadIO m => MemcachedServers -> m MemcachedClient+newMemcachedClient servers = case toServerSpecs servers of+  [] -> pure memcachedClientDisabled+  specs -> liftIO $ MemcachedClient <$> Memcache.newClient specs Memcache.def++withMemcachedClient+  :: MonadUnliftIO m => MemcachedServers -> (MemcachedClient -> m a) -> m a+withMemcachedClient servers f = do+  c <- newMemcachedClient servers+  f c `finally` quitClient c++memcachedClientDisabled :: MemcachedClient+memcachedClientDisabled = MemcachedClientDisabled++get+  :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env)+  => CacheKey+  -> m (Maybe Value)+get k = traced $ with $ \case+  MemcachedClient mc -> liftIO $ fmap (view _1) <$> Memcache.get mc (fromCacheKey k)+  MemcachedClientDisabled -> pure Nothing+ where+  traced =+    inSpan+      "cache.get"+      defaultSpanArguments+        { Trace.kind = Client+        , Trace.attributes =+            HashMap.fromList+              [ ("service.name", "memcached")+              , ("key", Trace.toAttribute k)+              ]+        }++-- | Set a value to expire in the given seconds+--+-- Pass @0@ to set a value that never expires.+set+  :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env)+  => CacheKey+  -> Value+  -> CacheTTL+  -> m ()+set k v expiration = traced $ with $ \case+  MemcachedClient mc ->+    void $+      liftIO $+        Memcache.set mc (fromCacheKey k) v 0 $+          fromCacheTTL+            expiration+  MemcachedClientDisabled -> pure ()+ where+  traced =+    inSpan+      "cache.set"+      defaultSpanArguments+        { Trace.kind = Client+        , Trace.attributes =+            HashMap.fromList+              [ ("service.name", "memcached")+              , ("key", Trace.toAttribute k)+              , ("value", byteStringToAttribute v)+              , ("expiration", Trace.toAttribute expiration)+              ]+        }++-- | Delete a key+delete+  :: (MonadUnliftIO m, MonadTracer m, MonadReader env m, HasMemcachedClient env)+  => CacheKey+  -> m ()+delete k = traced $ with $ \case+  MemcachedClient mc -> void $ liftIO $ Memcache.delete mc (fromCacheKey k) bypassCAS+  MemcachedClientDisabled -> pure ()+ where+  traced =+    inSpan+      "cache.delete"+      defaultSpanArguments+        { Trace.kind = Client+        , Trace.attributes = HashMap.fromList [("key", Trace.toAttribute k)]+        }++quitClient :: MonadIO m => MemcachedClient -> m ()+quitClient = \case+  MemcachedClient mc -> void $ liftIO $ Memcache.quit mc+  MemcachedClientDisabled -> pure ()++with+  :: (MonadReader env m, HasMemcachedClient env)+  => (MemcachedClient -> m a)+  -> m a+with f = do+  c <- view memcachedClientL+  f c++-- | The sentinal version @0@ means to not perform CAS checking+bypassCAS :: Version+bypassCAS = 0
+ library/Freckle/App/Memcached/MD5.hs view
@@ -0,0 +1,24 @@+module Freckle.App.Memcached.MD5+  ( md5CacheKey+  , md5Key+  , md5Text+  ) where++import Prelude++import Data.ByteString.Lazy qualified as BSL+import Data.Digest.Pure.MD5 qualified as Digest+import Data.Text (Text)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Freckle.App.Memcached.CacheKey++md5CacheKey :: Show a => a -> CacheKey+md5CacheKey = either (error "md5 is always cacheable") id . cacheKey . md5Key++-- | Pack any showable into an md5 encoded text+md5Key :: Show a => a -> Text+md5Key = md5Text . T.pack . show++md5Text :: Text -> Text+md5Text = T.pack . show . Digest.md5 . BSL.fromStrict . T.encodeUtf8
+ library/Freckle/App/Memcached/Servers.hs view
@@ -0,0 +1,113 @@+-- | Read a Memcached Servers value, to support ENV-based configuration+--+-- Format:+--+-- @+-- memcached://[user[:password]@]host][:port],...+-- @+--+-- Usage with "Freckle.App.Env":+--+-- @+-- -- Required+-- Env.var (Env.eitherReader readMemcachedServers <=< Env.nonempty) "MEMCACHED_SERVERS" mempty+--+-- -- Default to localhost:11211+-- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def defaultMemcachedServers)+--+-- -- Default to disabled+-- Env.var (Env.eitherReader readMemcachedServers) "MEMCACHED_SERVERS" (Env.def emptyMemcachedServers)+-- @+module Freckle.App.Memcached.Servers+  ( MemcachedServers (..)+  , defaultMemcachedServers+  , emptyMemcachedServers+  , readMemcachedServers+  , toServerSpecs+  ) where++import Prelude++import Control.Error.Util (note)+import Control.Monad (guard)+import Data.Bifunctor (second)+import Data.Maybe (fromMaybe)+import Data.Text qualified as T+import Data.Text.Encoding qualified as T+import Database.Memcache.Client qualified as Memcache+import Network.URI (URI (..), URIAuth (..), parseAbsoluteURI)++newtype MemcachedServers = MemcachedServers+  { unMemcachedServers :: [MemcachedServer]+  }++defaultMemcachedServers :: MemcachedServers+defaultMemcachedServers = MemcachedServers [defaultMemcachedServer]++emptyMemcachedServers :: MemcachedServers+emptyMemcachedServers = MemcachedServers []++readMemcachedServers :: String -> Either String MemcachedServers+readMemcachedServers =+  fmap MemcachedServers+    . traverse (readMemcachedServer . T.unpack)+    . filter (not . T.null)+    . map T.strip+    . T.splitOn ","+    . T.pack++toServerSpecs :: MemcachedServers -> [Memcache.ServerSpec]+toServerSpecs = map unMemcachedServer . unMemcachedServers++newtype MemcachedServer = MemcachedServer+  { unMemcachedServer :: Memcache.ServerSpec+  }++defaultMemcachedServer :: MemcachedServer+defaultMemcachedServer = MemcachedServer Memcache.def++readMemcachedServer :: String -> Either String MemcachedServer+readMemcachedServer s = do+  uri <- note ("Not a valid URI: " <> s) $ parseAbsoluteURI s+  note "Must begin memcached://" $ guard $ uriScheme uri == "memcached:"++  let mAuth = uriAuthority uri++  pure+    . MemcachedServer+    . maybe id setHost mAuth+    . maybe id setPort mAuth+    . maybe id setAuth (readAuthentication . uriUserInfo =<< mAuth)+    $ Memcache.def++readAuthentication :: String -> Maybe Memcache.Authentication+readAuthentication = go . T.pack+ where+  go a = do+    (u, p) <- second (T.drop 1) . T.breakOn ":" <$> T.stripSuffix "@" a++    guard $ not $ T.null u+    guard $ not $ T.null p++    pure+      Memcache.Auth+        { Memcache.username = T.encodeUtf8 u+        , Memcache.password = T.encodeUtf8 p+        }++setHost :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec+setHost auth ss = case uriRegName auth of+  "" -> ss+  rn -> ss {Memcache.ssHost = rn}++setPort :: URIAuth -> Memcache.ServerSpec -> Memcache.ServerSpec+setPort auth ss = fromMaybe ss $ do+  p <- case uriPort auth of+    "" -> Nothing+    (':' : p) -> Just p+    p -> Just p+  pure $ ss {Memcache.ssPort = p}++setAuth+  :: Memcache.Authentication -> Memcache.ServerSpec -> Memcache.ServerSpec+setAuth auth ss = ss {Memcache.ssAuth = auth}
+ package.yaml view
@@ -0,0 +1,98 @@+name: freckle-memcached+version: 0.0.0.1+maintainer: Freckle Education+category: Database+github: freckle/freckle-app+synopsis: ..+description: Please see README.md++extra-doc-files:+  - README.md+  - CHANGELOG.md++extra-source-files:+  - package.yaml++language: GHC2021++ghc-options:+  - -fignore-optim-changes+  - -fwrite-ide-info+  - -Weverything+  - -Wno-all-missed-specialisations+  - -Wno-missing-exported-signatures # re-enables missing-signatures+  - -Wno-missing-import-lists+  - -Wno-missing-kind-signatures+  - -Wno-missing-local-signatures+  - -Wno-missing-safe-haskell-mode+  - -Wno-monomorphism-restriction+  - -Wno-prepositive-qualified-module+  - -Wno-safe+  - -Wno-unsafe++when:+  - condition: "impl(ghc >= 9.8)"+    ghc-options:+      - -Wno-missing-role-annotations+      - -Wno-missing-poly-kind-signatures++dependencies:+  - base < 5++default-extensions:+  - DataKinds+  - DeriveAnyClass+  - DerivingVia+  - DerivingStrategies+  - GADTs+  - LambdaCase+  - NoImplicitPrelude+  - NoMonomorphismRestriction+  - OverloadedStrings+  - RecordWildCards+  - TypeFamilies++library:+  source-dirs: library+  dependencies:+    - Blammo >= 2.0.0.0+    - aeson+    - annotated-exception+    - bytestring+    - errors+    - freckle-otel+    - hashable+    - hs-opentelemetry-sdk+    - lens+    - memcache+    - mtl+    - network-uri+    - pureMD5+    - serialise+    - text+    - unliftio+    - unordered-containers++tests:+  spec:+    main: Main.hs+    source-dirs: tests+    ghc-options: -threaded -rtsopts "-with-rtsopts=-N"+    dependencies:+      - Blammo+      - aeson+      - errors+      - exceptions+      - freckle-env+      - freckle-memcached+      - hs-opentelemetry-sdk+      - hspec+      - hspec-core+      - hspec-expectations-lifted+      - lens+      - lens-aeson+      - memcache+      - mtl+      - safe+      - text+      - unliftio
+ tests/AppExample.hs view
@@ -0,0 +1,69 @@+module AppExample+  ( AppExample (..)+  , appExample+  , withApp+  ) where++import Prelude++import Blammo.Logging+import Control.Lens (view)+import Control.Monad.Catch+import Control.Monad.Reader (MonadReader, ReaderT (..))+import Data.Functor (void)+import Freckle.App.Dotenv qualified as Dotenv+import OpenTelemetry.Trace (HasTracer (..))+import OpenTelemetry.Trace.Monad (MonadTracer (..))+import Test.Hspec (Spec, SpecWith, aroundAll, beforeAll)+import Test.Hspec.Core.Spec (Example (..))+import UnliftIO++withApp :: ((app -> IO ()) -> IO ()) -> SpecWith app -> Spec+withApp run = beforeAll Dotenv.loadTest . aroundAll run++-- | An Hspec example over some @app@ value+newtype AppExample app a = AppExample+  { unAppExample :: ReaderT app IO a+  }+  deriving newtype+    ( Applicative+    , Functor+    , Monad+    , MonadCatch+    , MonadIO+    , MonadUnliftIO+    , MonadReader app+    , MonadThrow+    , MonadFail+    )+  deriving+    (MonadLogger, MonadLoggerIO)+    via WithLogger app IO++instance MonadMask (AppExample app) where+  mask = UnliftIO.mask+  uninterruptibleMask = UnliftIO.uninterruptibleMask+  generalBracket acquire release use = UnliftIO.mask $ \unmasked -> do+    resource <- acquire+    b <-+      unmasked (use resource) `UnliftIO.catch` \e -> do+        _ <- release resource (ExitCaseException e)+        throwM e++    c <- release resource (ExitCaseSuccess b)+    pure (b, c)++instance Example (AppExample app a) where+  type Arg (AppExample app a) = app++  evaluateExample (AppExample ex) params action =+    evaluateExample+      (action $ \app -> void $ runReaderT ex app)+      params+      ($ ())++instance HasTracer app => MonadTracer (AppExample app) where+  getTracer = view tracerL++appExample :: AppExample app a -> AppExample app a+appExample = id
+ tests/Freckle/App/Memcached/ServersSpec.hs view
@@ -0,0 +1,87 @@+module Freckle.App.Memcached.ServersSpec+  ( spec+  ) where++import Prelude++import Control.Error.Util (hush)+import Control.Monad ((<=<))+import Data.Either (isLeft, isRight)+import Data.Functor (void)+import Database.Memcache.Client qualified as Memcache+import Freckle.App.Memcached.Servers+import Safe (headMay)+import Test.Hspec++spec :: Spec+spec = do+  describe "readMemcachedServers" $ do+    it "requires the correct prefix" $ example $ do+      void (readMemcachedServers "http://") `shouldSatisfy` isLeft+      void (readMemcachedServers "memcached://") `shouldSatisfy` isRight++    it "treats an empty value as none" $ example $ do+      readServerSpecs "" `shouldBe` Just []++    it "treats an empty prefixed value as default" $ example $ do+      readServerSpecs "memcached://" `shouldBe` Just [Memcache.def]++    it "can set host" $ example $ do+      let mServer = readServerSpec "memcached://my-host"++      fmap Memcache.ssHost mServer `shouldBe` Just "my-host"+      fmap Memcache.ssPort mServer `shouldBe` Just "11211"+      fmap Memcache.ssAuth mServer `shouldBe` Just Memcache.NoAuth++    it "can set port" $ example $ do+      let mServer = readServerSpec "memcached://:11212"++      fmap Memcache.ssHost mServer `shouldBe` Just defaultHost+      fmap Memcache.ssPort mServer `shouldBe` Just "11212"+      fmap Memcache.ssAuth mServer `shouldBe` Just Memcache.NoAuth++    it "can set auth" $ example $ do+      let mServer = readServerSpec "memcached://user:password@"++      fmap Memcache.ssHost mServer `shouldBe` Just defaultHost+      fmap Memcache.ssPort mServer `shouldBe` Just "11211"+      fmap Memcache.ssAuth mServer+        `shouldBe` Just (Memcache.Auth "user" "password")++    it "refuses user-less or password-less auth" $ example $ do+      let+        mAuth1 = Memcache.ssAuth <$> readServerSpec "memcached://user:@"+        mAuth2 = Memcache.ssAuth <$> readServerSpec "memcached://:password@"++      mAuth1 `shouldBe` Just Memcache.NoAuth+      mAuth2 `shouldBe` Just Memcache.NoAuth++    it "can set lots at once" $ example $ do+      let mServer = readServerSpec "memcached://user:password@my-host:11212"++      fmap Memcache.ssHost mServer `shouldBe` Just "my-host"+      fmap Memcache.ssPort mServer `shouldBe` Just "11212"+      fmap Memcache.ssAuth mServer+        `shouldBe` Just (Memcache.Auth "user" "password")++    it "can do all of this for a list of servers" $ example $ do+      let mServerSpecs =+            readServerSpecs+              "memcached://a-host,memcached://b-host:11212,memcached://u:p@:11213"++      fmap (map Memcache.ssHost) mServerSpecs+        `shouldBe` Just ["a-host", "b-host", defaultHost]+      fmap (map Memcache.ssPort) mServerSpecs+        `shouldBe` Just ["11211", "11212", "11213"]+      fmap (map Memcache.ssAuth) mServerSpecs+        `shouldBe` Just+          [Memcache.NoAuth, Memcache.NoAuth, Memcache.Auth "u" "p"]++readServerSpec :: String -> Maybe Memcache.ServerSpec+readServerSpec = headMay <=< readServerSpecs++readServerSpecs :: String -> Maybe [Memcache.ServerSpec]+readServerSpecs = fmap toServerSpecs . hush . readMemcachedServers++defaultHost :: String+defaultHost = Memcache.ssHost Memcache.def
+ tests/Freckle/App/MemcachedSpec.hs view
@@ -0,0 +1,139 @@+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module Freckle.App.MemcachedSpec+  ( spec+  ) where++import Prelude++import AppExample+import Blammo.Logging.LogSettings+import Blammo.Logging.Logger+import Control.Lens (lens, to, (^?))+import Control.Monad.IO.Class (liftIO)+import Data.Aeson (Value (..))+import Data.Aeson.Lens+import Data.List.NonEmpty qualified as NE+import Data.Text qualified as T+import Freckle.App.Env qualified as Env+import Freckle.App.Memcached+import Freckle.App.Memcached.Client+  ( MemcachedClient+  , withMemcachedClient+  )+import Freckle.App.Memcached.Client qualified as Memcached+import Freckle.App.Memcached.Servers+import OpenTelemetry.Trace+  ( HasTracer (..)+  , Tracer+  , TracerProvider+  , initializeGlobalTracerProvider+  , makeTracer+  , shutdownTracerProvider+  , tracerOptions+  )+import Test.Hspec (Spec, describe, it)+import Test.Hspec.Expectations.Lifted (shouldBe, shouldSatisfy)+import UnliftIO (MonadUnliftIO)+import UnliftIO.Exception (bracket)++data ExampleValue+  = A+  | B+  | C+  deriving stock (Eq, Show)++instance Cachable ExampleValue where+  toCachable = \case+    A -> "A"+    B -> "Broken"+    C -> "C"++  fromCachable = \case+    "A" -> Right A+    "B" -> Right B+    "C" -> Right C+    x -> Left $ "invalid: " <> show x++data App = App+  { appMemcachedClient :: MemcachedClient+  , appLogger :: Logger+  , appTracer :: Tracer+  }++instance HasMemcachedClient App where+  memcachedClientL =+    lens appMemcachedClient $ \x y -> x {appMemcachedClient = y}++instance HasLogger App where+  loggerL = lens appLogger $ \x y -> x {appLogger = y}++instance HasTracer App where+  tracerL = lens appTracer $ \x y -> x {appTracer = y}++loadApp :: (App -> IO a) -> IO a+loadApp f = do+  servers <-+    Env.parse id $+      Env.var+        (Env.eitherReader readMemcachedServers)+        "MEMCACHED_SERVERS"+        (Env.def defaultMemcachedServers)+  appLogger <- newTestLogger defaultLogSettings+  withTracerProvider $ \tp -> do+    let appTracer = makeTracer tp "freckle-app" tracerOptions+    withMemcachedClient servers $ \appMemcachedClient -> do+      f App {..}++withTracerProvider :: MonadUnliftIO m => (TracerProvider -> m a) -> m a+withTracerProvider =+  bracket+    (liftIO initializeGlobalTracerProvider)+    (liftIO . shutdownTracerProvider)++spec :: Spec+spec = withApp loadApp $ do+  describe "caching" $ do+    it "caches the given action by key using Cachable" $ appExample $ do+      k <- cacheKeyThrow "A"++      val <- caching k (cacheTTL 5) $ pure A+      mbs <- Memcached.get k++      val `shouldBe` A+      mbs `shouldBe` Just "A"++    it "logs, but doesn't fail, on deserialization errors" $ appExample $ do+      k <- cacheKeyThrow "B"++      val0 <- caching k (cacheTTL 5) $ pure B -- set+      val1 <- caching k (cacheTTL 5) $ pure B -- get will fail+      mbs <- Memcached.get k++      val0 `shouldBe` B+      val1 `shouldBe` B+      mbs `shouldBe` Just "Broken"++      msgs <- getLoggedMessagesLenient+      let Just LoggedMessage {..} = NE.last <$> NE.nonEmpty msgs+      Object loggedMessageMeta+        ^? key "error"+          . key "message"+          . _String+        `shouldBe` Just "Unable to deserialize: invalid: \"Broken\""++      -- This assertion is far too brittle, but can be useful to un-comment if+      -- you intend to work on this logic specifically+      -- Object loggedMessageMeta ^? key "error" . key "stack" . _String . to T.lines+      --   `shouldBe` Just+      --     [ "CallStack (from HasCallStack):"+      --     , "  throwM, called at library/Freckle/App/Memcached.hs:121:30 in freckle-app-1.10.8.0-1ebuZKUCQVI9sAWTLATGfO:Freckle.App.Memcached"+      --     , "  cachingAs, called at library/Freckle/App/Memcached.hs:92:11 in freckle-app-1.10.8.0-1ebuZKUCQVI9sAWTLATGfO:Freckle.App.Memcached"+      --     , "  caching, called at tests/Freckle/App/MemcachedSpec.hs:87:15 in main:Freckle.App.MemcachedSpec"+      --     ]+      Object loggedMessageMeta+        ^? key "error"+          . key "stack"+          . _String+          . to T.lines+        `shouldSatisfy` maybe False (not . null)
+ tests/Main.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-}