packages feed

persistent-redis (empty) → 0.0.2

raw patch · 8 files changed

+378/−0 lines, 8 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, bytestring, hedis, monad-control, mtl, persistent, persistent-redis, persistent-template, template-haskell, text, transformers, utf8-string

Files

+ Database/Persist/Redis.hs view
@@ -0,0 +1,7 @@+module Database.Persist.Redis +    ( module Database.Persist.Redis.Config+    , module Database.Persist.Redis.Store+    ) where++import Database.Persist.Redis.Config+import Database.Persist.Redis.Store
+ Database/Persist/Redis/Config.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE RankNTypes, TypeFamilies, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, UndecidableInstances, DeriveFunctor #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.Persist.Redis.Config +    ( RedisAuth (..)+    , RedisConf (..)+    , R.RedisCtx+    , R.Redis+    , R.Connection+    , R.PortID (..)+    , RedisT (..)+    , runRedisPool+    , withRedisConn+    , thisConnection+    , module Database.Persist+    ) where++import Database.Persist+import qualified Database.Redis as R+import Data.Text (Text, unpack, pack)+import Data.Aeson (Value (Object, Number, String), (.:?), (.!=), FromJSON(..))+import Control.Monad (mzero, MonadPlus(..))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Class (MonadTrans (..))+import Control.Applicative (Applicative (..))+import Control.Monad.Reader(ReaderT(..))+import Control.Monad.Reader.Class +import qualified Data.ByteString.Char8 as B+import Data.Attoparsec.Number++newtype RedisAuth =  RedisAuth Text deriving (Eq, Show)++-- | Information required to connect to a Redis server+data RedisConf = RedisConf {+    rdHost    :: Text,  -- | Host+    rdPort    :: R.PortID, -- | Port+    rdAuth    :: Maybe RedisAuth, -- | Auth info+    rdMaxConn :: Int -- | Maximum number of connections+} deriving (Show)++instance FromJSON R.PortID where+    parseJSON (Number (I x)) = (return . R.PortNumber . fromInteger) x+    parseJSON _ = fail "couldn't parse port number"++instance FromJSON RedisAuth where+    parseJSON (String t) = (return . RedisAuth) t+    parseJSON _ = fail "couldn't parse auth" ++-- | Monad reader transformer keeping Redis connection through out the work+newtype RedisT m a = RedisT { runRedisT :: ReaderT R.Connection m a }+    deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadPlus)++-- | Extracts connection from RedisT monad transformer+thisConnection :: Monad m => RedisT m R.Connection+thisConnection = RedisT $ ask++-- | Run a connection reader function against a Redis configuration+withRedisConn :: (Monad m, MonadIO m) => RedisConf -> (R.Connection -> m a) -> m a+withRedisConn conf connectionReader = do+    conn <- liftIO $ createPoolConfig conf+    connectionReader conn++runRedisPool :: RedisT m a -> R.Connection -> m a+runRedisPool (RedisT r) = runReaderT r++instance PersistConfig RedisConf where+    type PersistConfigBackend RedisConf = RedisT+    type PersistConfigPool RedisConf = R.Connection++    loadConfig (Object o) = do+        host               <- o .:? "host" .!= R.connectHost R.defaultConnectInfo+        port               <- o .:? "port" .!= R.connectPort R.defaultConnectInfo+        mPass              <- o .:? "password"+        maxConn            <- o .:? "maxConn" .!= R.connectMaxConnections R.defaultConnectInfo++        return RedisConf {+            rdHost = pack host,+            rdPort = port,+            rdAuth = mPass,+            rdMaxConn = maxConn+        }++    loadConfig _ = mzero++    createPoolConfig (RedisConf h p Nothing m) = +        R.connect $ +        R.defaultConnectInfo {+            R.connectHost = unpack h,+            R.connectPort = p,+            R.connectMaxConnections = m+        }+    createPoolConfig (RedisConf h p (Just (RedisAuth pwd)) m) = +        R.connect $ +        R.defaultConnectInfo {+            R.connectHost = unpack h,+            R.connectPort = p,+            R.connectAuth = Just $ B.pack $ unpack pwd,+            R.connectMaxConnections = m+        }++    runPool _ = runRedisPool+
+ Database/Persist/Redis/Internal.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE OverloadedStrings #-}+module Database.Persist.Redis.Internal+	( toInsertFields+    , toKey+    , toKeyId+    , toEntityName+    , deconvert+	) where++import Data.Data+import Data.Text (Text, unpack)+import Database.Persist.Types+import Database.Persist.Class+import Data.Aeson.Generic (encode)+import qualified Data.ByteString as B+import Data.ByteString.Lazy (toStrict)+import qualified Data.ByteString.UTF8 as U+import qualified Database.Redis as R++deconvert :: R.RedisCtx m f => f a -> a+deconvert = undefined++toLabel :: FieldDef a -> B.ByteString+toLabel = U.fromString . unpack . unDBName . fieldDB++toEntityName :: EntityDef a -> B.ByteString+toEntityName = U.fromString . unpack . unDBName . entityDB++moveToByteString :: Data a => Either Text a -> B.ByteString+moveToByteString (Left a)  = U.fromString $ unpack a+moveToByteString (Right a) = toStrict $ encode a++toValue :: PersistValue -> B.ByteString+toValue (PersistText x) = U.fromString $ unpack x+toValue (PersistByteString x) = x+toValue (PersistInt64 x) = U.fromString $ show x+toValue (PersistDouble x) = U.fromString $ show x+toValue (PersistBool x) = U.fromString $ show x+toValue (PersistDay x) = U.fromString $ show x+toValue (PersistTimeOfDay x) = U.fromString $ show x+toValue (PersistUTCTime x) = U.fromString $ show x+toValue (PersistNull) = U.fromString ""+toValue (PersistList x) = U.fromString $ show x+toValue (PersistMap x) = U.fromString $ show x+toValue (PersistObjectId _) = error "PersistObjectId is not supported."++zipAndConvert :: PersistField t => [FieldDef a] -> [t] -> [(B.ByteString, B.ByteString)]+zipAndConvert [] _ = []+zipAndConvert _ [] = []+zipAndConvert (e:efields) (p:pfields) = +    let pv = toPersistValue p+    in+        if pv == PersistNull then zipAndConvert efields pfields+            else (toLabel e, toValue pv) : zipAndConvert efields pfields++-- | Create a list for create/update in Redis store+toInsertFields :: PersistEntity val => val -> [(B.ByteString, B.ByteString)]+toInsertFields record = zipAndConvert entity fields+    where+        entity = entityFields $ entityDef $ Just record+        fields = toPersistFields record++underscoreBs :: B.ByteString+underscoreBs = U.fromString "_"++-- | Make a key for given entity and id+toKey :: PersistEntity val => val -> Integer -> B.ByteString+toKey val n = B.append (toObjectPrefix val) (U.fromString $ show n)++-- | Create a string key for given entity+toObjectPrefix :: PersistEntity val => val -> B.ByteString+toObjectPrefix val = B.append (toEntityName $ entityDef $ Just val) underscoreBs++idBs :: B.ByteString+idBs = U.fromString "id"++-- | Construct an id key, that is incremented for access+toKeyId :: PersistEntity val => val -> B.ByteString+toKeyId val = B.append (toObjectPrefix val) idBs
+ Database/Persist/Redis/Store.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE FlexibleContexts, UndecidableInstances #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE EmptyDataDecls #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+module Database.Persist.Redis.Store +    ( RedisBackend+    , execRedisT+    )where++import Database.Persist+import Control.Applicative (Applicative, (<$>))+import Control.Monad.IO.Class (MonadIO (..))+import Control.Monad.Trans.Control (MonadBaseControl)+import Control.Monad.Reader.Class +import Control.Monad.Reader(ReaderT(..), runReaderT)+import qualified Database.Redis as R+import Data.Text (pack)+import Database.Persist.Redis.Config (RedisT(..), thisConnection)+import Database.Persist.Redis.Internal++data RedisBackend++toOid :: (PersistEntity val) => Integer -> Key val+toOid = Key . PersistText . pack . show ++-- | Fetches a next key from <object>_id record+createKey :: (R.RedisCtx m f, PersistEntity val) => val -> m (f Integer)+createKey val = do+    let keyId = toKeyId val+    oid <- R.incr keyId+    return oid++-- | Inserts a hash map into <object>_<id> record+insertImpl :: (R.RedisCtx m f, PersistEntity val) => val -> Integer -> m (f R.Status)+insertImpl val keyId = do+    let fields = toInsertFields val+    let key    = toKey val keyId+    R.hmset key fields++desugar :: R.TxResult a -> Either String a+desugar (R.TxSuccess x) =  Right x+desugar R.TxAborted = Left "Transaction aborted!"+desugar (R.TxError string) = Left string++-- | Execute Redis transaction inside RedisT monad transformer+execRedisT :: (Monad m, MonadIO m) => R.RedisTx (R.Queued a) -> RedisT m a+execRedisT action = do+    conn <- thisConnection+    result <- liftIO $ R.runRedis conn $ R.multiExec action -- this is the question if we should support transaction here+    let r = desugar result+    case r of+        (Right x) -> return x+        (Left x)  -> fail x++instance (Applicative m, Functor m, MonadIO m, MonadBaseControl IO m) => PersistStore (RedisT m) where+    type PersistMonadBackend (RedisT m) = RedisBackend++    insert val = do+        key <- execRedisT $ createKey val+        r <- execRedisT $ insertImpl val key+        liftIO $ print r+        return $ toOid key++    insertKey k record = undefined++    repsert k record = undefined++    replace k record = undefined++    delete k = undefined++    get k = undefined
+ LICENSE view
@@ -0,0 +1,25 @@+The following license covers this documentation, and the source code, except+where otherwise indicated.++Copyright 2013, Pavel Ryzhov. 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.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS "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 HOLDERS 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ persistent-redis.cabal view
@@ -0,0 +1,52 @@+name:            persistent-redis+version:         0.0.2+license:         BSD3+license-file:    LICENSE+author:          Pavel Ryzhov <paul@paulrz.cz>+synopsis:        Backend for the persistent library using Redis.+description:     Based on the Redis package.+category:        Database, Yesod+stability:       Experimental+cabal-version:   >= 1.8+build-type:      Simple++library+    build-depends:   base                  >= 4        && < 5+                   , hedis                 >= 0.6.0    && < 0.7.0+                   , bytestring            >= 0.10.0.0 && < 0.11.0.0+                   , persistent            >= 1.2      && < 1.3+                   , text                  >= 0.8+                   , aeson                 >= 0.5+                   , attoparsec+                   , mtl                   >= 2.1.2    && < 2.2.0+                   , transformers          >= 0.3.0.0  && < 0.4.0.0+                   , monad-control         >= 0.3.2.0  && < 0.3.3.0+                   , utf8-string           >= 0.3.7    && < 0.4.0++    exposed-modules: Database.Persist.Redis++    other-modules:   Database.Persist.Redis.Config+                     Database.Persist.Redis.Internal+                     Database.Persist.Redis.Store+++    ghc-options:     -Wall++test-suite  basic+    type: exitcode-stdio-1.0+    main-is: tests/basic-test.hs+    build-depends:   base                  >= 4        && < 5+                   , hedis                 >= 0.6.0    && < 0.7.0+                   , persistent            >= 1.2      && < 1.3+                   , persistent-template   >= 1.2      && < 1.3+                   , mtl                   >= 2.1.2    && < 2.2.0+                   , transformers          >= 0.3.0.0  && < 0.4.0.0+                   , utf8-string           >= 0.3.7    && < 0.4.0+                   , bytestring            >= 0.10.0.0 && < 0.11.0.0+                   , text                  >= 0.8+                   , aeson                 >= 0.5+                   , attoparsec+                   , template-haskell+                   , monad-control         >= 0.3.2.0  && < 0.3.3.0+                   , utf8-string           >= 0.3.7    && < 0.4.0+                   , persistent-redis
+ tests/basic-test.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-}+{-# LANGUAGE TypeFamilies, EmptyDataDecls, GADTs #-}+module Main where++import Database.Redis+import Database.Persist+import Database.Persist.Redis+import Database.Persist.TH+import Database.Persist.Quasi+import Language.Haskell.TH.Syntax+import Control.Monad.IO.Class (liftIO)+import Data.Text (Text, pack)++let redisSettings = (mkPersistSettings (ConT ''RedisBackend))+ in share [mkPersist redisSettings] [persistLowerCase| +Person+    name String+    age Int+    deriving Show+|]++d :: ConnectInfo+d = defaultConnectInfo++host :: Text+host = pack $ connectHost d++redisConf :: RedisConf+redisConf = RedisConf host (connectPort d) Nothing 10++main :: IO ()+main = do+    withRedisConn redisConf $ runRedisPool $ do+        s <- insert $ Person "Test" 12+        liftIO $ print s+        return ()