module System.Posix.PAM.LowLevel where

import Foreign.C
import Foreign.Marshal.Alloc
import Foreign.Marshal.Array
import Foreign.Ptr
import Foreign.Storable

import System.Posix.PAM.Internals hiding ( conv, resp )
import System.Posix.PAM.Types

-- | `retCodeFromC` @responseCode@ converts @responseCode@ from PAM to
--   a PamRetCode
retCodeFromC :: CInt -> PamRetCode
retCodeFromC :: CInt -> PamRetCode
retCodeFromC rc :: CInt
rc = case CInt
rc of
            0 -> PamRetCode
PamSuccess
            a :: CInt
a -> Int -> PamRetCode
PamRetCode (Int -> PamRetCode) -> Int -> PamRetCode
forall a b. (a -> b) -> a -> b
$ CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
a

-- | `retCodeToC` @retCode@ converts @retCode@ to the corresponding integer
--   used in the PAM C library
retCodeToC :: PamRetCode -> CInt
retCodeToC :: PamRetCode -> CInt
retCodeToC PamSuccess     = 0
retCodeToC (PamRetCode a :: Int
a) = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
a

responseToC :: PamResponse -> IO CPamResponse
responseToC :: PamResponse -> IO CPamResponse
responseToC (PamResponse resp :: String
resp) = do
    CString
resp' <- String -> IO CString
newCString String
resp
    CPamResponse -> IO CPamResponse
forall (m :: * -> *) a. Monad m => a -> m a
return (CPamResponse -> IO CPamResponse)
-> CPamResponse -> IO CPamResponse
forall a b. (a -> b) -> a -> b
$ CString -> CInt -> CPamResponse
CPamResponse CString
resp' 0

messageFromC :: CPamMessage -> IO PamMessage
messageFromC :: CPamMessage -> IO PamMessage
messageFromC cmes :: CPamMessage
cmes =
    let style :: PamStyle
style = case CPamMessage -> CInt
msg_style CPamMessage
cmes of
            1 -> PamStyle
PamPromptEchoOff
            2 -> PamStyle
PamPromptEchoOn
            3 -> PamStyle
PamErrorMsg
            4 -> PamStyle
PamTextInfo
            a :: CInt
a -> String -> PamStyle
forall a. HasCallStack => String -> a
error (String -> PamStyle) -> String -> PamStyle
forall a b. (a -> b) -> a -> b
$ "unknown style value: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CInt -> String
forall a. Show a => a -> String
show CInt
a
    in do
        String
str <- CString -> IO String
peekCString (CString -> IO String) -> CString -> IO String
forall a b. (a -> b) -> a -> b
$ CPamMessage -> CString
msg CPamMessage
cmes
        PamMessage -> IO PamMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (PamMessage -> IO PamMessage) -> PamMessage -> IO PamMessage
forall a b. (a -> b) -> a -> b
$ String -> PamStyle -> PamMessage
PamMessage String
str PamStyle
style

cConv :: (Ptr () -> [PamMessage] -> IO [PamResponse]) -> CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt
cConv :: (Ptr () -> [PamMessage] -> IO [PamResponse])
-> CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt
cConv customConv :: Ptr () -> [PamMessage] -> IO [PamResponse]
customConv num :: CInt
num mesArrPtr :: Ptr (Ptr ())
mesArrPtr respArrPtr :: Ptr (Ptr ())
respArrPtr appData :: Ptr ()
appData =
    if CInt
num CInt -> CInt -> Bool
forall a. Ord a => a -> a -> Bool
<= 0
        then CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return 19
        else do
            -- get array pointer (pointer to first element)
            Ptr ()
voidArr <- Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ())
mesArrPtr

            -- cast pointer type from ()
            let mesArr :: Ptr CPamMessage
mesArr = Ptr () -> Ptr CPamMessage
forall a b. Ptr a -> Ptr b
castPtr Ptr ()
voidArr :: Ptr CPamMessage

            -- peek message list from array
            [CPamMessage]
cMessages <- Int -> Ptr CPamMessage -> IO [CPamMessage]
forall a. Storable a => Int -> Ptr a -> IO [a]
peekArray (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
num) Ptr CPamMessage
mesArr

            -- convert messages into high-level types
            [PamMessage]
messages <- (CPamMessage -> IO PamMessage) -> [CPamMessage] -> IO [PamMessage]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CPamMessage -> IO PamMessage
messageFromC [CPamMessage]
cMessages

            -- create response list
            [PamResponse]
responses <- Ptr () -> [PamMessage] -> IO [PamResponse]
customConv Ptr ()
appData [PamMessage]
messages

            -- convert responses into low-level types
            [CPamResponse]
cResponses <- (PamResponse -> IO CPamResponse)
-> [PamResponse] -> IO [CPamResponse]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM PamResponse -> IO CPamResponse
responseToC [PamResponse]
responses

            -- alloc memory for response array
            Ptr CPamResponse
respArr <- Int -> IO (Ptr CPamResponse)
forall a. Storable a => Int -> IO (Ptr a)
mallocArray (CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral CInt
num)

            -- poke resonse list into array
            Ptr CPamResponse -> [CPamResponse] -> IO ()
forall a. Storable a => Ptr a -> [a] -> IO ()
pokeArray Ptr CPamResponse
respArr [CPamResponse]
cResponses

            -- poke array pointer into respArrPtr
            Ptr (Ptr ()) -> Ptr () -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr ())
respArrPtr (Ptr () -> IO ()) -> Ptr () -> IO ()
forall a b. (a -> b) -> a -> b
$ Ptr CPamResponse -> Ptr ()
forall a b. Ptr a -> Ptr b
castPtr Ptr CPamResponse
respArr

            -- return PAM_SUCCESS
            CInt -> IO CInt
forall (m :: * -> *) a. Monad m => a -> m a
return 0


pamStart :: String -> String -> (PamConv, Ptr ()) -> IO (PamHandle, PamRetCode)
pamStart :: String
-> String
-> (Ptr () -> [PamMessage] -> IO [PamResponse], Ptr ())
-> IO (PamHandle, PamRetCode)
pamStart serviceName :: String
serviceName userName :: String
userName (pamConv :: Ptr () -> [PamMessage] -> IO [PamResponse]
pamConv, appData :: Ptr ()
appData) = do
    CString
cServiceName <- String -> IO CString
newCString String
serviceName
    CString
cUserName <- String -> IO CString
newCString String
userName

    -- create FunPtr pointer to function and embedd PamConv function into cConv
    FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
pamConvPtr <- (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
-> IO
     (FunPtr
        (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt))
mkconvFunc ((CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
 -> IO
      (FunPtr
         (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)))
-> (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
-> IO
     (FunPtr
        (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt))
forall a b. (a -> b) -> a -> b
$ (Ptr () -> [PamMessage] -> IO [PamResponse])
-> CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt
cConv Ptr () -> [PamMessage] -> IO [PamResponse]
pamConv
    let conv :: CPamConv
conv = FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
-> Ptr () -> CPamConv
CPamConv FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
pamConvPtr Ptr ()
appData

    Ptr CPamConv
convPtr <- IO (Ptr CPamConv)
forall a. Storable a => IO (Ptr a)
malloc
    Ptr CPamConv -> CPamConv -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr CPamConv
convPtr CPamConv
conv

    Ptr (Ptr ())
pamhPtr <- IO (Ptr (Ptr ()))
forall a. Storable a => IO (Ptr a)
malloc
    Ptr (Ptr ()) -> Ptr () -> IO ()
forall a. Storable a => Ptr a -> a -> IO ()
poke Ptr (Ptr ())
pamhPtr Ptr ()
forall a. Ptr a
nullPtr

    CInt
r1 <- CString -> CString -> Ptr CPamConv -> Ptr (Ptr ()) -> IO CInt
c_pam_start CString
cServiceName CString
cUserName Ptr CPamConv
convPtr Ptr (Ptr ())
pamhPtr

    Ptr ()
cPamHandle_ <- Ptr (Ptr ()) -> IO (Ptr ())
forall a. Storable a => Ptr a -> IO a
peek Ptr (Ptr ())
pamhPtr

    let retCode :: PamRetCode
retCode = CInt -> PamRetCode
retCodeFromC CInt
r1

    CString -> IO ()
forall a. Ptr a -> IO ()
free CString
cServiceName
    CString -> IO ()
forall a. Ptr a -> IO ()
free CString
cUserName
    Ptr CPamConv -> IO ()
forall a. Ptr a -> IO ()
free Ptr CPamConv
convPtr

    Ptr (Ptr ()) -> IO ()
forall a. Ptr a -> IO ()
free Ptr (Ptr ())
pamhPtr

    (PamHandle, PamRetCode) -> IO (PamHandle, PamRetCode)
forall (m :: * -> *) a. Monad m => a -> m a
return (Ptr ()
-> FunPtr
     (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
-> PamHandle
PamHandle Ptr ()
cPamHandle_ FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
pamConvPtr, PamRetCode
retCode)

pamEnd :: PamHandle -> PamRetCode -> IO PamRetCode
pamEnd :: PamHandle -> PamRetCode -> IO PamRetCode
pamEnd pamHandle :: PamHandle
pamHandle inRetCode :: PamRetCode
inRetCode = do
    CInt
r <- Ptr () -> CInt -> IO CInt
c_pam_end (PamHandle -> Ptr ()
cPamHandle PamHandle
pamHandle) (CInt -> IO CInt) -> CInt -> IO CInt
forall a b. (a -> b) -> a -> b
$ PamRetCode -> CInt
retCodeToC PamRetCode
inRetCode
    FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
-> IO ()
forall a. FunPtr a -> IO ()
freeHaskellFunPtr (FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
 -> IO ())
-> FunPtr
     (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
-> IO ()
forall a b. (a -> b) -> a -> b
$ PamHandle
-> FunPtr
     (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
cPamCallback PamHandle
pamHandle

    PamRetCode -> IO PamRetCode
forall (m :: * -> *) a. Monad m => a -> m a
return (PamRetCode -> IO PamRetCode) -> PamRetCode -> IO PamRetCode
forall a b. (a -> b) -> a -> b
$ CInt -> PamRetCode
retCodeFromC CInt
r

pamAuthenticate :: PamHandle -> PamFlag -> IO PamRetCode
pamAuthenticate :: PamHandle -> PamFlag -> IO PamRetCode
pamAuthenticate pamHandle :: PamHandle
pamHandle flag :: PamFlag
flag = do
    let cFlag :: CInt
cFlag = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ PamFlag -> Int
forall a. Enum a => a -> Int
fromEnum PamFlag
flag
    CInt
r <- Ptr () -> CInt -> IO CInt
c_pam_authenticate (PamHandle -> Ptr ()
cPamHandle PamHandle
pamHandle) CInt
cFlag
    PamRetCode -> IO PamRetCode
forall (m :: * -> *) a. Monad m => a -> m a
return (PamRetCode -> IO PamRetCode) -> PamRetCode -> IO PamRetCode
forall a b. (a -> b) -> a -> b
$ CInt -> PamRetCode
retCodeFromC CInt
r

pamAcctMgmt :: PamHandle -> PamFlag -> IO PamRetCode
pamAcctMgmt :: PamHandle -> PamFlag -> IO PamRetCode
pamAcctMgmt pamHandle :: PamHandle
pamHandle flag :: PamFlag
flag = do
    let cFlag :: CInt
cFlag = Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Int -> CInt) -> Int -> CInt
forall a b. (a -> b) -> a -> b
$ PamFlag -> Int
forall a. Enum a => a -> Int
fromEnum PamFlag
flag
    CInt
r <- Ptr () -> CInt -> IO CInt
c_pam_acct_mgmt (PamHandle -> Ptr ()
cPamHandle PamHandle
pamHandle) CInt
cFlag
    PamRetCode -> IO PamRetCode
forall (m :: * -> *) a. Monad m => a -> m a
return (PamRetCode -> IO PamRetCode) -> PamRetCode -> IO PamRetCode
forall a b. (a -> b) -> a -> b
$ CInt -> PamRetCode
retCodeFromC CInt
r