apiary-memcached 1.1.0 → 1.2.0
raw patch · 2 files changed
+49/−39 lines, 2 filesdep +cerealdep −binarydep ~apiaryPVP ok
version bump matches the API change (PVP)
Dependencies added: cereal
Dependencies removed: binary
Dependency ranges changed: apiary
API changes (from Hackage documentation)
Files
- apiary-memcached.cabal +3/−3
- src/Web/Apiary/Memcached.hs +46/−36
apiary-memcached.cabal view
@@ -1,5 +1,5 @@ name: apiary-memcached-version: 1.1.0+version: 1.2.0 synopsis: memcached client for apiary web framework. -- description: license: MIT@@ -19,10 +19,10 @@ exposed-modules: Web.Apiary.Memcached other-modules: build-depends: base >=4.6 && <4.8- , apiary >=1.1 && <1.2+ , apiary >=1.1 && <1.3 , memcached-binary >=0.1 && <0.3 , data-default-class >=0.0 && <0.1- , binary >=0.7 && <0.8+ , cereal >=0.4 && <0.5 , text >=1.1 && <1.3 , transformers >=0.3 && <0.5 , monad-control >=0.3 && <0.4
src/Web/Apiary/Memcached.hs view
@@ -1,10 +1,9 @@-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeOperators #-}-{-# LANGUAGE DataKinds #-}+{-# LANGUAGE Rank2Types #-} {-# LANGUAGE LambdaCase #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DataKinds #-} module Web.Apiary.Memcached ( Memcached, CacheConfig(..), MemcachedConfig(..)@@ -18,39 +17,43 @@ , cache, cacheMaybe ) where -import Web.Apiary-import Web.Apiary.Heroku+import Web.Apiary(MonadIO(..))+import Web.Apiary.Heroku(Heroku, getHerokuEnv') -import Control.Applicative-import Control.Monad.Trans.Maybe-import Control.Monad.Trans.Control-import Control.Monad.Apiary.Action+import Control.Applicative((<$>), (<*>), (<|>))+import Control.Monad.Trans.Maybe(MaybeT(MaybeT, runMaybeT))+import Control.Monad.Trans.Control(MonadBaseControl, control)+import Control.Monad.Apiary.Action(ActionT) -import Data.Default.Class+import Data.Default.Class(Default(..)) import Data.Apiary.Extension-import Data.Apiary.Compat-import qualified Data.Binary as B+ (Has, Extension, Initializer', initializerBracket'+ , Initializer, initializerBracket, getExtension, getExt+ )+import Data.Apiary.Compat(Proxy(Proxy))+import qualified Data.Serialize as Serialize import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Data.Text.Read as T -import Database.Memcached.Binary.IO+import qualified Database.Memcached.Binary.IO as Memcached+import qualified Database.Memcached.Binary.IO as IO import qualified Database.Memcached.Binary.Maybe as Maybe -data Memcached = Memcached Connection MemcachedConfig+data Memcached = Memcached Memcached.Connection MemcachedConfig instance Extension Memcached data CacheConfig = CacheConfig- { cacheFlags :: Key -> Flags- , cacheExpiry :: Expiry- , cacheNotHitExpiry :: Expiry+ { cacheFlags :: Memcached.Key -> Memcached.Flags+ , cacheExpiry :: Memcached.Expiry+ , cacheNotHitExpiry :: Memcached.Expiry } instance Default CacheConfig where def = CacheConfig (\_ -> 0) 0 0 data MemcachedConfig = MemcachedConfig- { connectInfo :: ConnectInfo+ { connectInfo :: Memcached.ConnectInfo , cacheConfig :: Maybe CacheConfig } @@ -59,7 +62,7 @@ initMemcached :: MonadBaseControl IO m => MemcachedConfig -> Initializer' m Memcached initMemcached cfg = initializerBracket' $ \m -> control $ \run -> - withConnection (connectInfo cfg) (\c -> run $ m (Memcached c cfg))+ Memcached.withConnection (connectInfo cfg) (\c -> run $ m (Memcached c cfg)) getHerokuConfig :: T.Text -> MemcachedConfig -> Heroku -> MaybeT IO MemcachedConfig getHerokuConfig pfx ci exts = do@@ -70,13 +73,13 @@ let (hst, prtTxt) = T.breakOnEnd ":" svr prt <- either fail (return . fst) $ T.decimal prtTxt - let auth = Plain <$> (T.encodeUtf8 <$> usr) <*> (T.encodeUtf8 <$> pwd)+ let auth = Memcached.Plain <$> (T.encodeUtf8 <$> usr) <*> (T.encodeUtf8 <$> pwd) return ci {connectInfo = (connectInfo ci)- { connectHost = T.unpack $ T.init hst- , connectPort = PortNumber prt- , connectAuth =- maybe id (\a -> (a:)) auth $ connectAuth (connectInfo ci)+ { Memcached.connectHost = T.unpack $ T.init hst+ , Memcached.connectPort = Memcached.PortNumber prt+ , Memcached.connectAuth =+ maybe id (\a -> (a:)) auth $ Memcached.connectAuth (connectInfo ci) }} -- | initialize memcached extension using heroku service.@@ -93,16 +96,17 @@ cfg' <- fmap (maybe cfg id) . runMaybeT $ getHerokuConfig "MEMCACHIER" cfg hc <|> getHerokuConfig "MEMCACHEDCLOUD" cfg hc- withConnection (connectInfo cfg') (\c -> run $ m (Memcached c cfg'))+ Memcached.withConnection (connectInfo cfg') (\c -> run $ m (Memcached c cfg')) memcached :: (Has Memcached exts, MonadIO m)- => (Connection -> IO a) -> ActionT exts prms m a+ => (Memcached.Connection -> IO a) -> ActionT exts prms m a memcached q = do Memcached conn _ <- getExt Proxy liftIO $ q conn cache :: (MonadIO m, Has Memcached exts)- => Key -> ActionT exts prms m Value -> ActionT exts prms m Value+ => Memcached.Key -> ActionT exts prms m Memcached.Value+ -> ActionT exts prms m Memcached.Value cache ky actn = do Memcached conn cfg <- getExt Proxy case cacheConfig cfg of@@ -111,25 +115,31 @@ Just cr -> return cr Nothing -> do ar <- actn- liftIO $ set (cacheFlags cc ky)+ liftIO $ IO.set (cacheFlags cc ky) (cacheExpiry cc) ky ar conn return ar +getRight :: Either l r -> Maybe r+getRight (Left _) = Nothing+getRight (Right a) = Just a+{-# INLINE getRight #-}+ cacheMaybe :: (MonadIO m, Has Memcached exts)- => Key -> ActionT exts prms m (Maybe Value)- -> ActionT exts prms m (Maybe Value)+ => Memcached.Key -> ActionT exts prms m (Maybe Memcached.Value)+ -> ActionT exts prms m (Maybe Memcached.Value) cacheMaybe ky actn = do Memcached conn cfg <- getExt Proxy case cacheConfig cfg of Nothing -> actn Just cc -> liftIO (Maybe.get_ ky conn) >>= \case- Just cr -> return $ B.decode cr+ Just cr -> return . getRight $ Serialize.decodeLazy cr Nothing -> actn >>= \case Nothing -> do- liftIO $ set (cacheFlags cc ky)- (cacheNotHitExpiry cc) ky (B.encode (Nothing :: Maybe Value)) conn+ liftIO $ IO.set (cacheFlags cc ky)+ (cacheNotHitExpiry cc) ky + (Serialize.encodeLazy (Nothing :: Maybe Memcached.Value)) conn return Nothing Just ar -> do- liftIO $ set (cacheFlags cc ky)- (cacheExpiry cc) ky (B.encode $ Just ar) conn+ liftIO $ IO.set (cacheFlags cc ky)+ (cacheExpiry cc) ky (Serialize.encodeLazy $ Just ar) conn return (Just ar)