Merge pull request #9 from tsirakisn/argo-st9

S9: [argo] Replace v4v with argo

xch-rpc/Rpc/DBusV4V.hs → xch-rpc/Rpc/DBusArgo.hs

@@ -18,7 +18,7 @@
 
 {-# LANGUAGE ScopedTypeVariables, CPP #-}
 
-module Rpc.DBusV4V ( 
+module Rpc.DBusArgo (
     domainSystemBus
   , remoteDomainBus
   ) where
@@ -39,50 +39,50 @@ import qualified Data.ByteString as B
 import qualified Network.DBus as D
 import qualified Network.DBus.Actions as D
 
-#ifdef USE_V4V
-import qualified Tools.V4V as V
+#ifdef USE_ARGO
+import qualified Tools.Argo as A
 #endif
 
 domainSystemBus :: Int -> IO D.DBusContext
 remoteDomainBus :: Int -> Int -> IO D.DBusContext
 
-#ifndef USE_V4V
-domainSystemBus = error "dbus v4v unsupported"
-remoteDomainBus = error "dbus v4v unsupported"
+#ifndef USE_ARGO
+domainSystemBus = error "dbus argo unsupported"
+remoteDomainBus = error "dbus argo unsupported"
 #else
 
 domainSystemBus domain = remoteDomainBus domain 5555
-remoteDomainBus domain v4vPort = do
-  let addr = V.Addr v4vPort domain
+remoteDomainBus domain argoPort = do
+  let addr = A.Addr argoPort domain
   fd <- connect addr
   info $ "connected to domain's " ++ show domain ++ " system bus proxy"
-  D.contextNewWith (v4vTransport fd)
+  D.contextNewWith (argoTransport fd)
   where
-    connect addr = V.socket Stream >>= \f ->
+    connect addr = A.socket Stream >>= \f ->
       -- be careful to close fd on connect error..
                   ( do setFdOption f NonBlockingRead False
-                       V.connect f addr
+                       A.connect f addr
                        setFdOption f NonBlockingRead True
                        return f )
                   `E.catch` connect_error f
-                      where connect_error f (err::E.SomeException) = V.close f >> E.throw err
-    v4vTransport fd
+                      where connect_error f (err::E.SomeException) = A.close f >> E.throw err
+    argoTransport fd
       = D.DBusTransport { D.transportPut  = send fd
                         , D.transportGet  = recv fd
                         , D.transportClose = close fd }
-    send  fd buf       = do sent <- V.send fd buf 0
+    send  fd buf       = do sent <- A.send fd buf 0
                             if sent < (B.length buf)
                                then send fd (B.drop sent buf)
                                else return ()
-      -- seems to be needed because stupid dbus bindings do recv 0 and v4v blocks on that ?
+      -- seems to be needed because stupid dbus bindings do recv 0 and argo blocks on that ?
     recv  fd 0         = return B.empty
     recv  fd sz        = recv_aux fd (fromIntegral sz)
-    recv_aux fd sz     = do chunk <- V.recv fd (fromIntegral $ sz) 0
+    recv_aux fd sz     = do chunk <- A.recv fd (fromIntegral $ sz) 0
                             case B.length chunk of
                                 0           -> return chunk
                                 l | l >= sz -> return chunk
                                 _           -> B.append chunk <$> recv_aux fd (sz - B.length chunk)
 
-    close fd        = V.close fd
+    close fd        = A.close fd
 
 #endif

xch-rpc/Rpc/Domain.hs

@@ -27,7 +27,7 @@ import qualified Data.Map as M
 import Rpc.Monad
 import Rpc.Log
 import Rpc.Dispatch
-import qualified Rpc.DBusV4V as V
+import qualified Rpc.DBusArgo as A
 import qualified Control.Exception as E
 
 -- rpc on another domain's bus
@@ -57,7 +57,7 @@ rpcTryConnectDomainBus domid 0 = return Nothing
 rpcTryConnectDomainBus domid timeout
   = ( Just <$> get ) `E.catch` retry
   where
-    get = V.domainSystemBus domid >>= connectBus >>= return . fst
+    get = A.domainSystemBus domid >>= connectBus >>= return . fst
     retry :: E.SomeException -> IO (Maybe Dispatcher)
     retry e = do warn $ "domain's " ++ show domid ++ " sytem bus is unresponsive: " ++ show e ++ ", retrying.."
                  threadDelay (10^6)

xch-rpc/xch-rpc.cabal

@@ -9,8 +9,8 @@ category: Network, Desktop
 stability: experimental
 tested-with: GHC==6.12.1
 
-Flag v4v
-  Description:  build with V4V supports
+Flag argo
+  Description:  build with Argo supports
   Default:      True
 
 library
@@ -31,14 +31,14 @@ library
     xchutils
 
   GHC-Options: -O2 -fwarn-incomplete-patterns
-  if flag(v4v)
-    Build-Depends: xchv4v
-    Extra-Libraries: v4v_nointerposer
-    cpp-options: -DUSE_V4V
+  if flag(argo)
+    Build-Depends: xchargo
+    Extra-Libraries: argo_nointerposer
+    cpp-options: -DUSE_ARGO
 
   exposed-modules:
     Rpc.Core
-    Rpc.DBusV4V
+    Rpc.DBusArgo
 
   other-modules:
     Rpc.Log
@@ -49,4 +49,4 @@ library
     Rpc.Domain
     Rpc.Variables
     Rpc.Dispatch
-    Rpc.Intro
+    Rpc.Intro

xchv4v/Tools/V4V.hsc → xchargo/Tools/Argo.hsc

@@ -17,7 +17,7 @@
 --
 
 {-# LANGUAGE CPP,ForeignFunctionInterface #-}
-module Tools.V4V ( Addr (..)
+module Tools.Argo ( Addr (..)
                  , DomID
                  , SocketType (..)
                  , socket, close, bind, connect, listen, accept, send, recv
@@ -60,54 +60,54 @@ type DomID = Int
 data Addr = Addr { addrPort  :: !Int
                  , addrDomID :: !DomID } deriving Show
 
-#include <libv4v.h>
+#include <libargo.h>
 
 #let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__)
 
 instance Storable Addr where
-    alignment _ = #{alignment v4v_addr_t}
-    sizeOf    _ = #{size v4v_addr_t}
-    peek p      = do port  <- #{peek v4v_addr_t, port} p
-                     domid <- ((.&.) 0xFFFF) <$> #{peek v4v_addr_t, domain} p
+    alignment _ = #{alignment xen_argo_addr_t}
+    sizeOf    _ = #{size xen_argo_addr_t}
+    peek p      = do port  <- #{peek xen_argo_addr_t, aport} p
+                     domid <- ((.&.) 0xFFFF) <$> #{peek xen_argo_addr_t, domain_id} p
                      return $ Addr port domid
-    poke p v    = do #{poke v4v_addr_t, port} p (addrPort v)
-                     #{poke v4v_addr_t, domain} p (addrDomID v)
-
--- subset of libv4v.h
-foreign import ccall "libv4v.h v4v_socket" c_v4v_socket    :: CInt -> IO CInt
-foreign import ccall "libv4v.h v4v_close" c_v4v_close      :: CInt -> IO CInt
-foreign import ccall "libv4v.h v4v_bind" c_v4v_bind        :: CInt -> Ptr Addr -> CInt -> IO CInt
-foreign import ccall "libv4v.h v4v_connect" c_v4v_connect  :: CInt -> Ptr Addr -> IO CInt
-foreign import ccall "libv4v.h v4v_listen" c_v4v_listen    :: CInt -> CInt -> IO CInt
-foreign import ccall "libv4v.h v4v_accept" c_v4v_accept    :: CInt -> Ptr Addr -> IO CInt
-foreign import ccall "libv4v.h v4v_send" c_v4v_send        :: CInt -> Ptr Word8 -> CULong -> CInt -> IO CLong
-foreign import ccall "libv4v.h v4v_recv" c_v4v_recv        :: CInt -> Ptr Word8 -> CULong -> CInt -> IO CLong
-foreign import ccall "libv4v.h v4v_getsockopt" c_v4v_getsockopt :: CInt -> CInt -> CInt -> Ptr () -> Ptr Int -> IO Int
+    poke p v    = do #{poke xen_argo_addr_t, aport} p (addrPort v)
+                     #{poke xen_argo_addr_t, domain_id} p (addrDomID v)
+
+-- subset of libargo.h
+foreign import ccall "libargo.h argo_socket" c_argo_socket    :: CInt -> IO CInt
+foreign import ccall "libargo.h argo_close" c_argo_close      :: CInt -> IO CInt
+foreign import ccall "libargo.h argo_bind" c_argo_bind        :: CInt -> Ptr Addr -> CInt -> IO CInt
+foreign import ccall "libargo.h argo_connect" c_argo_connect  :: CInt -> Ptr Addr -> IO CInt
+foreign import ccall "libargo.h argo_listen" c_argo_listen    :: CInt -> CInt -> IO CInt
+foreign import ccall "libargo.h argo_accept" c_argo_accept    :: CInt -> Ptr Addr -> IO CInt
+foreign import ccall "libargo.h argo_send" c_argo_send        :: CInt -> Ptr Word8 -> CULong -> CInt -> IO CLong 
+foreign import ccall "libargo.h argo_recv" c_argo_recv        :: CInt -> Ptr Word8 -> CULong -> CInt -> IO CLong
+foreign import ccall "libargo.h argo_getsockopt" c_argo_getsockopt :: CInt -> CInt -> CInt -> Ptr () -> Ptr Int -> IO Int
 
 int :: (Integral a, Num b) => a -> b
 int = fromIntegral
 
 socket :: SocketType -> IO Fd
 socket t =
-    do fd <- int <$> throwErrnoIfMinus1 "socket" ( c_v4v_socket (packSocketType t) )
+    do fd <- int <$> throwErrnoIfMinus1 "socket" ( c_argo_socket (packSocketType t) )
        setFdOption fd NonBlockingRead True
        return fd
 
 close :: Fd -> IO ()
-close f = throwErrnoIfMinus1 "close" ( c_v4v_close (int f) ) >> return ()
+close f = throwErrnoIfMinus1 "close" ( c_argo_close (int f) ) >> return ()
 
 bind :: Fd -> Addr -> DomID -> IO ()
 bind f addr partner = do
     with addr $ \addr_p ->
-        throwErrnoIfMinus1 "bind" $ c_v4v_bind (int f) addr_p (int partner)
+        throwErrnoIfMinus1 "bind" $ c_argo_bind (int f) addr_p (int partner)
     return ()
 
 maybeBindClient :: Fd -> Addr -> IO ()
 maybeBindClient f addr = do
     do
-       envAddend <- getEnv "V4V_CLIENT_PORT_ADDEND"
+       envAddend <- getEnv "ARGO_CLIENT_PORT_ADDEND"
        let addend = read envAddend::Int
-       bind f (Addr (addrPort addr + addend) 0x7FFF) (addrDomID addr)
+       bind f (Addr (addrPort addr + addend) 0x7FF4) (addrDomID addr)
        return ()
     `Control.Exception.catch` \e -> do
        if (System.IO.Error.isDoesNotExistError e)
@@ -119,7 +119,7 @@ connect f addr = do
     with addr $ \addr_p ->
         let connect_loop =
                 do maybeBindClient f addr
-                   r <- c_v4v_connect (int f) addr_p
+                   r <- c_argo_connect (int f) addr_p
                    if r == -1
                      then do err <- getErrno
                              case () of
@@ -137,13 +137,13 @@ connect f addr = do
 
 listen :: Fd -> Int -> IO ()
 listen f backlog = do
-    throwErrnoIfMinus1 "listen" $ c_v4v_listen (int f) (int backlog)
+    throwErrnoIfMinus1 "listen" $ c_argo_listen (int f) (int backlog)
     return ()
 
 accept :: Fd -> IO (Fd, Addr)
 accept f =
     alloca $ \addr_p ->
-        do f' <- throwErrnoIfMinus1RetryMayBlock "accept" (c_v4v_accept (int f) addr_p) (threadWaitRead f)
+        do f' <- throwErrnoIfMinus1RetryMayBlock "accept" (c_argo_accept (int f) addr_p) (threadWaitRead f)
            setFdOption (int f') NonBlockingRead True
            addr <- peek addr_p
            return (int f', addr)
@@ -153,12 +153,12 @@ send f buf flags =
     fmap int $
          unsafeUseAsCStringLen buf $ \(ptr,sz) ->
              throwErrnoIfMinus1RetryMayBlock "send"
-             ( c_v4v_send (int f) (castPtr ptr) (int sz) (int flags) )
+             ( c_argo_send (int f) (castPtr ptr) (int sz) (int flags) )
              ( moan f buf flags >> threadDelay (5 * 10^5) >> threadWaitWrite f )
 
 moan :: Fd -> B.ByteString -> Int -> IO ()
 moan fd buf flags = do
-    warn $ "ALERT! EAGAIN trying to send over v4v fd=" ++ show fd
+    warn $ "ALERT! EAGAIN trying to send over argo fd=" ++ show fd
              ++ " flags=" ++ show flags
              ++ ", data_len=" ++ show (B.length buf)
              ++ " data follows:"
@@ -169,7 +169,7 @@ recv f sz flags =
     createAndTrim sz $ \ptr ->
         fmap int $
              throwErrnoIfMinus1RetryMayBlock "recv"
-             ( c_v4v_recv (int f) (castPtr ptr) (int sz) (int flags) )
+             ( c_argo_recv (int f) (castPtr ptr) (int sz) (int flags) )
              ( threadWaitRead f )
 
 getsockopt :: Fd -> SocketOption -> IO Int
@@ -178,7 +178,7 @@ getsockopt fd option | option == so_error =
     alloca $ \buffer ->
     alloca $ \len_buffer ->
         do poke len_buffer (sizeOf $ (undefined :: CInt))
-           throwErrnoIfMinus1 "getsockopt" ( c_v4v_getsockopt
+           throwErrnoIfMinus1 "getsockopt" ( c_argo_getsockopt
                                              (int fd) 
                                              (socket_level sol_socket)
                                              (socket_option so_error)

xchv4v/xchv4v.cabal → xchargo/xchargo.cabal

@@ -1,6 +1,6 @@
-name: xchv4v
+name: xchargo
 version: 0.1
-synopsis: XenClient v4v bindings
+synopsis: XenClient argo bindings
 license: Proprietary
 author: Tomasz Wroblewski
 build-type: Simple
@@ -20,6 +20,6 @@ library
   GHC-Options: -O2 -fwarn-incomplete-patterns
 
   Exposed-Modules:
-    Tools.V4V
+    Tools.Argo
 
-  Extra-Libraries: v4v_nointerposer
+  Extra-Libraries: argo_nointerposer