module Database.Monarch.Binary
(
put, putKeep, putCat, putShiftLeft, multiplePut
, putNoResponse
, out, multipleOut
, get, multipleGet
, valueSize
, iterInit, iterNext
, forwardMatchingKeys
, addInt, addDouble
, ext, sync, optimize, vanish, copy, restore
, setMaster
, recordNum, size
, status
, misc
) where
import Data.Int
import Data.Maybe
import qualified Data.Binary as B
import Data.Binary.Put (putWord32be, putByteString)
import Data.ByteString.Char8 hiding (length, copy, init, last)
import Control.Applicative
import Control.Monad
import Control.Monad.Error
import Control.Monad.Trans.Control
import Database.Monarch.Raw
import Database.Monarch.Utils
put :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> ByteString
-> MonarchT m ()
put key value = communicate request response
where
request = do
putMagic 0x10
mapM_ (putWord32be . lengthBS32) [key, value]
mapM_ putByteString [key, value]
response Success = return ()
response code = throwError code
multiplePut :: ( MonadBaseControl IO m
, MonadIO m ) =>
[(ByteString,ByteString)]
-> MonarchT m ()
multiplePut [] = return ()
multiplePut kvs = void $ misc "putlist" [] (kvs >>= \(k,v)->[k,v])
putKeep :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> ByteString
-> MonarchT m ()
putKeep key value = communicate request response
where
request = do
putMagic 0x11
mapM_ (putWord32be . lengthBS32) [key, value]
mapM_ putByteString [key, value]
response Success = return ()
response InvalidOperation = return ()
response code = throwError code
putCat :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> ByteString
-> MonarchT m ()
putCat key value = communicate request response
where
request = do
putMagic 0x12
mapM_ (putWord32be . lengthBS32) [key, value]
mapM_ putByteString [key, value]
response Success = return ()
response code = throwError code
putShiftLeft :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> ByteString
-> Int
-> MonarchT m ()
putShiftLeft key value width = communicate request response
where
request = do
putMagic 0x13
mapM_ (putWord32be . lengthBS32) [key, value]
putWord32be $ fromIntegral width
mapM_ putByteString [key, value]
response Success = return ()
response code = throwError code
putNoResponse :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> ByteString
-> MonarchT m ()
putNoResponse key value = yieldRequest request
where
request = do
putMagic 0x18
mapM_ (putWord32be . lengthBS32) [key, value]
mapM_ putByteString [key, value]
out :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> MonarchT m ()
out key = communicate request response
where
request = do
putMagic 0x20
putWord32be $ lengthBS32 key
putByteString key
response Success = return ()
response InvalidOperation = return ()
response code = throwError code
multipleOut :: ( MonadBaseControl IO m
, MonadIO m ) =>
[ByteString]
-> MonarchT m ()
multipleOut [] = return ()
multipleOut keys = void $ misc "outlist" [] keys
get :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> MonarchT m (Maybe ByteString)
get key = communicate request response
where
request = do
putMagic 0x30
putWord32be $ lengthBS32 key
putByteString key
response Success = Just <$> parseBS
response InvalidOperation = return Nothing
response code = throwError code
multipleGet :: ( MonadBaseControl IO m
, MonadIO m ) =>
[ByteString]
-> MonarchT m [(ByteString, ByteString)]
multipleGet keys = communicate request response
where
request = do
putMagic 0x31
putWord32be . fromIntegral $ length keys
mapM_ (\key -> do
putWord32be $ lengthBS32 key
putByteString key) keys
response Success = do
siz <- fromIntegral <$> parseWord32
replicateM siz parseKeyValue
response code = throwError code
valueSize :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> MonarchT m (Maybe Int)
valueSize key = communicate request response
where
request = do
putMagic 0x38
putWord32be $ lengthBS32 key
putByteString key
response Success = Just . fromIntegral <$> parseWord32
response InvalidOperation = return Nothing
response code = throwError code
iterInit :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m ()
iterInit = communicate request response
where
request = putMagic 0x50
response Success = return ()
response code = throwError code
iterNext :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m (Maybe ByteString)
iterNext = communicate request response
where
request = putMagic 0x51
response Success = Just <$> parseBS
response InvalidOperation = return Nothing
response code = throwError code
forwardMatchingKeys :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> Maybe Int
-> MonarchT m [ByteString]
forwardMatchingKeys prefix n = communicate request response
where
request = do
putMagic 0x58
putWord32be $ lengthBS32 prefix
putWord32be $ fromIntegral (fromMaybe (1) n)
putByteString prefix
response Success = do
siz <- fromIntegral <$> parseWord32
replicateM siz parseBS
response code = throwError code
addInt :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> Int
-> MonarchT m Int
addInt key n = communicate request response
where
request = do
putMagic 0x60
putWord32be $ lengthBS32 key
putWord32be $ fromIntegral n
putByteString key
response Success = fromIntegral <$> parseWord32
response code = throwError code
addDouble :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> Double
-> MonarchT m Double
addDouble key n = communicate request response
where
request = do
putMagic 0x61
putWord32be $ lengthBS32 key
B.put (truncate n :: Int64)
B.put (truncate (snd (properFraction n :: (Int,Double)) * 1e12) :: Int64)
putByteString key
response Success = parseDouble
response code = throwError code
ext :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> [ExtOption]
-> ByteString
-> ByteString
-> MonarchT m ByteString
ext func opts key value = communicate request response
where
request = do
putMagic 0x68
putWord32be $ lengthBS32 func
putOptions opts
putWord32be $ lengthBS32 key
putWord32be $ lengthBS32 value
putByteString func
putByteString key
putByteString value
response Success = parseBS
response code = throwError code
sync :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m ()
sync = communicate request response
where
request = putMagic 0x70
response Success = return ()
response code = throwError code
optimize :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> MonarchT m ()
optimize param = communicate request response
where
request = do
putMagic 0x71
putWord32be $ lengthBS32 param
putByteString param
response Success = return ()
response code = throwError code
vanish :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m ()
vanish = communicate request response
where
request = putMagic 0x72
response Success = return ()
response code = throwError code
copy :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> MonarchT m ()
copy path = communicate request response
where
request = do
putMagic 0x73
putWord32be $ lengthBS32 path
putByteString path
response Success = return ()
response code = throwError code
restore :: ( MonadBaseControl IO m
, MonadIO m
, Integral a ) =>
ByteString
-> a
-> [RestoreOption]
-> MonarchT m ()
restore path usec opts = communicate request response
where
request = do
putMagic 0x74
putWord32be $ lengthBS32 path
B.put (fromIntegral usec :: Int64)
putOptions opts
putByteString path
response Success = return ()
response code = throwError code
setMaster :: ( MonadBaseControl IO m
, MonadIO m
, Integral a ) =>
ByteString
-> Int
-> a
-> [RestoreOption]
-> MonarchT m ()
setMaster host port usec opts = communicate request response
where
request = do
putMagic 0x78
putWord32be $ lengthBS32 host
putWord32be $ fromIntegral port
B.put (fromIntegral usec :: Int64)
putOptions opts
putByteString host
response Success = return ()
response code = throwError code
recordNum :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m Int64
recordNum = communicate request response
where
request = putMagic 0x80
response Success = parseInt64
response code = throwError code
size :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m Int64
size = communicate request response
where
request = putMagic 0x81
response Success = parseInt64
response code = throwError code
status :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m ByteString
status = communicate request response
where
request = putMagic 0x88
response Success = parseBS
response code = throwError code
misc :: ( MonadBaseControl IO m
, MonadIO m ) =>
ByteString
-> [MiscOption]
-> [ByteString]
-> MonarchT m [ByteString]
misc func opts args = communicate request response
where
request = do
putMagic 0x90
putWord32be $ lengthBS32 func
putOptions opts
putWord32be . fromIntegral $ length args
putByteString func
mapM_ (\arg -> do
putWord32be $ lengthBS32 arg
putByteString arg) args
response Success = do
siz <- fromIntegral <$> parseWord32
replicateM siz parseBS
response code = throwError code