-- |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 (Auth -> Auth -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Auth -> Auth -> Bool
$c/= :: Auth -> Auth -> Bool
== :: Auth -> Auth -> Bool
$c== :: Auth -> Auth -> Bool
Eq, Int -> Auth -> ShowS
[Auth] -> ShowS
Auth -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Auth] -> ShowS
$cshowList :: [Auth] -> ShowS
show :: Auth -> String
$cshow :: Auth -> String
showsPrec :: Int -> Auth -> ShowS
$cshowsPrec :: Int -> Auth -> ShowS
Show)

opacifyAuth :: Auth -> RPC.Opaque_auth
opacifyAuth :: Auth -> Opaque_auth
opacifyAuth Auth
AuthNone    = Int -> Opaque_auth_body -> Opaque_auth
RPC.Opaque_auth (forall a. XDREnum a => a -> Int
xdrFromEnum Auth_flavor
RPC.AUTH_NONE) forall a b. (a -> b) -> a -> b
$ forall (n :: Natural) a.
(CmpNat 0 n ~ 'LT, Array a) =>
LengthArray 'LT n a
emptyBoundedLengthArray
opacifyAuth (AuthSys Authsys_parms
s) = Int -> Opaque_auth_body -> Opaque_auth
RPC.Opaque_auth (forall a. XDREnum a => a -> Int
xdrFromEnum Auth_flavor
RPC.AUTH_SYS)  forall a b. (a -> b) -> a -> b
$ forall a (o :: Ordering) (n :: Natural).
(Opaqued a, KnownOrdering o, KnownNat n) =>
a -> LengthArray o n OpaqueString
toOpaque' Authsys_parms
s
opacifyAuth (AuthOpaque Opaque_auth
o) = Opaque_auth
o

unopacifyAuth :: RPC.Opaque_auth -> Auth
unopacifyAuth :: Opaque_auth -> Auth
unopacifyAuth o :: Opaque_auth
o@(RPC.Opaque_auth Int
n Opaque_auth_body
b) = case forall a (m :: * -> *). (XDREnum a, MonadFail m) => Int -> m a
xdrToEnum Int
n of
  Just Auth_flavor
RPC.AUTH_NONE -> Auth
AuthNone
  Just Auth_flavor
RPC.AUTH_SYS | Just Authsys_parms
s <- forall a (m :: * -> *) (o :: Ordering) (n :: Natural).
(Opaqued a, MonadFail m) =>
LengthArray o n OpaqueString -> m a
fromOpaque Opaque_auth_body
b -> Authsys_parms -> Auth
AuthSys Authsys_parms
s
  Maybe Auth_flavor
_ -> Opaque_auth -> Auth
AuthOpaque Opaque_auth
o

instance XDR.XDR Auth where
  xdrType :: Auth -> String
xdrType Auth
_ = String
"translucent_auth"
  xdrPut :: Auth -> Put
xdrPut = forall a. XDR a => a -> Put
xdrPut forall b c a. (b -> c) -> (a -> b) -> a -> c
. Auth -> Opaque_auth
opacifyAuth
  xdrGet :: Get Auth
xdrGet = Opaque_auth -> Auth
unopacifyAuth forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. XDR a => Get a
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 :: IO Auth
getAuthUnix = do
  ProcessID
pid <- IO ProcessID
getProcessID
  SystemID
sysid <- IO SystemID
getSystemID
  UserID
uid <- IO UserID
getEffectiveUserID
  GroupID
gid <- IO GroupID
getEffectiveGroupID
  [GroupID]
gids <- IO [GroupID]
getGroups
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Authsys_parms -> Auth
AuthSys RPC.Authsys_parms
    { authsys_parms'stamp :: UnsignedInt
RPC.authsys_parms'stamp = forall a b. (Integral a, Num b) => a -> b
fromIntegral ProcessID
pid
    , authsys_parms'machinename :: String 255
RPC.authsys_parms'machinename = forall (n :: Natural) a.
(KnownNat n, Array a) =>
a -> LengthArray 'LT n a
boundLengthArray forall a b. (a -> b) -> a -> b
$ String -> ByteString
BSC.pack forall a b. (a -> b) -> a -> b
$ SystemID -> String
nodeName SystemID
sysid
    , authsys_parms'uid :: UnsignedInt
RPC.authsys_parms'uid = forall a b. (Integral a, Num b) => a -> b
fromIntegral UserID
uid
    , authsys_parms'gid :: UnsignedInt
RPC.authsys_parms'gid = forall a b. (Integral a, Num b) => a -> b
fromIntegral GroupID
gid
    , authsys_parms'gids :: Array 16 UnsignedInt
RPC.authsys_parms'gids = forall (n :: Natural) a.
(KnownNat n, Array a) =>
[Elem a] -> LengthArray 'LT n a
boundLengthArrayFromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (Integral a, Num b) => a -> b
fromIntegral [GroupID]
gids
    }
#endif