module Database.Monarch.Types
(
Monarch, MonarchT
, Connection, ConnectionPool
, withMonarchConn
, withMonarchPool
, runMonarchConn
, runMonarchPool
, ExtOption(..), RestoreOption(..), MiscOption(..)
, Code(..)
, sendLBS, recvLBS
, MonadMonarch(..)
) where
import Prelude hiding (catch)
import Data.Int
import Data.Conduit.Pool
import Control.Exception.Lifted
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Base
import Control.Applicative
import Control.Monad.Trans.Control
import Network.Socket
import qualified Network.Socket.ByteString.Lazy as LBS
import qualified Data.ByteString.Lazy as LBS
import qualified Data.ByteString as BS
data Connection = Connection { connection :: Socket }
type ConnectionPool = Pool Connection
data Code = Success
| InvalidOperation
| HostNotFound
| ConnectionRefused
| SendError
| ReceiveError
| ExistingRecord
| NoRecordFound
| MiscellaneousError
deriving (Eq, Show)
instance Error Code
data ExtOption = RecordLocking
| GlobalLocking
data RestoreOption = ConsistencyChecking
data MiscOption = NoUpdateLog
newtype MonarchT m a =
MonarchT { unMonarchT :: ErrorT Code (ReaderT Connection m) a }
deriving ( Functor, Applicative, Monad, MonadIO
, MonadReader Connection, MonadError Code, MonadBase base )
instance MonadTrans MonarchT where
lift = MonarchT . lift . lift
instance MonadTransControl MonarchT where
newtype StT MonarchT a = StMonarch { unStMonarch :: Either Code a }
liftWith f = MonarchT . ErrorT . ReaderT $ (\r -> liftM Right (f $ \t -> liftM StMonarch (runReaderT (runErrorT (unMonarchT t)) r)))
restoreT = MonarchT . ErrorT . ReaderT . const . liftM unStMonarch
instance MonadBaseControl base m => MonadBaseControl base (MonarchT m) where
newtype StM (MonarchT m) a = StMMonarchT { unStMMonarchT :: ComposeSt MonarchT m a }
liftBaseWith = defaultLiftBaseWith StMMonarchT
restoreM = defaultRestoreM unStMMonarchT
type Monarch = MonarchT IO
runMonarch :: MonadIO m =>
Connection
-> MonarchT m a
-> m (Either Code a)
runMonarch conn action =
runReaderT (runErrorT $ unMonarchT action) conn
withMonarchConn :: ( MonadBaseControl IO m
, MonadIO m ) =>
String
-> Int
-> (Connection -> m a)
-> m a
withMonarchConn host port = bracket open' close'
where
open' = liftIO $ getConnection host port
close' = liftIO . sClose . connection
withMonarchPool :: ( MonadBaseControl IO m
, MonadIO m ) =>
String
-> Int
-> Int
-> (ConnectionPool -> m a)
-> m a
withMonarchPool host port connections f =
liftIO (createPool open' close' 1 20 connections) >>= f
where
open' = getConnection host port
close' = sClose . connection
runMonarchConn :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m a
-> Connection
-> m (Either Code a)
runMonarchConn action conn = runMonarch conn action
runMonarchPool :: ( MonadBaseControl IO m
, MonadIO m ) =>
MonarchT m a
-> ConnectionPool
-> m (Either Code a)
runMonarchPool action pool =
withResource pool $ flip runMonarch action
throwError' :: Monad m =>
Code
-> SomeException
-> MonarchT m a
throwError' = const . throwError
sendLBS :: ( MonadBaseControl IO m
, MonadIO m ) =>
LBS.ByteString
-> MonarchT m ()
sendLBS lbs = do
conn <- connection <$> ask
liftIO (LBS.sendAll conn lbs) `catch` throwError' SendError
recvLBS :: ( MonadBaseControl IO m
, MonadIO m ) =>
Int64
-> MonarchT m LBS.ByteString
recvLBS n = do
conn <- connection <$> ask
lbs <- liftIO (LBS.recv conn n) `catch` throwError' ReceiveError
if LBS.null lbs
then throwError ReceiveError
else if n == LBS.length lbs
then return lbs
else LBS.append lbs <$> recvLBS (n LBS.length lbs)
getConnection :: HostName
-> Int
-> IO Connection
getConnection host port = do
let hints = defaultHints { addrFlags = [ AI_ADDRCONFIG ]
, addrSocketType = Stream
}
(addr:_) <- getAddrInfo (Just hints) (Just host) (Just $ show port)
sock <- socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
let failConnect = (\e -> sClose sock >> throwIO e) :: SomeException -> IO ()
connect sock (addrAddress addr) `catch` failConnect
return $ Connection sock
class Monad m => MonadMonarch m where
put :: BS.ByteString
-> BS.ByteString
-> m ()
multiplePut :: [(BS.ByteString,BS.ByteString)]
-> m ()
putKeep :: BS.ByteString
-> BS.ByteString
-> m ()
putCat :: BS.ByteString
-> BS.ByteString
-> m ()
putShiftLeft :: BS.ByteString
-> BS.ByteString
-> Int
-> m ()
putNoResponse :: BS.ByteString
-> BS.ByteString
-> m ()
out :: BS.ByteString
-> m ()
multipleOut :: [BS.ByteString]
-> m ()
get :: BS.ByteString
-> m (Maybe BS.ByteString)
multipleGet :: [BS.ByteString]
-> m [(BS.ByteString, BS.ByteString)]
valueSize :: BS.ByteString
-> m (Maybe Int)
iterInit :: m ()
iterNext :: m (Maybe BS.ByteString)
forwardMatchingKeys :: BS.ByteString
-> Maybe Int
-> m [BS.ByteString]
addInt :: BS.ByteString
-> Int
-> m Int
addDouble :: BS.ByteString
-> Double
-> m Double
ext :: BS.ByteString
-> [ExtOption]
-> BS.ByteString
-> BS.ByteString
-> m BS.ByteString
sync :: m ()
optimize :: BS.ByteString
-> m ()
vanish :: m ()
copy :: BS.ByteString
-> m ()
restore :: ( Integral a ) =>
BS.ByteString
-> a
-> [RestoreOption]
-> m ()
setMaster :: ( Integral a ) =>
BS.ByteString
-> Int
-> a
-> [RestoreOption]
-> m ()
recordNum :: m Int64
size :: m Int64
status :: m BS.ByteString
misc :: BS.ByteString
-> [MiscOption]
-> [BS.ByteString]
-> m [BS.ByteString]