ONC-RPC 0.1 → 0.2

raw patch · 12 files changed

+185/−36 lines, 12 filesdep +base16-bytestringdep ~networkPVP ok

version bump matches the API change (PVP)

Dependencies added: base16-bytestring

Dependency ranges changed: network

API changes (from Hackage documentation)

Files

• Network/ONCRPC/Client.hs +31/−0
• Network/ONCRPC/Message.hs +1/−1
• Network/ONCRPC/RecordMarking.hs +6/−2
• Network/ONCRPC/Transport.hs +10/−4
• Network/ONCRPC/XDR/Array.hs +40/−0
• Network/ONCRPC/XDR/Generate.hs +3/−3
• Network/ONCRPC/XDR/Opaque.hs +13/−12
• Network/ONCRPC/XDR/Parse.hs +1/−1
• Network/ONCRPC/XDR/Serial.hs +18/−7
• Network/ONCRPC/XDR/Types.hs +2/−2
• ONC-RPC.cabal +14/−4
• README.md +46/−0

@@ -3,10 +3,12 @@ -- Clients are fully thread-safe, allowing multiple outstanding requests, and automatically reconnect on error. -- Currently error messages are just written to stdout. +{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE RecordWildCards #-} module Network.ONCRPC.Client   ( ClientServer(..)+  , makeClientServerPort   , Client   , openClient   , closeClient@@ -26,6 +28,13 @@ import           System.IO.Error (catchIOError) import           System.Random (randomIO) +#ifdef BINDRESVPORT+import           Control.Monad (when)+import           Foreign.C.Types (CInt(CInt))+import           Foreign.Ptr (Ptr, nullPtr)+import           Network.Socket.Internal (throwSocketErrorIfMinus1Retry_)+#endif+ import qualified Network.ONCRPC.XDR as XDR import qualified Network.ONCRPC.Prot as RPC import           Network.ONCRPC.Types@@ -39,8 +48,20 @@   = ClientServerPort     { clientServerHost :: Net.HostName -- ^Host name or IP address of server     , clientServerPort :: Net.ServiceName -- ^Service name (not portmap) or port number+#ifdef BINDRESVPORT+    , clientBindResvPort :: Bool+#endif     } -- ^a known service by host/port, currently only TCP +makeClientServerPort :: Net.HostName -> Net.ServiceName -> ClientServer+makeClientServerPort h p = ClientServerPort+  { clientServerHost = h+  , clientServerPort = p+#ifdef BINDRESVPORT+  , clientBindResvPort = False+#endif+  }+ data Request = forall a . XDR.XDR a => Request   { requestBody :: BSL.ByteString -- ^for retransmits   , requestAction :: MVar (Reply a)@@ -60,6 +81,10 @@   , clientCred, clientVerf :: Auth   } +#ifdef BINDRESVPORT+foreign import ccall unsafe "bindresvport" c_bindresvport :: CInt -> Ptr Net.SockAddr -> IO CInt+#endif+ warnMsg :: Show e => String -> e -> IO () warnMsg m = hPutStrLn stderr . (++) ("Network.ONCRPC.Client: " ++ m ++ ": ") . show @@ -90,6 +115,12 @@   conn ClientServerPort{..} s = do     addr:_ <- Net.getAddrInfo (Just Net.defaultHints{ Net.addrSocketType = Net.Stream }) (Just clientServerHost) (Just clientServerPort)     sock <- Net.socket (Net.addrFamily addr) (Net.addrSocketType addr) (Net.addrProtocol addr)+#ifdef BINDRESVPORT+    when clientBindResvPort $+      throwSocketErrorIfMinus1Retry_ "bindresvport" $+        Net.withFdSocket sock $ \fd ->+          c_bindresvport fd nullPtr+#endif     Net.connect sock (Net.addrAddress addr)     resend sock (stateRequests s)     return (s{ stateSocket = Just sock }, sock)

@@ -140,7 +140,7 @@  instance XDR.XDR a => XDR.XDR (Reply a) where   xdrType _ = "reply_body_result"-  xdrPut (ReplyFail e) = fail e+  xdrPut (ReplyFail e) = error e   xdrPut r = do     xdrPut b     mapM_ xdrPut a

@@ -1,3 +1,4 @@+{-# LANGUAGE CApiFFI #-} module Network.ONCRPC.RecordMarking   ( sendRecord   , RecordState(RecordStart)@@ -16,6 +17,9 @@ import qualified Network.Socket.ByteString as NetBS import qualified Network.Socket.ByteString.Lazy as NetBSL +foreign import capi unsafe "arpa/inet.h htonl" htonl :: Word32 -> Word32+foreign import capi unsafe "arpa/inet.h ntohl" ntohl :: Word32 -> Word32+ -- |A raw RPC record fragment header, stored in network byte order. type FragmentHeader = Word32 @@ -28,10 +32,10 @@ unFragmentHeader :: Integral i => FragmentHeader -> (Bool, i) unFragmentHeader w =   (testBit w' fragmentHeaderBit, fromIntegral $ clearBit w' fragmentHeaderBit)-  where w' = Net.ntohl w+  where w' = ntohl w  mkFragmentHeader :: Integral i => Bool -> i -> FragmentHeader-mkFragmentHeader l n = Net.htonl $ sb l $ fromIntegral n where+mkFragmentHeader l n = htonl $ sb l $ fromIntegral n where   sb True x = setBit x fragmentHeaderBit   sb False x = x 

@@ -15,12 +15,18 @@ import           Network.ONCRPC.RecordMarking  sendTransport :: Net.Socket -> BSL.ByteString -> IO ()-sendTransport sock@(Net.MkSocket _ _ Net.Stream _ _) = sendRecord sock-sendTransport _ = const $ fail "ONCRPC: Unsupported socket type"+sendTransport sock b = do+  t <- Net.getSocketType sock+  if t == Net.Stream+    then sendRecord sock b+    else fail "ONCRPC: Unsupported socket type"  recvTransport :: Net.Socket -> RecordState -> IO (BS.ByteString, RecordState)-recvTransport sock@(Net.MkSocket _ _ Net.Stream _ _) = recvRecord sock-recvTransport _ = const $ fail "ONCRPC: Unsupported socket type"+recvTransport sock r = do+  t <- Net.getSocketType sock+  if t == Net.Stream+    then recvRecord sock r+    else fail "ONCRPC: Unsupported socket type"  data TransportState = TransportState   { _bufferState :: BS.ByteString

@@ -2,6 +2,7 @@  {-# LANGUAGE DataKinds #-} {-# LANGUAGE ExplicitNamespaces #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}@@ -10,6 +11,9 @@ module Network.ONCRPC.XDR.Array   ( KnownNat   , KnownOrdering+  , OpaqueString(..)+  , opaqueLengthArray+  , unOpaqueLengthArray   , LengthArray   , FixedLengthArray   , fixedLengthArrayLength@@ -32,17 +36,41 @@   ) where  import           Prelude hiding (length, take, drop, replicate)+import           Control.Monad (guard) import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL+import qualified Data.ByteString.Base16 as Hex import qualified Data.List as List import           Data.Maybe (fromMaybe, fromJust) import           Data.Monoid (Monoid, (<>)) import           Data.Proxy (Proxy(..))+import           Data.Semigroup (Semigroup) import           Data.String (IsString(..)) import qualified Data.Vector as V import           Data.Word (Word8) import           GHC.TypeLits (Nat, KnownNat, natVal, type (+), type CmpNat)+import           Text.Read (readPrec) +-- |A 'ByteString' that uses hex (base16) for 'Read'/'Show'.+newtype OpaqueString = OpaqueString{ unOpaqueString :: BS.ByteString }+  deriving (Eq, Ord, Semigroup, Monoid, HasLength)++instance Show OpaqueString where+  show = show . Hex.encode . unOpaqueString+  showsPrec p = showsPrec p . Hex.encode . unOpaqueString++instance Read OpaqueString where+  readPrec = do+    b <- readPrec+    either fail (return . OpaqueString) $ Hex.decode b++-- |Allows either hex or character input, dynamically.+instance IsString OpaqueString where+  fromString s = OpaqueString $ either (\_ -> b) id $ Hex.decode b+    -- | all isHexDigit s = OpaqueString $ fst $ Hex.decode $ fromString s+    where+    b = fromString s+ -- See also MonoFoldable class HasLength a where   length :: a -> Int@@ -83,6 +111,12 @@   replicate = BS.replicate   fromList = BS.pack +instance Array OpaqueString where+  type Elem OpaqueString = Word8+  take n = OpaqueString . BS.take n . unOpaqueString+  replicate n = OpaqueString . BS.replicate n+  fromList = OpaqueString . BS.pack+ instance HasLength BSL.ByteString where   length = fromIntegral . BSL.length   compareLength b n@@ -211,3 +245,9 @@  fromLengthList :: Array a => LengthArray o n [Elem a] -> LengthArray o n a fromLengthList = LengthArray . fromList . unLengthArray++opaqueLengthArray :: LengthArray o n BS.ByteString -> LengthArray o n OpaqueString+opaqueLengthArray = LengthArray . OpaqueString . unLengthArray++unOpaqueLengthArray :: LengthArray o n OpaqueString -> LengthArray o n BS.ByteString+unOpaqueLengthArray = LengthArray . unOpaqueString . unLengthArray

@@ -56,7 +56,7 @@ constantType :: HS.Type () constantType = HS.TyForall ()   Nothing-  (Just $ HS.CxSingle () $ HS.ClassA () ("Prelude"!"Integral") [t])+  (Just $ HS.CxSingle () $ HS.TypeA () (HS.TyApp () (HS.TyCon () ("Prelude"!"Integral")) t))   t   where   t = HS.TyVar () $ HS.name "a"@@ -261,14 +261,14 @@  -- |Parse an XDR specification and generate a Haskell module, or fail on error. -- The 'String' argument provides a description of the input to use in parse errors.-generateModule :: Monad m => GenerateOptions -> String -> BSLC.ByteString -> m (HS.Module ())+generateModule :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m (HS.Module ()) generateModule GenerateOptions{..} n b = do   (d, s) <- either (fail . show) return $ XDR.parse n b   return $ specification generateModuleName $ reident generateReidentOptions s d  -- |Parse an XDR specification and generate pretty-printed Haskell source string, or fail on error. -- The 'String' argument provides a description of the input to use in parse errors.-generate :: Monad m => GenerateOptions -> String -> BSLC.ByteString -> m String+generate :: MonadFail m => GenerateOptions -> String -> BSLC.ByteString -> m String generate opts n s = do   m <- generateModule opts n s   return $ "-- |Generated from " ++ n ++ " by <https://github.com/dylex/oncrpc hsrpcgen>\n"

@@ -13,34 +13,35 @@  import           Data.ByteString (ByteString) import           Data.Functor.Identity (runIdentity)+import           Data.Maybe (fromJust)  import           Network.ONCRPC.XDR.Array import           Network.ONCRPC.XDR.Serial import qualified Network.ONCRPC.Prot as RPC --- |Values that can be stored in an 'Network.ONCRPC.XDR.Types.Opaque' 'ByteString'.+-- |Values that can be stored in an 'Network.ONCRPC.XDR.Types.Opaque' 'OpaqueString' 'ByteString'. -- The default implementation allows (re-)embedding of XDR-encoded data, such as with 'RPC.Opaque_auth'. class Opaqued a where   opacify :: a -> ByteString   default opacify :: XDR a => a -> ByteString   opacify = xdrSerialize-  unopacify :: Monad m => ByteString -> m a-  default unopacify :: (XDR a, Monad m) => ByteString -> m a+  unopacify :: MonadFail m => ByteString -> m a+  default unopacify :: (XDR a, MonadFail m) => ByteString -> m a   unopacify = either fail return . xdrDeserialize  unopacify' :: Opaqued a => ByteString -> a-unopacify' = runIdentity . unopacify+unopacify' = fromJust . unopacify -toOpaque :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> Maybe (LengthArray o n ByteString)-toOpaque = lengthArray . opacify+toOpaque :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> Maybe (LengthArray o n OpaqueString)+toOpaque = lengthArray . OpaqueString . opacify -toOpaque' :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> LengthArray o n ByteString-toOpaque' = lengthArray' . opacify+toOpaque' :: (Opaqued a, KnownOrdering o, KnownNat n) => a -> LengthArray o n OpaqueString+toOpaque' = lengthArray' . OpaqueString . opacify -fromOpaque :: (Opaqued a, Monad m) => LengthArray o n ByteString -> m a-fromOpaque = unopacify . unLengthArray+fromOpaque :: (Opaqued a, MonadFail m) => LengthArray o n OpaqueString -> m a+fromOpaque = unopacify . unOpaqueString . unLengthArray -fromOpaque' :: Opaqued a => LengthArray o n ByteString -> a-fromOpaque' = unopacify' . unLengthArray+fromOpaque' :: Opaqued a => LengthArray o n OpaqueString -> a+fromOpaque' = unopacify' . unOpaqueString . unLengthArray  instance Opaqued RPC.Authsys_parms

@@ -63,7 +63,7 @@     (Nothing, s') -> P.putState s'     _ -> fail $ "duplicate identifier: " ++ show i -checkInt :: (Monad m, Integral n) => Integer -> m n+checkInt :: (MonadFail m, Integral n) => Integer -> m n checkInt n   | n == toInteger n' = return n'   | otherwise = fail "invalid constant"

@@ -77,7 +77,7 @@ -- The 'Enum' instance is derived automatically to allow 'succ', etc. to work usefully in Haskell, whereas the 'XDREnum' reflects the XDR-defined values. class (XDR a, Enum a) => XDREnum a where   xdrFromEnum :: a -> XDR.Int-  xdrToEnum :: Monad m => XDR.Int -> m a+  xdrToEnum :: MonadFail m => XDR.Int -> m a  instance XDREnum XDR.Int where   xdrFromEnum = id@@ -87,9 +87,9 @@   xdrFromEnum = fromIntegral   xdrToEnum = return . fromIntegral --- |Version of 'xdrToEnum' that fails at runtime for invalid values: @fromMaybe undefined . 'xdrToEnum'@.+-- |Version of 'xdrToEnum' that fails at runtime for invalid values: @fromJust . 'xdrToEnum'@. xdrToEnum' :: XDREnum a => XDR.Int -> a-xdrToEnum' = runIdentity . xdrToEnum+xdrToEnum' = fromJust . xdrToEnum  -- |Default implementation of 'xdrPut' for 'XDREnum'. xdrPutEnum :: XDREnum a => a -> S.Put@@ -163,8 +163,9 @@ bsLength = fromIntegral . BS.length  xdrPutByteString :: XDR.Length -> BS.ByteString -> S.Put-xdrPutByteString l b = do-  unless (bsLength b == l) $ fail "xdrPutByteString: incorrect length"+xdrPutByteString l b+  | bsLength b /= l = error "xdrPutByteString: incorrect length"+  | otherwise = do   S.putByteString b   xdrPutPad l @@ -226,14 +227,14 @@   xdrGet = xdrGetBoundedArray $ \l -> V.replicateM (fromIntegral l) xdrGet  instance KnownNat n => XDR (LengthArray 'EQ n BS.ByteString) where-  xdrType o = fixedLength o "opaque"+  xdrType o = fixedLength o "string"   xdrPut o =     xdrPutByteString (fromInteger $ natVal (Proxy :: Proxy n)) $ unLengthArray o   xdrGet = unsafeLengthArray <$>     xdrGetByteString (fromInteger $ natVal (Proxy :: Proxy n))  instance KnownNat n => XDR (LengthArray 'LT n BS.ByteString) where-  xdrType o = variableLength o "opaque"+  xdrType o = variableLength o "string"   xdrPut o = do     xdrPut l     xdrPutByteString l b@@ -241,6 +242,16 @@     l = bsLength b     b = unLengthArray o   xdrGet = xdrGetBoundedArray xdrGetByteString++instance KnownNat n => XDR (LengthArray 'EQ n OpaqueString) where+  xdrType o = fixedLength o "opaque"+  xdrPut = xdrPut . unOpaqueLengthArray+  xdrGet = opaqueLengthArray <$> xdrGet++instance KnownNat n => XDR (LengthArray 'LT n OpaqueString) where+  xdrType o = variableLength o "opaque"+  xdrPut = xdrPut . unOpaqueLengthArray+  xdrGet = opaqueLengthArray <$> xdrGet  instance XDR () where   xdrType () = "void"

@@ -44,8 +44,8 @@ type UnsignedHyper  = Word64 type FixedArray n a =   FixedLengthArray n (Vector a) type      Array n a = BoundedLengthArray n (Vector a)-type FixedOpaque n  =   FixedLengthArray n ByteString-type      Opaque n  = BoundedLengthArray n ByteString+type FixedOpaque n  =   FixedLengthArray n OpaqueString+type      Opaque n  = BoundedLengthArray n OpaqueString type FixedString n  =   FixedLengthArray n ByteString type      String n  = BoundedLengthArray n ByteString type Optional a     = Maybe a

@@ -1,5 +1,5 @@ name:                ONC-RPC-version:             0.1+version:             0.2 synopsis:            ONC RPC (aka Sun RPC) and XDR library description:         Tools and library for writing ONC (Sun) RPC clients and servers.  Provides equivalent functionality to rpcgen and librpcsvc, except in pure Haskell.  The hsrpcgen tool (and Cabal preprocessor library) allows .x XDR files to generate Haskell protocol descriptors.  The library provides a client interface to use these descriptions to make RPC calls. license:             Apache-2.0@@ -9,8 +9,9 @@ copyright:           2017 category:            Network build-type:          Custom-cabal-version:       >=1.24+cabal-version:       1.24 tested-with:         GHC == 7.10.3, GHC == 8.0.1+extra-source-files:  README.md  source-repository head   type: git@@ -19,15 +20,20 @@ custom-setup   setup-depends:     base >=4.8 && <5,+    base16-bytestring >= 1.0,     bytestring,     Cabal,     cereal >=0.5.4,     containers,     filepath,-    haskell-src-exts >= 1.18,+    haskell-src-exts >= 1.22,     parsec,     vector +flag bindresvport+  Description: Enable bindresvport option on client connections+  Default: False+ library   exposed-modules:     Network.ONCRPC.XDR.Array@@ -56,13 +62,14 @@   ghc-options: -Wall   build-depends:            base >=4.8 && <5,+    base16-bytestring,     bytestring,     Cabal,     cereal >=0.5.4,     containers,     filepath,     haskell-src-exts >= 1.18,-    network >= 2.6.3,+    network >= 3,     parsec,     random,     time,@@ -71,6 +78,9 @@   if !os(windows)     build-depends:       unix++  if flag(bindresvport)+    cpp-options: -DBINDRESVPORT  executable hsrpcgen   hs-source-dirs: tools

@@ -0,0 +1,46 @@+# Haskell ONC (Sun) RPC and XDR tools and library++Haskell tools and library for interacting with ONC RPC (aka Sun RPC) protocols.+The goal is a working NFS4 client, so TCP clients and efficient large data+handling will be prioritized over servers, UDP, and portmaping.  It includes+the following complete components.++## Primary Components++### hsrpcgen++A code-generator for .x (XDR) files which you can call directly or use as a+pre-processor from cabal (see [Setup.hs](Setup.hs) for an example).  The module+[Network.ONCRPC.Prot](Network/ONCRPC/Prot.hs) in this package is itself+generated from the [XDR description](Network/ONCRPC/Prot.x) of the RPC+protocol.  While many .x files will work as-is, some depend on C-specific+functionality that will require some minor tweaking.++### Network.ONCRPC.Client++A client library which allows you to use the generated module to make RPC calls+to servers.++## Example++```+hsrpcgen -P nfs.x -o NFS.hs+```++```haskell+import qualified Network.ONCRPC as RPC+import qualified NFS++client <- RPC.openClient $ RPC.ClientServerPort "nfs.server.example.com" "nfs"+reply <- RPC.rpcCall client $ RPC.Call (NFS.nFSPROC_NULL (NFS.nFS_VERSION NFS.nFS_PROGRAM)) RPC.AuthNone RPC.AuthNone ()+RPC.closeClient client+```++## References++This package implements [RFC5531](https://tools.ietf.org/html/rfc5531) and+[RFC4506](https://tools.ietf.org/html/rfc4506) as closely as possible.++[xdrgen](http://github.com/jthornber/xdrgen) is a rpcgen replacement for+other languages, written in Haskell.  By contrast, this project targets full RPC+support in Haskell.