summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorWillLangstroth <>2010-11-08 03:46:11 (GMT)
committerLuite Stegeman <luite@luite.com>2010-11-08 03:46:11 (GMT)
commit2ef7bbdf724f6a46948ed0df68a610d78af92f11 (patch)
treeccd7b3f14baf6d60a9137d926701a5bff68c3e81
version 0.0.70.0.7
-rw-r--r--CONTRIBUTORS6
-rw-r--r--LICENSE22
-rw-r--r--README.md21
-rw-r--r--Setup.hs3
-rw-r--r--haddock.sh9
-rw-r--r--redis-hs.cabal56
-rw-r--r--src/Database/Redis.hs17
-rw-r--r--src/Database/Redis/Connection.hs38
-rw-r--r--src/Database/Redis/General.hs82
-rw-r--r--src/Database/Redis/Internal.hs124
-rw-r--r--src/Database/Redis/List.hs119
-rw-r--r--src/Database/Redis/Set.hs113
-rw-r--r--src/Database/Redis/String.hs55
-rw-r--r--test/redis-tests.cabal23
-rw-r--r--test/suite/Database/Redis/Tests.hs227
-rw-r--r--test/suite/TestSuite.hs11
16 files changed, 926 insertions, 0 deletions
diff --git a/CONTRIBUTORS b/CONTRIBUTORS
new file mode 100644
index 0000000..ab425f3
--- /dev/null
+++ b/CONTRIBUTORS
@@ -0,0 +1,6 @@
+Author:
+ Will Langstroth
+
+Based on code by:
+ Alexander Bogdanov
+ Anders Conbere
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..2fd9054
--- /dev/null
+++ b/LICENSE
@@ -0,0 +1,22 @@
+Copyright (c) 2010 Contributors
+
+Permission is hereby granted, free of charge, to any person
+obtaining a copy of this software and associated documentation
+files (the "Software"), to deal in the Software without
+restriction, including without limitation the rights to use,
+copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the
+Software is furnished to do so, subject to the following
+conditions:
+
+The above copyright notice and this permission notice shall be
+included in all copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
+OTHER DEALINGS IN THE SOFTWARE.
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..b402e3f
--- /dev/null
+++ b/README.md
@@ -0,0 +1,21 @@
+# redis-link
+
+A simple link to Redis in Haskell, emphasizing ease of use, readability of
+code, documentation and test coverage.
+
+## Install
+
+ cabal install redis-hs
+
+## Use
+
+To test it out, try the following:
+
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- itemSet con "greek" "ἐστίν"
+ tester <- itemGet con "greek"
+ putStrLn $ unwrapReply tester
+
+If you need to see the details of the response, replace `unwrapReply` with
+`show`.
diff --git a/Setup.hs b/Setup.hs
new file mode 100644
index 0000000..e8ef27d
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,3 @@
+import Distribution.Simple
+
+main = defaultMain
diff --git a/haddock.sh b/haddock.sh
new file mode 100644
index 0000000..4b6199c
--- /dev/null
+++ b/haddock.sh
@@ -0,0 +1,9 @@
+#!/bin/sh
+
+set -x
+
+rm -Rf dist/doc
+
+HADDOCK_OPTS='--html-location=http://hackage.haskell.org/packages/archive/$pkg/latest/doc/html'
+
+cabal haddock $HADDOCK_OPTS --hyperlink-source $@
diff --git a/redis-hs.cabal b/redis-hs.cabal
new file mode 100644
index 0000000..6fb478f
--- /dev/null
+++ b/redis-hs.cabal
@@ -0,0 +1,56 @@
+name: redis-hs
+version: 0.0.7
+author: Will Langstroth <will@langstroth.com>
+maintainer: Will Langstroth <will@langstroth.com>
+license: MIT
+license-file: LICENSE
+homepage: http://github.com/wlangstroth/redis-hs
+synopsis: A simple Redis library for Haskell
+description:
+ This package provides access to Redis stores using the Data.ByteString.UTF8
+ ByteString, for consistent handling of UTF8 encoding. It is a developer pre-
+ release, and so lacks many of the features of the existing `redis` package
+ (like a monad wrapper, state management, and custom concurrency management)
+ but for light use, this library makes using Redis very straightforward.
+ .
+ The feature set is incomplete, and version 1.0.0 will be tagged only when the
+ library has full command coverage, reasonable test coverage, and solid
+ documentation.
+ .
+ The source code is available on GitHub <http://github.com/wlangstroth/redis-hs>.
+
+category: Database
+build-type: Simple
+cabal-version: >= 1.6
+
+extra-source-files:
+ haddock.sh,
+ LICENSE,
+ CONTRIBUTORS,
+ README.md,
+ test/redis-tests.cabal,
+ test/suite/TestSuite.hs,
+ test/suite/Database/Redis/Tests.hs
+
+library
+ hs-source-dirs: src
+
+ exposed-modules:
+ Database.Redis,
+ Database.Redis.Internal,
+ Database.Redis.Connection,
+ Database.Redis.General,
+ Database.Redis.String,
+ Database.Redis.List,
+ Database.Redis.Set
+
+ build-depends:
+ base == 4.*,
+ bytestring >= 0.9,
+ mtl == 2.*,
+ network >= 2.2.3,
+ utf8-string >= 0.3.5
+
+source-repository head
+ type: git
+ location: http://github.com/wlangstroth/snap-core.git
diff --git a/src/Database/Redis.hs b/src/Database/Redis.hs
new file mode 100644
index 0000000..6ea5f8b
--- /dev/null
+++ b/src/Database/Redis.hs
@@ -0,0 +1,17 @@
+module Database.Redis
+ ( module Database.Redis.Connection
+ , module Database.Redis.General
+ , module Database.Redis.String
+ , module Database.Redis.List
+ , module Database.Redis.Set
+-- , module Database.Redis.SortedSet
+-- , module Database.Redis.Hash
+ ) where
+
+import Database.Redis.Connection
+import Database.Redis.General
+import Database.Redis.String
+import Database.Redis.List
+import Database.Redis.Set
+-- import Database.Redis.SortedSet
+-- import Database.Redis.Hash
diff --git a/src/Database/Redis/Connection.hs b/src/Database/Redis/Connection.hs
new file mode 100644
index 0000000..4623dd0
--- /dev/null
+++ b/src/Database/Redis/Connection.hs
@@ -0,0 +1,38 @@
+module Database.Redis.Connection
+ ( defaultPort
+ , localhost
+ , connect
+ , disconnect
+ ) where
+
+
+import Network
+import System.IO
+
+
+------------------------------------------------------------------------------
+defaultPort :: PortNumber
+defaultPort = 6379 :: PortNumber
+
+
+------------------------------------------------------------------------------
+localhost :: HostName
+localhost = "127.0.0.1" :: HostName
+
+
+------------------------------------------------------------------------------
+connect :: HostName -> PortNumber -> IO Handle
+connect host port =
+ withSocketsDo $ do
+ h <- connectTo host (PortNumber port)
+ hSetNewlineMode h (NewlineMode CRLF CRLF)
+ hSetBuffering h NoBuffering
+ return h
+
+
+------------------------------------------------------------------------------
+disconnect :: Handle -> IO ()
+disconnect h = hClose h
+
+-- QUIT
+-- AUTH
diff --git a/src/Database/Redis/General.hs b/src/Database/Redis/General.hs
new file mode 100644
index 0000000..e04ccac
--- /dev/null
+++ b/src/Database/Redis/General.hs
@@ -0,0 +1,82 @@
+module Database.Redis.General
+ ( RedisReply(..)
+ , keyExists
+ , keyDelete
+ , keyType
+ , keys
+ , keyRandom
+ , select
+ , toUTF8
+ , ping
+ , unwrapReply
+ ) where
+
+
+import System.IO
+
+import Database.Redis.Internal
+
+
+------------------------------------------------------------------------------
+-- EXISTS
+keyExists :: Handle
+ -> String
+ -> IO (Maybe RedisReply)
+keyExists h key = request h $ map toUTF8 ["EXISTS", key]
+
+
+-- EXISTS for ByteString input
+keyExistsB :: Handle
+ -> ByteString
+ -> IO (Maybe RedisReply)
+keyExistsB h key = request h [toUTF8 "EXISTS", key]
+
+
+------------------------------------------------------------------------------
+-- DEL
+-- FIXME: should handle multiple deletions
+keyDelete :: Handle -> String -> IO (Maybe RedisReply)
+keyDelete h key = request h $ map toUTF8 ["DEL", key]
+
+
+------------------------------------------------------------------------------
+-- TYPE
+keyType :: Handle -> String -> IO (Maybe RedisReply)
+keyType h key = request h $ map toUTF8 ["TYPE", key]
+
+
+------------------------------------------------------------------------------
+-- KEYS
+keys :: Handle -> String -> IO (Maybe RedisReply)
+keys h pattern = request h $ map toUTF8 ["KEYS", pattern]
+
+
+------------------------------------------------------------------------------
+-- RANDOMKEY
+keyRandom :: Handle -> IO (Maybe RedisReply)
+keyRandom h = request h $ map toUTF8 ["RANDOMKEY"]
+
+
+-- RENAME
+-- RENAMENX
+-- DBSIZE
+-- EXPIRE
+-- PERSIST
+-- TTL
+
+
+------------------------------------------------------------------------------
+-- SELECT
+select :: Handle -> Int -> IO (Maybe RedisReply)
+select h i = request h $ map toUTF8 ["SELECT", show i]
+
+
+-- MOVE
+-- FLUSHDB
+-- FLUSHALL
+
+------------------------------------------------------------------------------
+ping :: Handle -> IO (Maybe RedisReply)
+ping h = request h $ map toUTF8 ["PING"]
+
+
diff --git a/src/Database/Redis/Internal.hs b/src/Database/Redis/Internal.hs
new file mode 100644
index 0000000..6985cc8
--- /dev/null
+++ b/src/Database/Redis/Internal.hs
@@ -0,0 +1,124 @@
+module Database.Redis.Internal
+ ( RedisReply(..)
+ , ByteString
+ , request
+ , crlf
+ , toUTF8
+ , unwrapReply
+ ) where
+
+
+import Data.ByteString.UTF8 (ByteString)
+import qualified Data.ByteString.UTF8 as U
+import qualified Data.ByteString as B
+
+import System.IO
+
+
+data RedisReply = RedisSingle ByteString
+ | RedisError ByteString
+ | RedisInteger Int
+ | RedisBulk [Maybe RedisReply]
+ deriving (Eq, Show)
+
+
+------------------------------------------------------------------------------
+send :: Handle
+ -> ByteString -- ^ the request
+ -> IO (Maybe RedisReply)
+send h req = B.hPut h req >> B.hPut h (toUTF8 crlf) >>
+ hFlush h >> processReply h
+
+
+------------------------------------------------------------------------------
+-- | Formats and sends the request
+request :: Handle -> [ByteString] -> IO (Maybe RedisReply)
+request _ [] = return $ Just (RedisInteger 0)
+request h commandList = send h $
+ B.concat [ bulkLength commandList
+ , toUTF8 crlf
+ , sendCommands commandList
+ ]
+ where
+ sendCommands [] = toUTF8 " "
+ sendCommands (c:cs) = B.append (B.concat [ argLength c
+ , toUTF8 crlf
+ , c
+ , toUTF8 crlf
+ ]) (sendCommands cs)
+
+ bulkLength cmds = toUTF8 $ '*' : (show $ length cmds)
+
+ argLength arg = toUTF8 $ '$' : (show $ B.length arg)
+
+
+------------------------------------------------------------------------------
+processReply :: Handle -> IO (Maybe RedisReply)
+processReply h = do
+ reply <- fmap trim $ B.hGetLine h
+ case U.uncons reply of
+ Just ('+', rest) -> return $ Just (RedisSingle rest)
+ Just ('-', rest) -> return $ Just (RedisError rest)
+ Just (':', rest) -> integerReply rest
+ Just ('$', rest) -> bulkReply rest
+ Just ('*', rest) -> multiBulkReply rest
+ Just (_, _) -> return $ Nothing
+ Nothing -> return $ Nothing
+ where
+ trim = B.takeWhile (\c -> c /= 13 && c /= 10)
+
+ integerReply b = return $ Just $ RedisInteger $ toInt b
+
+ bulkReply b = do
+ body <- bulkBody $ toInt b
+ return $ case body of
+ Just x -> Just (RedisBulk [Just $ RedisSingle x])
+ _ -> Nothing
+
+ bulkBody (-1) = return $ Nothing
+ bulkBody size = do
+ body <- B.hGet h (size + 2)
+ let reply = B.take size body
+ return $ Just reply
+
+ multiBulkReply b = do
+ bulks <- multiBulkReplies $ toInt b
+ return $ Just $ RedisBulk bulks
+
+ multiBulkReplies (-1) = return $ [Nothing]
+ multiBulkReplies 0 = return $ [Nothing]
+ multiBulkReplies n = do
+ this <- processReply h
+ rest <- multiBulkReplies (n - 1)
+ return $ (this : rest)
+
+
+------------------------------------------------------------------------------
+crlf :: String
+crlf = "\r\n"
+
+
+------------------------------------------------------------------------------
+toUTF8 :: String -> ByteString
+toUTF8 = U.fromString
+
+
+------------------------------------------------------------------------------
+toInt :: ByteString -> Int
+toInt b = read (U.toString b) :: Int
+
+
+------------------------------------------------------------------------------
+-- FIXME: this needs to deal with the rest of the patterns, but this way is
+-- awkward.
+unwrapReply :: Maybe RedisReply -> String
+unwrapReply reply =
+ case reply of
+ Just (RedisBulk [Just (RedisSingle x)]) -> U.toString x
+ Just (RedisSingle x) -> U.toString x
+ Just (RedisError x) -> U.toString x
+ Just (RedisInteger x) -> show x
+ Nothing -> "Nada"
+ _ -> "Not yet Supported"
+
+
diff --git a/src/Database/Redis/List.hs b/src/Database/Redis/List.hs
new file mode 100644
index 0000000..d7abeb2
--- /dev/null
+++ b/src/Database/Redis/List.hs
@@ -0,0 +1,119 @@
+module Database.Redis.List
+ ( listRightPush
+ , listRightPushB
+ , listLeftPush
+ , listLeftPushB
+ , listLength
+ , listLengthB
+ , listRange
+ , listRangeB
+ , listIndex
+ , listIndexB
+ ) where
+
+-- import Data.ByteString (ByteString)
+import System.IO
+
+import Database.Redis.Internal
+
+
+------------------------------------------------------------------------------
+-- | RPUSH
+listRightPush :: Handle
+ -> String -- ^ key
+ -> String -- ^ value
+ -> IO (Maybe RedisReply)
+listRightPush h key value = request h $ map toUTF8 ["RPUSH", key, value]
+
+
+-- | RPUSH for ByteString input
+listRightPushB :: Handle
+ -> ByteString -- ^ key
+ -> ByteString -- ^ value
+ -> IO (Maybe RedisReply)
+listRightPushB h key value = request h [toUTF8 "RPUSH", key, value]
+
+
+------------------------------------------------------------------------------
+-- LPUSH
+listLeftPush :: Handle
+ -> String -- ^ key
+ -> String -- ^ value
+ -> IO (Maybe RedisReply)
+listLeftPush h key value = request h $ map toUTF8 ["LPUSH", key, value]
+
+
+-- | LPUSH for ByteString input
+listLeftPushB :: Handle
+ -> ByteString -- ^ key
+ -> ByteString -- ^ value
+ -> IO (Maybe RedisReply)
+listLeftPushB h key value = request h [toUTF8 "LPUSH", key, value]
+
+
+------------------------------------------------------------------------------
+-- | LLEN
+listLength :: Handle
+ -> String -- ^ key
+ -> IO (Maybe RedisReply)
+listLength h key = request h $ map toUTF8 ["LLEN", key]
+
+
+-- | LLEN for ByteString input
+listLengthB :: Handle
+ -> ByteString -- ^ key
+ -> IO (Maybe RedisReply)
+listLengthB h key = request h [toUTF8 "LLEN", key]
+
+
+------------------------------------------------------------------------------
+-- | LRANGE
+listRange :: Handle
+ -> String -- ^ key
+ -> Int -- ^ start
+ -> Int -- ^ end
+ -> IO (Maybe RedisReply)
+listRange h key start end =
+ request h $ map toUTF8 ["LRANGE", key, show start, show end]
+
+
+-- | LRANGE for ByteString input
+listRangeB :: Handle
+ -> ByteString -- ^ key
+ -> Int -- ^ start
+ -> Int -- ^ end
+ -> IO (Maybe RedisReply)
+listRangeB h key start end =
+ request h [toUTF8 "LRANGE", key, toUTF8 $ show start, toUTF8 $ show end]
+
+
+------------------------------------------------------------------------------
+-- LTRIM
+
+
+------------------------------------------------------------------------------
+-- LINDEX
+listIndex :: Handle
+ -> String -- ^ key
+ -> Int -- ^ index
+ -> IO (Maybe RedisReply)
+listIndex h key index =
+ request h $ map toUTF8 ["LINDEX", key, show index]
+
+
+-- LINDEX for ByteString input
+listIndexB :: Handle
+ -> ByteString -- ^ key
+ -> Int -- ^ index
+ -> IO (Maybe RedisReply)
+listIndexB h key index =
+ request h [toUTF8 "LINDEX", key, toUTF8 $ show index]
+
+
+-- LSET
+-- LREM
+-- LPOP
+-- RPOP
+-- BLPOP
+-- BRPOP
+-- RPOPLPUSH
diff --git a/src/Database/Redis/Set.hs b/src/Database/Redis/Set.hs
new file mode 100644
index 0000000..5a2838d
--- /dev/null
+++ b/src/Database/Redis/Set.hs
@@ -0,0 +1,113 @@
+module Database.Redis.Set
+ ( setAdd
+ , setAddB
+ , setRemove
+ , setRemoveB
+ , setContains
+ , setContainsB
+ , setMembers
+ , setMembersB
+ , setRandMember
+ , setRandMemberB
+ ) where
+
+
+import System.IO
+
+import Database.Redis.Internal
+
+
+------------------------------------------------------------------------------
+-- SADD
+setAdd :: Handle
+ -> String -- ^ key
+ -> String -- ^ value
+ -> IO (Maybe RedisReply)
+setAdd h key value = request h $ map toUTF8 ["SADD", key, value]
+
+
+-- SADD
+setAddB :: Handle
+ -> ByteString -- ^ key
+ -> ByteString -- ^ value
+ -> IO (Maybe RedisReply)
+setAddB h key value = request h [toUTF8 "SADD", key, value]
+
+
+------------------------------------------------------------------------------
+-- SREM
+setRemove :: Handle
+ -> String -- ^ key
+ -> String -- ^ value
+ -> IO (Maybe RedisReply)
+setRemove h key value = request h $ map toUTF8 ["SREM", key, value]
+
+
+-- SREM
+setRemoveB :: Handle
+ -> ByteString -- ^ key
+ -> ByteString -- ^ value
+ -> IO (Maybe RedisReply)
+setRemoveB h key value = request h [toUTF8 "SREM", key, value]
+
+
+-- SPOP
+-- SMOVE
+-- SCARD
+
+
+------------------------------------------------------------------------------
+-- SISMEMBER
+setContains :: Handle
+ -> String -- ^ key
+ -> String -- ^ value
+ -> IO (Maybe RedisReply)
+setContains h key value = request h $ map toUTF8 ["SISMEMBER", key, value]
+
+
+-- SISMEMBER
+setContainsB :: Handle
+ -> ByteString -- ^ key
+ -> ByteString -- ^ value
+ -> IO (Maybe RedisReply)
+setContainsB h key value = request h [toUTF8 "SISMEMBER", key, value]
+
+
+-- SINTER
+-- SINTERSTORE
+-- SUNION
+-- SUNIONSTORE
+-- SDIFF
+-- SDIFFSTORE
+
+
+------------------------------------------------------------------------------
+-- SMEMBERS
+setMembers :: Handle
+ -> String
+ -> IO (Maybe RedisReply)
+setMembers h key = request h $ map toUTF8 ["SMEMBERS", key]
+
+
+-- SMEMBERS
+setMembersB :: Handle
+ -> ByteString
+ -> IO (Maybe RedisReply)
+setMembersB h key = request h [toUTF8 "SMEMBERS", key]
+
+
+------------------------------------------------------------------------------
+-- SRANDMEMBER
+setRandMember :: Handle
+ -> String -- ^ key
+ -> IO (Maybe RedisReply)
+setRandMember h key = request h $ map toUTF8 ["SMEMBERS", key]
+
+
+-- SRANDMEMBER
+setRandMemberB :: Handle
+ -> ByteString -- ^ key
+ -> IO (Maybe RedisReply)
+setRandMemberB h key = request h [toUTF8 "SMEMBERS", key]
+
+
diff --git a/src/Database/Redis/String.hs b/src/Database/Redis/String.hs
new file mode 100644
index 0000000..919c104
--- /dev/null
+++ b/src/Database/Redis/String.hs
@@ -0,0 +1,55 @@
+module Database.Redis.String
+ ( itemSet
+ , itemSetB
+ , itemGet
+ , itemGetB
+ ) where
+
+
+import System.IO
+
+import Database.Redis.Internal
+
+
+------------------------------------------------------------------------------
+-- SET
+itemSet :: Handle
+ -> String -- ^ key to set
+ -> String -- ^ value to set
+ -> IO (Maybe RedisReply)
+itemSet h key value = request h $ map toUTF8 ["SET", key, value]
+
+
+-- SET for ByteString input
+itemSetB :: Handle
+ -> ByteString -- ^ key to set
+ -> ByteString -- ^ value to set
+ -> IO (Maybe RedisReply)
+itemSetB h key value = request h [toUTF8 "SET", key, value]
+
+
+------------------------------------------------------------------------------
+-- GET
+itemGet :: Handle
+ -> String -- ^ key of the value to return
+ -> IO (Maybe RedisReply)
+itemGet h key = request h $ map toUTF8 ["GET", key]
+
+-- GET for ByteString input
+itemGetB :: Handle
+ -> ByteString -- ^ key of the value to return
+ -> IO (Maybe RedisReply)
+itemGetB h key = request h [toUTF8 "GET", key]
+
+-- GETSET
+-- MGET
+-- SETNX
+-- SETEX
+-- MSET
+-- MSETNX
+-- INCR
+-- INCRBY
+-- DECR
+-- DECRBY
+-- APPEND
+-- SUBSTR
diff --git a/test/redis-tests.cabal b/test/redis-tests.cabal
new file mode 100644
index 0000000..11f9681
--- /dev/null
+++ b/test/redis-tests.cabal
@@ -0,0 +1,23 @@
+name: redis-tests
+version: 0.0.7
+build-type: Simple
+cabal-version: >= 1.6
+
+Executable testsuite
+ hs-source-dirs: ../src suite
+ main-is: TestSuite.hs
+
+ build-depends:
+ QuickCheck >= 2,
+ base >= 4 && < 5,
+ bytestring,
+ network >= 2.2.3,
+ HUnit >= 1.2 && < 2,
+ random,
+ test-framework >= 0.3.1 && <0.4,
+ test-framework-hunit >= 0.2.5 && < 0.3,
+ test-framework-quickcheck2 >= 0.2.6 && < 0.3,
+ utf8-string
+
+ ghc-options: -O2 -Wall -fhpc -fwarn-tabs -funbox-strict-fields -threaded
+
diff --git a/test/suite/Database/Redis/Tests.hs b/test/suite/Database/Redis/Tests.hs
new file mode 100644
index 0000000..a55f74c
--- /dev/null
+++ b/test/suite/Database/Redis/Tests.hs
@@ -0,0 +1,227 @@
+module Database.Redis.Tests
+ ( tests ) where
+
+
+------------------------------------------------------------------------------
+-- import Data.ByteString.Char8 (ByteString)
+-- import qualified Data.ByteString.Char8 as B
+-- import qualified Data.ByteString.Lazy.Char8 as L
+-- import Data.Maybe
+import Test.Framework (Test)
+import Test.Framework.Providers.HUnit
+-- import Test.Framework.Providers.QuickCheck2
+import qualified Test.HUnit as H
+-- import Test.QuickCheck
+-- import Test.QuickCheck.Monadic
+
+import Database.Redis
+
+
+------------------------------------------------------------------------------
+-- N.B. These aren't proper tests yet, just checks
+
+
+------------------------------------------------------------------------------
+tests :: [Test]
+tests = [ testCase "redis-link ping" pingTest
+ , testCase "redis-link itemSet" itemSetTest
+ , testCase "redis-link itemGet" itemGetTest
+ , testCase "redis-link keyExists" keyExistsTest
+ , testCase "redis-link keyType" keyTypeTest
+ , testCase "redis-link listRightPush" listRightPushTest
+ , testCase "redis-link listLeftPush" listLeftPushTest
+ , testCase "redis-link listIndex" listIndexTest
+ , testCase "redis-link listLength" listLengthTest
+ , testCase "redis-link listRange" listRangeTest
+ , testCase "redis-link setAdd" setAddTest
+ , testCase "redis-link setContains" setContainsTest
+ , testCase "redis-link setMembers" setMembersTest
+ , testCase "redis-link setRemove" setRemoveTest
+ ]
+
+
+------------------------------------------------------------------------------
+pingTest :: H.Assertion
+pingTest = do
+ con <- connect localhost defaultPort
+ returning <- ping con
+ disconnect con
+ H.assertEqual "ping" (Just $ RedisSingle $ toUTF8 "PONG") returning
+
+
+------------------------------------------------------------------------------
+itemSetTest :: H.Assertion
+itemSetTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ returning <- itemSet con "akey" "ἐστίν"
+ _ <- keyDelete con "akey"
+ disconnect con
+ H.assertEqual "itemSet" (Just $ RedisSingle $ toUTF8 "OK") returning
+
+
+------------------------------------------------------------------------------
+itemGetTest :: H.Assertion
+itemGetTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- itemSet con "differentKey" "ἐστίν"
+ returning <- itemGet con "differentKey"
+ _ <- keyDelete con "differentKey"
+ disconnect con
+ H.assertEqual "itemGet" (Just $ RedisBulk [Just (RedisSingle $ toUTF8 "ἐστίν")]) returning
+
+
+------------------------------------------------------------------------------
+keyExistsTest :: H.Assertion
+keyExistsTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- itemSet con "thekey" "thevalue"
+ returning <- keyExists con "thekey"
+ _ <- keyDelete con "thekey"
+ disconnect con
+ H.assertEqual "keyExistsTest" (Just $ RedisInteger 1) returning
+
+
+------------------------------------------------------------------------------
+keyTypeTest :: H.Assertion
+keyTypeTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- itemSet con "typekey" "typevalue"
+ returning <- keyType con "typekey"
+ _ <- keyDelete con "typekey"
+ disconnect con
+ H.assertEqual "keyTypeTest" (Just $ RedisSingle $ toUTF8 "string") returning
+
+
+------------------------------------------------------------------------------
+listRightPushTest :: H.Assertion
+listRightPushTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ returning <- listRightPush con "thelist" "theitem"
+ _ <- keyDelete con "thelist"
+ disconnect con
+ H.assertBool "listRightPush" $ case returning of
+ Just (RedisInteger _) -> True
+ _ -> False
+
+
+------------------------------------------------------------------------------
+listLeftPushTest :: H.Assertion
+listLeftPushTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ returning <- listLeftPush con "leftlist" "anitem"
+ _ <- keyDelete con "leftlist"
+ disconnect con
+ H.assertBool "listLeftPush" $ case returning of
+ Just (RedisInteger _) -> True
+ _ -> False
+
+
+------------------------------------------------------------------------------
+listLengthTest :: H.Assertion
+listLengthTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- listRightPush con "lengthlist" "anitem"
+ _ <- listRightPush con "lengthlist" "anitem"
+ returning <- listLength con "lengthlist"
+ _ <- keyDelete con "lengthlist"
+ disconnect con
+ H.assertEqual "listLeftPush" (Just $ RedisInteger 2) returning
+
+
+------------------------------------------------------------------------------
+listIndexTest :: H.Assertion
+listIndexTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- listRightPush con "indexlist" "theitem"
+ returning <- listIndex con "indexlist" 0
+ _ <- keyDelete con "indexlist"
+ disconnect con
+ H.assertEqual "listIndex"
+ (Just $ RedisBulk [Just (RedisSingle $ toUTF8 "theitem")])
+ returning
+
+
+------------------------------------------------------------------------------
+listRangeTest :: H.Assertion
+listRangeTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- listRightPush con "alist" "value0"
+ _ <- listRightPush con "alist" "value1"
+ returning <- listRange con "alist" 0 1
+ _ <- keyDelete con "alist"
+ disconnect con
+ H.assertEqual "listRange"
+ (Just (RedisBulk [Just (RedisBulk [Just (RedisSingle $ toUTF8 "value0")])
+ ,Just (RedisBulk [Just (RedisSingle $ toUTF8 "value1")])
+ ,Nothing]))
+ returning
+
+
+------------------------------------------------------------------------------
+setAddTest :: H.Assertion
+setAddTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ returning <- setAdd con "theset" "bob"
+ _ <- keyDelete con "theset"
+ disconnect con
+ H.assertEqual "setAdd" (Just $ RedisInteger 1) returning
+
+
+------------------------------------------------------------------------------
+setContainsTest :: H.Assertion
+setContainsTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- setAdd con "setkey" "bob"
+ returning <- setContains con "setkey" "bob"
+ _ <- keyDelete con "setkey"
+ disconnect con
+ H.assertEqual "setContains" (Just $ RedisInteger 1) returning
+
+
+------------------------------------------------------------------------------
+setMembersTest :: H.Assertion
+setMembersTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- setAdd con "nameset" "Bob"
+ _ <- setAdd con "nameset" "Jane"
+ returning <- setMembers con "nameset"
+ _ <- keyDelete con "setkey"
+ disconnect con
+ H.assertEqual "setContains"
+ (Just (RedisBulk [Just (RedisBulk [Just (RedisSingle $ toUTF8 "Bob")])
+ ,Just (RedisBulk [Just (RedisSingle $ toUTF8 "Jane")])
+ ,Nothing]))
+ returning
+
+
+------------------------------------------------------------------------------
+setRemoveTest :: H.Assertion
+setRemoveTest = do
+ con <- connect localhost defaultPort
+ _ <- select con 0
+ _ <- setAdd con "setit" "Bob"
+ _ <- setAdd con "setit" "Frank"
+ _ <- setAdd con "setit" "Jane"
+ _ <- setRemove con "setit" "Frank"
+ returning <- setMembers con "setit"
+ _ <- keyDelete con "setit"
+ disconnect con
+ H.assertEqual "setRemove"
+ (Just (RedisBulk [Just (RedisBulk [Just (RedisSingle $ toUTF8 "Bob")])
+ ,Just (RedisBulk [Just (RedisSingle $ toUTF8 "Jane")])
+ ,Nothing]))
+ returning
+
+
diff --git a/test/suite/TestSuite.hs b/test/suite/TestSuite.hs
new file mode 100644
index 0000000..c08892d
--- /dev/null
+++ b/test/suite/TestSuite.hs
@@ -0,0 +1,11 @@
+module Main where
+
+import Test.Framework (defaultMain, testGroup)
+
+import qualified Database.Redis.Tests
+main :: IO ()
+main = defaultMain tests
+ where tests = [
+ testGroup "Database.Redis.Tests"
+ Database.Redis.Tests.tests
+ ]