module Database.Redis.Commands (
process,
) where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad.Trans (MonadIO)
import qualified Data.ByteString.Char8 as S
import Data.Foldable
import qualified Data.HashSet as HS
import Data.Maybe
import qualified Data.Sequence as Seq
import Database.Curry as Curry
import Database.Redis.Types
type RedisCommand = RedisT STM Reply
ping :: RedisCommand
ping = return $ StatusReply "PONG"
set :: S.ByteString -> S.ByteString -> RedisCommand
set key val = do
Curry.insert key (VString val)
return replyOK
mset :: [S.ByteString] -> RedisCommand
mset ss = go ss >> return replyOK where
go (key: val: rest) = do
Curry.insert key (VString val)
go rest
go _ = return ()
get :: S.ByteString -> RedisCommand
get key = do
x <- Curry.lookup key
return $ case x of
Just (VString val) -> BulkReply $ Just val
Nothing -> BulkReply Nothing
_ -> typeErr
incr, decr :: S.ByteString -> RedisCommand
incr = modInt succ
decr = modInt pred
modInt :: (Int -> Int) -> S.ByteString -> RedisCommand
modInt f key = do
x <- Curry.lookup key
case x of
Just (VString (toInt -> Just (f -> val))) -> do
Curry.insert key $ toVString val
return $ IntReply val
Nothing -> do
Curry.insert key $ toVString $ f 0
return $ IntReply $ f 0
Just (VString _) -> do
return notIntErr
_ ->
return typeErr
lpush :: S.ByteString -> [S.ByteString] -> RedisCommand
lpush key vals = do
x <- Curry.lookup key
case x of
Just (VList ls) -> do
Curry.insert key $ VList $ foldl' (\ys y -> y Seq.<| ys) ls vals
return $ IntReply $ Seq.length ls + length vals
Nothing -> do
Curry.insert key $ VList $ foldl' (\ys y -> y Seq.<| ys) Seq.empty vals
return $ IntReply $ length vals
_ ->
return typeErr
lpop :: S.ByteString -> RedisCommand
lpop key = do
x <- fromMaybe (VList Seq.empty) <$> Curry.lookup key
case x of
VList ls -> do
case Seq.viewl ls of
val Seq.:< rest -> do
Curry.insert key $ VList rest
return $ BulkReply $ Just val
_ ->
return $ BulkReply Nothing
_ ->
return typeErr
lrange :: S.ByteString -> S.ByteString -> S.ByteString -> RedisCommand
lrange key sstart sstop = do
x <- fromMaybe (VList Seq.empty) <$> Curry.lookup key
case (x, toInt sstart, toInt sstop) of
(VList ss, Just start, Just stop) -> do
return
$ MultiBulkReply $ Just $ map Just $ toList
$ Seq.take (stop start) $ Seq.drop start ss
_ ->
return typeErr
sadd :: S.ByteString -> [S.ByteString] -> RedisCommand
sadd key vals = do
x <- fromMaybe (VSet HS.empty) <$> Curry.lookup key
case x of
VSet ss -> do
let nss = foldl' (flip HS.insert) ss vals
Curry.insert key $ VSet nss
return $ IntReply $ HS.size nss HS.size ss
_ ->
return typeErr
spop :: S.ByteString -> RedisCommand
spop key = do
x <- fromMaybe (VSet HS.empty) <$> Curry.lookup key
case x of
VSet ss -> do
case HS.toList ss of
(arb:_) -> do
Curry.insert key $ VSet $ HS.delete arb ss
return $ BulkReply $ Just arb
_ -> do
return $ BulkReply Nothing
_ ->
return typeErr
toInt :: S.ByteString -> Maybe Int
toInt bs =
case S.readInt bs of
Just (n, "") -> Just n
_ -> Nothing
toVString :: Int -> Value
toVString = VString . S.pack . show
replyOK, typeErr, notIntErr :: Reply
replyOK = StatusReply "OK"
typeErr = ErrorReply "ERR Operation against a key holding the wrong kind of value"
notIntErr = ErrorReply "ERR value is not an integer or out of range"
process :: (Functor m, Applicative m, MonadIO m)
=> (a, Request) -> RedisT m Reply
process (_pos, req)= transaction $ case req of
Request ["PING"] -> ping
Request ["SET", key, val] -> set key val
Request ("MSET": args) -> mset args
Request ["GET", key] -> get key
Request ["INCR", key] -> incr key
Request ["DECR", key] -> decr key
Request ("LPUSH": key: vals) -> lpush key vals
Request ["LPOP", key] -> lpop key
Request ["LRANGE", key, start, stop] -> lrange key start stop
Request ("SADD": key: vals) -> sadd key vals
Request ["SPOP", key] -> spop key
_ -> do
return $ ErrorReply "Bad Request"