LowLevel.hs

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 rc = case rc of
            0 -> PamSuccess
            a -> PamRetCode $ fromIntegral a

-- | `retCodeToC` @retCode@ converts @retCode@ to the corresponding integer
--   used in the PAM C library
retCodeToC :: PamRetCode -> CInt
retCodeToC PamSuccess     = 0
retCodeToC (PamRetCode a) = fromIntegral a

responseToC :: PamResponse -> IO CPamResponse
responseToC (PamResponse resp) = do
    resp' <- newCString resp
    return $ CPamResponse resp' 0

messageFromC :: CPamMessage -> IO PamMessage
messageFromC cmes =
    let style = case msg_style cmes of
            1 -> PamPromptEchoOff
            2 -> PamPromptEchoOn
            3 -> PamErrorMsg
            4 -> PamTextInfo
            a -> error $ "unknown style value: " ++ show a
    in do
        str <- peekCString $ msg cmes
        return $ PamMessage str style

cConv :: (Ptr () -> [PamMessage] -> IO [PamResponse]) -> CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt
cConv customConv num mesArrPtr respArrPtr appData =
    if num <= 0
        then return 19
        else do
            -- get array pointer (pointer to first element)
            voidArr <- peek mesArrPtr

            -- cast pointer type from ()
            let mesArr = castPtr voidArr :: Ptr CPamMessage

            -- peek message list from array
            cMessages <- peekArray (fromIntegral num) mesArr

            -- convert messages into high-level types
            messages <- mapM messageFromC cMessages

            -- create response list
            responses <- customConv appData messages

            -- convert responses into low-level types
            cResponses <- mapM responseToC responses

            -- alloc memory for response array
            respArr <- mallocArray (fromIntegral num)

            -- poke resonse list into array
            pokeArray respArr cResponses

            -- poke array pointer into respArrPtr
            poke respArrPtr $ castPtr respArr

            -- return PAM_SUCCESS
            return 0


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

    -- create FunPtr pointer to function and embedd PamConv function into cConv
    pamConvPtr <- mkconvFunc $ cConv pamConv
    let conv = CPamConv pamConvPtr appData

    convPtr <- malloc
    poke convPtr conv

    pamhPtr <- malloc
    poke pamhPtr nullPtr

    r1 <- c_pam_start cServiceName cUserName convPtr pamhPtr

    cPamHandle_ <- peek pamhPtr

    let retCode = retCodeFromC r1

    free cServiceName
    free cUserName
    free convPtr

    free pamhPtr

    return (PamHandle cPamHandle_ pamConvPtr, retCode)

pamEnd :: PamHandle -> PamRetCode -> IO PamRetCode
pamEnd pamHandle inRetCode = do
    r <- c_pam_end (cPamHandle pamHandle) $ retCodeToC inRetCode
    freeHaskellFunPtr $ cPamCallback pamHandle

    return $ retCodeFromC r

pamAuthenticate :: PamHandle -> PamFlag -> IO PamRetCode
pamAuthenticate pamHandle flag = do
    let cFlag = fromIntegral $ fromEnum flag
    r <- c_pam_authenticate (cPamHandle pamHandle) cFlag
    return $ retCodeFromC r

pamAcctMgmt :: PamHandle -> PamFlag -> IO PamRetCode
pamAcctMgmt pamHandle flag = do
    let cFlag = fromIntegral $ fromEnum flag
    r <- c_pam_acct_mgmt (cPamHandle pamHandle) cFlag
    return $ retCodeFromC r