{-# 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
data Call a r = Call
{ forall a r. Call a r -> Procedure a r
callProcedure :: !(Procedure a r)
, forall a r. Call a r -> Auth
callCred :: !Auth
, forall a r. Call a r -> Auth
callVerf :: !Auth
, forall a r. Call a r -> a
callArgs :: a
}
deriving (Int -> Call a r -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a r. Show a => Int -> Call a r -> ShowS
forall a r. Show a => [Call a r] -> ShowS
forall a r. Show a => Call a r -> String
showList :: [Call a r] -> ShowS
$cshowList :: forall a r. Show a => [Call a r] -> ShowS
show :: Call a r -> String
$cshow :: forall a r. Show a => Call a r -> String
showsPrec :: Int -> Call a r -> ShowS
$cshowsPrec :: forall a r. Show a => Int -> Call a r -> ShowS
Show)
splitCall :: Call a r -> (RPC.Call_body, a)
splitCall :: forall a r. Call a r -> (Call_body, a)
splitCall Call{ callProcedure :: forall a r. Call a r -> Procedure a r
callProcedure = Procedure{UnsignedInt
procedureProc :: forall a r. Procedure a r -> UnsignedInt
procedureVers :: forall a r. Procedure a r -> UnsignedInt
procedureProg :: forall a r. Procedure a r -> UnsignedInt
procedureProc :: UnsignedInt
procedureVers :: UnsignedInt
procedureProg :: UnsignedInt
..}, a
Auth
callArgs :: a
callVerf :: Auth
callCred :: Auth
callArgs :: forall a r. Call a r -> a
callVerf :: forall a r. Call a r -> Auth
callCred :: forall a r. Call a r -> Auth
..} =
( RPC.Call_body
{ call_body'rpcvers :: UnsignedInt
RPC.call_body'rpcvers = forall a. Integral a => a
RPC.rPC_VERS
, call_body'prog :: UnsignedInt
RPC.call_body'prog = UnsignedInt
procedureProg
, call_body'vers :: UnsignedInt
RPC.call_body'vers = UnsignedInt
procedureVers
, call_body'proc :: UnsignedInt
RPC.call_body'proc = UnsignedInt
procedureProc
, call_body'cred :: Opaque_auth
RPC.call_body'cred = Auth -> Opaque_auth
opacifyAuth Auth
callCred
, call_body'verf :: Opaque_auth
RPC.call_body'verf = Auth -> Opaque_auth
opacifyAuth Auth
callVerf
}
, a
callArgs
)
getCall :: XDR.XDR a => RPC.Call_body -> S.Get (Call a r)
getCall :: forall a r. XDR a => Call_body -> Get (Call a r)
getCall RPC.Call_body{UnsignedInt
Opaque_auth
call_body'verf :: Opaque_auth
call_body'cred :: Opaque_auth
call_body'proc :: UnsignedInt
call_body'vers :: UnsignedInt
call_body'prog :: UnsignedInt
call_body'rpcvers :: UnsignedInt
call_body'verf :: Call_body -> Opaque_auth
call_body'cred :: Call_body -> Opaque_auth
call_body'proc :: Call_body -> UnsignedInt
call_body'vers :: Call_body -> UnsignedInt
call_body'prog :: Call_body -> UnsignedInt
call_body'rpcvers :: Call_body -> UnsignedInt
..} = do
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ UnsignedInt
call_body'rpcvers forall a. Eq a => a -> a -> Bool
== forall a. Integral a => a
RPC.rPC_VERS
a
a <- forall a. XDR a => Get a
xdrGet
forall (m :: * -> *) a. Monad m => a -> m a
return Call
{ callProcedure :: Procedure a r
callProcedure = Procedure
{ procedureProg :: UnsignedInt
procedureProg = UnsignedInt
call_body'prog
, procedureVers :: UnsignedInt
procedureVers = UnsignedInt
call_body'vers
, procedureProc :: UnsignedInt
procedureProc = UnsignedInt
call_body'proc
}
, callCred :: Auth
callCred = Opaque_auth -> Auth
unopacifyAuth Opaque_auth
call_body'cred
, callVerf :: Auth
callVerf = Opaque_auth -> Auth
unopacifyAuth Opaque_auth
call_body'verf
, callArgs :: a
callArgs = a
a
}
instance XDR.XDR a => XDR.XDR (Call a r) where
xdrType :: Call a r -> String
xdrType Call a r
_ = String
"call_body_args"
xdrPut :: Call a r -> Put
xdrPut = forall a. XDR a => a -> Put
xdrPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a r. Call a r -> (Call_body, a)
splitCall
xdrGet :: Get (Call a r)
xdrGet = forall a r. XDR a => Call_body -> Get (Call a r)
getCall forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. XDR a => Get a
xdrGet
data Reply a
= Reply
{ forall a. Reply a -> Auth
replyVerf :: !Auth
, forall a. Reply a -> a
replyResults :: a
}
| ReplyError
{ replyVerf :: !Auth
, forall a. Reply a -> Accepted_reply_data
replyError :: !RPC.Accepted_reply_data
}
| ReplyRejected
{ forall a. Reply a -> Rejected_reply
replyRejected :: !RPC.Rejected_reply
}
| ReplyFail String
deriving (Typeable)
instance Show a => Show (Reply a) where
showsPrec :: Int -> Reply a -> ShowS
showsPrec Int
p (Reply Auth
v a
r) = Bool -> ShowS -> ShowS
showParen (Int
p forall a. Ord a => a -> a -> Bool
> Int
10) forall a b. (a -> b) -> a -> b
$
String -> ShowS
showString String
"Reply " forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 Auth
v forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ShowS
showChar Char
' ' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => Int -> a -> ShowS
showsPrec Int
11 a
r
showsPrec Int
_ Reply a
r = String -> ShowS
showString String
"RPC reply error: " forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ShowS
showString (forall {a}. Reply a -> String
se Reply a
r) where
se :: Reply a -> String
se (Reply Auth
_ a
_) = String
"SUCCESS"
se (ReplyError Auth
_ (RPC.Accepted_reply_data'PROG_MISMATCH UnsignedInt
l UnsignedInt
h)) = String
"PROG_MISMATCH(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnsignedInt
l forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnsignedInt
h forall a. [a] -> [a] -> [a]
++ String
")"
se (ReplyError Auth
_ Accepted_reply_data
e) = forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ Accepted_reply_data -> Accept_stat
RPC.accepted_reply_data'stat Accepted_reply_data
e
se (ReplyRejected (RPC.Rejected_reply'RPC_MISMATCH UnsignedInt
l UnsignedInt
h)) = String
"RPC_MISMATCH(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnsignedInt
l forall a. [a] -> [a] -> [a]
++ String
"," forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show UnsignedInt
h forall a. [a] -> [a] -> [a]
++ String
")"
se (ReplyRejected (RPC.Rejected_reply'AUTH_ERROR Auth_stat
s)) = String
"AUTH_ERROR(" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Auth_stat
s forall a. [a] -> [a] -> [a]
++ String
")"
se (ReplyFail String
e) = String
e
instance Functor Reply where
fmap :: forall a b. (a -> b) -> Reply a -> Reply b
fmap a -> b
f (Reply Auth
v a
r) = forall a. Auth -> a -> Reply a
Reply Auth
v forall a b. (a -> b) -> a -> b
$ a -> b
f a
r
fmap a -> b
_ (ReplyError Auth
v Accepted_reply_data
e) = forall a. Auth -> Accepted_reply_data -> Reply a
ReplyError Auth
v Accepted_reply_data
e
fmap a -> b
_ (ReplyRejected Rejected_reply
e) = forall a. Rejected_reply -> Reply a
ReplyRejected Rejected_reply
e
fmap a -> b
_ (ReplyFail String
e) = forall a. String -> Reply a
ReplyFail String
e
type ReplyException = Reply Void
instance Exception ReplyException where
toException :: ReplyException -> SomeException
toException = forall e. Exception e => e -> SomeException
rpcExceptionToException
fromException :: SomeException -> Maybe ReplyException
fromException = forall e. Exception e => SomeException -> Maybe e
rpcExceptionFromException
replyResult :: Reply a -> Either ReplyException a
replyResult :: forall a. Reply a -> Either ReplyException a
replyResult (Reply Auth
_ a
r) = forall a b. b -> Either a b
Right a
r
replyResult (ReplyError Auth
v Accepted_reply_data
e) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Auth -> Accepted_reply_data -> Reply a
ReplyError Auth
v Accepted_reply_data
e
replyResult (ReplyRejected Rejected_reply
e) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Rejected_reply -> Reply a
ReplyRejected Rejected_reply
e
replyResult (ReplyFail String
e) = forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. String -> Reply a
ReplyFail String
e
splitReply :: Reply a -> (RPC.Reply_body, Maybe a)
splitReply :: forall a. Reply a -> (Reply_body, Maybe a)
splitReply (Reply Auth
v a
r) =
( Accepted_reply -> Reply_body
RPC.Reply_body'MSG_ACCEPTED
forall a b. (a -> b) -> a -> b
$ Opaque_auth -> Accepted_reply_data -> Accepted_reply
RPC.Accepted_reply (Auth -> Opaque_auth
opacifyAuth Auth
v) Accepted_reply_data
RPC.Accepted_reply_data'SUCCESS
, forall a. a -> Maybe a
Just a
r
)
splitReply (ReplyError Auth
v Accepted_reply_data
e) =
( Accepted_reply -> Reply_body
RPC.Reply_body'MSG_ACCEPTED
forall a b. (a -> b) -> a -> b
$ Opaque_auth -> Accepted_reply_data -> Accepted_reply
RPC.Accepted_reply (Auth -> Opaque_auth
opacifyAuth Auth
v) Accepted_reply_data
e
, forall a. Maybe a
Nothing
)
splitReply (ReplyRejected Rejected_reply
r) =
( Rejected_reply -> Reply_body
RPC.Reply_body'MSG_DENIED Rejected_reply
r
, forall a. Maybe a
Nothing
)
splitReply (ReplyFail String
e) = (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"splitReply ReplyFail: " forall a. [a] -> [a] -> [a]
++ String
e, forall a. Maybe a
Nothing)
getReply :: XDR.XDR a => RPC.Reply_body -> S.Get (Reply a)
getReply :: forall a. XDR a => Reply_body -> Get (Reply a)
getReply (RPC.Reply_body'MSG_ACCEPTED (RPC.Accepted_reply Opaque_auth
v d :: Accepted_reply_data
d@Accepted_reply_data
RPC.Accepted_reply_data'SUCCESS)) =
forall a. Auth -> a -> Reply a
Reply (Opaque_auth -> Auth
unopacifyAuth Opaque_auth
v) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. XDR a => Get a
xdrGet forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Auth -> Accepted_reply_data -> Reply a
ReplyError (Opaque_auth -> Auth
unopacifyAuth Opaque_auth
v) Accepted_reply_data
d)
getReply (RPC.Reply_body'MSG_ACCEPTED (RPC.Accepted_reply Opaque_auth
v Accepted_reply_data
e)) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Auth -> Accepted_reply_data -> Reply a
ReplyError (Opaque_auth -> Auth
unopacifyAuth Opaque_auth
v) Accepted_reply_data
e
getReply (RPC.Reply_body'MSG_DENIED Rejected_reply
r) =
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Rejected_reply -> Reply a
ReplyRejected Rejected_reply
r
instance XDR.XDR a => XDR.XDR (Reply a) where
xdrType :: Reply a -> String
xdrType Reply a
_ = String
"reply_body_result"
xdrPut :: Reply a -> Put
xdrPut (ReplyFail String
e) = forall a. HasCallStack => String -> a
error String
e
xdrPut Reply a
r = do
forall a. XDR a => a -> Put
xdrPut Reply_body
b
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. XDR a => a -> Put
xdrPut Maybe a
a
where (Reply_body
b, Maybe a
a) = forall a. Reply a -> (Reply_body, Maybe a)
splitReply Reply a
r
xdrGet :: Get (Reply a)
xdrGet = forall a. XDR a => Reply_body -> Get (Reply a)
getReply forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a. XDR a => Get a
xdrGet
data Msg a r
= MsgCall
{ forall a r. Msg a r -> UnsignedInt
msgXID :: XID
, forall a r. Msg a r -> Call a r
msgCall :: Call a r
}
| MsgReply
{ msgXID :: XID
, forall a r. Msg a r -> Reply r
msgReply :: Reply r
}
deriving (Int -> Msg a r -> ShowS
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a r. (Show a, Show r) => Int -> Msg a r -> ShowS
forall a r. (Show a, Show r) => [Msg a r] -> ShowS
forall a r. (Show a, Show r) => Msg a r -> String
showList :: [Msg a r] -> ShowS
$cshowList :: forall a r. (Show a, Show r) => [Msg a r] -> ShowS
show :: Msg a r -> String
$cshow :: forall a r. (Show a, Show r) => Msg a r -> String
showsPrec :: Int -> Msg a r -> ShowS
$cshowsPrec :: forall a r. (Show a, Show r) => Int -> Msg a r -> ShowS
Show)
instance (XDR.XDR a, XDR.XDR r) => XDR.XDR (Msg a r) where
xdrType :: Msg a r -> String
xdrType Msg a r
_ = String
"rpc_msg_content"
xdrPut :: Msg a r -> Put
xdrPut (MsgCall UnsignedInt
x Call a r
c) = forall a. XDR a => a -> Put
xdrPut (UnsignedInt -> Rpc_msg_body -> Rpc_msg
RPC.Rpc_msg UnsignedInt
x forall a b. (a -> b) -> a -> b
$ Call_body -> Rpc_msg_body
RPC.Rpc_msg_body'CALL Call_body
b, a
a)
where (Call_body
b, a
a) = forall a r. Call a r -> (Call_body, a)
splitCall Call a r
c
xdrPut (MsgReply UnsignedInt
x Reply r
r) = do
forall a. XDR a => a -> Put
xdrPut forall a b. (a -> b) -> a -> b
$ UnsignedInt -> Rpc_msg_body -> Rpc_msg
RPC.Rpc_msg UnsignedInt
x forall a b. (a -> b) -> a -> b
$ Reply_body -> Rpc_msg_body
RPC.Rpc_msg_body'REPLY Reply_body
b
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. XDR a => a -> Put
xdrPut Maybe r
a
where (Reply_body
b, Maybe r
a) = forall a. Reply a -> (Reply_body, Maybe a)
splitReply Reply r
r
xdrGet :: Get (Msg a r)
xdrGet = do
RPC.Rpc_msg UnsignedInt
x Rpc_msg_body
b <- forall a. XDR a => Get a
xdrGet
case Rpc_msg_body
b of
RPC.Rpc_msg_body'CALL Call_body
c -> forall a r. UnsignedInt -> Call a r -> Msg a r
MsgCall UnsignedInt
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a r. XDR a => Call_body -> Get (Call a r)
getCall Call_body
c
RPC.Rpc_msg_body'REPLY Reply_body
r -> forall a r. UnsignedInt -> Reply r -> Msg a r
MsgReply UnsignedInt
x forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. XDR a => Reply_body -> Get (Reply a)
getReply Reply_body
r