freckle-app 1.0.2.10 → 1.0.3.0

raw patch · 15 files changed

+697/−5 lines, 15 filesdep +memcachedep +scientistdep +unliftio-corePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: memcache, scientist, unliftio-core

API changes (from Hackage documentation)

Files

• CHANGELOG.md +6/−1
• freckle-app.cabal +18/−1
• gittest/Spec.hs +1/−1
• library/Freckle/App/Memcached.hs +125/−0
• library/Freckle/App/Memcached/CacheKey.hs +48/−0
• library/Freckle/App/Memcached/CacheTTL.hs +29/−0
• library/Freckle/App/Memcached/Client.hs +72/−0
• library/Freckle/App/Memcached/Servers.hs +119/−0
• library/Freckle/App/Scientist.hs +36/−0
• library/Freckle/App/Test/Logging.hs +30/−0
• library/Yesod/Core/Lens.hs +15/−0
• package.yaml +9/−1
• tests/Freckle/App/Memcached/ServersSpec.hs +94/−0
• tests/Freckle/App/MemcachedSpec.hs +94/−0
• tests/Spec.hs +1/−1

@@ -1,6 +1,11 @@ ## [_Unreleased_](https://github.com/freckle/freckle-app/compare/v1.0.2.10...main) -- None+## [v1.0.3.0](https://github.com/freckle/freckle-app/compare/v1.0.2.10...v1.0.3.0)++- Add `Freckle.App.Memcache` for using memcached in Apps+- Add `Freckle.App.Scientist` for using [scientist][] in Apps++  [scientist]: https://github.com/freckle/scientist-hs#readme  ## [v1.0.2.10](https://github.com/freckle/freckle-app/compare/v1.0.2.9...v1.0.2.10) 

@@ -1,6 +1,6 @@ cabal-version:      1.18 name:               freckle-app-version:            1.0.2.10+version:            1.0.3.0 license:            MIT license-file:       LICENSE maintainer:         Freckle Education@@ -38,16 +38,24 @@         Freckle.App.Http.Paginate         Freckle.App.Http.Retry         Freckle.App.Logging+        Freckle.App.Memcached+        Freckle.App.Memcached.CacheKey+        Freckle.App.Memcached.CacheTTL+        Freckle.App.Memcached.Client+        Freckle.App.Memcached.Servers         Freckle.App.Prelude         Freckle.App.RIO+        Freckle.App.Scientist         Freckle.App.Test         Freckle.App.Test.DocTest         Freckle.App.Test.Hspec.Runner+        Freckle.App.Test.Logging         Freckle.App.Version         Freckle.App.Wai         Freckle.App.Yesod         Freckle.App.Yesod.Routes         Network.HTTP.Link.Compat+        Yesod.Core.Lens      hs-source-dirs:     library     other-modules:      Paths_freckle_app@@ -92,6 +100,7 @@         iproute >=1.7.7,         lens >=4.16.1,         load-env >=0.2.0.2,+        memcache >=0.2.0.1,         monad-control >=1.0.2.3,         monad-logger >=0.3.31,         mtl >=2.2.2,@@ -106,6 +115,7 @@         retry >=0.8.1.0,         rio >=0.1.7.0,         safe >=0.3.17,+        scientist >=0.0.0.0,         semigroupoids >=5.2.2,         template-haskell >=2.13.0.0,         text >=1.2.3.1,@@ -181,6 +191,8 @@     other-modules:         Freckle.App.Env.InternalSpec         Freckle.App.HttpSpec+        Freckle.App.Memcached.ServersSpec+        Freckle.App.MemcachedSpec         Freckle.App.WaiSpec         Spec         Paths_freckle_app@@ -200,10 +212,15 @@         aeson >=1.3.1.1,         base >=4.11.1.0 && <5,         bytestring >=0.10.8.2,+        errors >=2.3.0,         freckle-app -any,         hspec >=2.8.1,         http-types >=0.12.2,         lens >=4.16.1,         lens-aeson >=1.0.2,+        memcache >=0.2.0.1,+        monad-logger >=0.3.31,+        mtl >=2.2.2,+        unliftio-core >=0.1.2.0,         wai >=3.2.1.2,         wai-extra >=3.0.24.3

@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec -optF --no-main #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

@@ -0,0 +1,125 @@+-- | 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++  -- * Re-exports+  , module Freckle.App.Memcached.Client+  , module Freckle.App.Memcached.CacheKey+  , module Freckle.App.Memcached.CacheTTL+  ) where++import Freckle.App.Prelude++import Control.Monad.Logger (MonadLogger, logErrorN)+import Data.Aeson+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as BSL+import Data.Text.Encoding (decodeUtf8With)+import Data.Text.Encoding.Error (lenientDecode)+import Freckle.App.Memcached.CacheKey+import Freckle.App.Memcached.CacheTTL+import Freckle.App.Memcached.Client (HasMemcachedClient(..))+import qualified Freckle.App.Memcached.Client as Memcached+import UnliftIO.Exception (Exception(..), handleAny)++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 = encodeUtf8+  fromCachable = Right . decodeUtf8With lenientDecode++data Cached a+  = CacheFound a+  | CacheNotFound+  | CacheError Text++-- | Memoize an action using Memcached and 'Cachable'+caching+  :: ( MonadUnliftIO m+     , MonadLogger m+     , MonadReader env m+     , HasMemcachedClient env+     , Cachable a+     )+  => CacheKey+  -> CacheTTL+  -> m a+  -> m a+caching = cachingAs fromCachable toCachable++-- | Like 'caching', but with explicit conversion functions+cachingAs+  :: (MonadUnliftIO m, MonadLogger m, MonadReader env m, HasMemcachedClient env)+  => (ByteString -> Either String a)+  -> (a -> ByteString)+  -> CacheKey+  -> CacheTTL+  -> m a+  -> m a+cachingAs from to key ttl f = do+  result <-+    fmap (maybe CacheNotFound (either (CacheError . pack) CacheFound . from))+    $ handleCachingError Nothing "getting"+    $ Memcached.get key++  case result of+    CacheFound a -> pure a+    CacheNotFound -> store+    CacheError e -> do+      logCachingError "deserializing" e+      store+ where+  store = do+    a <- f+    a <$ handleCachingError () "setting" (Memcached.set key (to a) ttl)++-- | Like 'caching', but de/serializing the value as JSON+cachingAsJSON+  :: ( MonadUnliftIO m+     , MonadLogger m+     , MonadReader env m+     , HasMemcachedClient env+     , FromJSON a+     , ToJSON a+     )+  => CacheKey+  -> CacheTTL+  -> m a+  -> m a+cachingAsJSON = cachingAs eitherDecodeStrict encodeStrict++handleCachingError+  :: (MonadUnliftIO m, MonadLogger m) => a -> Text -> m a -> m a+handleCachingError value action = handleAny $ \ex -> do+  logCachingError action $ pack $ displayException ex+  pure value++logCachingError :: MonadLogger m => Text -> Text -> m ()+logCachingError action message =+  logErrorN $ "[Caching] error " <> action <> ": " <> message++encodeStrict :: ToJSON a => a -> ByteString+encodeStrict = BSL.toStrict . encode

@@ -0,0 +1,48 @@+module Freckle.App.Memcached.CacheKey+  ( CacheKey+  , cacheKey+  , cacheKeyThrow+  , fromCacheKey+  ) where++import Freckle.App.Prelude++import Data.Char (isControl, isSpace)+import qualified Data.Text as T+import Database.Memcache.Types (Key)+import GHC.Stack (HasCallStack)+import UnliftIO.Exception (throwString)++newtype CacheKey = CacheKey Text+  deriving stock Show+  deriving newtype (Eq, Hashable)++unCacheKey :: CacheKey -> Text+unCacheKey (CacheKey x) = x++-- | 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 container whitespace"+  | otherwise = Right $ CacheKey t+ where+  invalid msg =+    Left $ "Not a valid memcached key:\n  " <> unpack t <> "\n\n" <> msg++-- | Build a 'CacheKey' and throw if invalid+cacheKeyThrow :: (HasCallStack, MonadIO m) => Text -> m CacheKey+cacheKeyThrow = either throwString pure . cacheKey++fromCacheKey :: CacheKey -> Key+fromCacheKey = encodeUtf8 . unCacheKey

@@ -0,0 +1,29 @@+module Freckle.App.Memcached.CacheTTL+  ( CacheTTL+  , cacheTTL+  , fromCacheTTL+  ) where++import Freckle.App.Prelude++import Data.Word (Word32)+import Database.Memcache.Types (Expiration)++newtype CacheTTL = CacheTTL Int+  deriving stock Show+  deriving newtype (Eq, Ord, Enum, Num, Real, Integral)++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

@@ -0,0 +1,72 @@+module Freckle.App.Memcached.Client+  ( MemcachedClient+  , newMemcachedClient+  , memcachedClientDisabled+  , HasMemcachedClient(..)+  , get+  , set+  ) where++import Freckle.App.Prelude++import Control.Lens (Lens', _1, view)+import qualified Database.Memcache.Client as Memcache+import Database.Memcache.Types (Value)+import Freckle.App.Memcached.CacheKey+import Freckle.App.Memcached.CacheTTL+import Freckle.App.Memcached.Servers+import Yesod.Core.Lens+import Yesod.Core.Types (HandlerData)++data MemcachedClient+  = MemcachedClient Memcache.Client+  | MemcachedClientDisabled++class HasMemcachedClient env where+  memcachedClientL :: Lens' env MemcachedClient++instance HasMemcachedClient MemcachedClient where+  memcachedClientL = id++instance HasMemcachedClient site => HasMemcachedClient (HandlerData child site) where+  memcachedClientL = envL . siteL . memcachedClientL++newMemcachedClient :: MonadIO m => MemcachedServers -> m MemcachedClient+newMemcachedClient servers = case toServerSpecs servers of+  [] -> pure memcachedClientDisabled+  specs -> liftIO $ MemcachedClient <$> Memcache.newClient specs Memcache.def++memcachedClientDisabled :: MemcachedClient+memcachedClientDisabled = MemcachedClientDisabled++get+  :: (MonadIO m, MonadReader env m, HasMemcachedClient env)+  => CacheKey+  -> m (Maybe Value)+get k = with $ \case+  MemcachedClient mc -> liftIO $ view _1 <$$> Memcache.get mc (fromCacheKey k)+  MemcachedClientDisabled -> pure Nothing++-- | Set a value to expire in the given seconds+--+-- Pass @0@ to set a value that never expires.+--+set+  :: (MonadIO m, MonadReader env m, HasMemcachedClient env)+  => CacheKey+  -> Value+  -> CacheTTL+  -> m ()+set k v expiration = with $ \case+  MemcachedClient mc ->+    void $ liftIO $ Memcache.set mc (fromCacheKey k) v 0 $ fromCacheTTL+      expiration+  MemcachedClientDisabled -> pure ()++with+  :: (MonadReader env m, HasMemcachedClient env)+  => (MemcachedClient -> m a)+  -> m a+with f = do+  c <- view memcachedClientL+  f c

@@ -0,0 +1,119 @@+{-# LANGUAGE CPP #-}++-- | 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) "MEMCACHED_SERVERS" Env.nonEmpty+--+-- -- 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 Freckle.App.Prelude++import Control.Error.Util (note)+import qualified Data.Text as T+import qualified Database.Memcache.Client 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 . unpack)+    . filter (not . T.null)+    . map T.strip+    . T.splitOn ","+    . 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 . 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 = encodeUtf8 u+      , Memcache.password = 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) -> fromPort p+    p -> fromPort p+  pure $ ss { Memcache.ssPort = p }+ where+#if MIN_VERSION_memcache(0,3,0)+  -- ssPort is a ServiceName, which is a String+  fromPort = Just+#else+  -- ssPort is a PortNumber, which we need to Read+  fromPort = readMay+#endif++setAuth+  :: Memcache.Authentication -> Memcache.ServerSpec -> Memcache.ServerSpec+setAuth auth ss = ss { Memcache.ssAuth = auth }

@@ -0,0 +1,36 @@+module Freckle.App.Scientist+  ( experimentPublishDatadog+  ) where++import Freckle.App.Prelude++import Data.List.NonEmpty as NE+import qualified Freckle.App.Datadog as Datadog+import Scientist+import Scientist.Duration++-- | Publish experiment durations to Datadog+--+-- * Experiments are labeled "science.${name}"+-- * Control results are tagged with "variant:control"+-- * Candidates are tagged with "variant:control-${i}"+--+experimentPublishDatadog+  :: ( MonadReader env m+     , MonadUnliftIO m+     , Datadog.HasDogStatsClient env+     , Datadog.HasDogStatsTags env+     )+  => Result c a b+  -> m ()+experimentPublishDatadog result = for_ (resultDetails result) $ \details -> do+  let statName = "science." <> resultDetailsExperimentName details+  Datadog.gauge statName [("variant", "control")]+    $ durationToSeconds+    $ resultControlDuration+    $ resultDetailsControl details+  for_ (NE.zip (resultDetailsCandidates details) (NE.fromList [1 ..]))+    $ \(candidate, i :: Int) -> do+        Datadog.gauge statName [("variant", "candidate-" <> tshow i)]+          $ durationToSeconds+          $ resultCandidateDuration candidate

@@ -0,0 +1,30 @@+module Freckle.App.Test.Logging+  ( runCapturedLoggingT+  ) where++import Freckle.App.Prelude++import Control.Concurrent.Chan+import Control.Monad (forever)+import Control.Monad.Logger+import UnliftIO.Async+import UnliftIO.IORef++-- | Run a 'LoggingT', capturing and returning any logged messages alongside+--+-- I do not know why 'runChanLoggingT' exists presumably for this purpose, but+-- requires so much more effort to ultimately accomplish.+--+runCapturedLoggingT :: MonadUnliftIO m => LoggingT m a -> m (a, [Text])+runCapturedLoggingT f = do+  chan <- liftIO newChan+  ref <- newIORef []+  x <- async $ forever $ do+    (_, _, _, str) <- liftIO $ readChan chan+    modifyIORef' ref (<> [decodeUtf8 $ fromLogStr str])++  a <- runChanLoggingT chan f++  cancel x+  msgs <- readIORef ref+  pure (a, msgs)

@@ -0,0 +1,15 @@+module Yesod.Core.Lens+  ( envL+  , siteL+  ) where++import Freckle.App.Prelude++import Control.Lens (Lens', lens)+import Yesod.Core.Types (HandlerData, RunHandlerEnv, handlerEnv, rheSite)++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 }

@@ -1,6 +1,6 @@ --- name: freckle-app-version: 1.0.2.10+version: 1.0.3.0 maintainer: Freckle Education category: Utils github: freckle/freckle-app@@ -81,6 +81,7 @@     - iproute     - lens     - load-env+    - memcache     - monad-control     - monad-logger >= 0.3.31     - mtl@@ -95,6 +96,7 @@     - retry >= 0.8.1.0     - rio     - safe+    - scientist     - semigroupoids     - template-haskell     - text@@ -118,11 +120,16 @@     dependencies:       - aeson       - bytestring+      - errors       - freckle-app       - hspec       - http-types       - lens       - lens-aeson+      - memcache+      - monad-logger+      - mtl+      - unliftio-core       - wai       - wai-extra @@ -131,6 +138,7 @@     source-dirs: doctest     dependencies:       - freckle-app+   gittest:     main: Main.hs     source-dirs: gittest

@@ -0,0 +1,94 @@+{-# LANGUAGE CPP #-}++module Freckle.App.Memcached.ServersSpec+  ( spec+  ) where++import Freckle.App.Prelude++import Control.Error.Util (hush)+import Data.Either (isLeft, isRight)+import qualified Database.Memcache.Client as Memcache+import Freckle.App.Memcached.Servers+import Freckle.App.Test++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 (portServiceName . 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 (portServiceName . 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 (portServiceName . 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 (portServiceName . 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 (portServiceName . 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++#if MIN_VERSION_memcache(0,3,0)+portServiceName :: String -> String+portServiceName = id+#else+portServiceName :: Show a => a -> String+portServiceName = show+#endif

@@ -0,0 +1,94 @@+module Freckle.App.MemcachedSpec+  ( spec+  ) where++import Freckle.App.Prelude++import Control.Monad.IO.Unlift (MonadUnliftIO(..))+import Control.Monad.Logger+import Control.Monad.Reader+import qualified Data.List.NonEmpty as NE+import qualified Freckle.App.Env as Env+import Freckle.App.Memcached+import Freckle.App.Memcached.Client (MemcachedClient, newMemcachedClient)+import qualified Freckle.App.Memcached.Client as Memcached+import Freckle.App.Memcached.Servers+import Freckle.App.Test.Logging+import Test.Hspec++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++newtype TestAppT m a = TestAppT+  { unTestAppT :: ReaderT MemcachedClient (LoggingT m) a+  }+  deriving newtype+    ( Functor+    , Applicative+    , Monad+    , MonadReader MemcachedClient+    , MonadIO+    , MonadLogger+    )++-- We could derive this in newer versions of unliftio-core, but defining it by+-- hand supports a few resolvers back, without CPP. This is just a copy of the+-- ReaderT instance,+--+-- https://hackage.haskell.org/package/unliftio-core-0.2.0.1/docs/src/Control.Monad.IO.Unlift.html#line-64+--+instance MonadUnliftIO m => MonadUnliftIO (TestAppT m) where+  {-# INLINE withRunInIO #-}+  withRunInIO inner = TestAppT $ withRunInIO $ \run -> inner (run . unTestAppT)++runTestAppT :: MonadUnliftIO m => TestAppT m a -> m (a, [Text])+runTestAppT f = do+  servers <- liftIO $ Env.parse $ Env.var+    (Env.eitherReader readMemcachedServers)+    "MEMCACHED_SERVERS"+    (Env.def defaultMemcachedServers)+  mc <- newMemcachedClient servers+  runCapturedLoggingT $ runReaderT (unTestAppT f) mc++spec :: Spec+spec = do+  describe "caching" $ do+    it "caches the given action by key using Cachable" $ example $ do+      void $ runTestAppT $ do+        key <- cacheKeyThrow "A"++        val <- caching key (cacheTTL 5) $ pure A+        mbs <- Memcached.get key++        liftIO $ val `shouldBe` A+        liftIO $ mbs `shouldBe` Just "A"++    it "logs, but doesn't fail, on deserialization errors" $ example $ do+      (_, msgs) <- runTestAppT $ do+        key <- cacheKeyThrow "B"++        val0 <- caching key (cacheTTL 5) $ pure B -- set+        val1 <- caching key (cacheTTL 5) $ pure B -- get will fail+        mbs <- Memcached.get key++        liftIO $ val0 `shouldBe` B+        liftIO $ val1 `shouldBe` B+        liftIO $ mbs `shouldBe` Just "Broken"++      fmap NE.last (NE.nonEmpty msgs)+        `shouldBe` Just "[Caching] error deserializing: invalid: \"Broken\""

@@ -1,1 +1,1 @@-{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec -optF --no-main #-}+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}