diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Network/ONCRPC.hs b/Network/ONCRPC.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC.hs @@ -0,0 +1,17 @@ +-- | ONC (Sun) RPC: Remote Procedure Call Protocol Version 2 as described in RFC5531 +-- +-- This module should be imported qualified, e.g., as @RPC@. + +module Network.ONCRPC + ( module Network.ONCRPC.XDR + , module Network.ONCRPC.Auth + , module Network.ONCRPC.Message + , module Network.ONCRPC.Exception + , module Network.ONCRPC.Client + ) where + +import Network.ONCRPC.XDR +import Network.ONCRPC.Auth hiding (opacifyAuth, unopacifyAuth) +import Network.ONCRPC.Message (Call(..), Reply(..), ReplyException) +import Network.ONCRPC.Exception (RPCException) +import Network.ONCRPC.Client diff --git a/Network/ONCRPC/Auth.hs b/Network/ONCRPC/Auth.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Auth.hs @@ -0,0 +1,68 @@ +-- |Authentication mechanisms for RPC. + +{-# LANGUAGE CPP #-} +module Network.ONCRPC.Auth + ( Auth(..) + , RPC.Authsys_parms(..) + , opacifyAuth + , unopacifyAuth +#ifdef VERSION_unix + , getAuthUnix +#endif + ) where + +import qualified Data.ByteString.Char8 as BSC + +#ifdef VERSION_unix +import System.Posix.Process (getProcessID) +import System.Posix.Unistd (getSystemID, nodeName) +import System.Posix.User (getEffectiveUserID, getEffectiveGroupID, getGroups) +#endif + +import qualified Network.ONCRPC.XDR as XDR +import Network.ONCRPC.XDR.Array +import Network.ONCRPC.XDR.Serial +import Network.ONCRPC.XDR.Opaque +import qualified Network.ONCRPC.Prot as RPC + +-- |More translucent version of 'RPC.Opaque_auth' union (not expressible in XDR) +data Auth + = AuthNone + | AuthSys !RPC.Authsys_parms + | AuthOpaque !RPC.Opaque_auth + deriving (Eq, Show) + +opacifyAuth :: Auth -> RPC.Opaque_auth +opacifyAuth AuthNone = RPC.Opaque_auth (xdrFromEnum RPC.AUTH_NONE) $ emptyBoundedLengthArray +opacifyAuth (AuthSys s) = RPC.Opaque_auth (xdrFromEnum RPC.AUTH_SYS) $ toOpaque' s +opacifyAuth (AuthOpaque o) = o + +unopacifyAuth :: RPC.Opaque_auth -> Auth +unopacifyAuth o@(RPC.Opaque_auth n b) = case xdrToEnum n of + Just RPC.AUTH_NONE -> AuthNone + Just RPC.AUTH_SYS | Just s <- fromOpaque b -> AuthSys s + _ -> AuthOpaque o + +instance XDR.XDR Auth where + xdrType _ = "translucent_auth" + xdrPut = xdrPut . opacifyAuth + xdrGet = unopacifyAuth <$> xdrGet + +#ifdef VERSION_unix +-- |Get the appropriate, effective AuthSys value for the current process. +-- You know, if you're into that sort of thing. +getAuthUnix :: IO Auth +getAuthUnix = do + pid <- getProcessID + sysid <- getSystemID + uid <- getEffectiveUserID + gid <- getEffectiveGroupID + gids <- getGroups + return $ AuthSys RPC.Authsys_parms + { RPC.authsys_parms'stamp = fromIntegral pid + , RPC.authsys_parms'machinename = boundLengthArray $ BSC.pack $ nodeName sysid + , RPC.authsys_parms'uid = fromIntegral uid + , RPC.authsys_parms'gid = fromIntegral gid + , RPC.authsys_parms'gids = boundLengthArrayFromList $ map fromIntegral gids + } +#endif diff --git a/Network/ONCRPC/Bind/Prot.x b/Network/ONCRPC/Bind/Prot.x new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Bind/Prot.x @@ -0,0 +1,336 @@ +/* Extracted from RFC1833 */ + +/* + * rpcb_prot.x + * rpcbind protocol, versions 3 and 4, in RPC Language + */ + +/* + * rpcbind address for TCP/UDP + */ +const RPCB_PORT = 111; + +/* + * A mapping of (program, version, network ID) to address + * + * The network identifier (r_netid): + * This is a string that represents a local identification for a + * network. This is defined by a system administrator based on local + * conventions, and cannot be depended on to have the same value on + * every system. + */ +struct rpcb { + unsigned int r_prog; /* program number */ + unsigned int r_vers; /* version number */ + string r_netid<>; /* network id */ + string r_addr<>; /* universal address */ + string r_owner<>; /* owner of this service */ +}; + +struct rp__list { + rpcb rpcb_map; + struct rp__list *rpcb_next; +}; + + +typedef rp__list *rpcblist_ptr; /* results of RPCBPROC_DUMP */ + + +/* + * Arguments of remote calls + */ +struct rpcb_rmtcallargs { + unsigned int prog; /* program number */ + unsigned int vers; /* version number */ + unsigned int proc; /* procedure number */ + opaque args<>; /* argument */ +}; + + +/* + * Results of the remote call + */ +struct rpcb_rmtcallres { + string addr<>; /* remote universal address */ + opaque results<>; /* result */ +}; + + +/* + * rpcb_entry contains a merged address of a service on a particular + * transport, plus associated netconfig information. A list of + * rpcb_entry items is returned by RPCBPROC_GETADDRLIST. The meanings + * and values used for the r_nc_* fields are given below. + * + * The network identifier (r_nc_netid): + + * This is a string that represents a local identification for a + * network. This is defined by a system administrator based on + * local conventions, and cannot be depended on to have the same + * value on every system. + * + * Transport semantics (r_nc_semantics): + * This represents the type of transport, and has the following values: + * NC_TPI_CLTS (1) Connectionless + * NC_TPI_COTS (2) Connection oriented + * NC_TPI_COTS_ORD (3) Connection oriented with graceful close + * NC_TPI_RAW (4) Raw transport + * + * Protocol family (r_nc_protofmly): + * This identifies the family to which the protocol belongs. The + * following values are defined: + * NC_NOPROTOFMLY "-" + * NC_LOOPBACK "loopback" + * NC_INET "inet" + * NC_IMPLINK "implink" + * NC_PUP "pup" + * NC_CHAOS "chaos" + * NC_NS "ns" + * NC_NBS "nbs" + * NC_ECMA "ecma" + * NC_DATAKIT "datakit" + * NC_CCITT "ccitt" + * NC_SNA "sna" + * NC_DECNET "decnet" + * NC_DLI "dli" + * NC_LAT "lat" + * NC_HYLINK "hylink" + * NC_APPLETALK "appletalk" + * NC_NIT "nit" + * NC_IEEE802 "ieee802" + * NC_OSI "osi" + * NC_X25 "x25" + * NC_OSINET "osinet" + * NC_GOSIP "gosip" + * + * Protocol name (r_nc_proto): + * This identifies a protocol within a family. The following are + * currently defined: + * NC_NOPROTO "-" + * NC_TCP "tcp" + * NC_UDP "udp" + * NC_ICMP "icmp" + */ +struct rpcb_entry { + string r_maddr<>; /* merged address of service */ + string r_nc_netid<>; /* netid field */ + unsigned int r_nc_semantics; /* semantics of transport */ + string r_nc_protofmly<>; /* protocol family */ + string r_nc_proto<>; /* protocol name */ +}; + +/* + * A list of addresses supported by a service. + */ +struct rpcb_entry_list { + rpcb_entry rpcb_entry_map; + struct rpcb_entry_list *rpcb_entry_next; +}; + +typedef rpcb_entry_list *rpcb_entry_list_ptr; + +/* + * rpcbind statistics + */ + +const rpcb_highproc_2 = 5; +const rpcb_highproc_3 = 8; +const rpcb_highproc_4 = 12; + +const RPCBSTAT_HIGHPROC = 13; /* # of procs in rpcbind V4 plus one */ +const RPCBVERS_STAT = 3; /* provide only for rpcbind V2, V3 and V4 */ +const RPCBVERS_4_STAT = 2; +const RPCBVERS_3_STAT = 1; +const RPCBVERS_2_STAT = 0; + +/* Link list of all the stats about getport and getaddr */ +struct rpcbs_addrlist { + unsigned int prog; + unsigned int vers; + int success; + int failure; + string netid<>; + struct rpcbs_addrlist *next; +}; + +/* Link list of all the stats about rmtcall */ +struct rpcbs_rmtcalllist { + unsigned int prog; + unsigned int vers; + unsigned int proc; + int success; + int failure; + int indirect; /* whether callit or indirect */ + string netid<>; + struct rpcbs_rmtcalllist *next; +}; + +typedef int rpcbs_proc[RPCBSTAT_HIGHPROC]; +typedef rpcbs_addrlist *rpcbs_addrlist_ptr; +typedef rpcbs_rmtcalllist *rpcbs_rmtcalllist_ptr; + +struct rpcb_stat { + rpcbs_proc info; + int setinfo; + int unsetinfo; + rpcbs_addrlist_ptr addrinfo; + rpcbs_rmtcalllist_ptr rmtinfo; +}; + +/* + * One rpcb_stat structure is returned for each version of rpcbind + * being monitored. + */ + +typedef rpcb_stat rpcb_stat_byvers[RPCBVERS_STAT]; + +/* + * netbuf structure, used to store the transport specific form of + * a universal transport address. + */ +struct netbuf { + unsigned int maxlen; + opaque buf<>; +}; + +typedef string rpc_string<>; + +/* + * rpcbind procedures + */ +program RPCBPROG { + version RPCBVERS { + bool + RPCBPROC_SET(rpcb) = 1; + + bool + RPCBPROC_UNSET(rpcb) = 2; + + rpc_string + RPCBPROC_GETADDR(rpcb) = 3; + + rpcblist_ptr + RPCBPROC_DUMP(void) = 4; + + rpcb_rmtcallres + RPCBPROC_CALLIT(rpcb_rmtcallargs) = 5; + + unsigned int + RPCBPROC_GETTIME(void) = 6; + + netbuf + RPCBPROC_UADDR2TADDR(rpc_string) = 7; + + rpc_string + RPCBPROC_TADDR2UADDR(netbuf) = 8; + } = 3; + + + version RPCBVERS4 { + bool + RPCBPROC_SET(rpcb) = 1; + + bool + RPCBPROC_UNSET(rpcb) = 2; + + rpc_string + RPCBPROC_GETADDR(rpcb) = 3; + + rpcblist_ptr + RPCBPROC_DUMP(void) = 4; + + /* + * NOTE: RPCBPROC_BCAST has the same functionality as CALLIT; + * the new name is intended to indicate that this + * procedure should be used for broadcast RPC, and + * RPCBPROC_INDIRECT should be used for indirect calls. + */ + rpcb_rmtcallres + RPCBPROC_BCAST(rpcb_rmtcallargs) = 5; + + unsigned int + RPCBPROC_GETTIME(void) = 6; + + netbuf + RPCBPROC_UADDR2TADDR(rpc_string) = 7; + + rpc_string + RPCBPROC_TADDR2UADDR(netbuf) = 8; + + rpc_string + RPCBPROC_GETVERSADDR(rpcb) = 9; + + rpcb_rmtcallres + RPCBPROC_INDIRECT(rpcb_rmtcallargs) = 10; + + rpcb_entry_list_ptr + RPCBPROC_GETADDRLIST(rpcb) = 11; + + rpcb_stat_byvers + RPCBPROC_GETSTAT(void) = 12; + } = 4; +} = 100000; + + +const PMAP_PORT = 111; /* portmapper port number */ + +/* A mapping of (program, version, protocol) to port number: */ +struct mapping { + unsigned int prog; + unsigned int vers; + unsigned int prot; + unsigned int port; +}; + + +/* Supported values for the "prot" field: */ +const IPPROTO_TCP = 6; /* protocol number for TCP/IP */ +const IPPROTO_UDP = 17; /* protocol number for UDP/IP */ + +/* A list of mappings: */ + +struct pmap { + mapping map; + pmaplist next; +}; +typedef pmap *pmaplist; + +/* Arguments to callit: */ + +struct call_args { + unsigned int prog; + unsigned int vers; + unsigned int proc; + opaque args<>; +}; + +/* Results of callit: */ + +struct call_result { + unsigned int port; + opaque res<>; +}; + +/* Port mapper procedures: */ + +program PMAP_PROG { + version PMAP_VERS { + void + PMAPPROC_NULL(void) = 0; + + bool + PMAPPROC_SET(mapping) = 1; + + bool + PMAPPROC_UNSET(mapping) = 2; + + unsigned int + PMAPPROC_GETPORT(mapping) = 3; + + pmaplist + PMAPPROC_DUMP(void) = 4; + + call_result + PMAPPROC_CALLIT(call_args) = 5; + } = 2; +} = 100000; diff --git a/Network/ONCRPC/Client.hs b/Network/ONCRPC/Client.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Client.hs @@ -0,0 +1,183 @@ +-- |ONC RPC Client interface. +-- Handles RPC client protocol layer. +-- Clients are fully thread-safe, allowing multiple outstanding requests, and automatically reconnect on error. +-- Currently error messages are just written to stdout. + +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE RecordWildCards #-} +module Network.ONCRPC.Client + ( ClientServer(..) + , Client + , openClient + , closeClient + , clientCall + , setClientAuth + , rpcCall + ) where + +import Control.Concurrent (ThreadId, forkIO, killThread, threadDelay) +import Control.Concurrent.MVar (MVar, newEmptyMVar, putMVar, takeMVar, modifyMVar, modifyMVar_, modifyMVarMasked) +import Control.Exception (throwIO) +import qualified Data.ByteString.Lazy as BSL +import qualified Data.IntMap.Strict as IntMap +import Data.Time.Clock (getCurrentTime, diffUTCTime) +import qualified Network.Socket as Net +import System.IO (hPutStrLn, stderr) +import System.IO.Error (catchIOError) +import System.Random (randomIO) + +import qualified Network.ONCRPC.XDR as XDR +import qualified Network.ONCRPC.Prot as RPC +import Network.ONCRPC.Types +import Network.ONCRPC.Auth +import Network.ONCRPC.Message +import Network.ONCRPC.Transport + +-- |How to connect to an RPC server. +-- Currently only TCP connections to pre-defined ports are supported (no portmap). +data ClientServer + = ClientServerPort + { clientServerHost :: Net.HostName -- ^Host name or IP address of server + , clientServerPort :: Net.ServiceName -- ^Service name (not portmap) or port number + } -- ^a known service by host/port, currently only TCP + +data Request = forall a . XDR.XDR a => Request + { requestBody :: BSL.ByteString -- ^for retransmits + , requestAction :: MVar (Reply a) + } + +data State = State + { stateSocket :: Maybe Net.Socket + , stateXID :: XID + , stateRequests :: IntMap.IntMap Request + } + +-- |An RPC Client. +data Client = Client + { clientServer :: ClientServer + , clientThread :: ThreadId + , clientState :: MVar State + , clientCred, clientVerf :: Auth + } + +warnMsg :: Show e => String -> e -> IO () +warnMsg m = hPutStrLn stderr . (++) ("Network.ONCRPC.Client: " ++ m ++ ": ") . show + +clientRecv :: Client -> Net.Socket -> IO () +clientRecv c sock = next transportStart where + next ms = + check msg =<< recvGetFirst sock XDR.xdrGet ms + msg (Right (RPC.Rpc_msg x (RPC.Rpc_msg_body'REPLY b))) ms = do + q <- modifyMVarMasked (clientState c) $ \s@State{ stateRequests = m } -> do + let (q, m') = IntMap.updateLookupWithKey (const $ const Nothing) (fromIntegral x) m + return (s{ stateRequests = m' }, q) + case q of + Nothing -> do + warnMsg "ignoring response to unknown xid" x + next ms -- ignore + Just (Request _ a) -> + check (\r ms' -> do + putMVar a $ either ReplyFail id r + next ms') + =<< recvGetNext sock (getReply b) ms + msg e _ = warnMsg "couldn't decode reply msg" e -- return + check _ Nothing = warnMsg "socket closed" () -- return + check f (Just (r, ms)) = f r ms + +clientConnect :: Client -> IO Net.Socket +clientConnect c = modifyMVar (clientState c) $ conn (clientServer c) where + conn _ s@State{ stateSocket = Just sock } = return (s, sock) + 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) + Net.connect sock (Net.addrAddress addr) + resend sock (stateRequests s) + return (s{ stateSocket = Just sock }, sock) + resend sock = mapM_ $ sendTransport sock . requestBody + +clientDisconnect :: Client -> IO () +clientDisconnect c = modifyMVar_ (clientState c) $ \s -> do + catchIOError + (mapM_ Net.close $ stateSocket s) + (warnMsg "close") + return s{ stateSocket = Nothing } + +clientMain :: Client -> IO () +clientMain c = do + t <- getCurrentTime + catchIOError + (clientConnect c >>= clientRecv c) + (warnMsg "client") + clientDisconnect c + dt <- (`diffUTCTime` t) <$> getCurrentTime + threadDelay $ ceiling $ 300000000 / (dt + 20) + clientMain c + +-- |Create a new RPC client to the given server. +-- This client must be destroyed with 'closeClient' when done. +openClient :: ClientServer -> IO Client +openClient srv = do + s <- newEmptyMVar + let c = Client + { clientServer = srv + , clientThread = error "clientThread" + , clientState = s + , clientCred = AuthNone + , clientVerf = AuthNone + } + xid <- randomIO + tid <- forkIO $ clientMain c + putMVar s State + { stateSocket = Nothing + , stateXID = xid + , stateRequests = IntMap.empty + } + return c{ clientThread = tid } + +-- |Set the credentials and verifier to use when calling 'rpcCall' on a client. +-- Note that you can safely use different sets of credentials with the same underlying connection this way. +-- By default, both are set to 'AuthNone'. +setClientAuth :: Auth -> Auth -> Client -> Client +setClientAuth cred verf client = client + { clientCred = cred + , clientVerf = verf + } + +-- |Destroy an RPC client and close its underlying network connection. +-- Any outstanding requests return 'ReplyFail', any any further attempt to use the 'Client' may hang indefinitely. +closeClient :: Client -> IO () +closeClient c = do + killThread $ clientThread c + clientDisconnect c + -- Leave the state empty. + s <- takeMVar $ clientState c + mapM_ (\(Request _ a) -> putMVar a $ ReplyFail "closed") $ stateRequests s + +-- |Send a call message using an open client, and wait for a reply, returning 'ReplyFail' on protocol error. +-- The request will be automatically retried until a response is received. +clientCall :: (XDR.XDR a, XDR.XDR r) => Client -> Call a r -> IO (Reply r) +clientCall c a = do + rv <- newEmptyMVar + p <- modifyMVar (clientState c) $ \s -> do + let x = stateXID s + q = Request + { requestBody = XDR.xdrSerializeLazy $ MsgCall x a + , requestAction = rv + } + (p, r) = IntMap.insertLookupWithKey (const const) (fromIntegral x) q (stateRequests s) + catchIOError + (mapM_ (`sendTransport` requestBody q) $ stateSocket s) + (warnMsg "sendTransport") + return (s{ stateRequests = r, stateXID = x+1 }, p) + case p of + Nothing -> return () + Just (Request _ v) -> putMVar v (ReplyFail "no response") -- should only happen on xid wraparound + takeMVar rv + +-- |Make an RPC request. +-- It waits for a response, retrying as necessary, or throws the 'Network.ONCRPC.Exception.RPCException', 'ReplyException', on any failure. +-- This uses the credentials set by 'setClientAuth'. +-- If you need to retrieve the auth verifier, use 'clientCall'. +rpcCall :: (XDR.XDR a, XDR.XDR r) => Client -> Procedure a r -> a -> IO r +rpcCall c p a = either throwIO return . replyResult + =<< clientCall c (Call p (clientCred c) (clientVerf c) a) diff --git a/Network/ONCRPC/Exception.hs b/Network/ONCRPC/Exception.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Exception.hs @@ -0,0 +1,27 @@ +-- |Exceptions for RPC calls + +{-# LANGUAGE ExistentialQuantification #-} +module Network.ONCRPC.Exception + ( RPCException(..) + , rpcExceptionToException + , rpcExceptionFromException + ) where + +import Control.Exception (Exception(..), SomeException) +import Data.Typeable (Typeable, cast) + +data RPCException = forall e . Exception e => RPCException e + deriving (Typeable) + +instance Show RPCException where + showsPrec p (RPCException e) = showsPrec p e + +instance Exception RPCException + +rpcExceptionToException :: Exception e => e -> SomeException +rpcExceptionToException = toException . RPCException + +rpcExceptionFromException :: Exception e => SomeException -> Maybe e +rpcExceptionFromException x = do + RPCException a <- fromException x + cast a diff --git a/Network/ONCRPC/Message.hs b/Network/ONCRPC/Message.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Message.hs @@ -0,0 +1,174 @@ +-- |Higher-level for RPC messages. + +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE RecordWildCards #-} +module Network.ONCRPC.Message + ( Call(..) + , Reply(..) + , ReplyException + , replyResult + , getReply + , Msg(..) + ) where + +import Control.Applicative ((<|>)) +import Control.Exception (Exception(..)) +import Control.Monad (guard) +import qualified Data.Serialize as S +import Data.Typeable (Typeable) +import Data.Void (Void) + +import qualified Network.ONCRPC.XDR as XDR +import Network.ONCRPC.XDR.Serial +import qualified Network.ONCRPC.Prot as RPC +import Network.ONCRPC.Types +import Network.ONCRPC.Exception +import Network.ONCRPC.Auth + +-- |'RPC.Call_body' with parameters +data Call a r = Call + { callProcedure :: !(Procedure a r) + , callCred :: !Auth + , callVerf :: !Auth + , callArgs :: a + } + deriving (Show) + +splitCall :: Call a r -> (RPC.Call_body, a) +splitCall Call{ callProcedure = Procedure{..}, ..} = + ( RPC.Call_body + { RPC.call_body'rpcvers = RPC.rPC_VERS + , RPC.call_body'prog = procedureProg + , RPC.call_body'vers = procedureVers + , RPC.call_body'proc = procedureProc + , RPC.call_body'cred = opacifyAuth callCred + , RPC.call_body'verf = opacifyAuth callVerf + } + , callArgs + ) + +getCall :: XDR.XDR a => RPC.Call_body -> S.Get (Call a r) +getCall RPC.Call_body{..} = do + guard $ call_body'rpcvers == RPC.rPC_VERS + a <- xdrGet + return Call + { callProcedure = Procedure + { procedureProg = call_body'prog + , procedureVers = call_body'vers + , procedureProc = call_body'proc + } + , callCred = unopacifyAuth call_body'cred + , callVerf = unopacifyAuth call_body'verf + , callArgs = a + } + +instance XDR.XDR a => XDR.XDR (Call a r) where + xdrType _ = "call_body_args" + xdrPut = xdrPut . splitCall + xdrGet = getCall =<< xdrGet + +-- |'RPC.Reply_body' with results +data Reply a + = Reply + { replyVerf :: !Auth + , replyResults :: a + } + | ReplyError + { replyVerf :: !Auth + , replyError :: !RPC.Accepted_reply_data + } + | ReplyRejected + { replyRejected :: !RPC.Rejected_reply + } + | ReplyFail String -- ^Missing/corrupt response + deriving (Typeable) + +instance Show a => Show (Reply a) where + showsPrec p (Reply v r) = showParen (p > 10) $ + showString "Reply " . showsPrec 11 v . showChar ' ' . showsPrec 11 r + showsPrec _ r = showString "RPC reply error: " . showString (se r) where + se (Reply _ _) = "SUCCESS" + se (ReplyError _ (RPC.Accepted_reply_data'PROG_MISMATCH l h)) = "PROG_MISMATCH(" ++ show l ++ "," ++ show h ++ ")" + se (ReplyError _ e) = show $ RPC.accepted_reply_data'stat e + se (ReplyRejected (RPC.Rejected_reply'RPC_MISMATCH l h)) = "RPC_MISMATCH(" ++ show l ++ "," ++ show h ++ ")" + se (ReplyRejected (RPC.Rejected_reply'AUTH_ERROR s)) = "AUTH_ERROR(" ++ show s ++ ")" + se (ReplyFail e) = e + +instance Functor Reply where + fmap f (Reply v r) = Reply v $ f r + fmap _ (ReplyError v e) = ReplyError v e + fmap _ (ReplyRejected e) = ReplyRejected e + fmap _ (ReplyFail e) = ReplyFail e + +type ReplyException = Reply Void +instance Exception ReplyException where + toException = rpcExceptionToException + fromException = rpcExceptionFromException + +-- |The successful reply results or an error. +replyResult :: Reply a -> Either ReplyException a +replyResult (Reply _ r) = Right r +replyResult (ReplyError v e) = Left $ ReplyError v e +replyResult (ReplyRejected e) = Left $ ReplyRejected e +replyResult (ReplyFail e) = Left $ ReplyFail e + +splitReply :: Reply a -> (RPC.Reply_body, Maybe a) +splitReply (Reply v r) = + ( RPC.Reply_body'MSG_ACCEPTED + $ RPC.Accepted_reply (opacifyAuth v) RPC.Accepted_reply_data'SUCCESS + , Just r + ) +splitReply (ReplyError v e) = + ( RPC.Reply_body'MSG_ACCEPTED + $ RPC.Accepted_reply (opacifyAuth v) e + , Nothing + ) +splitReply (ReplyRejected r) = + ( RPC.Reply_body'MSG_DENIED r + , Nothing + ) +splitReply (ReplyFail e) = (error $ "splitReply ReplyFail: " ++ e, Nothing) + +-- |Construct a 'Reply' based on an already-parsed 'RPC.Reply_body' and to-be-parsed results. +getReply :: XDR.XDR a => RPC.Reply_body -> S.Get (Reply a) +getReply (RPC.Reply_body'MSG_ACCEPTED (RPC.Accepted_reply v d@RPC.Accepted_reply_data'SUCCESS)) = + Reply (unopacifyAuth v) <$> xdrGet <|> return (ReplyError (unopacifyAuth v) d) +getReply (RPC.Reply_body'MSG_ACCEPTED (RPC.Accepted_reply v e)) = + return $ ReplyError (unopacifyAuth v) e +getReply (RPC.Reply_body'MSG_DENIED r) = + return $ ReplyRejected r + +instance XDR.XDR a => XDR.XDR (Reply a) where + xdrType _ = "reply_body_result" + xdrPut (ReplyFail e) = fail e + xdrPut r = do + xdrPut b + mapM_ xdrPut a + where (b, a) = splitReply r + xdrGet = getReply =<< xdrGet + +-- |'RPC.Rpc_msg' with arguments or results. +data Msg a r + = MsgCall + { msgXID :: XID + , msgCall :: Call a r + } + | MsgReply + { msgXID :: XID + , msgReply :: Reply r + } + deriving (Show) + +instance (XDR.XDR a, XDR.XDR r) => XDR.XDR (Msg a r) where + xdrType _ = "rpc_msg_content" + xdrPut (MsgCall x c) = xdrPut (RPC.Rpc_msg x $ RPC.Rpc_msg_body'CALL b, a) + where (b, a) = splitCall c + xdrPut (MsgReply x r) = do + xdrPut $ RPC.Rpc_msg x $ RPC.Rpc_msg_body'REPLY b + mapM_ xdrPut a + where (b, a) = splitReply r + xdrGet = do + RPC.Rpc_msg x b <- xdrGet + case b of + RPC.Rpc_msg_body'CALL c -> MsgCall x <$> getCall c + RPC.Rpc_msg_body'REPLY r -> MsgReply x <$> getReply r diff --git a/Network/ONCRPC/Prot.hs b/Network/ONCRPC/Prot.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Prot.hs @@ -0,0 +1,401 @@ +-- |RPC protocol description, as generated from Prot.x, based on RFC5531. +-- This file is not used: cabal automatically generates it from Prot.x. +-- It is only here in case you need to bootstrap. +{-# LANGUAGE DataKinds, TypeFamilies #-} +module Network.ONCRPC.Prot where +import qualified Prelude +import qualified Control.Applicative +import qualified Network.ONCRPC.XDR as XDR + +rPC_VERS :: Prelude.Integral a => a +rPC_VERS = 2 + +data Auth_flavor = AUTH_NONE + | AUTH_SYS + | AUTH_SHORT + | AUTH_DH + | AUTH_KERB + | AUTH_RSA + | RPCSEC_GSS + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR Auth_flavor where + xdrType _ = "Auth_flavor" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum Auth_flavor where + xdrFromEnum AUTH_NONE = 0 + xdrFromEnum AUTH_SYS = 1 + xdrFromEnum AUTH_SHORT = 2 + xdrFromEnum AUTH_DH = 3 + xdrFromEnum AUTH_KERB = 4 + xdrFromEnum AUTH_RSA = 5 + xdrFromEnum RPCSEC_GSS = 6 + xdrToEnum 0 = Prelude.return AUTH_NONE + xdrToEnum 1 = Prelude.return AUTH_SYS + xdrToEnum 2 = Prelude.return AUTH_SHORT + xdrToEnum 3 = Prelude.return AUTH_DH + xdrToEnum 4 = Prelude.return AUTH_KERB + xdrToEnum 5 = Prelude.return AUTH_RSA + xdrToEnum 6 = Prelude.return RPCSEC_GSS + xdrToEnum _ = Prelude.fail "invalid Auth_flavor" + +type Opaque_auth_body = XDR.Opaque 400 + +data Opaque_auth = Opaque_auth{opaque_auth'flavor :: !XDR.Int, + opaque_auth'body :: !Opaque_auth_body} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Opaque_auth where + xdrType _ = "Opaque_auth" + xdrPut _x + = XDR.xdrPut (opaque_auth'flavor _x) Control.Applicative.*> + XDR.xdrPut (opaque_auth'body _x) + xdrGet + = Control.Applicative.pure Opaque_auth Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data Msg_type = CALL + | REPLY + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR Msg_type where + xdrType _ = "Msg_type" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum Msg_type where + xdrFromEnum CALL = 0 + xdrFromEnum REPLY = 1 + xdrToEnum 0 = Prelude.return CALL + xdrToEnum 1 = Prelude.return REPLY + xdrToEnum _ = Prelude.fail "invalid Msg_type" + +data Reply_stat = MSG_ACCEPTED + | MSG_DENIED + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR Reply_stat where + xdrType _ = "Reply_stat" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum Reply_stat where + xdrFromEnum MSG_ACCEPTED = 0 + xdrFromEnum MSG_DENIED = 1 + xdrToEnum 0 = Prelude.return MSG_ACCEPTED + xdrToEnum 1 = Prelude.return MSG_DENIED + xdrToEnum _ = Prelude.fail "invalid Reply_stat" + +data Accept_stat = SUCCESS + | PROG_UNAVAIL + | PROG_MISMATCH + | PROC_UNAVAIL + | GARBAGE_ARGS + | SYSTEM_ERR + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR Accept_stat where + xdrType _ = "Accept_stat" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum Accept_stat where + xdrFromEnum SUCCESS = 0 + xdrFromEnum PROG_UNAVAIL = 1 + xdrFromEnum PROG_MISMATCH = 2 + xdrFromEnum PROC_UNAVAIL = 3 + xdrFromEnum GARBAGE_ARGS = 4 + xdrFromEnum SYSTEM_ERR = 5 + xdrToEnum 0 = Prelude.return SUCCESS + xdrToEnum 1 = Prelude.return PROG_UNAVAIL + xdrToEnum 2 = Prelude.return PROG_MISMATCH + xdrToEnum 3 = Prelude.return PROC_UNAVAIL + xdrToEnum 4 = Prelude.return GARBAGE_ARGS + xdrToEnum 5 = Prelude.return SYSTEM_ERR + xdrToEnum _ = Prelude.fail "invalid Accept_stat" + +data Reject_stat = RPC_MISMATCH + | AUTH_ERROR + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR Reject_stat where + xdrType _ = "Reject_stat" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum Reject_stat where + xdrFromEnum RPC_MISMATCH = 0 + xdrFromEnum AUTH_ERROR = 1 + xdrToEnum 0 = Prelude.return RPC_MISMATCH + xdrToEnum 1 = Prelude.return AUTH_ERROR + xdrToEnum _ = Prelude.fail "invalid Reject_stat" + +data Auth_stat = AUTH_OK + | AUTH_BADCRED + | AUTH_REJECTEDCRED + | AUTH_BADVERF + | AUTH_REJECTEDVERF + | AUTH_TOOWEAK + | AUTH_INVALIDRESP + | AUTH_FAILED + | AUTH_KERB_GENERIC + | AUTH_TIMEEXPIRE + | AUTH_TKT_FILE + | AUTH_DECODE + | AUTH_NET_ADDR + | RPCSEC_GSS_CREDPROBLEM + | RPCSEC_GSS_CTXPROBLEM + deriving (Prelude.Eq, Prelude.Ord, Prelude.Enum, Prelude.Bounded, + Prelude.Show) + +instance XDR.XDR Auth_stat where + xdrType _ = "Auth_stat" + xdrPut = XDR.xdrPutEnum + xdrGet = XDR.xdrGetEnum + +instance XDR.XDREnum Auth_stat where + xdrFromEnum AUTH_OK = 0 + xdrFromEnum AUTH_BADCRED = 1 + xdrFromEnum AUTH_REJECTEDCRED = 2 + xdrFromEnum AUTH_BADVERF = 3 + xdrFromEnum AUTH_REJECTEDVERF = 4 + xdrFromEnum AUTH_TOOWEAK = 5 + xdrFromEnum AUTH_INVALIDRESP = 6 + xdrFromEnum AUTH_FAILED = 7 + xdrFromEnum AUTH_KERB_GENERIC = 8 + xdrFromEnum AUTH_TIMEEXPIRE = 9 + xdrFromEnum AUTH_TKT_FILE = 10 + xdrFromEnum AUTH_DECODE = 11 + xdrFromEnum AUTH_NET_ADDR = 12 + xdrFromEnum RPCSEC_GSS_CREDPROBLEM = 13 + xdrFromEnum RPCSEC_GSS_CTXPROBLEM = 14 + xdrToEnum 0 = Prelude.return AUTH_OK + xdrToEnum 1 = Prelude.return AUTH_BADCRED + xdrToEnum 2 = Prelude.return AUTH_REJECTEDCRED + xdrToEnum 3 = Prelude.return AUTH_BADVERF + xdrToEnum 4 = Prelude.return AUTH_REJECTEDVERF + xdrToEnum 5 = Prelude.return AUTH_TOOWEAK + xdrToEnum 6 = Prelude.return AUTH_INVALIDRESP + xdrToEnum 7 = Prelude.return AUTH_FAILED + xdrToEnum 8 = Prelude.return AUTH_KERB_GENERIC + xdrToEnum 9 = Prelude.return AUTH_TIMEEXPIRE + xdrToEnum 10 = Prelude.return AUTH_TKT_FILE + xdrToEnum 11 = Prelude.return AUTH_DECODE + xdrToEnum 12 = Prelude.return AUTH_NET_ADDR + xdrToEnum 13 = Prelude.return RPCSEC_GSS_CREDPROBLEM + xdrToEnum 14 = Prelude.return RPCSEC_GSS_CTXPROBLEM + xdrToEnum _ = Prelude.fail "invalid Auth_stat" + +data Rpc_msg = Rpc_msg{rpc_msg'xid :: !XDR.UnsignedInt, + rpc_msg'body :: !Rpc_msg_body} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Rpc_msg where + xdrType _ = "Rpc_msg" + xdrPut _x + = XDR.xdrPut (rpc_msg'xid _x) Control.Applicative.*> + XDR.xdrPut (rpc_msg'body _x) + xdrGet + = Control.Applicative.pure Rpc_msg Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data Rpc_msg_body = Rpc_msg_body'CALL{rpc_msg_body'cbody :: + !Call_body} + | Rpc_msg_body'REPLY{rpc_msg_body'rbody :: !Reply_body} + deriving (Prelude.Eq, Prelude.Show) + +rpc_msg_body'mtype :: Rpc_msg_body -> Msg_type +rpc_msg_body'mtype = XDR.xdrDiscriminant + +instance XDR.XDR Rpc_msg_body where + xdrType _ = "Rpc_msg_body" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Rpc_msg_body where + type XDRDiscriminant Rpc_msg_body = Msg_type + xdrSplitUnion _x@Rpc_msg_body'CALL{} + = (0, XDR.xdrPut (rpc_msg_body'cbody _x)) + xdrSplitUnion _x@Rpc_msg_body'REPLY{} + = (1, XDR.xdrPut (rpc_msg_body'rbody _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure Rpc_msg_body'CALL + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure Rpc_msg_body'REPLY + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid Rpc_msg_body discriminant" + +data Call_body = Call_body{call_body'rpcvers :: !XDR.UnsignedInt, + call_body'prog :: !XDR.UnsignedInt, + call_body'vers :: !XDR.UnsignedInt, + call_body'proc :: !XDR.UnsignedInt, call_body'cred :: !Opaque_auth, + call_body'verf :: !Opaque_auth} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Call_body where + xdrType _ = "Call_body" + xdrPut _x + = XDR.xdrPut (call_body'rpcvers _x) Control.Applicative.*> + XDR.xdrPut (call_body'prog _x) + Control.Applicative.*> XDR.xdrPut (call_body'vers _x) + Control.Applicative.*> XDR.xdrPut (call_body'proc _x) + Control.Applicative.*> XDR.xdrPut (call_body'cred _x) + Control.Applicative.*> XDR.xdrPut (call_body'verf _x) + xdrGet + = Control.Applicative.pure Call_body Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data Reply_body = Reply_body'MSG_ACCEPTED{reply_body'areply :: + !Accepted_reply} + | Reply_body'MSG_DENIED{reply_body'rreply :: !Rejected_reply} + deriving (Prelude.Eq, Prelude.Show) + +reply_body'stat :: Reply_body -> Reply_stat +reply_body'stat = XDR.xdrDiscriminant + +instance XDR.XDR Reply_body where + xdrType _ = "Reply_body" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Reply_body where + type XDRDiscriminant Reply_body = Reply_stat + xdrSplitUnion _x@Reply_body'MSG_ACCEPTED{} + = (0, XDR.xdrPut (reply_body'areply _x)) + xdrSplitUnion _x@Reply_body'MSG_DENIED{} + = (1, XDR.xdrPut (reply_body'rreply _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure Reply_body'MSG_ACCEPTED + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure Reply_body'MSG_DENIED + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c = Prelude.fail "invalid Reply_body discriminant" + +data Accepted_reply = Accepted_reply{accepted_reply'verf :: + !Opaque_auth, + accepted_reply'reply_data :: !Accepted_reply_data} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Accepted_reply where + xdrType _ = "Accepted_reply" + xdrPut _x + = XDR.xdrPut (accepted_reply'verf _x) Control.Applicative.*> + XDR.xdrPut (accepted_reply'reply_data _x) + xdrGet + = Control.Applicative.pure Accepted_reply Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + +data Accepted_reply_data = Accepted_reply_data'SUCCESS{} + | Accepted_reply_data'PROG_MISMATCH{accepted_reply_data'mismatch_info'low + :: !XDR.UnsignedInt, + accepted_reply_data'mismatch_info'high + :: !XDR.UnsignedInt} + | Accepted_reply_data'default{accepted_reply_data'stat' :: + !Accept_stat} + deriving (Prelude.Eq, Prelude.Show) + +accepted_reply_data'stat :: Accepted_reply_data -> Accept_stat +accepted_reply_data'stat = XDR.xdrDiscriminant + +instance XDR.XDR Accepted_reply_data where + xdrType _ = "Accepted_reply_data" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Accepted_reply_data where + type XDRDiscriminant Accepted_reply_data = Accept_stat + xdrSplitUnion _x@Accepted_reply_data'SUCCESS{} + = (0, Control.Applicative.pure ()) + xdrSplitUnion _x@Accepted_reply_data'PROG_MISMATCH{} + = (2, + XDR.xdrPut (accepted_reply_data'mismatch_info'low _x) + Control.Applicative.*> + XDR.xdrPut (accepted_reply_data'mismatch_info'high _x)) + xdrSplitUnion + _x@Accepted_reply_data'default{accepted_reply_data'stat' = d} + = (XDR.xdrFromEnum d, Control.Applicative.pure ()) + xdrGetUnionArm 0 + = Control.Applicative.pure Accepted_reply_data'SUCCESS + xdrGetUnionArm 2 + = Control.Applicative.pure Accepted_reply_data'PROG_MISMATCH + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Accepted_reply_data'default Control.Applicative.<$> + XDR.xdrToEnum _c + +data Rejected_reply = Rejected_reply'RPC_MISMATCH{rejected_reply'mismatch_info'low + :: !XDR.UnsignedInt, + rejected_reply'mismatch_info'high :: + !XDR.UnsignedInt} + | Rejected_reply'AUTH_ERROR{rejected_reply'auth_stat :: !Auth_stat} + deriving (Prelude.Eq, Prelude.Show) + +rejected_reply'stat :: Rejected_reply -> Reject_stat +rejected_reply'stat = XDR.xdrDiscriminant + +instance XDR.XDR Rejected_reply where + xdrType _ = "Rejected_reply" + xdrPut = XDR.xdrPutUnion + xdrGet = XDR.xdrGetUnion + +instance XDR.XDRUnion Rejected_reply where + type XDRDiscriminant Rejected_reply = Reject_stat + xdrSplitUnion _x@Rejected_reply'RPC_MISMATCH{} + = (0, + XDR.xdrPut (rejected_reply'mismatch_info'low _x) + Control.Applicative.*> + XDR.xdrPut (rejected_reply'mismatch_info'high _x)) + xdrSplitUnion _x@Rejected_reply'AUTH_ERROR{} + = (1, XDR.xdrPut (rejected_reply'auth_stat _x)) + xdrGetUnionArm 0 + = Control.Applicative.pure Rejected_reply'RPC_MISMATCH + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm 1 + = Control.Applicative.pure Rejected_reply'AUTH_ERROR + Control.Applicative.<*> XDR.xdrGet + xdrGetUnionArm _c + = Prelude.fail "invalid Rejected_reply discriminant" + +data Authsys_parms = Authsys_parms{authsys_parms'stamp :: + !XDR.UnsignedInt, + authsys_parms'machinename :: !(XDR.String 255), + authsys_parms'uid :: !XDR.UnsignedInt, + authsys_parms'gid :: !XDR.UnsignedInt, + authsys_parms'gids :: !(XDR.Array 16 XDR.UnsignedInt)} + deriving (Prelude.Eq, Prelude.Show) + +instance XDR.XDR Authsys_parms where + xdrType _ = "Authsys_parms" + xdrPut _x + = XDR.xdrPut (authsys_parms'stamp _x) Control.Applicative.*> + XDR.xdrPut (authsys_parms'machinename _x) + Control.Applicative.*> XDR.xdrPut (authsys_parms'uid _x) + Control.Applicative.*> XDR.xdrPut (authsys_parms'gid _x) + Control.Applicative.*> XDR.xdrPut (authsys_parms'gids _x) + xdrGet + = Control.Applicative.pure Authsys_parms Control.Applicative.<*> + XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet + Control.Applicative.<*> XDR.xdrGet diff --git a/Network/ONCRPC/Prot.x b/Network/ONCRPC/Prot.x new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Prot.x @@ -0,0 +1,146 @@ +/* rpc.x extracted from RFC5531 */ + +const RPC_VERS = 2; + +enum auth_flavor { + AUTH_NONE = 0, + AUTH_SYS = 1, + AUTH_SHORT = 2, + AUTH_DH = 3, + AUTH_KERB = 4, /* RFC2695 */ + AUTH_RSA = 5, + RPCSEC_GSS = 6 /* RFC2203 */ + /* and more to be defined */ +}; + +typedef opaque opaque_auth_body<400>; + +struct opaque_auth { + int flavor; /* may be "pseudo" value outside enum */ + opaque_auth_body body; +}; + +enum msg_type { + CALL = 0, + REPLY = 1 +}; + +enum reply_stat { + MSG_ACCEPTED = 0, + MSG_DENIED = 1 +}; + +enum accept_stat { + SUCCESS = 0, /* RPC executed successfully */ + PROG_UNAVAIL = 1, /* remote hasn't exported program */ + PROG_MISMATCH = 2, /* remote can't support version # */ + PROC_UNAVAIL = 3, /* program can't support procedure */ + GARBAGE_ARGS = 4, /* procedure can't decode params */ + SYSTEM_ERR = 5 /* e.g. memory allocation failure */ +}; + +enum reject_stat { + RPC_MISMATCH = 0, /* RPC version number != 2 */ + AUTH_ERROR = 1 /* remote can't authenticate caller */ +}; + +enum auth_stat { + AUTH_OK = 0, /* success */ + /* + * failed at remote end + */ + AUTH_BADCRED = 1, /* bad credential (seal broken) */ + AUTH_REJECTEDCRED = 2, /* client must begin new session */ + AUTH_BADVERF = 3, /* bad verifier (seal broken) */ + AUTH_REJECTEDVERF = 4, /* verifier expired or replayed */ + AUTH_TOOWEAK = 5, /* rejected for security reasons */ + /* + * failed locally + */ + AUTH_INVALIDRESP = 6, /* bogus response verifier */ + AUTH_FAILED = 7, /* reason unknown */ + /* + * AUTH_KERB errors; deprecated. See [[139]RFC2695] + */ + AUTH_KERB_GENERIC = 8, /* kerberos generic error */ + AUTH_TIMEEXPIRE = 9, /* time of credential expired */ + AUTH_TKT_FILE = 10, /* problem with ticket file */ + AUTH_DECODE = 11, /* can't decode authenticator */ + AUTH_NET_ADDR = 12, /* wrong net address in ticket */ + /* + * RPCSEC_GSS GSS related errors + */ + RPCSEC_GSS_CREDPROBLEM = 13, /* no credentials for user */ + RPCSEC_GSS_CTXPROBLEM = 14 /* problem with context */ +}; + +struct rpc_msg { + unsigned int xid; + union rpc_msg_body body; +}; + +union rpc_msg_body switch (msg_type mtype) { + case CALL: + call_body cbody; + case REPLY: + reply_body rbody; +}; + +struct call_body { + unsigned int rpcvers; /* must be equal to two (2) */ + unsigned int prog; + unsigned int vers; + unsigned int proc; + opaque_auth cred; + opaque_auth verf; + /* procedure-specific parameters start here */ +}; + +union reply_body switch (reply_stat stat) { + case MSG_ACCEPTED: + accepted_reply areply; + case MSG_DENIED: + rejected_reply rreply; +} /*reply*/; + +struct accepted_reply { + opaque_auth verf; + union accepted_reply_data reply_data; +}; + +union accepted_reply_data switch (accept_stat stat) { + case SUCCESS: + void /* opaque results[0] */; + /* + * procedure-specific results start here + */ + case PROG_MISMATCH: + struct { + unsigned int low; + unsigned int high; + } mismatch_info; + default: + /* + * Void. Cases include PROG_UNAVAIL, PROC_UNAVAIL, + * GARBAGE_ARGS, and SYSTEM_ERR. + */ + void; +}; + +union rejected_reply switch (reject_stat stat) { + case RPC_MISMATCH: + struct { + unsigned int low; + unsigned int high; + } mismatch_info; + case AUTH_ERROR: + auth_stat auth_stat; /* renamed to avoid conflict with discriminator */ +}; + +struct authsys_parms { + unsigned int stamp; + string machinename<255>; + unsigned int uid; + unsigned int gid; + unsigned int gids<16>; +}; diff --git a/Network/ONCRPC/RecordMarking.hs b/Network/ONCRPC/RecordMarking.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/RecordMarking.hs @@ -0,0 +1,78 @@ +module Network.ONCRPC.RecordMarking + ( sendRecord + , RecordState(RecordStart) + , recordDone + , recordRemaining + , recvRecord + ) where + +import Control.Monad (unless) +import Data.Bits (Bits, finiteBitSize, bit, clearBit, setBit, testBit) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Word (Word32) +import qualified Network.Socket as Net +import qualified Network.Socket.All as NetAll +import qualified Network.Socket.ByteString as NetBS +import qualified Network.Socket.ByteString.Lazy as NetBSL + +-- |A raw RPC record fragment header, stored in network byte order. +type FragmentHeader = Word32 + +fragmentHeaderBit :: Int +fragmentHeaderBit = pred $ finiteBitSize (0 :: FragmentHeader) + +maxFragmentSize :: (Bits i, Integral i) => i +maxFragmentSize = pred $ bit fragmentHeaderBit + +unFragmentHeader :: Integral i => FragmentHeader -> (Bool, i) +unFragmentHeader w = + (testBit w' fragmentHeaderBit, fromIntegral $ clearBit w' fragmentHeaderBit) + where w' = Net.ntohl w + +mkFragmentHeader :: Integral i => Bool -> i -> FragmentHeader +mkFragmentHeader l n = Net.htonl $ sb l $ fromIntegral n where + sb True x = setBit x fragmentHeaderBit + sb False x = x + +sendRecord :: Net.Socket -> BSL.ByteString -> IO () +sendRecord sock b = do + NetAll.sendStorable sock $ mkFragmentHeader l (BSL.length h) + NetBSL.sendAll sock h + unless l $ sendRecord sock t + where + (h, t) = BSL.splitAt maxFragmentSize b + l = BSL.null t + +data RecordState + = RecordStart + | RecordHeader + | RecordFragment + { _fragmentLast :: !Bool + , _fragmentLength :: !Int + } + deriving (Eq, Show) + +-- |Is the current record complete? +recordDone :: RecordState -> Bool +recordDone RecordStart = True +recordDone _ = False + +-- |How many bytes are left in this record, if known? +recordRemaining :: RecordState -> Maybe Int +recordRemaining RecordStart = Just 0 +recordRemaining (RecordFragment True n) = Just n +recordRemaining _ = Nothing + +-- |Receive the next block of a record +recvRecord :: Net.Socket -> RecordState -> IO (BS.ByteString, RecordState) +recvRecord sock (RecordFragment e n) = do + b <- NetBS.recv sock n + let l = BS.length b + return (b, if l < n + then RecordFragment e (n - l) + else if e + then RecordStart + else RecordHeader) +recvRecord sock s = + maybe (return (BS.empty, s)) (recvRecord sock . uncurry RecordFragment . unFragmentHeader) =<< NetAll.recvStorable sock diff --git a/Network/ONCRPC/Transport.hs b/Network/ONCRPC/Transport.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Transport.hs @@ -0,0 +1,63 @@ +module Network.ONCRPC.Transport + ( sendTransport + , recvTransport + , TransportState + , transportStart + , recvGetFirst + , recvGetNext + ) where + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.Serialize.Get as S +import qualified Network.Socket as Net + +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" + +recvTransport :: Net.Socket -> RecordState -> IO (BS.ByteString, RecordState) +recvTransport sock@(Net.MkSocket _ _ Net.Stream _ _) = recvRecord sock +recvTransport _ = const $ fail "ONCRPC: Unsupported socket type" + +data TransportState = TransportState + { _bufferState :: BS.ByteString + , recordState :: RecordState + } + deriving (Eq, Show) + +transportNext :: RecordState -> TransportState +transportNext = TransportState BS.empty + +transportStart :: TransportState +transportStart = transportNext RecordStart + +recvTransportWith :: Net.Socket -> RecordState -> (BS.ByteString -> RecordState -> IO (Maybe a)) -> IO (Maybe a) +recvTransportWith sock rs f = do + (b, rs') <- recvTransport sock rs + if BS.null b + then return Nothing + else f b rs' + +-- |Get the next part of the current record, after calling 'recvGetFirst' to start. +recvGetNext :: Net.Socket -> S.Get a -> TransportState -> IO (Maybe (Either String a, TransportState)) +recvGetNext sock getter = start where + start (TransportState b rs) -- continue record + | BS.null b = get Nothing rs -- check for more + | otherwise = got Nothing b rs -- buffered data + get f RecordStart = got f BS.empty RecordStart -- end of record + get f rs = recvTransportWith sock rs $ got f -- read next block + got Nothing b rs = fed rs $ S.runGetChunk getter (recordRemaining rs) b -- start parsing + got (Just f) b rs = fed rs $ f b -- parse block + fed rs (S.Partial f) = get (Just f) rs + fed rs (S.Done r b) = return $ Just (Right r, TransportState b rs) + fed rs (S.Fail e b) = return $ Just (Left e, TransportState b rs) + +-- |Get the first part of the next record, possibly skipping over the rest of the current record. +recvGetFirst :: Net.Socket -> S.Get a -> TransportState -> IO (Maybe (Either String a, TransportState)) +recvGetFirst sock getter = get . recordState where + get rs = recvTransportWith sock rs $ got rs -- read next block + got RecordStart b rs = recvGetNext sock getter $ TransportState b rs -- start next record + got _ _ rs = get rs -- ignore remaining record diff --git a/Network/ONCRPC/Types.hs b/Network/ONCRPC/Types.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/Types.hs @@ -0,0 +1,25 @@ +-- |Types for RPC protocol and procedure. + +{-# LANGUAGE RecordWildCards #-} +module Network.ONCRPC.Types + ( XID + , ProgNum + , VersNum + , ProcNum + , Procedure(..) + ) where + +import Data.Word (Word32) + +type XID = Word32 +type ProgNum = Word32 +type VersNum = Word32 +type ProcNum = Word32 + +-- |Description of a specific procedure, parameterized by argument and result types. +data Procedure a r = Procedure + { procedureProg :: !ProgNum + , procedureVers :: !VersNum + , procedureProc :: !ProcNum + } + deriving (Eq, Show) diff --git a/Network/ONCRPC/XDR.hs b/Network/ONCRPC/XDR.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR.hs @@ -0,0 +1,13 @@ +-- | XDR: External Data Representation as described in RFC4506 +-- +-- This module should be imported qualified, e.g., as @XDR@. + +module Network.ONCRPC.XDR + ( module Network.ONCRPC.XDR.Types + , module Network.ONCRPC.XDR.Array + , module Network.ONCRPC.XDR.Serial + ) where + +import Network.ONCRPC.XDR.Types +import Network.ONCRPC.XDR.Array +import Network.ONCRPC.XDR.Serial diff --git a/Network/ONCRPC/XDR/Array.hs b/Network/ONCRPC/XDR/Array.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Array.hs @@ -0,0 +1,213 @@ +-- |Various kinds of arrays (lists, vectors, bytestrings) with statically aserted length constraints encoded in their type. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE ExplicitNamespaces #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +-- {-# OPTIONS_GHC -Wno-redundant-constraints #-} +module Network.ONCRPC.XDR.Array + ( KnownNat + , KnownOrdering + , LengthArray + , FixedLengthArray + , fixedLengthArrayLength + , BoundedLengthArray + , boundedLengthArrayBound + , unLengthArray + , unsafeLengthArray + , lengthArray + , lengthArray' + , boundLengthArray + , boundLengthArrayFromList + , padLengthArray + , constLengthArray + , emptyFixedLengthArray + , emptyBoundedLengthArray + , expandBoundedLengthArray + , boundFixedLengthArray + , appendLengthArray + , fromLengthList + ) where + +import Prelude hiding (length, take, drop, replicate) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.List as List +import Data.Maybe (fromMaybe, fromJust) +import Data.Monoid (Monoid, (<>)) +import Data.Proxy (Proxy(..)) +import Data.String (IsString(..)) +import qualified Data.Vector as V +import Data.Word (Word8) +import GHC.TypeLits (Nat, KnownNat, natVal, type (+), type CmpNat) + +-- See also MonoFoldable +class HasLength a where + length :: a -> Int + -- |Equivalent to @'compare' . 'length'@ but allows more efficient implementations + compareLength :: a -> Int -> Ordering + compareLength = compare . length + +-- See also IsSquence +class (Monoid a, HasLength a) => Array a where + type Elem a :: * + take :: Int -> a -> a + replicate :: Int -> Elem a -> a + fromList :: [Elem a] -> a + +instance HasLength [a] where + length = List.length + compareLength [] n = compare 0 n + compareLength (_:l) n = compareLength l (n - 1) +instance Array [a] where + type Elem [a] = a + take = List.take + replicate = List.replicate + fromList = id + +instance HasLength (V.Vector a) where + length = V.length +instance Array (V.Vector a) where + type Elem (V.Vector a) = a + take = V.take + replicate = V.replicate + fromList = V.fromList + +instance HasLength BS.ByteString where + length = BS.length +instance Array BS.ByteString where + type Elem BS.ByteString = Word8 + take = BS.take + replicate = BS.replicate + fromList = BS.pack + +instance HasLength BSL.ByteString where + length = fromIntegral . BSL.length + compareLength b n + | BSL.null b' = LT + | BSL.null (BSL.tail b') = EQ + | otherwise = GT + where b' = BSL.drop (fromIntegral n - 1) b +instance Array BSL.ByteString where + type Elem BSL.ByteString = Word8 + take = BSL.take . fromIntegral + replicate = BSL.replicate . fromIntegral + fromList = BSL.pack + +class KnownOrdering (o :: Ordering) where + orderingVal :: proxy o -> Ordering + +instance KnownOrdering 'LT where orderingVal _ = LT +instance KnownOrdering 'EQ where orderingVal _ = EQ +instance KnownOrdering 'GT where orderingVal _ = GT + +-- |Assertion that the contained array satisfies @'compareLength' a n = o@ +newtype LengthArray (o :: Ordering) (n :: Nat) a = LengthArray{ unLengthArray :: a } + deriving (Eq, Ord, Show) + +instance HasLength a => HasLength (LengthArray o n a) where + length = length . unLengthArray + compareLength = compareLength . unLengthArray + +-- |Assertion that the contained array is exactly a static length +type FixedLengthArray n a = LengthArray 'EQ n a +-- |Assertion that the contained array is at most a static length (inclusive) +type BoundedLengthArray n a = LengthArray 'LT (n + 1) a + +lengthArrayOrdering :: forall o n a . KnownOrdering o => LengthArray o n a -> Ordering +lengthArrayOrdering _ = orderingVal (Proxy :: Proxy o) + +lengthArrayBound :: forall o n a . KnownNat n => LengthArray o n a -> Int +lengthArrayBound _ = fromInteger $ natVal (Proxy :: Proxy n) + +orderingOp :: Ordering -> Char +orderingOp LT = '<' +orderingOp EQ = '=' +orderingOp GT = '>' + +describeLengthArray :: (KnownOrdering o, KnownNat n) => LengthArray o n a -> String +describeLengthArray a = orderingOp (lengthArrayOrdering a) : show (lengthArrayBound a) + +-- |Static length of a 'FixedLengthArray' +fixedLengthArrayLength :: KnownNat n => LengthArray 'EQ n a -> Int +fixedLengthArrayLength = lengthArrayBound + +-- |Static upper-bound (inclusive) of a 'BoundedLengthArray' +boundedLengthArrayBound :: KnownNat n => LengthArray 'LT n a -> Int +boundedLengthArrayBound = subtract 1 . lengthArrayBound + +-- |Unsafely create a 'LengthArray' without checking the length bound assertion. +-- May cause unpredictable behavior if the bound does not hold. +unsafeLengthArray :: a -> LengthArray o n a +unsafeLengthArray = LengthArray + +checkLengthArray :: (KnownOrdering o, KnownNat n, HasLength a) => LengthArray o n a -> Bool +checkLengthArray l@(LengthArray a) = compareLength a (lengthArrayBound l) == lengthArrayOrdering l + +-- |Safely create a 'LengthArray' out of an array if it conforms to the static length assertion. +lengthArray :: forall o n a . (KnownOrdering o, KnownNat n, HasLength a) => a -> Maybe (LengthArray o n a) +lengthArray a + | checkLengthArray l = Just l + | otherwise = Nothing + where l = LengthArray a :: LengthArray o n a + +-- |Create a 'LengthArray' or runtime error if the assertion fails: @fromMaybe undefined . 'lengthArray'@ +lengthArray' :: forall o n a . (KnownOrdering o, KnownNat n, HasLength a) => a -> LengthArray o n a +lengthArray' a = fromMaybe (error $ "lengthArray': fails check " ++ describeLengthArray (fromJust la)) la + where la = lengthArray a + +-- |Create a 'BoundedLengthArray' by trimming the given array if necessary. +boundLengthArray :: (KnownNat n, Array a) => a -> LengthArray 'LT n a +boundLengthArray a = l where + l = LengthArray $ take (boundedLengthArrayBound l) a + +-- |Create a 'BoundedLengthArray' by trimming the given array if necessary. +boundLengthArrayFromList :: (KnownNat n, Array a) => [Elem a] -> LengthArray 'LT n a +boundLengthArrayFromList a = l where + l = LengthArray $ fromList $ take (boundedLengthArrayBound l) a + +-- |Create a 'FixedLengthArray' by trimming or padding (on the right) as necessary. +padLengthArray :: (KnownNat n, Array a) => a -> Elem a -> LengthArray 'EQ n a +padLengthArray a p = l where + a' = case compareLength a n of + LT -> a <> replicate (n - length a) p + EQ -> a + GT -> take n a + n = fixedLengthArrayLength l + l = LengthArray a' + +-- |Create a 'FixedLengthArray' filled with the same value. +constLengthArray :: (KnownNat n, Array a) => Elem a -> LengthArray 'EQ n a +constLengthArray p = l where + l = LengthArray $ replicate (fixedLengthArrayLength l) p + +instance (KnownOrdering o, KnownNat n, IsString a, HasLength a) => IsString (LengthArray o n a) where + fromString s = fromMaybe + (error $ "String " ++ show s ++ " fails LengthArray check " ++ describeLengthArray (fromJust ls)) + ls + where ls = lengthArray $ fromString s + +-- |An empty 'FixedLengthArray'. +emptyFixedLengthArray :: Array a => LengthArray 'EQ 0 a +emptyFixedLengthArray = LengthArray mempty + +-- |An empty 'BoundedLengthArray'. +emptyBoundedLengthArray :: (CmpNat 0 n ~ 'LT, Array a) => LengthArray 'LT n a +emptyBoundedLengthArray = LengthArray mempty + +-- |Grow the bound of a 'BoundedLengthArray'. +expandBoundedLengthArray :: (CmpNat n m ~ 'LT) => LengthArray 'LT n a -> LengthArray 'LT m a +expandBoundedLengthArray = LengthArray . unLengthArray + +-- |Convert a 'FixedLengthArray' to a 'BoundedLengthArray'. +boundFixedLengthArray :: (CmpNat n m ~ 'LT) => LengthArray 'EQ n a -> LengthArray 'LT m a +boundFixedLengthArray = LengthArray . unLengthArray + +-- |Append to two 'LengthArray's. +appendLengthArray :: Monoid a => LengthArray o n a -> LengthArray o m a -> LengthArray o (n + m) a +appendLengthArray (LengthArray a) (LengthArray b) = LengthArray $ mappend a b + +fromLengthList :: Array a => LengthArray o n [Elem a] -> LengthArray o n a +fromLengthList = LengthArray . fromList . unLengthArray diff --git a/Network/ONCRPC/XDR/Cabal.hs b/Network/ONCRPC/XDR/Cabal.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Cabal.hs @@ -0,0 +1,70 @@ +-- |Cabal utilities for XDR processing. +{-# LANGUAGE CPP #-} +module Network.ONCRPC.XDR.Cabal + ( ppRPCGenSuffixHandler + ) where + +import Data.Char (toLower) +import Data.List (intercalate, isPrefixOf) +import Data.Maybe (fromMaybe, mapMaybe) +import Distribution.PackageDescription (BuildInfo(customFieldsBI)) +import Distribution.Verbosity (Verbosity) +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo) +import Distribution.Simple.PreProcess (PreProcessor(..), PPSuffixHandler) +import Distribution.Simple.Utils (info) +#if MIN_VERSION_Cabal(2,0,0) +import Distribution.Types.ComponentLocalBuildInfo (ComponentLocalBuildInfo) +#endif +import System.FilePath ((), dropExtension, splitDirectories) + +import Network.ONCRPC.XDR.Generate + +runRPCGen :: [(String, String)] -> (FilePath, FilePath) -> (FilePath, FilePath) -> Verbosity -> IO () +runRPCGen custom (indir, infile) (outdir, outfile) verb = do + info verb $ "hdrpcgen " ++ inpath ++ " with " ++ show opts + writeFile outpath + =<< generateFromFile opts inpath + where + opts = GenerateOptions + { generateModuleName = modname + , generateReidentOptions = ReidentOptions + { reidentUpperPrefix = fromMaybe "" $ opt "upper-prefix" + , reidentLowerPrefix = fromMaybe "" $ opt "lower-prefix" + , reidentJoinField = joinopt "field" + , reidentJoinProcedure = joinopt "procedure" + } + } + joinopt t = case (maybe False boolish $ opt $ t ++ "s-unique", opt $ "join-" ++ t) of + (False, j) -> Just $ fromMaybe "'" j + (True, Nothing) -> Nothing + (True, Just _) -> error $ "x-rpcgen join and unique options are mutually exclusive" + boolish s = map toLower s `isPrefixOf` "true" + opt f = lookup f custom + inpath = indir infile + outpath = outdir outfile + modname = intercalate "." $ splitDirectories $ dropExtension infile + +ppRPCGenCustomField :: (String, String) -> Maybe (String, String) +ppRPCGenCustomField ('x':'-':'r':'p':'c':'g':'e':'n':'-':f,v) = Just (f,v) +ppRPCGenCustomField _ = Nothing + +ppRPCGen :: BuildInfo -> LocalBuildInfo +#if MIN_VERSION_Cabal(2,0,0) + -> ComponentLocalBuildInfo +#endif + -> PreProcessor +ppRPCGen bi _ +#if MIN_VERSION_Cabal(2,0,0) + _ +#endif + = PreProcessor + { platformIndependent = True + , runPreProcessor = runRPCGen $ mapMaybe ppRPCGenCustomField $ customFieldsBI bi + } + +-- |Pre-processor for hsrpcgen. +-- You can use it by setting @'Distributin.Simple.UserHooks' { 'Distributin.Simple.hookedPrepProcessors' = ['ppRPCGenSuffixHandler'] }@. +-- Note that this will override the default alex @.x@ file handler. +-- You can also specify custom cabal fields corresponding to 'ReidentOptions' and command-line flags prefixed with @x-rpcgen-@: @{upper,lower}-prefix@, @join-{field,procedure}@, and @{field,procedure}s-unique}@. +ppRPCGenSuffixHandler :: PPSuffixHandler +ppRPCGenSuffixHandler = ("x", ppRPCGen) diff --git a/Network/ONCRPC/XDR/Generate.hs b/Network/ONCRPC/XDR/Generate.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Generate.hs @@ -0,0 +1,287 @@ +-- |Generate Haskell code from XDR descriptions as per RFC4506 and RPC extensions from RFC5531 + +{-# LANGUAGE CPP #-} +{-# LANGUAGE RecordWildCards #-} +module Network.ONCRPC.XDR.Generate + ( generateFromFile + , generate + , generateModule + , ReidentOptions(..) + , GenerateOptions(..) + , defaultReidentOptions + ) where + +import Control.Arrow ((***), (&&&)) +import qualified Data.ByteString.Lazy.Char8 as BSLC +import Data.Char (isAlpha, isUpper) +import Data.Maybe (fromMaybe, maybeToList) +import qualified Language.Haskell.Exts.Build as HS +import Language.Haskell.Exts.Pretty (prettyPrintWithMode, PPHsMode(..), defaultMode) +import qualified Language.Haskell.Exts.Syntax as HS + +import qualified Network.ONCRPC.XDR as XDR +import Network.ONCRPC.XDR.Specification +import qualified Network.ONCRPC.XDR.Parse as XDR +import Network.ONCRPC.XDR.Reident + +name :: String -> HS.Name () +name s@(~(c:_)) + | isAlpha c || c == '_' = HS.Ident () s + | otherwise = HS.Symbol () s + +infix 9 !, !. +(!) :: String -> String -> HS.QName () +(!) "" = HS.UnQual () . name +(!) m = HS.Qual () (HS.ModuleName () m) . name + +(!.) :: String -> String -> HS.Exp () +(!.) m n@(~(c:_)) + | isUpper c || c == ':' = HS.Con () $ m ! n + | otherwise = HS.Var () $ m ! n + +instDecl :: HS.QName () -> String -> [HS.InstDecl ()] -> HS.Decl () +instDecl c t = HS.InstDecl () Nothing + (HS.IRule () Nothing Nothing $ HS.IHApp () (HS.IHCon () c) $ HS.TyCon () $ ""!t) + . Just + +dataDecl :: String -> [HS.ConDecl ()] -> [String] -> HS.Decl () +dataDecl n con derive = HS.DataDecl () (HS.DataType ()) Nothing (HS.DHead () $ HS.name n) + (map (HS.QualConDecl () Nothing Nothing) con) + (return $ HS.Deriving () +#if MIN_VERSION_haskell_src_exts(1,20,0) + Nothing +#endif + $ map (HS.IRule () Nothing Nothing . HS.IHCon () . ("Prelude"!)) derive) + +constantType :: HS.Type () +constantType = HS.TyForall () + Nothing + (Just $ HS.CxSingle () $ HS.ClassA () ("Prelude"!"Integral") [t]) + t + where + t = HS.TyVar () $ HS.name "a" + +primType :: TypeSpecifier -> Maybe String +primType TypeInt = Just "Int" +primType TypeUnsignedInt = Just "UnsignedInt" +primType TypeHyper = Just "Hyper" +primType TypeUnsignedHyper = Just "UnsignedHyper" +primType TypeFloat = Just "Float" +primType TypeDouble = Just "Double" +primType TypeQuadruple = Just "Quadruple" +primType TypeBool = Just "Bool" +primType _ = Nothing + +specType :: TypeSpecifier -> Maybe (HS.Type ()) +specType (TypeIdentifier t) = Just $ HS.TyCon () $ ""!t +specType t = HS.TyCon () . (!) "XDR" <$> primType t + +specType' :: TypeSpecifier -> HS.Type () +specType' = fromMaybe (error $ "parameter data structures are not supported") . specType + +lengthType :: String -> XDR.Length -> HS.Type () +lengthType t l = HS.TyApp () (HS.TyCon () $ "XDR"!t) $ HS.TyPromoted () $ HS.PromotedInteger () (toInteger l) (show l) + +descrType :: TypeDescriptor -> Maybe (HS.Type ()) +descrType (TypeSingle t) = specType t +descrType (TypeArray t (FixedLength l)) = HS.TyApp () (lengthType "FixedArray" l) <$> specType t +descrType (TypeArray t (VariableLength l)) = HS.TyApp () (lengthType "Array" l) <$> specType t +descrType (TypeOpaque (FixedLength l)) = Just $ lengthType "FixedOpaque" l +descrType (TypeOpaque (VariableLength l)) = Just $ lengthType "Opaque" l +descrType (TypeString (FixedLength l)) = Just $ lengthType "FixedString" l +descrType (TypeString (VariableLength l)) = Just $ lengthType "String" l +descrType (TypeOptional t) = HS.TyApp () (HS.TyCon () $ "XDR"!"Optional") <$> specType t + +declType' :: Declaration -> HS.Type () +declType' (Declaration n t) = fromMaybe (error $ "nested data structures are not supported: " ++ show n) $ descrType t + +strictType :: HS.Type () -> HS.Type () +strictType = HS.TyBang () (HS.BangedTy ()) (HS.NoUnpackPragma ()) + +declaration :: Declaration -> [HS.FieldDecl ()] +declaration (Declaration _ (TypeSingle (TypeStruct (StructBody dl)))) = + concatMap declaration dl +declaration d@(Declaration i _) = + [HS.FieldDecl () [HS.name i] $ strictType $ declType' d] + +optionalDeclaration :: OptionalDeclaration -> [HS.FieldDecl ()] +optionalDeclaration = foldMap declaration + +typeDef :: String -> HS.Decl () +typeDef = HS.simpleFun (HS.name "xdrType") (HS.name "_") . HS.strE + +fieldNames :: [HS.FieldDecl ()] -> [HS.Name ()] +fieldNames = concatMap $ \(HS.FieldDecl _ nl _) -> nl + +putFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp () +putFields _ [] = HS.app ("Control.Applicative"!."pure") (HS.Con () $ HS.Special () $ HS.UnitCon ()) +putFields x l = foldl1 (flip HS.infixApp $ HS.QVarOp () $ "Control.Applicative"!"*>") + $ map (HS.app ("XDR"!."xdrPut") . flip HS.app x . HS.var) + $ fieldNames l + +getFields :: HS.Exp () -> [HS.FieldDecl ()] -> HS.Exp () +getFields n = foldl (\c _ -> HS.infixApp c (HS.QVarOp () $ "Control.Applicative"!"<*>") $ "XDR"!."xdrGet") n . fieldNames + +pureCon :: String -> HS.Exp () +pureCon = HS.app ("Control.Applicative"!."pure") . HS.Con () . (""!) + +sMatch :: String -> HS.Pat () -> HS.Exp () -> HS.Match () +sMatch n p e = HS.Match () (HS.name n) [p] (HS.UnGuardedRhs () e) Nothing + +definition :: Definition -> [HS.Decl ()] +definition (Definition n (TypeDef (TypeSingle (TypeEnum (EnumBody el))))) = + [ dataDecl n + (map (flip (HS.ConDecl ()) [] . HS.name . fst) el) + ["Eq", "Ord", "Enum", "Bounded", "Show"] + , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ()) + [ typeDef n + , HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutEnum" + , HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetEnum" + ] + , instDecl ("XDR"!"XDREnum") n $ map (HS.InsDecl ()) + [ HS.FunBind () $ map (\(i,v) -> + sMatch "xdrFromEnum" (HS.pApp (HS.name i) []) $ HS.intE $ toInteger v) + el + , HS.FunBind () $ map (\(i,v) -> + sMatch "xdrToEnum" (HS.intP $ toInteger v) $ HS.app ("Prelude"!."return") $ HS.Con () $ ""!i) + el ++ + [ sMatch "xdrToEnum" (HS.PWildCard ()) $ HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n] + ] + ] +definition (Definition n (TypeDef (TypeSingle (TypeStruct (StructBody dl))))) = + [ dataDecl n + [HS.RecDecl () (HS.name n) hdl] + ["Eq", "Show"] + , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ()) + [ typeDef n + , HS.simpleFun (HS.name "xdrPut") (HS.name "_x") $ putFields (HS.var $ HS.name "_x") hdl + , HS.nameBind (HS.name "xdrGet") $ getFields (pureCon n) hdl + ] + ] where + hdl = concatMap declaration dl +definition (Definition n (TypeDef (TypeSingle (TypeUnion (UnionBody d@(Declaration dn _) cl o))))) = + [ dataDecl n + (map (\(_,(l,b)) -> + HS.RecDecl () (HS.name l) b) hcl + ++ maybe [] (\(l,b) -> [HS.RecDecl () (HS.name l) + $ HS.FieldDecl () [HS.name hom] (strictType hdt) : b]) + ho) + ["Eq", "Show"] + , HS.TypeSig () [HS.name dn] $ HS.TyFun () (HS.TyCon () $ ""!n) hdt + , HS.nameBind (HS.name dn) $ "XDR"!."xdrDiscriminant" + , instDecl ("XDR"!"XDR") n $ map (HS.InsDecl ()) + [ typeDef n + , HS.nameBind (HS.name "xdrPut") $ "XDR"!."xdrPutUnion" + , HS.nameBind (HS.name "xdrGet") $ "XDR"!."xdrGetUnion" + ] + , instDecl ("XDR"!"XDRUnion") n + [ HS.InsType () (HS.TyApp () (HS.TyCon () $ ""!"XDRDiscriminant") (HS.TyCon () $ ""!n)) hdt + , HS.InsDecl () $ HS.FunBind () $ map + (uncurry (split [] . HS.intE)) + hcl + ++ maybeToList (split + [HS.PFieldPat () (""!hom) (HS.pvar $ HS.name "d")] + (HS.app ("XDR"!."xdrFromEnum") (""!."d")) + <$> ho) + , HS.InsDecl () $ HS.FunBind () $ map (\(c,(l,b)) -> + sMatch "xdrGetUnionArm" + (HS.intP c) + $ getFields (pureCon l) b) + hcl + ++ [sMatch "xdrGetUnionArm" + (HS.pvar $ HS.name "_c") + $ maybe + (HS.app ("Prelude"!."fail") $ HS.strE $ "invalid " ++ n ++ " discriminant") + (\(l,b) -> getFields (HS.infixApp (HS.Con () $ ""!l) (HS.QVarOp () $ "Control.Applicative"!"<$>") + (HS.app ("XDR"!."xdrToEnum") $ HS.var $ HS.name "_c")) b) + ho] + ] + ] where + split p c (l,b) = sMatch "xdrSplitUnion" + (HS.PAsPat () (HS.name "_x") $ HS.PRec () (""!l) p) + $ HS.tuple [c, putFields (""!."_x") b] + hdt = declType' d + hcl = map (toInteger *** arm) cl + hom = dn ++ "'" + ho = arm <$> o + arm = unionCaseIdentifier &&& optionalDeclaration . unionDeclaration +definition (Definition n (TypeDef t)) = + [ HS.TypeDecl () (HS.DHead () $ HS.name n) $ declType' (Declaration n t) + ] +definition (Definition n (Constant v)) = + [ HS.TypeSig () [HS.name n] constantType + , HS.nameBind (HS.name n) $ HS.intE v + ] +definition (Definition n (Program t vl px)) = + [ HS.TypeSig () [HS.name n] $ HS.TyCon () $ ""!t + , HS.nameBind (HS.name n) $ HS.appFun (""!.t) $ map (\(Version _ vt rl vx) -> + HS.appFun (""!.vt) $ map (\(Procedure _ _ _ rx) -> + HS.appFun ("RPC"!."Procedure") $ map (HS.intE . toInteger) [px, vx, rx]) + rl) + vl + , dataDecl t [HS.RecDecl () (HS.name t) (map (\(Version vn vt _ _) -> + HS.FieldDecl () [HS.name vn] $ strictType $ HS.TyCon () $ ""!vt) + vl)] [] + ] ++ map (\(Version _ vt rl _) -> + dataDecl vt [HS.RecDecl () (HS.name vt) (map (\(Procedure rr rn ra _) -> + HS.FieldDecl () [HS.name rn] + $ strictType $ HS.TyApp () (HS.TyApp () (HS.TyCon () $ "RPC"!"Procedure") + $ tt $ map specType' ra) + $ maybe (HS.unit_tycon ()) specType' rr) + rl)] [] + ) vl + where + tt [] = HS.unit_tycon () + tt [a] = a + tt l = HS.TyTuple () HS.Boxed l + +hasProgramDefinition :: Specification -> Bool +hasProgramDefinition = any isProgramDefinition where + isProgramDefinition (Definition _ Program{}) = True + isProgramDefinition _ = False + +specification :: String -> Specification -> HS.Module () +specification n l = HS.Module () + (Just $ HS.ModuleHead () (HS.ModuleName () n) Nothing Nothing) + [ HS.LanguagePragma () $ map HS.name ["DataKinds", "TypeFamilies"] ] + ([HS.ImportDecl () (HS.ModuleName () "Prelude") True False False Nothing Nothing Nothing + , HS.ImportDecl () (HS.ModuleName () "Control.Applicative") True False False Nothing Nothing Nothing + , HS.ImportDecl () (HS.ModuleName () "Network.ONCRPC.XDR") True False False Nothing (Just $ HS.ModuleName () "XDR") Nothing + ] ++ if hasProgramDefinition l then + [ HS.ImportDecl () (HS.ModuleName () "Network.ONCRPC.Types") True False False Nothing (Just $ HS.ModuleName () "RPC") Nothing ] + else []) + $ concatMap definition l + +-- |Options for generating Haskell code +data GenerateOptions = GenerateOptions + { generateModuleName :: String -- ^Name for the generated module + , generateReidentOptions :: ReidentOptions + } + deriving (Eq, Show) + +-- |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 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 opts n s = do + m <- generateModule opts n s + return $ "-- |Generated from " ++ n ++ " by \n" + ++ prettyPrintWithMode defaultMode + { classIndent = 2 + , doIndent = 2 + , multiIfIndent = 2 + , caseIndent = 2 + , letIndent = 2 + , whereIndent = 2 + , onsideIndent = 2 + } m + +-- |'generate' from a file. +generateFromFile :: GenerateOptions -> FilePath -> IO String +generateFromFile opts f = generate opts f =<< BSLC.readFile f diff --git a/Network/ONCRPC/XDR/Opaque.hs b/Network/ONCRPC/XDR/Opaque.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Opaque.hs @@ -0,0 +1,46 @@ +-- |Marshalling values into and out of 'Network.ONCRPC.XDR.Types.Opaque' byte strings. +-- Not really part of XDR, but convenient way to avoid many conversion functions. + +{-# LANGUAGE DefaultSignatures #-} +module Network.ONCRPC.XDR.Opaque + ( Opaqued(..) + , unopacify' + , toOpaque + , toOpaque' + , fromOpaque + , fromOpaque' + ) where + +import Data.ByteString (ByteString) +import Data.Functor.Identity (runIdentity) + +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'. +-- 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 = either fail return . xdrDeserialize + +unopacify' :: Opaqued a => ByteString -> a +unopacify' = runIdentity . 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 -> LengthArray o n ByteString +toOpaque' = lengthArray' . opacify + +fromOpaque :: (Opaqued a, Monad m) => LengthArray o n ByteString -> m a +fromOpaque = unopacify . unLengthArray + +fromOpaque' :: Opaqued a => LengthArray o n ByteString -> a +fromOpaque' = unopacify' . unLengthArray + +instance Opaqued RPC.Authsys_parms diff --git a/Network/ONCRPC/XDR/Parse.hs b/Network/ONCRPC/XDR/Parse.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Parse.hs @@ -0,0 +1,305 @@ +-- | XDR Parser for .x files, as per RFC4506 and RPC extensions from RFC5531 + +{-# LANGUAGE TupleSections #-} +module Network.ONCRPC.XDR.Parse + ( Binding(..) + , Scope + , parse + ) where + +import Control.Applicative ((<|>)) +import Control.Arrow ((***), second) +import Control.Monad (void, join, liftM2) +import qualified Data.ByteString.Lazy as BSL +import Data.Char (digitToInt, isLower, isUpper, toLower, toUpper) +import Data.Functor.Identity (Identity) +import qualified Data.Map as Map +import Data.Maybe (catMaybes, mapMaybe) +import qualified Data.Set as Set +import qualified Text.Parsec as P +import qualified Text.Parsec.Token as PT + +import qualified Network.ONCRPC.XDR.Types as XDR +import Network.ONCRPC.XDR.Specification hiding (arrayLength) + +data Binding = Binding + { bindingInitCaseConflict :: !Bool -- ^Same name as another identifier modulo first character case + , bindingDefinition :: !DefinitionBody + } + +type Scope = Map.Map String Binding +type Stream = BSL.ByteString +type Parser = P.Parsec Stream Scope + +tupleM :: Monad m => m a -> m b -> m (a, b) +tupleM = liftM2 (,) + +baseScope :: Scope +baseScope = Map.fromList $ + ("bool", Binding False $ TypeDef $ TypeSingle $ TypeEnum $ EnumBody $ boolValues) + : map (id *** Binding False . TypeDef . TypeSingle) + [ ("int", TypeInt) + , ("unsigned", TypeUnsignedInt) + , ("hyper", TypeHyper) + , ("float", TypeFloat) + , ("double", TypeDouble) + , ("quadruple", TypeQuadruple) + ] + ++ map (second $ Binding False . Constant . toInteger) boolValues + +toggleCase :: String -> String +toggleCase (c:s) + | isUpper c = toLower c:s + | isLower c = toUpper c:s +toggleCase s = s + +addScope :: Definition -> Parser () +addScope (Definition i b) = do + case b of + TypeDef t -> void $ resolveTypeDescriptor t + _ -> return () + s <- P.getState + case Map.insertLookupWithKey (const const) i (Binding (Map.member (toggleCase i) s) b) s of + (Nothing, s') -> P.putState s' + _ -> fail $ "duplicate identifier: " ++ show i + +checkInt :: (Monad m, Integral n) => Integer -> m n +checkInt n + | n == toInteger n' = return n' + | otherwise = fail "invalid constant" + where n' = fromInteger n + +data Value + = ValueIdentifier !String + | ValueConstant !Integer + deriving (Show) + +resolveValue :: Integral n => Value -> Parser n +resolveValue (ValueConstant n) = checkInt n +resolveValue (ValueIdentifier v) = do + s <- P.getState + case Map.lookup v s of + Just (Binding _ (Constant n)) -> checkInt n + _ -> fail $ "undefined constant: " ++ show v + +-- |Expand 'TypeSingle' 'TypeIdentifier' +resolveTypeDescriptor :: TypeDescriptor -> Parser TypeDescriptor +resolveTypeDescriptor (TypeSingle (TypeIdentifier i)) = do + s <- P.getState + case Map.lookup i s of + Just (Binding _ (TypeDef t)) -> resolveTypeDescriptor t + _ -> fail $ "undefined type: " ++ show i +resolveTypeDescriptor d = return d + +literalLetter :: Parser Char +literalLetter = P.alphaNum <|> P.char '_' + +token :: PT.GenTokenParser Stream Scope Identity +token = PT.makeTokenParser PT.LanguageDef + { PT.commentStart = "/*" + , PT.commentEnd = "*/" + , PT.commentLine = "%" + , PT.nestedComments = False + , PT.identStart = P.letter + , PT.identLetter = literalLetter + , PT.opStart = fail "token op" + , PT.opLetter = fail "token op" + , PT.reservedNames = + [ "bool" + , "case" + , "const" + , "default" + , "double" + , "quadruple" + , "enum" + , "float" + , "hyper" + , "int" + , "opaque" + , "string" + , "struct" + , "switch" + , "typedef" + , "union" + , "unsigned" + , "void" + + , "program" + , "version" + ] + , PT.reservedOpNames = [] + , PT.caseSensitive = True + } + +reserved :: String -> Parser () +reserved = PT.reserved token + +identifier :: Parser String +identifier = PT.identifier token + +endSemi1 :: Parser a -> Parser [a] +endSemi1 p = p `P.endBy1` PT.semi token + +arrayLength, variableArrayLength :: Parser ArrayLength +variableArrayLength = + VariableLength <$> PT.angles token (P.option XDR.maxLength value) +arrayLength = + FixedLength <$> PT.brackets token value + <|> variableArrayLength + +declaration :: Parser Declaration +declaration = + typeDeclaration + <|> opaqueDeclaration + <|> stringDeclaration + where + typeDeclaration = do + t <- typeSpecifier + Declaration + <$> (PT.symbol token "*" *> identifier) + <*> pure (TypeOptional t) + <|> Declaration + <$> identifier + <*> (TypeArray t <$> arrayLength <|> return (TypeSingle t)) + opaqueDeclaration = + Declaration + <$> (reserved "opaque" *> identifier) + <*> (TypeOpaque <$> arrayLength) + stringDeclaration = + Declaration + <$> (reserved "string" *> identifier) + <*> (TypeString <$> variableArrayLength) + +optionalDeclaration :: Parser OptionalDeclaration +optionalDeclaration = + Just <$> declaration + <|> Nothing <$ reserved "void" + +constant :: Parser Integer +constant = (PT.lexeme token $ + nat <|> P.char '-' *> (negate <$> dec)) + P. "constant" where + nat = P.char '0' *> (P.oneOf "xX" *> number 16 P.hexDigit <|> number 8 P.octDigit <|> return 0) <|> dec + dec = number 10 P.digit + number base digit = foldl (\x d -> base*x + toInteger (digitToInt d)) 0 <$> P.many1 digit + +value :: Integral n => Parser n +value = resolveValue =<< + ValueConstant <$> constant + <|> ValueIdentifier <$> identifier + +typeSpecifier :: Parser TypeSpecifier +typeSpecifier = P.choice + [ TypeInt <$ reserved "int" + , TypeHyper <$ reserved "hyper" + , reserved "unsigned" *> ( + TypeUnsignedInt <$ reserved "int" + <|> TypeUnsignedHyper <$ reserved "hyper" + <|> return TypeUnsignedInt) + , TypeFloat <$ reserved "float" + , TypeDouble <$ reserved "double" + , TypeQuadruple <$ reserved "quadruple" + , TypeBool <$ reserved "bool" + , reserved "enum" *> (TypeEnum <$> enumBody <|> typeIdentifier) + , reserved "struct"*> (TypeStruct <$> structBody <|> typeIdentifier) + , reserved "union" *> (TypeUnion <$> unionBody <|> typeIdentifier) + , typeIdentifier + ] where + typeIdentifier = TypeIdentifier <$> identifier + +checkUnique :: (Ord k, Show k) => String -> [k] -> Parser (Set.Set k) +checkUnique t = ui Set.empty where + ui m [] = return m + ui m (k:l) + | Set.member k m = fail $ "duplicate " ++ t ++ ": " ++ show k + | otherwise = ui (Set.insert k m) l + +enumBody :: Parser EnumBody +enumBody = do + l <- PT.braces token $ PT.commaSep1 token $ + tupleM identifier (PT.symbol token "=" *> value) + _ <- checkUnique "enum identifier" $ fst <$> l + _ <- checkUnique "enum value" $ snd <$> l + mapM_ (\(i, v) -> addScope $ Definition i $ Constant $ toInteger v) l + return $ EnumBody l + +structBody :: Parser StructBody +structBody = do + l <- PT.braces token $ catMaybes <$> endSemi1 optionalDeclaration + _ <- checkUnique "struct member" $ declarationIdentifier <$> l + return $ StructBody l + +unionBody :: Parser UnionBody +unionBody = do + reserved "switch" + d <- PT.parens token declaration + r <- resolveTypeDescriptor $ declarationType d + p <- case r of + TypeSingle TypeInt -> return value + TypeSingle TypeUnsignedInt -> return $ fromIntegral <$> (value :: Parser XDR.UnsignedInt) + TypeSingle TypeBool -> return $ valid boolValues =<< value + TypeSingle (TypeEnum (EnumBody v)) -> return $ valid v =<< value + _ -> fail "invalid discriminant declaration" + PT.braces token $ do + l <- endSemi1 (tupleM + (P.many1 $ reserved "case" *> tupleM (P.lookAhead $ P.many1 literalLetter) p <* PT.colon token) + optionalDeclaration) + _ <- checkUnique "union member" $ mapMaybe (fmap declarationIdentifier . snd) l + _ <- checkUnique "union case" $ map snd . fst =<< l + f <- P.optionMaybe $ UnionArm "default" <$> (reserved "default" *> PT.colon token *> optionalDeclaration <* PT.semi token) + return $ UnionBody d [ (c, UnionArm s b) | (cs, b) <- l, (s, c) <- cs ] f + where + valid l n + | any ((n ==) . snd) l = return n + | otherwise = fail "invalid enum value" + +procedure :: Parser Procedure +procedure = Procedure + <$> optionalType + <*> identifier + <*> PT.parens token (catMaybes <$> PT.commaSep1 token optionalType) + <*> (PT.symbol token "=" *> value) + where + optionalType :: Parser (Maybe TypeSpecifier) + optionalType = + Just <$> typeSpecifier + <|> Nothing <$ reserved "void" + +programVersion :: Parser Version +programVersion = join Version + <$> (reserved "version" *> identifier) + <*> PT.braces token (endSemi1 procedure) + <*> (PT.symbol token "=" *> value) + +def :: Parser Definition +def = constantDef <|> typeDef <|> programDef where + constantDef = Definition + <$> (reserved "const" *> identifier) + <*> (PT.symbol token "=" *> (Constant <$> constant)) + typeDef = + reserved "typedef" *> (declDef <$> declaration) + <|> Definition <$> (reserved "enum" *> identifier) <*> (TypeDef . TypeSingle . TypeEnum <$> enumBody) + <|> Definition <$> (reserved "struct" *> identifier) <*> (TypeDef . TypeSingle . TypeStruct <$> structBody) + <|> Definition <$> (reserved "union" *> identifier) <*> (TypeDef . TypeSingle . TypeUnion <$> unionBody) + declDef (Declaration i t) = Definition i $ TypeDef t + programDef = do + reserved "program" + i <- identifier + Definition i <$> (Program i + <$> PT.braces token (endSemi1 programVersion) + <*> (PT.symbol token "=" *> value)) + +definition :: Parser Definition +definition = do + d <- def + addScope d + return d + +specification :: Parser Specification +specification = endSemi1 definition + +file :: Parser (Specification, Scope) +file = PT.whiteSpace token *> tupleM specification P.getState <* P.eof + +parse :: String -> BSL.ByteString -> Either P.ParseError (Specification, Scope) +parse = P.runParser file baseScope diff --git a/Network/ONCRPC/XDR/Reident.hs b/Network/ONCRPC/XDR/Reident.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Reident.hs @@ -0,0 +1,106 @@ +-- |Convert XDR identifiers to Haskell identifiers. +-- Rules to convert identifiers in a 'Specification' to follow Haskell's lexical rules and ensure uniqueness for Haskell's scoping. +{-# LANGUAGE RecordWildCards #-} +module Network.ONCRPC.XDR.Reident + ( ReidentOptions(..) + , defaultReidentOptions + , reident + ) where + +import Control.Arrow (first, second) +import Data.Char (isLower, isUpper, toLower, toUpper) +import qualified Data.Map as Map +import qualified Data.Set as Set + +import Network.ONCRPC.XDR.Specification +import qualified Network.ONCRPC.XDR.Parse as XDR + +-- |How to generate Haskell identifiers from XDR in order to confirm to Haskell's lexical rules and ensure uniqueness. +data ReidentOptions = ReidentOptions + { reidentUpperPrefix, reidentLowerPrefix :: String -- ^Prefix to use to make an identifier a different case if necessary, e.g. @\"_\"@ for lower-case, or @\"XDR_\"@ for upper case (default empty: just changes the first character, possibly resulting in names like @\"nFS_NULL\"@) + , reidentJoinField, reidentJoinProcedure :: Maybe String -- ^Prefix fields with their type name (or program, version name) and this string (necessary for most XDR files), or @Nothing@ to use only the field name (or procedure name), which assumes uniqueness across the file (e.g., if you wrote the file yourself, though often safe for procedures only) (default @Just \"\'\"@) + } + deriving (Eq, Show) + +defaultReidentOptions :: ReidentOptions +defaultReidentOptions = ReidentOptions + { reidentUpperPrefix = "" + , reidentLowerPrefix = "" + , reidentJoinField = Just "'" + , reidentJoinProcedure = Just "'" + } + +data ReidentOps = ReidentOps + { reidentUpper, reidentLower :: String -> String + , reidentField, reidentProcedure :: String -> String -> String + , reidentUnique :: String -> String + } + +reidentOps :: ReidentOptions -> XDR.Scope -> ReidentOps +reidentOps ReidentOptions{..} scope = ReidentOps + { reidentUpper = toUpperPrefix reidentUpperPrefix + , reidentLower = toLowerPrefix reidentLowerPrefix + , reidentField = joinField reidentJoinField + , reidentProcedure = joinField reidentJoinProcedure + , reidentUnique = unique + } where + toUpperPrefix p s@(~(h:t)) + | isUpper h = s + | null p = toUpper h : t + | otherwise = p ++ s + toLowerPrefix p s@(~(h:t)) + | isLower h = s + | null p = toLower h : t + | otherwise = p ++ s + joinField (Just c) p n = p ++ c ++ n + joinField Nothing _ n = n + unique n + | Set.member n dups = n ++ "'" + | otherwise = n + dups = Map.keysSet $ Map.filter XDR.bindingInitCaseConflict scope + +declaration :: ReidentOps -> String -> Declaration -> Declaration +declaration ops n (Declaration m t) = Declaration (reidentLower ops nm) (typeDescriptor ops nm t) where + nm = reidentField ops n m + +typeSpecifier :: ReidentOps -> String -> TypeSpecifier -> TypeSpecifier +typeSpecifier ops _ (TypeEnum (EnumBody el)) = TypeEnum $ + EnumBody $ map (first $ reidentUnique ops) el +typeSpecifier ops n (TypeStruct (StructBody dl)) = TypeStruct $ + StructBody $ map (declaration ops n) dl +typeSpecifier ops n (TypeUnion (UnionBody d cl o)) = TypeUnion $ + UnionBody (decl d) (map (second arm) cl) (arm <$> o) where + arm (UnionArm l m) = UnionArm (con l) (decl <$> m) + con l = reidentUpper ops $ n ++ '\'' : l + decl = declaration ops n +typeSpecifier ops _ (TypeIdentifier i) = TypeIdentifier $ + reidentUpper ops $ reidentUnique ops i +typeSpecifier _ _ t = t + +typeDescriptor :: ReidentOps -> String -> TypeDescriptor -> TypeDescriptor +typeDescriptor ops n (TypeSingle t) = TypeSingle (typeSpecifier ops n t) +typeDescriptor ops n (TypeArray t l) = TypeArray (typeSpecifier ops n t) l +typeDescriptor ops n (TypeOptional t) = TypeOptional (typeSpecifier ops n t) +typeDescriptor _ _ t = t + +procedure :: ReidentOps -> String -> Procedure -> Procedure +procedure ops n (Procedure r m al x) = Procedure (ts <$> r) (reidentLower ops nm) (ts <$> al) x where + nm = reidentProcedure ops n m + ts = typeSpecifier ops nm + +version :: ReidentOps -> String -> Version -> Version +version ops n (Version m t pl x) = Version (reidentLower ops nm) (reidentUpper ops nt) (map (procedure ops nm) pl) x where + nm = reidentProcedure ops n m + nt = reidentProcedure ops n t + +makeDefinition :: ReidentOps -> String -> DefinitionBody -> Definition +makeDefinition ops n (TypeDef d) = Definition (reidentUpper ops n) $ TypeDef $ typeDescriptor ops n d +makeDefinition ops n (Program t vl x) = Definition (reidentLower ops n) $ Program (reidentUpper ops t) (map (version ops n) vl) x +makeDefinition ops n b@(Constant _) = Definition (reidentLower ops n) b + +definition :: ReidentOps -> Definition -> Definition +definition ops (Definition n d) = makeDefinition ops (reidentUnique ops n) d + +reident :: ReidentOptions -> XDR.Scope -> Specification -> Specification +reident o = map . definition . reidentOps o + diff --git a/Network/ONCRPC/XDR/Serial.hs b/Network/ONCRPC/XDR/Serial.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Serial.hs @@ -0,0 +1,277 @@ +-- |XDR Serialization + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Network.ONCRPC.XDR.Serial + ( XDR(..) + , XDREnum(..) + , xdrToEnum' + , xdrPutEnum + , xdrGetEnum + , XDRUnion(..) + , xdrDiscriminant + , xdrPutUnion + , xdrGetUnion + + , xdrSerialize + , xdrSerializeLazy + , xdrDeserialize + , xdrDeserializeLazy + ) where + +import Control.Monad (guard, unless, replicateM) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Functor.Identity (runIdentity) +import Data.Maybe (fromJust) +import Data.Proxy (Proxy(..)) +import qualified Data.Serialize as S +import qualified Data.Vector as V +import qualified Network.ONCRPC.XDR.Types as XDR +import GHC.TypeLits (KnownNat, natVal) + +import Network.ONCRPC.XDR.Array + +-- |An XDR type that can be (de)serialized. +class XDR a where + -- |XDR identifier/type descriptor; argument value is ignored. + xdrType :: a -> String + xdrPut :: a -> S.Put + xdrGet :: S.Get a + +instance XDR XDR.Int where + xdrType _ = "int" + xdrPut = S.putInt32be + xdrGet = S.getInt32be +instance XDR XDR.UnsignedInt where + xdrType _ = "unsigned int" + xdrPut = S.putWord32be + xdrGet = S.getWord32be +instance XDR XDR.Hyper where + xdrType _ = "hyper" + xdrPut = S.putInt64be + xdrGet = S.getInt64be +instance XDR XDR.UnsignedHyper where + xdrType _ = "unsigned hyper" + xdrPut = S.putWord64be + xdrGet = S.getWord64be +instance XDR XDR.Float where + xdrType _ = "float" + xdrPut = S.putFloat32be + xdrGet = S.getFloat32be +instance XDR XDR.Double where + xdrType _ = "double" + xdrPut = S.putFloat64be + xdrGet = S.getFloat64be +instance XDR XDR.Bool where + xdrType _ = "bool" + xdrPut = xdrPutEnum + xdrGet = xdrGetEnum + +-- |An XDR type defined with \"enum\". +-- Note that the 'XDREnum' 'XDR.Int' value is not (necessarily) the same as the 'Enum' 'Int' value. +-- 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 + +instance XDREnum XDR.Int where + xdrFromEnum = id + xdrToEnum = return + +instance XDREnum XDR.UnsignedInt where + xdrFromEnum = fromIntegral + xdrToEnum = return . fromIntegral + +-- |Version of 'xdrToEnum' that fails at runtime for invalid values: @fromMaybe undefined . 'xdrToEnum'@. +xdrToEnum' :: XDREnum a => XDR.Int -> a +xdrToEnum' = runIdentity . xdrToEnum + +-- |Default implementation of 'xdrPut' for 'XDREnum'. +xdrPutEnum :: XDREnum a => a -> S.Put +xdrPutEnum = S.put . xdrFromEnum + +-- |Default implementation of 'xdrGet' for 'XDREnum'. +xdrGetEnum :: XDREnum a => S.Get a +xdrGetEnum = xdrToEnum =<< S.get + +instance XDREnum XDR.Bool where + xdrFromEnum False = 0 + xdrFromEnum True = 1 + xdrToEnum 0 = return False + xdrToEnum 1 = return True + xdrToEnum _ = fail "invalid bool" + +-- |An XDR type defined with \"union\" +class (XDR a, XDREnum (XDRDiscriminant a)) => XDRUnion a where + type XDRDiscriminant a :: * + -- |Split a union into its discriminant and body generator. + xdrSplitUnion :: a -> (XDR.Int, S.Put) + -- |Get the body of a union based on its discriminant. + xdrGetUnionArm :: XDR.Int -> S.Get a + +xdrDiscriminant :: XDRUnion a => a -> XDRDiscriminant a +xdrDiscriminant = xdrToEnum' . fst . xdrSplitUnion + +-- |Default implementation of 'xdrPut' for 'XDRUnion'. +xdrPutUnion :: XDRUnion a => a -> S.Put +xdrPutUnion = uncurry ((>>) . xdrPut) . xdrSplitUnion + +-- |Default implementation of 'xdrGet' for 'XDRUnion'. +xdrGetUnion :: XDRUnion a => S.Get a +xdrGetUnion = xdrGet >>= xdrGetUnionArm + +instance XDR a => XDR (XDR.Optional a) where + xdrType = ('*':) . xdrType . fromJust + xdrPut = xdrPutUnion + xdrGet = xdrGetUnion + +instance XDR a => XDRUnion (XDR.Optional a) where + type XDRDiscriminant (XDR.Optional a) = XDR.Bool + xdrSplitUnion Nothing = (0, return ()) + xdrSplitUnion (Just a) = (1, xdrPut a) + xdrGetUnionArm 0 = return Nothing + xdrGetUnionArm 1 = Just <$> xdrGet + xdrGetUnionArm _ = fail $ "xdrGetUnion: invalid discriminant for " ++ xdrType (undefined :: XDR.Optional a) + +xdrPutPad :: XDR.Length -> S.Put +xdrPutPad n = case n `mod` 4 of + 0 -> return () + 1 -> S.putWord16host 0 >> S.putWord8 0 + 2 -> S.putWord16host 0 + ~3 -> S.putWord8 0 + +xdrGetPad :: XDR.Length -> S.Get () +xdrGetPad n = case n `mod` 4 of + 0 -> return () + 1 -> do + 0 <- S.getWord16host + 0 <- S.getWord8 + return () + 2 -> do + 0 <- S.getWord16host + return () + ~3 -> do + 0 <- S.getWord8 + return () + +bsLength :: BS.ByteString -> XDR.Length +bsLength = fromIntegral . BS.length + +xdrPutByteString :: XDR.Length -> BS.ByteString -> S.Put +xdrPutByteString l b = do + unless (bsLength b == l) $ fail "xdrPutByteString: incorrect length" + S.putByteString b + xdrPutPad l + +xdrGetByteString :: XDR.Length -> S.Get BS.ByteString +xdrGetByteString l = do + b <- S.getByteString $ fromIntegral l + xdrGetPad l + return b + +fixedLength :: forall n a . KnownNat n => LengthArray 'EQ n a -> String -> String +fixedLength a = (++ ('[' : show (fixedLengthArrayLength a) ++ "]")) + +variableLength :: forall n a . KnownNat n => LengthArray 'LT n a -> String -> String +variableLength a + | n == XDR.maxLength = (++ "<>") + | otherwise = (++ ('<' : show n ++ ">")) + where n = fromIntegral $ boundedLengthArrayBound a + +xdrGetBoundedArray :: forall n a . KnownNat n => (XDR.Length -> S.Get a) -> S.Get (LengthArray 'LT n a) +xdrGetBoundedArray g = do + l <- xdrGet + guard $ l <= fromIntegral (boundedLengthArrayBound (undefined :: LengthArray 'LT n a)) + unsafeLengthArray <$> g l + +instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n [a]) where + xdrType la = fixedLength la $ xdrType $ head $ unLengthArray la + xdrPut la = do + mapM_ xdrPut a + where + a = unLengthArray la + xdrGet = unsafeLengthArray <$> + replicateM (fromInteger (natVal (Proxy :: Proxy n))) xdrGet + +instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n [a]) where + xdrType la = variableLength la $ xdrType $ head $ unLengthArray la + xdrPut la = do + xdrPut (fromIntegral (length a) :: XDR.Length) + mapM_ xdrPut a + where + a = unLengthArray la + xdrGet = xdrGetBoundedArray $ \l -> replicateM (fromIntegral l) xdrGet + +instance (KnownNat n, XDR a) => XDR (LengthArray 'EQ n (V.Vector a)) where + xdrType la = fixedLength la $ xdrType $ V.head $ unLengthArray la + xdrPut la = do + mapM_ xdrPut a + where + a = unLengthArray la + xdrGet = unsafeLengthArray <$> + V.replicateM (fromInteger (natVal (Proxy :: Proxy n))) xdrGet + +instance (KnownNat n, XDR a) => XDR (LengthArray 'LT n (V.Vector a)) where + xdrType la = variableLength la $ xdrType $ V.head $ unLengthArray la + xdrPut la = do + xdrPut (fromIntegral (V.length a) :: XDR.Length) + mapM_ xdrPut a + where + a = unLengthArray la + xdrGet = xdrGetBoundedArray $ \l -> V.replicateM (fromIntegral l) xdrGet + +instance KnownNat n => XDR (LengthArray 'EQ n BS.ByteString) where + xdrType o = fixedLength o "opaque" + 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" + xdrPut o = do + xdrPut l + xdrPutByteString l b + where + l = bsLength b + b = unLengthArray o + xdrGet = xdrGetBoundedArray xdrGetByteString + +instance XDR () where + xdrType () = "void" + xdrPut () = return () + xdrGet = return () + +instance (XDR a, XDR b) => XDR (a, b) where + xdrType (a, b) = xdrType a ++ '+' : xdrType b + xdrPut (a, b) = xdrPut a >> xdrPut b + xdrGet = (,) <$> xdrGet <*> xdrGet + +instance (XDR a, XDR b, XDR c) => XDR (a, b, c) where + xdrType (a, b, c) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c + xdrPut (a, b, c) = xdrPut a >> xdrPut b >> xdrPut c + xdrGet = (,,) <$> xdrGet <*> xdrGet <*> xdrGet + +instance (XDR a, XDR b, XDR c, XDR d) => XDR (a, b, c, d) where + xdrType (a, b, c, d) = xdrType a ++ '+' : xdrType b ++ '+' : xdrType c ++ '+' : xdrType d + xdrPut (a, b, c, d) = xdrPut a >> xdrPut b >> xdrPut c >> xdrPut d + xdrGet = (,,,) <$> xdrGet <*> xdrGet <*> xdrGet <*> xdrGet + +xdrSerialize :: XDR a => a -> BS.ByteString +xdrSerialize = S.runPut . xdrPut + +xdrSerializeLazy :: XDR a => a -> BSL.ByteString +xdrSerializeLazy = S.runPutLazy . xdrPut + +-- |@"S.runGet' 'xdrGet'@ +xdrDeserialize :: XDR a => BS.ByteString -> Either String a +xdrDeserialize = S.runGet xdrGet + +-- |@"S.runGetLazy' 'xdrGet'@ +xdrDeserializeLazy :: XDR a => BSL.ByteString -> Either String a +xdrDeserializeLazy = S.runGetLazy xdrGet diff --git a/Network/ONCRPC/XDR/Specification.hs b/Network/ONCRPC/XDR/Specification.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Specification.hs @@ -0,0 +1,107 @@ +-- |XDR specification, as per RFC4506 and RPC extensions from RFC5531 + +module Network.ONCRPC.XDR.Specification + where + +import qualified Network.ONCRPC.XDR.Types as XDR +import qualified Network.ONCRPC.Types as RPC + +data ArrayLength + = FixedLength { arrayLength :: !XDR.Length } + | VariableLength { arrayLength :: !XDR.Length -- ^defaulted to maxLength + } + +data TypeDescriptor + = TypeSingle + { descriptorType :: !TypeSpecifier + } + | TypeArray + { descriptorType :: !TypeSpecifier + , descriptorLength :: !ArrayLength + } + | TypeOpaque + { descriptorLength :: !ArrayLength + } + | TypeString + { descriptorLength :: !ArrayLength -- ^only 'VariableArray' + } + | TypeOptional + { descriptorType :: !TypeSpecifier + } + +data TypeSpecifier + = TypeInt + | TypeUnsignedInt + | TypeHyper + | TypeUnsignedHyper + | TypeFloat + | TypeDouble + | TypeQuadruple + | TypeBool + | TypeEnum !EnumBody + | TypeStruct !StructBody + | TypeUnion !UnionBody + | TypeIdentifier !String + +-- |Non-void declaration +data Declaration = Declaration + { declarationIdentifier :: !String + , declarationType :: TypeDescriptor + } + +-- |'Declaration' or void +type OptionalDeclaration = Maybe Declaration + +type EnumValues = [(String, XDR.Int)] + +newtype EnumBody = EnumBody + { enumValues :: EnumValues + } + +boolValues :: EnumValues +boolValues = [("FALSE", 0), ("TRUE", 1)] + +newtype StructBody = StructBody + { structMembers :: [Declaration] -- ^with voids elided + } + +data UnionArm = UnionArm + { unionCaseIdentifier :: String -- ^The literal string found after "case", for labeling + , unionDeclaration :: OptionalDeclaration + } + +data UnionBody = UnionBody + { unionDiscriminant :: !Declaration + , unionCases :: [(XDR.Int, UnionArm)] + , unionDefault :: Maybe UnionArm + } + +data Procedure = Procedure + { procedureRes :: Maybe TypeSpecifier + , procedureIdentifier :: !String + , procedureArgs :: [TypeSpecifier] + , procedureNumber :: !RPC.ProcNum + } + +data Version = Version + { versionIdentifier :: !String + , versionTypeIdentifier :: !String + , versionProcedures :: [Procedure] + , versionNumber :: !RPC.VersNum + } + +data DefinitionBody + = TypeDef TypeDescriptor + | Constant Integer + | Program + { programTypeIdentifier :: !String + , programVersions :: [Version] + , programNumber :: !RPC.ProgNum + } + +data Definition = Definition + { definitionIdentifier :: !String + , definitionBody :: !DefinitionBody + } + +type Specification = [Definition] diff --git a/Network/ONCRPC/XDR/Types.hs b/Network/ONCRPC/XDR/Types.hs new file mode 100644 --- /dev/null +++ b/Network/ONCRPC/XDR/Types.hs @@ -0,0 +1,57 @@ +-- | XDR Types. +-- The 'Quadruple' type is not supported as there is no reasonable Haskell equivalent. +-- +-- This module should be imported qualified, e.g., as @XDR@. + +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE TypeSynonymInstances #-} +module Network.ONCRPC.XDR.Types + ( Int + , UnsignedInt + , Hyper + , UnsignedHyper + , Float + , Double + , Bool + , FixedArray + , Array + , FixedOpaque + , Opaque + , FixedString + , String + , Optional + + , Length + , maxLength + ) + where + +import Prelude hiding (Int, String) + +import Data.ByteString (ByteString) +import Data.Int (Int32, Int64) +import Data.Vector (Vector) +import Data.Word (Word32, Word64) + +import Network.ONCRPC.XDR.Array + +type Int = Int32 +type UnsignedInt = Word32 +type Hyper = Int64 +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 FixedString n = FixedLengthArray n ByteString +type String n = BoundedLengthArray n ByteString +type Optional a = Maybe a + +-- |Not a real XDR type, but used for length headers +type Length = UnsignedInt + +maxLength :: Length +maxLength = maxBound diff --git a/Network/Socket/All.hs b/Network/Socket/All.hs new file mode 100644 --- /dev/null +++ b/Network/Socket/All.hs @@ -0,0 +1,83 @@ +-- |Wrappers for "Network.Socket" calls that run over entire buffers or builds. +{-# LANGUAGE ScopedTypeVariables #-} +module Network.Socket.All + ( recvAllBuf + , recvStorable + , sendAllBuf + , sendStorable + , sendBuilderWith + , sendBuilder + ) where + +import Control.Monad (unless) +import qualified Data.ByteString.Builder as B +import qualified Data.ByteString.Builder.Extra as B +import Data.Word (Word8) +import Foreign.Ptr (Ptr, castPtr, plusPtr) +import Foreign.Marshal (alloca, allocaBytes, with) +import Foreign.Storable (Storable, sizeOf, peek) +import Network.Socket +import qualified Network.Socket.ByteString as BS + +allBufWith :: (Ptr a -> Int -> IO Int) -> Ptr a -> Int -> IO Int +allBufWith f p n = run 0 where + run l + | l >= n = return l + | otherwise = do + r <- f (p `plusPtr` l) (n - l) + if r == 0 + then return l + else run (l + r) + +-- |Receive data from a socket, attempting to fill the entire buffer, blocking as necessary. +-- Any short read indicates a 0 (closed) result from 'recvBuf'. +recvAllBuf :: Socket -> Ptr Word8 -> Int -> IO Int +recvAllBuf = allBufWith . recvBuf + +-- |Receive a raw memory object from a socket. +-- Returns 'Nothing' on short read. +recvStorable :: forall a . Storable a => Socket -> IO (Maybe a) +recvStorable s = alloca $ \p -> do + r <- recvAllBuf s (castPtr p) n + if r < n + then return Nothing + else Just <$> peek p + where + n = sizeOf (undefined :: a) + +-- |Send an entire buffer to a socket, blocking as necessary. +-- Any short write indicates a 0 result from 'sendBuf'. +sendAllBuf :: Socket -> Ptr Word8 -> Int -> IO () +sendAllBuf s p n = do + r <- allBufWith (sendBuf s) p n + unless (r == n) $ fail $ "sendAllBuf: sent " ++ show r ++ "/" ++ show n + +-- |Send a raw memory object to a socket. +-- Returns 'False' on short read. +sendStorable :: Storable a => Socket -> a -> IO () +sendStorable s x = with x $ \p -> + sendAllBuf s (castPtr p) (sizeOf x) + +-- |Effeciently send an entire builder to a network socket, using a specific buffer size. +-- Of course, this could be made even more efficient by using something like 'B.AllocationStrategy', but this is good enough for most purposes. +sendBuilderWith :: Socket -> Int -> B.Builder -> IO () +sendBuilderWith s z0 = buf z0 . B.runBuilder where + buf z w = do + n <- allocaBytes z $ run z w + case n of + B.More z' w' -> buf z' w' + ~B.Done -> return () + run z w p = do + (l, n) <- w p z + sendAllBuf s p l + case n of + B.More z' w' | z' <= z -> + run z w' p + B.Chunk b w' -> do + BS.sendAll s b + run z w' p + _ -> return n + +-- |Effeciently send an entire builder to a network socket, using a buffer size of 'B.defaultChunkSize'. +sendBuilder :: Socket -> B.Builder -> IO () +sendBuilder s = sendBuilderWith s B.defaultChunkSize diff --git a/ONC-RPC.cabal b/ONC-RPC.cabal new file mode 100644 --- /dev/null +++ b/ONC-RPC.cabal @@ -0,0 +1,83 @@ +name: ONC-RPC +version: 0.1 +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 +license-file: LICENSE +author: Dylan Simon +maintainer: dylan@dylex.net +copyright: 2017 +category: Network +build-type: Custom +cabal-version: >=1.24 +tested-with: GHC == 7.10.3, GHC == 8.0.1 + +source-repository head + type: git + location: https://github.com/dylex/haskell-nfs + +custom-setup + setup-depends: + base >=4.8 && <5, + bytestring, + Cabal, + cereal >=0.5.4, + containers, + filepath, + haskell-src-exts >= 1.18, + parsec, + vector + +library + exposed-modules: + Network.ONCRPC.XDR.Array + Network.ONCRPC.XDR.Types + Network.ONCRPC.XDR.Serial + Network.ONCRPC.XDR.Opaque + Network.ONCRPC.XDR.Generate + Network.ONCRPC.XDR.Cabal + Network.ONCRPC.XDR + Network.ONCRPC.Types + Network.ONCRPC.Prot + Network.ONCRPC.Exception + Network.ONCRPC.Auth + Network.ONCRPC.Message + Network.ONCRPC.Client + Network.ONCRPC + Network.ONCRPC.Bind.Prot + other-modules: + Network.Socket.All + Network.ONCRPC.XDR.Specification + Network.ONCRPC.XDR.Parse + Network.ONCRPC.XDR.Reident + Network.ONCRPC.RecordMarking + Network.ONCRPC.Transport + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.8 && <5, + bytestring, + Cabal, + cereal >=0.5.4, + containers, + filepath, + haskell-src-exts >= 1.18, + network >= 2.6.3, + parsec, + random, + time, + vector + + if !os(windows) + build-depends: + unix + +executable hsrpcgen + hs-source-dirs: tools + main-is: hsrpcgen.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.8 && <5, + filepath, + ONC-RPC diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,7 @@ +import Distribution.Simple +import Network.ONCRPC.XDR.Cabal + +main :: IO () +main = defaultMainWithHooks simpleUserHooks + { hookedPreProcessors = [ppRPCGenSuffixHandler] + } diff --git a/tools/hsrpcgen.hs b/tools/hsrpcgen.hs new file mode 100644 --- /dev/null +++ b/tools/hsrpcgen.hs @@ -0,0 +1,80 @@ +{-# LANGUAGE RecordWildCards #-} +import Data.List (foldl', intercalate) +import Data.Maybe (fromMaybe) +import qualified System.Console.GetOpt as Opt +import System.Environment (getProgName, getArgs) +import System.Exit (exitFailure) +import System.FilePath (splitExtension, splitDirectories) +import System.IO (hPutStrLn, stderr) + +import Network.ONCRPC.XDR.Generate + +data Opts = Opts + { optGenerate :: GenerateOptions + , optOutput :: FilePath + } + +defModuleName :: String +defModuleName = "Prot" + +defOpts :: Opts +defOpts = Opts + { optGenerate = GenerateOptions + { generateModuleName = defModuleName + , generateReidentOptions = defaultReidentOptions + } + , optOutput = "-" + } + +setGenerate :: (GenerateOptions -> GenerateOptions) -> Opts -> Opts +setGenerate f o = o{ optGenerate = f (optGenerate o) } + +setReident :: (ReidentOptions -> ReidentOptions) -> Opts -> Opts +setReident f = setGenerate $ \g -> g{ generateReidentOptions = f (generateReidentOptions g) } + +setOutput :: FilePath -> Opts -> Opts +setOutput f o@Opts{ optGenerate = g } = o + { optOutput = f + , optGenerate = if generateModuleName g == defModuleName && e == ".hs" + then g{ generateModuleName = m } else g + } where + (b, e) = splitExtension f + m = intercalate "." $ splitDirectories b + +opts :: [Opt.OptDescr (Opts -> Opts)] +opts = + [ Opt.Option "o" ["output"] + (Opt.ReqArg setOutput "FILE") + "write the output to FILE [stdout]" + , Opt.Option "m" ["module"] + (Opt.ReqArg (\a -> setGenerate $ \g -> g{ generateModuleName = a }) "NAME") + ("set the generated module name [" ++ defModuleName ++ " or from output filename]") + , Opt.Option "P" ["procedures-unique"] + (Opt.NoArg (setReident $ \r -> r{ reidentJoinProcedure = Nothing })) + "assume program version and procedure names are unique: don't add prefixes" + , Opt.Option "F" ["fields-unique"] + (Opt.NoArg (setReident $ \r -> r{ reidentJoinField = Nothing })) + "assume struct and union fields are unique: don't add type prefixes" + , Opt.Option "L" ["lowercase-prefix"] + (Opt.OptArg (\a -> setReident $ \r -> r{ reidentLowerPrefix = fromMaybe "_" a }) "PREFIX") + "make identifiers lower-case by prefixing them (with underscore)" + , Opt.Option "U" ["uppercase-prefix"] + (Opt.ReqArg (\a -> setReident $ \r -> r{ reidentLowerPrefix = a }) "PREFIX") + "make identifiers upper-case by prefixing them" + ] + +output :: FilePath -> String -> IO () +output "-" = putStrLn +output f = writeFile f + +main :: IO () +main = do + prog <- getProgName + args <- getArgs + (Opts{..}, f) <- case Opt.getOpt Opt.Permute opts args of + (ol, [f], []) -> return (foldl' (flip ($)) defOpts ol, f) + (_, _, err) -> do + mapM_ (hPutStrLn stderr) err + hPutStrLn stderr $ Opt.usageInfo ("Usage: " ++ prog ++ " [OPTION...] FILE") opts + exitFailure + output optOutput =<< generateFromFile optGenerate f