module Network.Rserve.Client
(RConn(..)
, Result
, RserveError
, ResultUnpack(..)
, RSEXP(..)
, connect
, eval
, voidEval
, login
, shutdown
, openFile
, createFile
, closeFile
, removeFile
, Network.Rserve.Client.writeFile
, assign
, unpackRArrayInt
, unpackRArrayBool
, unpackRArrayDouble
, unpackRArrayComplex
, unpackRArrayString
, unpackRInt
, unpackRBool
, unpackRDouble
, unpackRString
, unpackRSym
, unpackRVector
, unpackRListTag
, unpackRSEXPWithAttrib
, rRepl
) where
import Network
import System.IO (hSetBuffering, hFlush, BufferMode(NoBuffering), stdout)
import qualified Data.ByteString.Char8 as B
import qualified Data.ByteString.Lazy.Char8 as BL
import Data.Binary
import Data.Bits
import qualified Data.ByteString.Internal as BI
import Network.Rserve.Constants
import Network.Rserve.Internal
type RserveError = String
type Result = Either RserveError (Maybe RSEXP)
connect :: String
->Int
->IO RConn
connect server port = do
h <- connectTo server (PortNumber (fromIntegral port))
hSetBuffering h NoBuffering
idString <- B.hGet h 12
a <- B.hGetNonBlocking h 10000
let (sig, rserveVersion, protocol, attributes) = parseIdString (B.append idString a)
return RConn {rcHandle=h, rcRserveSig=sig, rcRserveVersion=rserveVersion, rcProtocol=protocol, rcAttributes=attributes}
eval :: RConn -> String -> IO Result
eval rconn = eval' cmdEval rconn . DTString
voidEval :: RConn -> String -> IO ()
voidEval rconn cmd = do _ <- eval' cmdVoidEval rconn (DTString cmd)
return ()
login :: RConn
-> String
-> String
-> IO Result
login rconn name pwd = eval' cmdLogin rconn (DTString (name ++ "\n" ++ pwd))
shutdown :: RConn -> IO()
shutdown rconn = do
_ <- eval' cmdShutdown rconn (DTString "")
return ()
openFile :: RConn -> String -> IO Result
openFile rconn = eval' cmdOpenFile rconn . DTString
writeFile :: RConn -> B.ByteString -> IO Result
writeFile rconn = eval' cmdWriteFile rconn . DTBytestream . map BI.c2w . B.unpack
createFile :: RConn -> String -> IO Result
createFile rconn = eval' cmdCreateFile rconn . DTString
closeFile :: RConn -> String -> IO Result
closeFile rconn = eval' cmdCloseFile rconn . DTString
removeFile :: RConn -> String -> IO Result
removeFile rconn = eval' cmdRemoveFile rconn . DTString
assign :: RConn -> String -> RSEXP -> IO Result
assign rconn symbol = eval' cmdSetSexp rconn . DTAssign symbol
class ResultUnpack a where
unpack :: Result -> Maybe a
instance ResultUnpack Int where
unpack (Right (Just (RInt x))) = Just x
unpack _ = Nothing
instance ResultUnpack Double where
unpack (Right (Just (RDouble x))) = Just x
unpack _ = Nothing
instance ResultUnpack String where
unpack (Right (Just (RString x))) = Just x
unpack (Right (Just (RSym x))) = Just x
unpack _ = Nothing
instance ResultUnpack Bool where
unpack (Right (Just (RBool x))) = Just x
unpack _ = Nothing
instance ResultUnpack [Int] where
unpack (Right (Just (RArrayInt x))) = Just x
unpack _ = Nothing
instance ResultUnpack [Double] where
unpack (Right (Just (RArrayDouble x))) = Just x
unpack _ = Nothing
instance ResultUnpack [String] where
unpack (Right (Just (RArrayString x))) = Just x
unpack _ = Nothing
instance ResultUnpack [Bool] where
unpack (Right (Just (RArrayBool x))) = Just x
unpack _ = Nothing
instance ResultUnpack [(Double, Double)] where
unpack (Right (Just (RArrayComplex x))) = Just x
unpack _ = Nothing
instance ResultUnpack (RSEXP, RSEXP) where
unpack (Right (Just (RSEXPWithAttrib a v))) = Just (a,v)
unpack _ = Nothing
instance ResultUnpack [RSEXP] where
unpack (Right (Just (RVector v))) = Just v
unpack _ = Nothing
instance ResultUnpack [(RSEXP, RSEXP)] where
unpack (Right (Just (RListTag l))) = Just l
unpack _ = Nothing
unpackDT :: DT -> Maybe RSEXP
unpackDT (DTSexp x) = Just x
unpackDT _ = Nothing
unpackRArrayInt :: Result -> Maybe [Int]
unpackRArrayInt (Right (Just (RArrayInt is))) = Just is
unpackRArrayInt _ = Nothing
unpackRArrayDouble :: Result -> Maybe [Double]
unpackRArrayDouble (Right (Just (RArrayDouble ds))) = Just ds
unpackRArrayDouble _ = Nothing
unpackRArrayComplex :: Result -> Maybe [(Double, Double)]
unpackRArrayComplex (Right (Just (RArrayComplex cs))) = Just cs
unpackRArrayComplex _ = Nothing
unpackRArrayString :: Result -> Maybe [String]
unpackRArrayString (Right (Just (RArrayString ss))) = Just ss
unpackRArrayString _ = Nothing
unpackRArrayBool :: Result -> Maybe [Bool]
unpackRArrayBool (Right (Just (RArrayBool bs))) = Just bs
unpackRArrayBool _ = Nothing
unpackRInt :: Result -> Maybe Int
unpackRInt (Right (Just (RInt i))) = Just i
unpackRInt _ = Nothing
unpackRDouble :: Result -> Maybe Double
unpackRDouble (Right (Just (RDouble d))) = Just d
unpackRDouble _ = Nothing
unpackRString :: Result -> Maybe String
unpackRString (Right (Just (RString s))) = Just s
unpackRString _ = Nothing
unpackRSym :: Result -> Maybe String
unpackRSym (Right (Just (RSym s))) = Just s
unpackRSym _ = Nothing
unpackRBool :: Result -> Maybe Bool
unpackRBool (Right (Just (RBool b))) = Just b
unpackRBool _ = Nothing
unpackRVector :: Result -> Maybe [RSEXP]
unpackRVector (Right (Just (RVector v))) = Just v
unpackRVector _ = Nothing
unpackRListTag :: Result -> Maybe [(RSEXP, RSEXP)]
unpackRListTag (Right (Just (RListTag ls))) = Just ls
unpackRListTag _ = Nothing
unpackRSEXPWithAttrib :: Result -> Maybe (RSEXP, RSEXP)
unpackRSEXPWithAttrib (Right (Just (RSEXPWithAttrib attrib value)))=Just (attrib, value)
unpackRSEXPWithAttrib _ = Nothing
eval' :: Word32 -> RConn -> DT -> IO Result
eval' rcmd rconn cmd = do
let msg = createMessage rcmd (Just cmd)
response <- request rconn msg
if responseOK response then return (Right (qap1Content response >>= unpackDT))
else return (Left (getError response))
request :: RConn -> QAP1Message -> IO QAP1Message
request rconn msg = do
let msgContent = encode msg
BL.hPut h msgContent
header <- BL.hGet h 16
let rheader = decode header :: QAP1Header
let bodyLength = fromIntegral(headerLen rheader) :: Int
body <- if bodyLength > 0 then BL.hGet h bodyLength else return (BL.pack "")
let content = if bodyLength > 0 then Just (decode body :: DT) else Nothing
return QAP1Message {qap1Header = rheader, qap1Content = content }
where h = rcHandle rconn
createMessage :: Word32 -> Maybe DT -> QAP1Message
createMessage cmdId content = QAP1Message (QAP1Header cmdId tlen 0 0) content
where tlen = fromIntegral contentLength :: Word32
contentLength = case content of
Nothing -> 0
Just x -> BL.length (encode x)
rRepl :: IO()
rRepl = connect "localhost" 6311 >>= rReplLoop
rReplLoop :: RConn -> IO()
rReplLoop conn = do
putStr ">"
hFlush stdout
cmd <- getLine
response <- eval conn cmd
case response of
Right x -> print x
Left x -> print ("Error:"++show x)
rReplLoop conn
responseOK :: QAP1Message -> Bool
responseOK h = headerCmd (qap1Header h) .&. respOK == respOK
getError :: QAP1Message -> String
getError h = if errmatch == [] then show h ++ " cmd stat:"++ show s else snd (head errmatch)
where s = cmdStat (headerCmd (qap1Header h))
errmatch = filter (\(c,_) -> c == s) errorStats