diff --git a/.git/HEAD b/.git/HEAD new file mode 100644 --- /dev/null +++ b/.git/HEAD @@ -0,0 +1,1 @@ +ref: refs/heads/master diff --git a/.git/config b/.git/config new file mode 100644 --- /dev/null +++ b/.git/config @@ -0,0 +1,11 @@ +[core] + repositoryformatversion = 0 + filemode = true + bare = false + logallrefupdates = true +[remote "origin"] + fetch = +refs/heads/*:refs/remotes/origin/* + url = git@github.com:tdoris/Rclient.git +[branch "master"] + remote = origin + merge = refs/heads/master diff --git a/.git/description b/.git/description new file mode 100644 --- /dev/null +++ b/.git/description @@ -0,0 +1,1 @@ +Unnamed repository; edit this file 'description' to name the repository. diff --git a/.git/hooks/applypatch-msg.sample b/.git/hooks/applypatch-msg.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/applypatch-msg.sample @@ -0,0 +1,15 @@ +#!/bin/sh +# +# An example hook script to check the commit log message taken by +# applypatch from an e-mail message. +# +# The hook should exit with non-zero status after issuing an +# appropriate message if it wants to stop the commit. The hook is +# allowed to edit the commit message file. +# +# To enable this hook, rename this file to "applypatch-msg". + +. git-sh-setup +test -x "$GIT_DIR/hooks/commit-msg" && + exec "$GIT_DIR/hooks/commit-msg" ${1+"$@"} +: diff --git a/.git/hooks/commit-msg.sample b/.git/hooks/commit-msg.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/commit-msg.sample @@ -0,0 +1,24 @@ +#!/bin/sh +# +# An example hook script to check the commit log message. +# Called by git-commit with one argument, the name of the file +# that has the commit message. The hook should exit with non-zero +# status after issuing an appropriate message if it wants to stop the +# commit. The hook is allowed to edit the commit message file. +# +# To enable this hook, rename this file to "commit-msg". + +# Uncomment the below to add a Signed-off-by line to the message. +# Doing this in a hook is a bad idea in general, but the prepare-commit-msg +# hook is more suited to it. +# +# SOB=$(git var GIT_AUTHOR_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p') +# grep -qs "^$SOB" "$1" || echo "$SOB" >> "$1" + +# This example catches duplicate Signed-off-by lines. + +test "" = "$(grep '^Signed-off-by: ' "$1" | + sort | uniq -c | sed -e '/^[ ]*1[ ]/d')" || { + echo >&2 Duplicate Signed-off-by lines. + exit 1 +} diff --git a/.git/hooks/post-commit.sample b/.git/hooks/post-commit.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/post-commit.sample @@ -0,0 +1,8 @@ +#!/bin/sh +# +# An example hook script that is called after a successful +# commit is made. +# +# To enable this hook, rename this file to "post-commit". + +: Nothing diff --git a/.git/hooks/post-receive.sample b/.git/hooks/post-receive.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/post-receive.sample @@ -0,0 +1,15 @@ +#!/bin/sh +# +# An example hook script for the "post-receive" event. +# +# The "post-receive" script is run after receive-pack has accepted a pack +# and the repository has been updated. It is passed arguments in through +# stdin in the form +# +# For example: +# aa453216d1b3e49e7f6f98441fa56946ddcd6a20 68f7abf4e6f922807889f52bc043ecd31b79f814 refs/heads/master +# +# see contrib/hooks/ for a sample, or uncomment the next line and +# rename the file to "post-receive". + +#. /usr/share/doc/git-core/contrib/hooks/post-receive-email diff --git a/.git/hooks/post-update.sample b/.git/hooks/post-update.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/post-update.sample @@ -0,0 +1,8 @@ +#!/bin/sh +# +# An example hook script to prepare a packed repository for use over +# dumb transports. +# +# To enable this hook, rename this file to "post-update". + +exec git-update-server-info diff --git a/.git/hooks/pre-applypatch.sample b/.git/hooks/pre-applypatch.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/pre-applypatch.sample @@ -0,0 +1,14 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed +# by applypatch from an e-mail message. +# +# The hook should exit with non-zero status after issuing an +# appropriate message if it wants to stop the commit. +# +# To enable this hook, rename this file to "pre-applypatch". + +. git-sh-setup +test -x "$GIT_DIR/hooks/pre-commit" && + exec "$GIT_DIR/hooks/pre-commit" ${1+"$@"} +: diff --git a/.git/hooks/pre-commit.sample b/.git/hooks/pre-commit.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/pre-commit.sample @@ -0,0 +1,46 @@ +#!/bin/sh +# +# An example hook script to verify what is about to be committed. +# Called by git-commit with no arguments. The hook should +# exit with non-zero status after issuing an appropriate message if +# it wants to stop the commit. +# +# To enable this hook, rename this file to "pre-commit". + +if git-rev-parse --verify HEAD >/dev/null 2>&1 +then + against=HEAD +else + # Initial commit: diff against an empty tree object + against=4b825dc642cb6eb9a060e54bf8d69288fbee4904 +fi + +# If you want to allow non-ascii filenames set this variable to true. +allownonascii=$(git config hooks.allownonascii) + +# Cross platform projects tend to avoid non-ascii filenames; prevent +# them from being added to the repository. We exploit the fact that the +# printable range starts at the space character and ends with tilde. +if [ "$allownonascii" != "true" ] && + # Note that the use of brackets around a tr range is ok here, (it's + # even required, for portability to Solaris 10's /usr/bin/tr), since + # the square bracket bytes happen to fall in the designated range. + test "$(git diff --cached --name-only --diff-filter=A -z $against | + LC_ALL=C tr -d '[ -~]\0')" +then + echo "Error: Attempt to add a non-ascii file name." + echo + echo "This can cause problems if you want to work" + echo "with people on other platforms." + echo + echo "To be portable it is advisable to rename the file ..." + echo + echo "If you know what you are doing you can disable this" + echo "check using:" + echo + echo " git config hooks.allownonascii true" + echo + exit 1 +fi + +exec git diff-index --check --cached $against -- diff --git a/.git/hooks/pre-rebase.sample b/.git/hooks/pre-rebase.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/pre-rebase.sample @@ -0,0 +1,169 @@ +#!/bin/sh +# +# Copyright (c) 2006, 2008 Junio C Hamano +# +# The "pre-rebase" hook is run just before "git-rebase" starts doing +# its job, and can prevent the command from running by exiting with +# non-zero status. +# +# The hook is called with the following parameters: +# +# $1 -- the upstream the series was forked from. +# $2 -- the branch being rebased (or empty when rebasing the current branch). +# +# This sample shows how to prevent topic branches that are already +# merged to 'next' branch from getting rebased, because allowing it +# would result in rebasing already published history. + +publish=next +basebranch="$1" +if test "$#" = 2 +then + topic="refs/heads/$2" +else + topic=`git symbolic-ref HEAD` || + exit 0 ;# we do not interrupt rebasing detached HEAD +fi + +case "$topic" in +refs/heads/??/*) + ;; +*) + exit 0 ;# we do not interrupt others. + ;; +esac + +# Now we are dealing with a topic branch being rebased +# on top of master. Is it OK to rebase it? + +# Does the topic really exist? +git show-ref -q "$topic" || { + echo >&2 "No such branch $topic" + exit 1 +} + +# Is topic fully merged to master? +not_in_master=`git-rev-list --pretty=oneline ^master "$topic"` +if test -z "$not_in_master" +then + echo >&2 "$topic is fully merged to master; better remove it." + exit 1 ;# we could allow it, but there is no point. +fi + +# Is topic ever merged to next? If so you should not be rebasing it. +only_next_1=`git-rev-list ^master "^$topic" ${publish} | sort` +only_next_2=`git-rev-list ^master ${publish} | sort` +if test "$only_next_1" = "$only_next_2" +then + not_in_topic=`git-rev-list "^$topic" master` + if test -z "$not_in_topic" + then + echo >&2 "$topic is already up-to-date with master" + exit 1 ;# we could allow it, but there is no point. + else + exit 0 + fi +else + not_in_next=`git-rev-list --pretty=oneline ^${publish} "$topic"` + perl -e ' + my $topic = $ARGV[0]; + my $msg = "* $topic has commits already merged to public branch:\n"; + my (%not_in_next) = map { + /^([0-9a-f]+) /; + ($1 => 1); + } split(/\n/, $ARGV[1]); + for my $elem (map { + /^([0-9a-f]+) (.*)$/; + [$1 => $2]; + } split(/\n/, $ARGV[2])) { + if (!exists $not_in_next{$elem->[0]}) { + if ($msg) { + print STDERR $msg; + undef $msg; + } + print STDERR " $elem->[1]\n"; + } + } + ' "$topic" "$not_in_next" "$not_in_master" + exit 1 +fi + +exit 0 + +################################################################ + +This sample hook safeguards topic branches that have been +published from being rewound. + +The workflow assumed here is: + + * Once a topic branch forks from "master", "master" is never + merged into it again (either directly or indirectly). + + * Once a topic branch is fully cooked and merged into "master", + it is deleted. If you need to build on top of it to correct + earlier mistakes, a new topic branch is created by forking at + the tip of the "master". This is not strictly necessary, but + it makes it easier to keep your history simple. + + * Whenever you need to test or publish your changes to topic + branches, merge them into "next" branch. + +The script, being an example, hardcodes the publish branch name +to be "next", but it is trivial to make it configurable via +$GIT_DIR/config mechanism. + +With this workflow, you would want to know: + +(1) ... if a topic branch has ever been merged to "next". Young + topic branches can have stupid mistakes you would rather + clean up before publishing, and things that have not been + merged into other branches can be easily rebased without + affecting other people. But once it is published, you would + not want to rewind it. + +(2) ... if a topic branch has been fully merged to "master". + Then you can delete it. More importantly, you should not + build on top of it -- other people may already want to + change things related to the topic as patches against your + "master", so if you need further changes, it is better to + fork the topic (perhaps with the same name) afresh from the + tip of "master". + +Let's look at this example: + + o---o---o---o---o---o---o---o---o---o "next" + / / / / + / a---a---b A / / + / / / / + / / c---c---c---c B / + / / / \ / + / / / b---b C \ / + / / / / \ / + ---o---o---o---o---o---o---o---o---o---o---o "master" + + +A, B and C are topic branches. + + * A has one fix since it was merged up to "next". + + * B has finished. It has been fully merged up to "master" and "next", + and is ready to be deleted. + + * C has not merged to "next" at all. + +We would want to allow C to be rebased, refuse A, and encourage +B to be deleted. + +To compute (1): + + git-rev-list ^master ^topic next + git-rev-list ^master next + + if these match, topic has not merged in next at all. + +To compute (2): + + git-rev-list master..topic + + if this is empty, it is fully merged to "master". diff --git a/.git/hooks/prepare-commit-msg.sample b/.git/hooks/prepare-commit-msg.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/prepare-commit-msg.sample @@ -0,0 +1,36 @@ +#!/bin/sh +# +# An example hook script to prepare the commit log message. +# Called by git-commit with the name of the file that has the +# commit message, followed by the description of the commit +# message's source. The hook's purpose is to edit the commit +# message file. If the hook fails with a non-zero status, +# the commit is aborted. +# +# To enable this hook, rename this file to "prepare-commit-msg". + +# This hook includes three examples. The first comments out the +# "Conflicts:" part of a merge commit. +# +# The second includes the output of "git diff --name-status -r" +# into the message, just before the "git status" output. It is +# commented because it doesn't cope with --amend or with squashed +# commits. +# +# The third example adds a Signed-off-by line to the message, that can +# still be edited. This is rarely a good idea. + +case "$2,$3" in + merge,) + perl -i.bak -ne 's/^/# /, s/^# #/#/ if /^Conflicts/ .. /#/; print' "$1" ;; + +# ,|template,) +# perl -i.bak -pe ' +# print "\n" . `git diff --cached --name-status -r` +# if /^#/ && $first++ == 0' "$1" ;; + + *) ;; +esac + +# SOB=$(git var GIT_AUTHOR_IDENT | sed -n 's/^\(.*>\).*$/Signed-off-by: \1/p') +# grep -qs "^$SOB" "$1" || echo "$SOB" >> "$1" diff --git a/.git/hooks/update.sample b/.git/hooks/update.sample new file mode 100644 --- /dev/null +++ b/.git/hooks/update.sample @@ -0,0 +1,128 @@ +#!/bin/sh +# +# An example hook script to blocks unannotated tags from entering. +# Called by git-receive-pack with arguments: refname sha1-old sha1-new +# +# To enable this hook, rename this file to "update". +# +# Config +# ------ +# hooks.allowunannotated +# This boolean sets whether unannotated tags will be allowed into the +# repository. By default they won't be. +# hooks.allowdeletetag +# This boolean sets whether deleting tags will be allowed in the +# repository. By default they won't be. +# hooks.allowmodifytag +# This boolean sets whether a tag may be modified after creation. By default +# it won't be. +# hooks.allowdeletebranch +# This boolean sets whether deleting branches will be allowed in the +# repository. By default they won't be. +# hooks.denycreatebranch +# This boolean sets whether remotely creating branches will be denied +# in the repository. By default this is allowed. +# + +# --- Command line +refname="$1" +oldrev="$2" +newrev="$3" + +# --- Safety check +if [ -z "$GIT_DIR" ]; then + echo "Don't run this script from the command line." >&2 + echo " (if you want, you could supply GIT_DIR then run" >&2 + echo " $0 )" >&2 + exit 1 +fi + +if [ -z "$refname" -o -z "$oldrev" -o -z "$newrev" ]; then + echo "Usage: $0 " >&2 + exit 1 +fi + +# --- Config +allowunannotated=$(git config --bool hooks.allowunannotated) +allowdeletebranch=$(git config --bool hooks.allowdeletebranch) +denycreatebranch=$(git config --bool hooks.denycreatebranch) +allowdeletetag=$(git config --bool hooks.allowdeletetag) +allowmodifytag=$(git config --bool hooks.allowmodifytag) + +# check for no description +projectdesc=$(sed -e '1q' "$GIT_DIR/description") +case "$projectdesc" in +"Unnamed repository"* | "") + echo "*** Project description file hasn't been set" >&2 + exit 1 + ;; +esac + +# --- Check types +# if $newrev is 0000...0000, it's a commit to delete a ref. +zero="0000000000000000000000000000000000000000" +if [ "$newrev" = "$zero" ]; then + newrev_type=delete +else + newrev_type=$(git-cat-file -t $newrev) +fi + +case "$refname","$newrev_type" in + refs/tags/*,commit) + # un-annotated tag + short_refname=${refname##refs/tags/} + if [ "$allowunannotated" != "true" ]; then + echo "*** The un-annotated tag, $short_refname, is not allowed in this repository" >&2 + echo "*** Use 'git tag [ -a | -s ]' for tags you want to propagate." >&2 + exit 1 + fi + ;; + refs/tags/*,delete) + # delete tag + if [ "$allowdeletetag" != "true" ]; then + echo "*** Deleting a tag is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/tags/*,tag) + # annotated tag + if [ "$allowmodifytag" != "true" ] && git rev-parse $refname > /dev/null 2>&1 + then + echo "*** Tag '$refname' already exists." >&2 + echo "*** Modifying a tag is not allowed in this repository." >&2 + exit 1 + fi + ;; + refs/heads/*,commit) + # branch + if [ "$oldrev" = "$zero" -a "$denycreatebranch" = "true" ]; then + echo "*** Creating a branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/heads/*,delete) + # delete branch + if [ "$allowdeletebranch" != "true" ]; then + echo "*** Deleting a branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + refs/remotes/*,commit) + # tracking branch + ;; + refs/remotes/*,delete) + # delete tracking branch + if [ "$allowdeletebranch" != "true" ]; then + echo "*** Deleting a tracking branch is not allowed in this repository" >&2 + exit 1 + fi + ;; + *) + # Anything else (is there anything else?) + echo "*** Update hook: unknown type of update to ref $refname of type $newrev_type" >&2 + exit 1 + ;; +esac + +# --- Finished +exit 0 diff --git a/.git/index b/.git/index new file mode 100644 Binary files /dev/null and b/.git/index differ diff --git a/.git/info/exclude b/.git/info/exclude new file mode 100644 --- /dev/null +++ b/.git/info/exclude @@ -0,0 +1,6 @@ +# git-ls-files --others --exclude-from=.git/info/exclude +# Lines that start with '#' are comments. +# For a project mostly in C, the following would be a good set of +# exclude patterns (uncomment them if you want to use them): +# *.[oa] +# *~ diff --git a/.git/logs/HEAD b/.git/logs/HEAD new file mode 100644 --- /dev/null +++ b/.git/logs/HEAD @@ -0,0 +1,1 @@ +0000000000000000000000000000000000000000 e0c77b133b8d689d094f5be16e499d44bbf26f61 Tom Doris 1291459940 +0000 clone: from git@github.com:tdoris/Rclient.git diff --git a/.git/logs/refs/heads/master b/.git/logs/refs/heads/master new file mode 100644 --- /dev/null +++ b/.git/logs/refs/heads/master @@ -0,0 +1,1 @@ +0000000000000000000000000000000000000000 e0c77b133b8d689d094f5be16e499d44bbf26f61 Tom Doris 1291459940 +0000 clone: from git@github.com:tdoris/Rclient.git diff --git a/.git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.idx b/.git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.idx new file mode 100644 Binary files /dev/null and b/.git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.idx differ diff --git a/.git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.pack b/.git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.pack new file mode 100644 Binary files /dev/null and b/.git/objects/pack/pack-692007fe248a601ec31a4397d90d0022285297fd.pack differ diff --git a/.git/packed-refs b/.git/packed-refs new file mode 100644 --- /dev/null +++ b/.git/packed-refs @@ -0,0 +1,2 @@ +# pack-refs with: peeled +e0c77b133b8d689d094f5be16e499d44bbf26f61 refs/remotes/origin/master diff --git a/.git/refs/heads/master b/.git/refs/heads/master new file mode 100644 --- /dev/null +++ b/.git/refs/heads/master @@ -0,0 +1,1 @@ +e0c77b133b8d689d094f5be16e499d44bbf26f61 diff --git a/.git/refs/remotes/origin/HEAD b/.git/refs/remotes/origin/HEAD new file mode 100644 --- /dev/null +++ b/.git/refs/remotes/origin/HEAD @@ -0,0 +1,1 @@ +ref: refs/remotes/origin/master diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE diff --git a/Main.hs b/Main.hs new file mode 100644 --- /dev/null +++ b/Main.hs @@ -0,0 +1,6 @@ +import Rclient + +main :: IO() +main = rRepl + + diff --git a/Network/Rserve/Client.hs b/Network/Rserve/Client.hs new file mode 100644 --- /dev/null +++ b/Network/Rserve/Client.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE FlexibleInstances,TypeSynonymInstances #-} + +-- | This module allows you to issue R commands from Haskell to be executed via Rserve and get the results back in Haskell data types. + +module Network.Rserve.Client + (RConn(..) + , Result + , RserveError + , ResultUnpack(..) + , RSEXP(..) + , connect + , eval + , voidEval + , login + , shutdown + , openFile + , createFile + , closeFile + , removeFile + --, Network.Rserve.Client.readFile + , Network.Rserve.Client.writeFile + , assign + , unpackRArrayInt + , unpackRArrayBool + , unpackRArrayDouble + , unpackRArrayComplex + , unpackRArrayString + , unpackRInt + , unpackRBool + , unpackRDouble + , unpackRString + , unpackRSym + , unpackRVector + , unpackRListTag + , unpackRSEXPWithAttrib + , rRepl + ) where + + -- TODO : + -- handle authenticated connections to Rserve + -- support LARGE + -- support readFile (if Rserve fixes their bug omitting DT_BYTESTREAM header, and/or someone asks for readFile) + +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 to Rserve server +connect :: String -- ^ server name, e.g. "localhost" + ->Int -- ^ port, e.g. 6311 + ->IO RConn -- ^ the connection +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} + +-- | evaluate an R expression +eval :: RConn -> String -> IO Result +eval rconn = eval' cmdEval rconn . DTString + +-- | evaluate an R expression, discarding any result +voidEval :: RConn -> String -> IO () +voidEval rconn cmd = do _ <- eval' cmdVoidEval rconn (DTString cmd) + return () + +-- | login to Rserve, not normally required, for authenticated sessions only +login :: RConn + -> String -- ^ user name + -> String -- ^ password + -> IO Result +login rconn name pwd = eval' cmdLogin rconn (DTString (name ++ "\n" ++ pwd)) + +-- | shutdown the Rserve server +shutdown :: RConn -> IO() +shutdown rconn = do + _ <- eval' cmdShutdown rconn (DTString "") + return () + +-- | open a file +openFile :: RConn -> String -> IO Result +openFile rconn = eval' cmdOpenFile rconn . DTString + +-- | write content to a file accessible to the Rserve session +writeFile :: RConn -> B.ByteString -> IO Result +writeFile rconn = eval' cmdWriteFile rconn . DTBytestream . map BI.c2w . B.unpack + +-- | create a file +createFile :: RConn -> String -> IO Result +createFile rconn = eval' cmdCreateFile rconn . DTString + +-- | close a file +closeFile :: RConn -> String -> IO Result +closeFile rconn = eval' cmdCloseFile rconn . DTString + +-- | remove a file +removeFile :: RConn -> String -> IO Result +removeFile rconn = eval' cmdRemoveFile rconn . DTString + +-- read file, Rserve seems not to have ever fixed the bug whereby the response is omits the DT_BYTESTREAM header, so we have to write custom serialisation for this one function. +-- nobody's expressed a need for it, so leaving it out for now +--readFile :: RConn -> String -> IO QAP1Message +--readFile rconn = undefined + +-- | assign a RSEXP value to a symbol +assign :: RConn -> String -> RSEXP -> IO Result +assign rconn symbol = eval' cmdSetSexp rconn . DTAssign symbol + +-- | The ResultUnpack instances are used to extract R data structures from the Result container. +class ResultUnpack a where + unpack :: Result -> Maybe a + +-- | unpack RInt +instance ResultUnpack Int where + unpack (Right (Just (RInt x))) = Just x + unpack _ = Nothing + +-- | unpack RDouble +instance ResultUnpack Double where + unpack (Right (Just (RDouble x))) = Just x + unpack _ = Nothing + +-- | unpack RString, RSym +instance ResultUnpack String where + unpack (Right (Just (RString x))) = Just x + unpack (Right (Just (RSym x))) = Just x + unpack _ = Nothing + +-- | unpack RBool +instance ResultUnpack Bool where + unpack (Right (Just (RBool x))) = Just x + unpack _ = Nothing + +-- | unpack RArrayInt +instance ResultUnpack [Int] where + unpack (Right (Just (RArrayInt x))) = Just x + unpack _ = Nothing + +-- | unpack RArrayDouble +instance ResultUnpack [Double] where + unpack (Right (Just (RArrayDouble x))) = Just x + unpack _ = Nothing + +-- | unpack RArrayString +instance ResultUnpack [String] where + unpack (Right (Just (RArrayString x))) = Just x + unpack _ = Nothing + +-- | unpack RArrayBool +instance ResultUnpack [Bool] where + unpack (Right (Just (RArrayBool x))) = Just x + unpack _ = Nothing + +-- | unpack RArrayComplex +instance ResultUnpack [(Double, Double)] where + unpack (Right (Just (RArrayComplex x))) = Just x + unpack _ = Nothing + +-- | unpack RSEXPWithAttrib +instance ResultUnpack (RSEXP, RSEXP) where + unpack (Right (Just (RSEXPWithAttrib a v))) = Just (a,v) + unpack _ = Nothing +-- | unpack RVector +instance ResultUnpack [RSEXP] where + unpack (Right (Just (RVector v))) = Just v + unpack _ = Nothing + +-- | unpack RListTag +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 + +-- | unpack a Result containing an RArrayInt +unpackRArrayInt :: Result -> Maybe [Int] +unpackRArrayInt (Right (Just (RArrayInt is))) = Just is +unpackRArrayInt _ = Nothing + +-- | unpack a Result containing an RArrayDouble +unpackRArrayDouble :: Result -> Maybe [Double] +unpackRArrayDouble (Right (Just (RArrayDouble ds))) = Just ds +unpackRArrayDouble _ = Nothing + +-- | unpack a Result containing an RArrayComplex +unpackRArrayComplex :: Result -> Maybe [(Double, Double)] +unpackRArrayComplex (Right (Just (RArrayComplex cs))) = Just cs +unpackRArrayComplex _ = Nothing + +-- | unpack a Result containing an RArrayString +unpackRArrayString :: Result -> Maybe [String] +unpackRArrayString (Right (Just (RArrayString ss))) = Just ss +unpackRArrayString _ = Nothing + +-- | unpack a Result containing an RArrayBool +unpackRArrayBool :: Result -> Maybe [Bool] +unpackRArrayBool (Right (Just (RArrayBool bs))) = Just bs +unpackRArrayBool _ = Nothing + +-- | unpack a Result containing an RInt +unpackRInt :: Result -> Maybe Int +unpackRInt (Right (Just (RInt i))) = Just i +unpackRInt _ = Nothing + +-- | unpack a Result containing an RDouble +unpackRDouble :: Result -> Maybe Double +unpackRDouble (Right (Just (RDouble d))) = Just d +unpackRDouble _ = Nothing + +-- | unpack a Result containing an RString +unpackRString :: Result -> Maybe String +unpackRString (Right (Just (RString s))) = Just s +unpackRString _ = Nothing + +-- | unpack a Result containing an RSym +unpackRSym :: Result -> Maybe String +unpackRSym (Right (Just (RSym s))) = Just s +unpackRSym _ = Nothing + +-- | unpack a Result containing an RBool +unpackRBool :: Result -> Maybe Bool +unpackRBool (Right (Just (RBool b))) = Just b +unpackRBool _ = Nothing + +-- | unpack a Result containing an RVector +unpackRVector :: Result -> Maybe [RSEXP] +unpackRVector (Right (Just (RVector v))) = Just v +unpackRVector _ = Nothing + +-- | unpack a Result containing an RListTag +unpackRListTag :: Result -> Maybe [(RSEXP, RSEXP)] +unpackRListTag (Right (Just (RListTag ls))) = Just ls +unpackRListTag _ = Nothing + +-- | unpack a Result containing an RSEXPWithAttrib +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 +-- putStrLn ("request:"++ show (lazyByteStringToString msgContent)) + BL.hPut h msgContent + header <- BL.hGet h 16 + let rheader = decode header :: QAP1Header +-- putStrLn ("header:"++show (lazyByteStringToString header)) + let bodyLength = fromIntegral(headerLen rheader) :: Int + body <- if bodyLength > 0 then BL.hGet h bodyLength else return (BL.pack "") +-- putStrLn ("bodylen:"++show bodyLength) + let content = if bodyLength > 0 then Just (decode body :: DT) else Nothing +-- putStrLn ("body:"++show (lazyByteStringToString body)) + 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) + +{- | Read-evaluate-print-loop for interacting with Rserve session. +in ghci, load this module and run this command to test and play with Rserve +this is useful to check the actual types returned by Rserve, e.g. + +$ ghci + +Prelude>:m Network.Rserve.Client + +Prelude Network.Rserve.Client> rRepl + +\>c(1,2,3) + +Just (RArrayDouble [1.0,2.0,3.0]) + +\>summary(rnorm(100)) + +Just (RSEXPWithAttrib (RListTag [(RArrayString [\"Min.\",\"1st Qu.\",\"Median\",\"Mean\",\"3rd Qu.\",\"Max.\"],RSym \"names\"),(RArrayString [\"table\"],RSym \"class\")]) (RArrayDouble [-2.914,-0.5481,0.1618,0.1491,0.9279,3.001])) +-} +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 + diff --git a/Network/Rserve/Constants.hs b/Network/Rserve/Constants.hs new file mode 100644 --- /dev/null +++ b/Network/Rserve/Constants.hs @@ -0,0 +1,154 @@ +module Network.Rserve.Constants where + +import Data.Binary +import Data.Bits + +cmds :: [(String, Word32)] +cmds = [("login", cmdLogin), ("voidEval", cmdVoidEval), ("eval", cmdEval), ("shutdown", cmdShutdown), + ("openFile", cmdOpenFile), ("createFile", cmdCreateFile), ("closeFile", cmdCloseFile), + ("readFile", cmdReadFile), ("writeFile", cmdWriteFile), ("removeFile", cmdRemoveFile), ("setSexp", cmdSetSexp), ("assignSexp", cmdAssignSexp), + ("detachSession", cmdDetachSession), ("detachedVoidEval", cmdDetachedVoidEval), ("attachSession", cmdAttachSession)] + +cmdLogin :: Word32 +cmdLogin = 0x0001 +cmdVoidEval :: Word32 +cmdVoidEval = 0x0002 +cmdEval :: Word32 +cmdEval = 0x0003 +cmdShutdown :: Word32 +cmdShutdown = 0x0004 +cmdOpenFile :: Word32 +cmdOpenFile = 0x0010 +cmdCreateFile ::Word32 +cmdCreateFile = 0x0011 +cmdCloseFile :: Word32 +cmdCloseFile = 0x0012 +cmdReadFile :: Word32 +cmdReadFile = 0x0013 +cmdWriteFile :: Word32 +cmdWriteFile = 0x0014 +cmdRemoveFile ::Word32 +cmdRemoveFile = 0x0015 +cmdSetSexp :: Word32 +cmdSetSexp = 0x0020 +cmdAssignSexp :: Word32 +cmdAssignSexp = 0x0021 +cmdDetachSession :: Word32 +cmdDetachSession = 0x0030 +cmdDetachedVoidEval :: Word32 +cmdDetachedVoidEval = 0x0031 +cmdAttachSession :: Word32 +cmdAttachSession = 0x0032 +cmdResp :: Word32 +cmdResp = 0x10000 + +cmdStat :: Word32 -> Word32 +cmdStat x = (x `shiftR` 24) .&. 127 + +respOK :: Word32 +respOK = cmdResp .|. 0x0001 +respErr :: Word32 +respErr = cmdResp .|. 0x0002 + +errAuthFailed :: Word32 +errAuthFailed = 0x41 +errConnBroken :: Word32 +errConnBroken = 0x42 +errInvCmd :: Word32 +errInvCmd = 0x43 +errInvPar :: Word32 +errInvPar = 0x44 +errRerror :: Word32 +errRerror = 0x45 +errIOerror :: Word32 +errIOerror = 0x46 +errNotOpen :: Word32 +errNotOpen = 0x47 +errAccessDenied :: Word32 +errAccessDenied = 0x48 +errUnsupportedCmd :: Word32 +errUnsupportedCmd = 0x49 +errDataOverflow :: Word32 +errDataOverflow = 0x4b +errObjectTooBig :: Word32 +errObjectTooBig = 0x4c +errOutOfMem :: Word32 +errOutOfMem = 0x4d +errCtrlClosed :: Word32 +errCtrlClosed = 0x4e +errSessionBusy :: Word32 +errSessionBusy = 0x50 +errDetachFailed :: Word32 +errDetachFailed = 0x51 +errorStats :: [(Word32, String)] +errorStats = [(errAuthFailed,"errAuthFailed"), (errConnBroken,"errConnBroken"), (errInvCmd,"errInvCmd"), (errInvPar,"errInvPar"), + (errRerror,"errRerror"), (errIOerror,"errIOerror"), (errNotOpen,"errNotOpen"), (errAccessDenied,"errAccessDenied"), + (errUnsupportedCmd,"errUnsupportedCmd"), (errDataOverflow,"errDataOverflow"), (errObjectTooBig,"errObjectTooBig"), + (errOutOfMem,"errOutOfMem"), (errCtrlClosed,"errCtrlClosed"), (errSessionBusy,"errSessionBusy"), (errDetachFailed,"errDetachFailed")] + +dtInt :: Word8 +dtInt = 1 +dtChar :: Word8 +dtChar = 2 +dtDouble :: Word8 +dtDouble = 3 +dtString :: Word8 +dtString = 4 +dtBytestream:: Word8 +dtBytestream = 5 +dtSexp :: Word8 +dtSexp = 10 +dtArray :: Word8 +dtArray = 11 +dtLarge :: Word8 +dtLarge = 64 + + + +xtNull:: Word8 +xtNull = 0 +xtInt:: Word8 +xtInt = 1 +xtDouble:: Word8 +xtDouble = 2 +xtStr:: Word8 +xtStr = 3 +xtLang:: Word8 +xtLang = 4 +xtSym:: Word8 +xtSym = 5 +xtBool:: Word8 +xtBool = 6 +xtS4:: Word8 +xtS4 = 7 +xtVector:: Word8 +xtVector = 16 +xtList:: Word8 +xtList = 17 +xtClos:: Word8 +xtClos = 18 +xtSymName:: Word8 +xtSymName = 19 +xtListNotag:: Word8 +xtListNotag = 20 +xtListTag:: Word8 +xtListTag = 21 +xtVectorExp:: Word8 +xtVectorExp = 26 +xtVectorStr:: Word8 +xtVectorStr = 27 +xtArrayInt:: Word8 +xtArrayInt = 32 +xtArrayDouble:: Word8 +xtArrayDouble = 33 +xtArrayStr:: Word8 +xtArrayStr = 34 +xtArrayBool:: Word8 +xtArrayBool = 36 +xtArrayCplx:: Word8 +xtArrayCplx = 38 +xtHasAttr:: Word8 +xtHasAttr = 128 +xtUnknown:: Word8 +xtUnknown = 48 + diff --git a/Network/Rserve/Internal.hs b/Network/Rserve/Internal.hs new file mode 100644 --- /dev/null +++ b/Network/Rserve/Internal.hs @@ -0,0 +1,296 @@ +module Network.Rserve.Internal where + +import System.IO +import Data.Bits +import Data.Binary +import Data.Binary.Put +import Data.Binary.Get +import Data.Binary.IEEE754 +import Data.Char +import Data.List +import Data.List.Split +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Lazy.Char8 as BL +import qualified Data.ByteString.Internal as BI +import Control.Monad +import Network.Rserve.Constants + +data Len24 = Len24 Word8 Word8 Word8 deriving Show + +instance Binary Len24 where + put (Len24 l1 l2 l3) = putWord8 l1 >> putWord8 l2 >> putWord8 l3 + get = do l1 <- getWord8 + l2 <- getWord8 + l3 <- getWord8 + return (Len24 l1 l2 l3) + +data QAP1Header = QAP1Header { headerCmd::Word32, headerLen ::Word32, headerDof::Word32, headerRes::Word32} deriving Show + +data QAP1Message = QAP1Message { qap1Header :: QAP1Header, qap1Content :: Maybe DT } deriving Show + +instance Binary QAP1Header where + put r = putWord32le (headerCmd r) >> putWord32le (headerLen r) >> putWord32le (headerDof r) >> putWord32le (headerRes r) + get = do c <- getWord32le + l <- getWord32le + d <- getWord32le + r <- getWord32le + return (QAP1Header c l d r) + +instance Binary QAP1Message where + put m = case qap1Content m of + Just dt -> put (qap1Header m) >> put dt + Nothing -> put (qap1Header m) + + get = do header <- get + content <- get + return (QAP1Message header content) + + +data DT = DTInt Int | DTChar Char | DTDouble Double | DTString String | DTBytestream [Word8] | DTSexp RSEXP | DTAssign String RSEXP + deriving (Show) + +instance Binary DT where + put (DTInt i) = putWord8 dtInt >> put (to24bit 0) >> putWord32le (fromIntegral i::Word32) + put (DTChar c) = putWord8 dtChar >> put (to24bit 0)>> putWord8 (BI.c2w c) + put (DTDouble d) = putWord8 dtDouble >> put (to24bit 0) >> putFloat64le d + put (DTString s) = putWord8 dtString >> put len24 >> mapM_ put paddedString + where len24 = to24bit (length paddedString) + paddedString = padRstring s + put (DTBytestream s)= putWord8 dtBytestream >> put len24 >> mapM_ putWord8 s + where len24 = to24bit (length s) + put (DTSexp s) = putWord8 dtSexp >> put len24 >> put s + where len24 = to24bit (fromIntegral (BL.length (encode s))::Int) + put (DTAssign symbol sexp) = put (DTString symbol) >> put (DTSexp sexp) + get = do t <- getWord8 + case fromIntegral t::Int of + 1 -> liftM DTInt get + 2 -> liftM DTChar get + 3 -> liftM DTDouble get + 4 -> do len24 <- get + let len = (from24Bit len24) + chars <- replicateM len getWord8 + return (DTString (map BI.w2c chars)) + 5 -> do len24 <- get + let len = (from24Bit len24) + ws <- replicateM len getWord8 + return (DTBytestream ws) + 10 -> do replicateM_ 3 getWord8 + liftM DTSexp get + x -> error ("Unsupported DT id:"++show x) + +data RConn = RConn {rcHandle::Handle, rcRserveSig:: String, rcRserveVersion::String, rcProtocol::String, rcAttributes::[String]} deriving (Show) + +-- | Representations for the types transmitted on the Rserve protocol, refer to Rserve documentation for details +data RSEXP = + RNULL + | RInt Int + | RDouble Double + | RString String + | RSym String + | RBool Bool + | RVector [RSEXP] +-- | RList RSEXP RSEXP RSEXP -- head vals tag -- I can't find any evidence that this is ever used in Rserve + | RClos Word32 -- just store the length + | RListTag [(RSEXP,RSEXP)] + | RArrayInt [Int] + | RArrayDouble [Double] + | RArrayString [String] + | RArrayBool [Bool] + | RArrayComplex [(Double, Double)] + | RSEXPWithAttrib RSEXP RSEXP + | RUnknown Word32 + deriving (Show,Eq) + +getTypeCode :: RSEXP -> Word8 +getTypeCode (RNULL) = xtNull +getTypeCode (RInt _) = xtInt +getTypeCode (RDouble _) = xtDouble +getTypeCode (RString _) = xtStr +getTypeCode (RSym _) = xtSym +getTypeCode (RBool _) = xtBool +getTypeCode (RVector _) = xtVector +getTypeCode (RClos _) = xtClos +getTypeCode (RListTag _) = xtListTag +getTypeCode (RArrayInt _) = xtArrayInt +getTypeCode (RArrayDouble _)= xtArrayDouble +getTypeCode (RArrayString _)= xtArrayStr +getTypeCode (RArrayBool _) = xtArrayBool +getTypeCode (RArrayComplex _) = xtArrayCplx +getTypeCode (RSEXPWithAttrib _ v) = xtHasAttr .|. getTypeCode v +getTypeCode (RUnknown _) = xtUnknown + +data RTypeCode = RType Word8 | RTypeAttr Word8 deriving Show + +to24bit :: Int -> Len24 +to24bit i = Len24 x y z + where x = fromIntegral(i .&. 0xff)::Word8 + y = fromIntegral((i `shiftR` 8) .&. 0xff)::Word8 + z = fromIntegral((i `shiftR` 16) .&. 0xff)::Word8 + +from24Bit :: Len24 -> Int +from24Bit (Len24 x y z) = (fromIntegral x::Int) + (fromIntegral y ::Int) `shiftL` 8 + (fromIntegral z ::Int) `shiftL` 16 + +-- TODO add support for large +getCode :: Word8 -> RTypeCode +getCode t | isLarge = error "LARGE" + | hasAttribute = RTypeAttr code + | otherwise = RType code + where hasAttribute = t .&. 128 == 128 + isLarge = t .&. 64 == 64 + code = t .&. 63 + +instance Binary RSEXP where + put (RNULL) = putWord8 xtNull >> put (to24bit 0) + put (RInt i) = putWord8 xtInt >> put (to24bit 4) >> putWord32le (fromIntegral i :: Word32) + put (RDouble d) = putWord8 xtDouble >> put (to24bit 8) >> putFloat64le d + put (RBool b) = putWord8 xtBool >> put (to24bit 4) >> putWord8 (if b then 1 else 0) >> replicateM_ 3 (putWord8 0) + put (RString s) = putWord8 xtStr >> put len24 >> mapM_ (putWord8 . BI.c2w) ps + where len24 = to24bit (length ps) + ps = padRstring s + put (RSym s) = putWord8 xtSym >> put len24 >> mapM_ (putWord8 . BI.c2w) ps + where len24 = to24bit (length ps) + ps = padRstring s + put (RArrayInt arr) = putWord8 xtArrayInt >> put len24 >> mapM_ (putWord32le . fromIntegral) arr + where len24 = to24bit (4* length arr) + put (RArrayDouble arr) = putWord8 xtArrayDouble >> put len24 >> mapM_ putFloat64le arr + where len24 = to24bit (length arr *8) + put (RArrayBool arr) = putWord8 xtArrayBool >> put len24 >> putWord32le (fromIntegral (length arr) :: Word32) >> mapM_ (putWord8 . (\x -> if x then 1 else 0)) arr >> replicateM_ (gapLen (length arr)) (putWord8 255) + where len24 = to24bit (4 + length arr + gapLen (length arr)) + + put (RArrayString ss) = putWord8 xtArrayStr >> put len24 >> mapM_ (putWord8 . BI.c2w) ss' + where len24 = to24bit (length ss') + ss' = if length ss > 0 then padRstring (intercalate "\0" ss) else [] + put (RListTag lt) = putWord8 xtListTag >> put len24 >> mapM_ put lt + where len24 = to24bit (sum (map encodedLength rsexps)) + rsexps = detuple lt + put (RClos v) = putWord8 xtClos >> put (to24bit 4) >> putWord32le v +-- put (RList h vals tag) = putWord8 xtList >> put len24 >> put h >> put vals >> put tag +-- where len24 = to24bit (encodedLength h + encodedLength vals + encodedLength tag) + put (RVector v) = putWord8 xtVector >> put len24 >> mapM_ put v + where len24 = to24bit (sum (map encodedLength v)) +-- The way Rserve serialises this isn't great, the val header is munged into the header for the entire object and the id bitwised ored with 128 +-- which also means it's impossible to serialise an RSEXPWithAttrib which has an RSEXPWithAttrib as a value + put (RSEXPWithAttrib attrib val) = putWord8 (fromIntegral code) >> put len24 >> put attrib >> mapM_ (putWord8 . BI.c2w) (BL.unpack (BL.drop 4 (encode val))) + where code = getTypeCode val .|. xtHasAttr + len24 = to24bit (encodedLength attrib + encodedLength val - 4) + put (RArrayComplex cs) = putWord8 xtArrayCplx >> put len24 >> mapM_ putFloat64le (detuple cs) + where len24 = to24bit (16 * length cs) + put (RUnknown v) = putWord8 xtUnknown >> put (to24bit 4) >> putWord32le v + get = do t <- getWord8 + len24 <- get + let len = from24Bit len24 + let typeCode = getCode t + case typeCode of + (RTypeAttr x) -> do attrib <- get + let remainingLen = len - encodedLength attrib + val <- getRType (RType x) remainingLen + return (RSEXPWithAttrib attrib val) + (RType _) -> getRType typeCode len + +getRType :: RTypeCode -> Int -> Get RSEXP +getRType typeCode len = + case typeCode of + (RType 0) -> return RNULL + (RType 1) -> do e <- getWord32le + return (RInt (fromIntegral e)) + (RType 2) -> do e <- getFloat64le + return (RDouble e) + (RType 3) -> do chars <- replicateM len getWord8 + return (RString (depadRstring (map BI.w2c chars))) + (RType 5) -> do chars <- replicateM len getWord8 + return (RSym (depadRstring (map BI.w2c chars))) + (RType 6) -> do b <- getWord32le -- this may be a byte in the spec but it's always padded + return (RBool (b == 1)) -- 1=TRUE, 0=FALSE, 2=NA + (RType 16) -> getVector len + (RType 18) -> do v <- getWord32le + return (RClos v ) + (RType 19) -> do chars <- replicateM len getWord8 + return (RSym (depadRstring (map BI.w2c chars))) + (RType 21) -> getListTag len + (RType 22) -> getVector len + (RType 23) -> getListTag len + (RType 26) -> getVector len + (RType 32) -> do ints <- replicateM (len `div` 4) getWord32le + return (RArrayInt (map fromIntegral ints)) + (RType 33) -> do doubles <- replicateM (len `div` 8) getFloat64le + return (RArrayDouble doubles) + (RType 34) -> do stringsBytes <- replicateM len getWord8 + let strings = vectorStringDecode (map BI.w2c stringsBytes) + return (RArrayString strings) + (RType 36) -> do boolCount <-getWord32le + bools <- replicateM (fromIntegral boolCount::Int) getWord8 + replicateM_ (len - 4 - fromIntegral boolCount::Int) getWord8 + return (RArrayBool (map (==1) bools)) + (RType 38) -> do doubles <- replicateM (len `div` 8) getFloat64le + return (RArrayComplex (pairs doubles)) + (RType 48) -> do v <- getWord32le + return (RUnknown v) + (RType x) -> do br <- bytesRead + error ("unsuppported type code:" ++ show x ++ " bytes read:"++show br) + _ -> error ("unsuppported RSEXP type code:"++show typeCode) + +getVector :: Int -> Get RSEXP +getVector len = do rsexpsBytes <- replicateM len getWord8 + let rsexps = vectorRSEXPDecode rsexpsBytes + return (RVector rsexps) + +getListTag :: Int -> Get RSEXP +getListTag len = do listTagBytes <- replicateM len getWord8 + let taglist = listTagDecode listTagBytes + return (RListTag taglist) + +vectorRSEXPDecode :: [Word8] -> [RSEXP] +vectorRSEXPDecode [] = [] +vectorRSEXPDecode ws@(_:l1:l2:l3:rws) = if encodingOK then val : vectorRSEXPDecode (drop (from24Bit (Len24 l1 l2 l3)) rws) + else error ("Encoding error in val:"++show val) + where content = BL.pack (map BI.w2c ws) + val = decode content + encodingOK = encodedLength val == from24Bit (Len24 l1 l2 l3) + 4 +vectorRSEXPDecode _ = error "vectorRSEXPDecode: trailing bytes" + +-- the serialisation code uses this function anywhere it needs to figure out how much it has written/read by encoding the RSEXP and getting the length +-- obviously this could be a disaster for performance as we're encoding many times for each serialisation +encodedLength :: RSEXP -> Int +encodedLength s = if l `mod` 4 == 0 then l else error ("Encoded length not a multiple of 4" ++ show s) + where l = fromIntegral(BL.length (encode s))::Int + +vectorStringDecode :: String -> [String] +vectorStringDecode = init . splitOn "\0" + +padRstring :: String -> String +padRstring s = padded + where padded = nullTerminated ++ replicate (gapLen r) '\1' + nullTerminated = s ++ "\0" + r = length nullTerminated + +gapLen :: Int -> Int +gapLen r = if gap == 0 then 0 else 4 - gap + where gap = rem r 4 + +depadRstring :: String -> String +depadRstring = takeWhile (/= '\0') + +pairs :: [a] -> [(a,a)] +pairs [] = [] +pairs [_] = [] +pairs (x:y:xs) = (x,y) : pairs xs + +detuple :: [(a,a)] -> [a] +detuple [] =[] +detuple ((x,y):xs) = x:y: detuple xs + +listTagDecode :: [Word8] -> [(RSEXP,RSEXP)] +listTagDecode [] = [] +listTagDecode ws = pairs $ vectorRSEXPDecode ws + +parseIdString :: B.ByteString -> (String, String, String, [String]) +parseIdString b = (sig, h, r, attributes) + where [sig,h,r] = map B.unpack [(B.take 4 b), (B.take 4 (B.drop 4 b)), (B.take 4 (B.drop 8 b))] + attributes = parseAttributes (B.drop 12 b) + +parseAttributes :: B.ByteString -> [String] +parseAttributes = filter (=="") . map B.unpack . B.lines + +lazyByteStringToString :: BL.ByteString->String +lazyByteStringToString = show . map ord . BL.unpack + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Tests.hs b/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests.hs @@ -0,0 +1,90 @@ +import Network.Rserve.Client +import Test.QuickCheck +import Text.Printf +import Data.Maybe +import Data.List +import Data.Binary +import qualified Data.ByteString.Lazy.Char8 as BL +import Control.Monad + +normalCharacters = ['A'..'Z'] ++ ['a' .. 'z'] ++ " ~!@#$%^&*()" + +--TODO arbitrary RSEXPs are likely to be enormous, limit nesting depth somehow +instance Arbitrary RSEXP where + arbitrary = oneof [ return RNULL + , liftM RInt arbitrary + , liftM RDouble arbitrary + , liftM RString arbitraryNonemptyString + , liftM RSym arbitraryNonemptyString + , liftM RBool arbitrary + , liftM RVector (listOf primitiveRSEXP) + , liftM RClos arbitrary + , liftM RListTag primitiveTagList -- TODO this can generate large recursive structures + , liftM RArrayInt arbitrary + , liftM RArrayDouble arbitrary + , liftM RArrayString (listOf arbitraryNonemptyString) + , liftM RArrayBool arbitrary + , liftM RArrayComplex arbitrary + , liftM2 RSEXPWithAttrib arbitrary nonRSEXPWithAttrib -- TODO, can't have a val that is an RSEXPWithAttrib limit recursion here + , liftM RUnknown arbitrary + , liftM RString arbitraryNonemptyString + ] + +arbitraryNonemptyString :: Gen String +arbitraryNonemptyString = do + x <- arbitrary + let x' = filter (\c -> c `elem` normalCharacters) x + let s = if x' == "" then "empt" else x' + return s + +nonRSEXPWithAttrib :: Gen RSEXP +nonRSEXPWithAttrib = do + oneof [ return RNULL + , liftM RInt arbitrary + , liftM RDouble arbitrary + , liftM RString arbitraryNonemptyString + , liftM RSym arbitraryNonemptyString + , liftM RBool arbitrary + , liftM RVector arbitrary + , liftM RClos arbitrary + , liftM RListTag arbitrary -- TODO this can generate large recursive structures + , liftM RArrayInt arbitrary + , liftM RArrayDouble arbitrary + , liftM RArrayString (listOf arbitraryNonemptyString) + , liftM RArrayBool arbitrary + , liftM RArrayComplex arbitrary + , liftM RUnknown arbitrary + , liftM RString arbitraryNonemptyString + ] +primitiveTagList :: Gen [(RSEXP, RSEXP)] +primitiveTagList = do liftM2 zip (listOf primitiveRSEXP) (listOf primitiveRSEXP) + +primitiveRSEXP :: Gen RSEXP +primitiveRSEXP = do + oneof [ return RNULL + , liftM RInt arbitrary + , liftM RDouble arbitrary + , liftM RString arbitraryNonemptyString + , liftM RSym arbitraryNonemptyString + , liftM RBool arbitrary + , liftM RArrayInt arbitrary + , liftM RArrayDouble arbitrary + , liftM RArrayString (listOf arbitraryNonemptyString) + , liftM RArrayBool arbitrary + , liftM RArrayComplex arbitrary + , liftM RUnknown arbitrary + , liftM RString arbitraryNonemptyString + ] +propEncodeDecodeIdentity :: RSEXP -> Bool +propEncodeDecodeIdentity r = (decode (encode r)) == r + +propEncodedLength ::RSEXP -> Bool +propEncodedLength r = BL.length (encode r) `mod` 4 == 0 + +tests = [("encodeDecodeIdentity", quickCheck propEncodeDecodeIdentity), + ("encodedLength", quickCheck propEncodedLength) + ] + +main = do --sample arbitraryNonemptyString + mapM_ (\(s,a) -> printf "%-25s: " s >> a) tests + diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,26 @@ +import qualified Network.Rserve.Client as R +import qualified Data.ByteString.Char8 as B +import Data.Binary + +main :: IO () +main = do + rc <- R.connect "localhost" 6311 + print ("Rserve version:"++R.rcRserveVersion rc) + m <- R.eval rc "rnorm(10)" + print (R.unpack m :: Maybe [Double]) + m1 <- R.assign rc "a" (R.RArrayDouble [1.0,201]) + m2 <- R.eval rc "a" + print m2 + fileStuff rc + +fileStuff :: R.RConn -> IO() +fileStuff rconn = do + r <- R.createFile rconn fileName + r2 <- R.writeFile rconn (B.pack "a,b\n1,2\n8,4") + r4 <- R.closeFile rconn fileName + r5 <- R.openFile rconn fileName + r6 <- R.eval rconn ("x <- read.csv(\""++fileName++"\", header=TRUE)") + r7 <- R.eval rconn "mean(x$a)" + r8 <- R.removeFile rconn fileName + print (R.unpackRArrayDouble r7) + where fileName = "/tmp/rserve_tmp.csv" diff --git a/rclient.cabal b/rclient.cabal new file mode 100644 --- /dev/null +++ b/rclient.cabal @@ -0,0 +1,32 @@ +name: rclient +version: 0.1.0.0 +synopsis: Haskell client for Rserve +description: This module allows you to issue R commands from Haskell to be executed via Rserve and get the results back in Haskell data types. +category: Statistics,Math,Network +license: BSD3 +license-file: LICENSE +author: TomDoris +maintainer: TomDoris +build-type: Simple +cabal-version: >= 1.2 + +library + exposed-modules: + Network.Rserve.Client + other-modules: + Network.Rserve.Internal + Network.Rserve.Constants + build-depends: base >= 3.0 && < 5, + network >= 2.3, + binary >= 0.4.2, + bytestring, + QuickCheck >= 2.4, + split >= 0.1, + data-binary-ieee754 >= 0.4 + if impl(ghc >= 6.10) + build-depends: + base >= 4 + if impl(ghc >= 6.8) + ghc-options: -fwarn-tabs + ghc-options: -Wall -O2 +