module Web.Apiary.Memcached
( Memcached, CacheConfig(..), MemcachedConfig(..)
, initMemcached, initHerokuMemcached
, memcached
, cache, cacheMaybe
) where
import Web.Apiary(MonadIO(..))
import Web.Apiary.Heroku(Heroku, getHerokuEnv')
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(Default(..))
import Data.Apiary.Extension
(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 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 Memcached.Connection MemcachedConfig
instance Extension Memcached
data CacheConfig = CacheConfig
{ cacheFlags :: Memcached.Key -> Memcached.Flags
, cacheExpiry :: Memcached.Expiry
, cacheNotHitExpiry :: Memcached.Expiry
}
instance Default CacheConfig where
def = CacheConfig (\_ -> 0) 0 0
data MemcachedConfig = MemcachedConfig
{ connectInfo :: Memcached.ConnectInfo
, cacheConfig :: Maybe CacheConfig
}
instance Default MemcachedConfig where
def = MemcachedConfig def Nothing
initMemcached :: MonadBaseControl IO m => MemcachedConfig -> Initializer' m Memcached
initMemcached cfg = initializerBracket' $ \m -> control $ \run ->
Memcached.withConnection (connectInfo cfg) (\c -> run $ m (Memcached c cfg))
getHerokuConfig :: T.Text -> MemcachedConfig -> Heroku -> MaybeT IO MemcachedConfig
getHerokuConfig pfx ci exts = do
svr <- MaybeT $ getHerokuEnv' (pfx `T.append` "_SERVERS") exts
usr <- liftIO $ getHerokuEnv' (pfx `T.append` "_USERNAME") exts
pwd <- liftIO $ getHerokuEnv' (pfx `T.append` "_PASSWORD") exts
let (hst, prtTxt) = T.breakOnEnd ":" svr
prt <- either fail (return . fst) $ T.decimal prtTxt
let auth = Memcached.Plain <$> (T.encodeUtf8 <$> usr) <*> (T.encodeUtf8 <$> pwd)
return ci {connectInfo = (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)
}}
initHerokuMemcached :: (Has Heroku exts, MonadBaseControl IO m)
=> MemcachedConfig -> Initializer m exts (Memcached ': exts)
initHerokuMemcached cfg = initializerBracket $ \exts m -> control $ \run -> do
let hc = getExtension Proxy exts
cfg' <- fmap (maybe cfg id) . runMaybeT $
getHerokuConfig "MEMCACHIER" cfg hc <|>
getHerokuConfig "MEMCACHEDCLOUD" cfg hc
Memcached.withConnection (connectInfo cfg') (\c -> run $ m (Memcached c cfg'))
memcached :: (Has Memcached exts, MonadIO m)
=> (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)
=> 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
Nothing -> actn
Just cc -> liftIO (Maybe.get_ ky conn) >>= \case
Just cr -> return cr
Nothing -> do
ar <- actn
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
cacheMaybe :: (MonadIO m, Has Memcached exts)
=> 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 . getRight $ Serialize.decodeLazy cr
Nothing -> actn >>= \case
Nothing -> do
liftIO $ IO.set (cacheFlags cc ky)
(cacheNotHitExpiry cc) ky
(Serialize.encodeLazy (Nothing :: Maybe Memcached.Value)) conn
return Nothing
Just ar -> do
liftIO $ IO.set (cacheFlags cc ky)
(cacheExpiry cc) ky (Serialize.encodeLazy $ Just ar) conn
return (Just ar)