rediscaching-haxl (empty) → 0.1.0.0
raw patch · 4 files changed
+311/−0 lines, 4 filesdep +aesondep +asyncdep +base
Dependencies added: aeson, async, base, bytestring, hashable, haxl, hedis, network, time
Files
- LICENSE +30/−0
- rediscaching-haxl.cabal +35/−0
- src/Haxl/RedisCache.hs +161/−0
- src/Haxl/RedisConfig.hs +85/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Li Meng Jun (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Li Meng Jun nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ rediscaching-haxl.cabal view
@@ -0,0 +1,35 @@+name: rediscaching-haxl+version: 0.1.0.0+synopsis: Combine redis caching and haxl.+description: Combine redis caching and haxl. easy to use redis caching on haxl+homepage: https://github.com/Lupino/yuntan-common/tree/master/rediscaching-haxl#readme+license: BSD3+license-file: LICENSE+author: Li Meng Jun+maintainer: lmjubuntu@gmail.com+copyright: MIT+category: Database,Cache+build-type: Simple+-- extra-source-files:+cabal-version: >=1.10+++library+ hs-source-dirs: src+ exposed-modules: Haxl.RedisCache+ , Haxl.RedisConfig+ build-depends: base >= 4.7 && < 5+ , haxl+ , hedis+ , bytestring+ , aeson++ , async+ , hashable+ , network+ , time+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/Lupino/yuntan-common
+ src/Haxl/RedisCache.hs view
@@ -0,0 +1,161 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TypeFamilies #-}++module Haxl.RedisCache+ ( cached+ , cached'+ , remove+ , removeAll+ , initRedisState+ ) where++import Control.Concurrent.Async+import Control.Concurrent.QSem+import qualified Control.Exception (SomeException, bracket_, try)+import Control.Monad (void)+import Data.Aeson (FromJSON, ToJSON, decodeStrict,+ encode)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B (concat)+import Data.ByteString.Lazy (toStrict)+import Data.Hashable (Hashable (..))+import Data.Typeable (Typeable)+import Database.Redis (Connection, del, get, runRedis, set)+import Haxl.Core hiding (fetchReq)++newtype Conn = Conn Connection++instance Eq Conn where+ _ == _ = True++instance Show Conn where+ show _ = "Conn"++genKey :: ByteString -> ByteString -> ByteString+genKey pref k = B.concat [pref, ":", k]++getData_ :: Connection -> ByteString -> IO (Maybe ByteString)+getData_ conn k = runRedis conn $ either (const Nothing) id <$> get k++setData_ :: Connection -> ByteString -> ByteString -> IO ()+setData_ conn k = runRedis conn . void . set k++delData_ :: Connection -> [ByteString] -> IO ()+delData_ conn ks = runRedis conn . void $ del ks++-- Data source implementation.++data RedisReq a where+ GetData :: Conn -> ByteString -> RedisReq (Maybe ByteString)+ SetData :: Conn -> ByteString -> ByteString -> RedisReq ()+ DelData :: Conn -> [ByteString] -> RedisReq ()+ deriving (Typeable)++deriving instance Eq (RedisReq a)+instance Hashable (RedisReq a) where+ hashWithSalt s (GetData _ k) = hashWithSalt s (1::Int, k)+ hashWithSalt s (SetData _ k v) = hashWithSalt s (2::Int, k, v)+ hashWithSalt s (DelData _ ks) = hashWithSalt s (3::Int, ks)++deriving instance Show (RedisReq a)+instance ShowP RedisReq where showp = show++instance StateKey RedisReq where+ data State RedisReq = RedisState { numThreads :: Int, prefix :: ByteString }++instance DataSourceName RedisReq where+ dataSourceName _ = "RedisDataSource"++instance DataSource u RedisReq where+ fetch = doFetch++doFetch+ :: State RedisReq+ -> Flags+ -> u+ -> PerformFetch RedisReq++doFetch _state _flags _ = AsyncFetch $ \reqs inner -> do+ sem <- newQSem $ numThreads _state+ asyncs <- mapM (fetchAsync sem (prefix _state)) reqs+ inner+ mapM_ wait asyncs++fetchAsync :: QSem -> ByteString -> BlockedFetch RedisReq -> IO (Async ())+fetchAsync sem pref req = async $+ Control.Exception.bracket_ (waitQSem sem) (signalQSem sem) $ fetchSync pref req++fetchSync :: ByteString -> BlockedFetch RedisReq -> IO ()+fetchSync pref (BlockedFetch req rvar) = do+ e <- Control.Exception.try $ fetchReq pref req+ case e of+ Left ex -> putFailure rvar (ex :: Control.Exception.SomeException)+ Right a -> putSuccess rvar a++fetchReq :: ByteString -> RedisReq a -> IO a+fetchReq pref (GetData (Conn conn) k) = getData_ conn $ genKey pref k+fetchReq pref (SetData (Conn conn) k v) = setData_ conn (genKey pref k) v+fetchReq pref (DelData (Conn conn) ks) = delData_ conn $ map (genKey pref) ks++initRedisState :: Int -> ByteString -> State RedisReq+initRedisState = RedisState++getData :: FromJSON v => Connection -> ByteString -> GenHaxl u w (Maybe v)+getData conn k = maybe Nothing decodeStrict <$> dataFetch (GetData (Conn conn) k)++setData :: ToJSON v => Connection -> ByteString -> v -> GenHaxl u w ()+setData conn k v = uncachedRequest . SetData (Conn conn) k . toStrict $ encode v++delData :: Connection -> [ByteString] -> GenHaxl u w ()+delData conn = uncachedRequest . DelData (Conn conn)++-- | Return the cached result of the action or, in the case of a cache+-- miss, execute the action and insert it in the cache.+cached :: (FromJSON v, ToJSON v) => (u -> Maybe Connection) -> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)+cached redis k io = do+ h <- redis <$> env userEnv+ go h k io++ where go :: (FromJSON v, ToJSON v) => Maybe Connection -> ByteString -> GenHaxl u w (Maybe v) -> GenHaxl u w (Maybe v)+ go Nothing _ io0 = io0+ go (Just conn) k0 io0 = do+ res <- getData conn k0+ case res of+ Just v -> return (Just v)+ Nothing -> do+ v <- io0+ case v of+ Nothing -> return Nothing+ Just v0 -> do+ setData conn k0 v0+ return v++cached' :: (FromJSON v, ToJSON v) => (u -> Maybe Connection) -> ByteString -> GenHaxl u w v -> GenHaxl u w v+cached' redis k io = do+ h <- redis <$> env userEnv+ go h k io+ where go :: (FromJSON v, ToJSON v) => Maybe Connection -> ByteString -> GenHaxl u w v -> GenHaxl u w v+ go Nothing _ io0 = io0+ go (Just conn) k0 io0 = do+ res <- getData conn k0+ case res of+ Just v -> return v+ Nothing -> do+ v <- io0+ setData conn k0 v+ return v++remove :: (u -> Maybe Connection) -> ByteString -> GenHaxl u w ()+remove redis k = removeAll redis [k]++removeAll :: (u -> Maybe Connection) -> [ByteString] -> GenHaxl u w ()+removeAll redis k = do+ h <- redis <$> env userEnv+ case h of+ Nothing -> return ()+ Just conn -> delData conn k
+ src/Haxl/RedisConfig.hs view
@@ -0,0 +1,85 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Haxl.RedisConfig+ ( RedisConfig (..)+ , genRedisConnection+ , defaultRedisConfig+ ) where+import Data.Aeson (FromJSON, parseJSON, withObject, (.!=), (.:?))+import Data.String (fromString)+import Data.Time (NominalDiffTime)+import Database.Redis (ConnectInfo (..), Connection,+ PortID (PortNumber), connect,+ defaultConnectInfo)+++++data RedisConfig = RedisConfig+ { redisHost :: String+ , redisPort :: Int+ , redisAuth :: String+ , redisDB :: Integer+ -- ^ Each connection will 'select' the database with the given index.+ , redisMaxConnections :: Int+ -- ^ Maximum number of connections to keep open. The smallest acceptable+ -- value is 1.+ , redisMaxIdleTime :: NominalDiffTime+ -- ^ Amount of time for which an unused connection is kept open. The+ -- smallest acceptable value is 0.5 seconds. If the @timeout@ value in+ -- your redis.conf file is non-zero, it should be larger than+ -- 'redisMaxIdleTime'.+ , redisEnable :: Bool+ , redisHaxlNumThreads :: Int+ -- numThreads of fetch async for haxl+ }+ deriving (Show)++instance FromJSON RedisConfig where+ parseJSON = withObject "RedisConfig" $ \o -> do+ redisDB <- o .:? "db" .!= 0+ redisHost <- o .:? "host" .!= "127.0.0.1"+ redisPort <- o .:? "port" .!= 6379+ redisAuth <- o .:? "auth" .!= ""+ redisEnable <- o .:? "enable" .!= False+ redisMaxConnections <- o .:? "maxConnections" .!= 50+ redisMaxIdleTime <- o .:? "idleTime" .!= 30+ redisHaxlNumThreads <- o .:? "numThreads" .!= 1+ return RedisConfig{..}++defaultRedisConfig :: RedisConfig+defaultRedisConfig = RedisConfig+ { redisHost = "127.0.0.1"+ , redisPort = 6379+ , redisAuth = ""+ , redisDB = 0+ , redisMaxConnections = 50+ , redisMaxIdleTime = 30+ , redisHaxlNumThreads = 1+ , redisEnable = False+ }++genRedisConnection :: RedisConfig -> IO (Maybe Connection)+genRedisConnection conf =+ if enable then do+ conn <- connect $ defaultConnectInfo+ { connectHost = h+ , connectPort = PortNumber p+ , connectAuth = auth+ , connectDatabase = db+ , connectMaxConnections = maxConnections+ , connectMaxIdleTime = maxIdleTime+ }++ return (Just conn)+ else return Nothing++ where db = redisDB conf+ h = redisHost conf+ p = fromIntegral $ redisPort conf+ enable = redisEnable conf+ maxConnections = redisMaxConnections conf+ maxIdleTime = redisMaxIdleTime conf+ auth = if not (null (redisAuth conf)) then+ Just $ fromString (redisAuth conf) else Nothing