diff --git a/apiary-memcached.cabal b/apiary-memcached.cabal --- a/apiary-memcached.cabal +++ b/apiary-memcached.cabal @@ -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 diff --git a/src/Web/Apiary/Memcached.hs b/src/Web/Apiary/Memcached.hs --- a/src/Web/Apiary/Memcached.hs +++ b/src/Web/Apiary/Memcached.hs @@ -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)