-- |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
  { 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

-- |'RPC.Reply_body' with results
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 -- ^Missing/corrupt response
  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

-- |The successful reply results or an error.
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)

-- |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 :: 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

-- |'RPC.Rpc_msg' with arguments or results.
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