diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index a150c406..8b322f65 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -23,16 +23,6 @@ jobs: test: needs: generate runs-on: ubuntu-latest - services: - memcached: - image: memcached:1.6.40 - ports: - - 11211:11211 - options: >- - --health-cmd "bash -c 'echo >/dev/tcp/127.0.0.1/11211'" - --health-interval 10s - --health-timeout 5s - --health-retries 5 strategy: matrix: diff --git a/.github/workflows/release.yml b/.github/workflows/release.yml index e334d79f..de7b9d42 100644 --- a/.github/workflows/release.yml +++ b/.github/workflows/release.yml @@ -12,7 +12,6 @@ jobs: matrix: package: - freckle-app - - freckle-memcached steps: - uses: actions/checkout@v6 @@ -33,7 +32,6 @@ jobs: matrix: package: - freckle-app - - freckle-memcached env: HACKAGE_KEY: ${{ secrets.HACKAGE_UPLOAD_API_KEY }} diff --git a/freckle-memcached/CHANGELOG.md b/freckle-memcached/CHANGELOG.md deleted file mode 100644 index f6f00b78..00000000 --- a/freckle-memcached/CHANGELOG.md +++ /dev/null @@ -1,29 +0,0 @@ -## [_Unreleased_](https://github.com/freckle/freckle-app/compare/freckle-memcached-v0.0.0.2...main) - -## [v0.0.0.2](https://github.com/freckle/freckle-app/compare/freckle-memcached-v0.0.0.1...freckle-memcached-v0.0.0.2) - -Upgrade `Blammo` to 2.1 - -## [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} -``` diff --git a/freckle-memcached/LICENSE b/freckle-memcached/LICENSE deleted file mode 100644 index 34c4f312..00000000 --- a/freckle-memcached/LICENSE +++ /dev/null @@ -1,21 +0,0 @@ -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. diff --git a/freckle-memcached/README.md b/freckle-memcached/README.md deleted file mode 100644 index 3550766e..00000000 --- a/freckle-memcached/README.md +++ /dev/null @@ -1,7 +0,0 @@ -# freckle-memcached - -Some extensions to the [memcache](https://hackage.haskell.org/package/memcache) library. - ---- - -[CHANGELOG](./CHANGELOG.md) | [LICENSE](./LICENSE) diff --git a/freckle-memcached/freckle-memcached.cabal b/freckle-memcached/freckle-memcached.cabal deleted file mode 100644 index ec055485..00000000 --- a/freckle-memcached/freckle-memcached.cabal +++ /dev/null @@ -1,120 +0,0 @@ -cabal-version: 1.18 - --- This file has been generated from package.yaml by hpack version 0.36.0. --- --- see: https://github.com/sol/hpack - -name: freckle-memcached -version: 0.0.0.2 -synopsis: Some extensions to the memcache library -description: Please see README.md -category: Database -homepage: https://github.com/freckle/freckle-app#readme -bug-reports: https://github.com/freckle/freckle-app/issues -maintainer: Freckle Education -license: MIT -license-file: LICENSE -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 - other-modules: - Paths_freckle_memcached - hs-source-dirs: - library - 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 - , aeson - , annotated-exception - , base <5 - , bytestring - , errors - , freckle-otel - , hashable - , hs-opentelemetry-sdk - , lens - , memcache - , mtl - , network-uri - , pureMD5 - , serialise - , text - , unliftio - , unordered-containers - default-language: GHC2021 - 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 - other-modules: - AppExample - Freckle.App.Memcached.ServersSpec - Freckle.App.MemcachedSpec - Paths_freckle_memcached - hs-source-dirs: - tests - 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 - , aeson - , base <5 - , errors - , exceptions - , freckle-env - , freckle-memcached - , hs-opentelemetry-sdk - , hspec - , hspec-core - , hspec-expectations-lifted - , lens - , lens-aeson - , memcache - , mtl - , safe - , text - , unliftio - default-language: GHC2021 - if impl(ghc >= 9.8) - ghc-options: -Wno-missing-role-annotations -Wno-missing-poly-kind-signatures diff --git a/freckle-memcached/library/Freckle/App/Memcached.hs b/freckle-memcached/library/Freckle/App/Memcached.hs deleted file mode 100644 index df5ee8f6..00000000 --- a/freckle-memcached/library/Freckle/App/Memcached.hs +++ /dev/null @@ -1,185 +0,0 @@ --- | 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 diff --git a/freckle-memcached/library/Freckle/App/Memcached/CacheKey.hs b/freckle-memcached/library/Freckle/App/Memcached/CacheKey.hs deleted file mode 100644 index d2805cf1..00000000 --- a/freckle-memcached/library/Freckle/App/Memcached/CacheKey.hs +++ /dev/null @@ -1,55 +0,0 @@ -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 --- --- --- --- @ --- 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 diff --git a/freckle-memcached/library/Freckle/App/Memcached/CacheTTL.hs b/freckle-memcached/library/Freckle/App/Memcached/CacheTTL.hs deleted file mode 100644 index d817e1e0..00000000 --- a/freckle-memcached/library/Freckle/App/Memcached/CacheTTL.hs +++ /dev/null @@ -1,39 +0,0 @@ -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 diff --git a/freckle-memcached/library/Freckle/App/Memcached/Client.hs b/freckle-memcached/library/Freckle/App/Memcached/Client.hs deleted file mode 100644 index f5a2e2b6..00000000 --- a/freckle-memcached/library/Freckle/App/Memcached/Client.hs +++ /dev/null @@ -1,139 +0,0 @@ -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 diff --git a/freckle-memcached/library/Freckle/App/Memcached/MD5.hs b/freckle-memcached/library/Freckle/App/Memcached/MD5.hs deleted file mode 100644 index 262ce409..00000000 --- a/freckle-memcached/library/Freckle/App/Memcached/MD5.hs +++ /dev/null @@ -1,24 +0,0 @@ -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 diff --git a/freckle-memcached/library/Freckle/App/Memcached/Servers.hs b/freckle-memcached/library/Freckle/App/Memcached/Servers.hs deleted file mode 100644 index 50372f90..00000000 --- a/freckle-memcached/library/Freckle/App/Memcached/Servers.hs +++ /dev/null @@ -1,113 +0,0 @@ --- | 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} diff --git a/freckle-memcached/package.yaml b/freckle-memcached/package.yaml deleted file mode 100644 index e5ced4ee..00000000 --- a/freckle-memcached/package.yaml +++ /dev/null @@ -1,98 +0,0 @@ -name: freckle-memcached -version: 0.0.0.2 -maintainer: Freckle Education -category: Database -github: freckle/freckle-app -synopsis: Some extensions to the memcache library -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 - - 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 diff --git a/freckle-memcached/tests/AppExample.hs b/freckle-memcached/tests/AppExample.hs deleted file mode 100644 index 904c1ce3..00000000 --- a/freckle-memcached/tests/AppExample.hs +++ /dev/null @@ -1,70 +0,0 @@ -module AppExample - ( AppExample (..) - , appExample - , withApp - ) where - -import Prelude - -import Blammo.Logging (MonadLogger, MonadLoggerIO) -import Blammo.Logging.Setup (WithLogger (..)) -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 diff --git a/freckle-memcached/tests/Freckle/App/Memcached/ServersSpec.hs b/freckle-memcached/tests/Freckle/App/Memcached/ServersSpec.hs deleted file mode 100644 index d58d87c0..00000000 --- a/freckle-memcached/tests/Freckle/App/Memcached/ServersSpec.hs +++ /dev/null @@ -1,87 +0,0 @@ -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 diff --git a/freckle-memcached/tests/Freckle/App/MemcachedSpec.hs b/freckle-memcached/tests/Freckle/App/MemcachedSpec.hs deleted file mode 100644 index 494e2ebf..00000000 --- a/freckle-memcached/tests/Freckle/App/MemcachedSpec.hs +++ /dev/null @@ -1,139 +0,0 @@ -{-# 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) diff --git a/freckle-memcached/tests/Main.hs b/freckle-memcached/tests/Main.hs deleted file mode 100644 index 1fcc19ca..00000000 --- a/freckle-memcached/tests/Main.hs +++ /dev/null @@ -1 +0,0 @@ -{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Main -Wno-missing-export-lists #-} diff --git a/hie.yaml b/hie.yaml index 0cf5eded..9d0728a5 100644 --- a/hie.yaml +++ b/hie.yaml @@ -8,9 +8,3 @@ cradle: - path: "freckle-app/tests" component: "freckle-app:test:spec" - - - path: "freckle-memcached/library" - component: "freckle-memcached:lib" - - - path: "freckle-memcached/tests" - component: "freckle-memcached:test:spec" diff --git a/stack-lts20.yaml b/stack-lts20.yaml index 16e44927..60b089b9 100644 --- a/stack-lts20.yaml +++ b/stack-lts20.yaml @@ -8,6 +8,7 @@ extra-deps: - freckle-env-0.0.1.2 - freckle-exception-0.0.0.0 - freckle-http-0.3.0.0 + - freckle-memcached-0.0.0.2 - freckle-otel-0.0.0.2 - freckle-prelude-0.0.4.0 - freckle-stats-0.0.0.0 @@ -44,4 +45,3 @@ extra-deps: packages: - freckle-app - - freckle-memcached diff --git a/stack-lts21.yaml b/stack-lts21.yaml index c6b11e6e..b52475f4 100644 --- a/stack-lts21.yaml +++ b/stack-lts21.yaml @@ -8,6 +8,7 @@ extra-deps: - freckle-env-0.0.1.2 - freckle-exception-0.0.0.0 - freckle-http-0.3.0.0 + - freckle-memcached-0.0.0.2 - freckle-otel-0.0.0.2 - freckle-prelude-0.0.4.0 - freckle-stats-0.0.0.0 @@ -39,4 +40,3 @@ extra-deps: packages: - freckle-app - - freckle-memcached diff --git a/stack-lts22.yaml b/stack-lts22.yaml index 07f3c50a..80dcc256 100644 --- a/stack-lts22.yaml +++ b/stack-lts22.yaml @@ -7,6 +7,7 @@ extra-deps: - freckle-env-0.0.1.2 - freckle-exception-0.0.0.0 - freckle-http-0.3.0.0 + - freckle-memcached-0.0.0.3 - freckle-otel-0.0.0.2 - freckle-prelude-0.0.4.0 - freckle-stats-0.0.0.0 @@ -26,4 +27,3 @@ extra-deps: packages: - freckle-app - - freckle-memcached diff --git a/stack-lts23.yaml b/stack-lts23.yaml index bef0b881..5bf75440 100644 --- a/stack-lts23.yaml +++ b/stack-lts23.yaml @@ -8,6 +8,7 @@ extra-deps: - freckle-env-0.0.1.2 - freckle-exception-0.0.0.0 - freckle-http-0.3.0.0 + - freckle-memcached-0.0.0.3 - freckle-otel-0.0.0.3 - freckle-prelude-0.0.4.0 - freckle-stats-0.0.0.0 @@ -27,4 +28,3 @@ extra-deps: packages: - freckle-app - - freckle-memcached diff --git a/stack-lts24.yaml b/stack-lts24.yaml index a5365fa7..8f66d927 100644 --- a/stack-lts24.yaml +++ b/stack-lts24.yaml @@ -10,6 +10,7 @@ extra-deps: - freckle-env-0.0.1.2 - freckle-exception-0.0.0.0 - freckle-http-0.3.0.0 + - freckle-memcached-0.0.0.3 - freckle-otel-0.0.0.3 - freckle-prelude-0.0.4.0 - freckle-stats-0.0.0.0 @@ -34,4 +35,3 @@ extra-deps: packages: - freckle-app - - freckle-memcached diff --git a/stack-nightly.yaml b/stack-nightly.yaml index 5d5bd8ab..1081d5b1 100644 --- a/stack-nightly.yaml +++ b/stack-nightly.yaml @@ -14,6 +14,7 @@ extra-deps: - freckle-env-0.0.1.2 - freckle-exception-0.0.0.0 - freckle-http-0.3.0.0 + - freckle-memcached-0.0.0.3 - freckle-otel-0.0.0.3 - freckle-prelude-0.0.4.0 - freckle-stats-0.0.0.0 @@ -51,4 +52,3 @@ allow-newer-deps: packages: - freckle-app - - freckle-memcached