Initial Commit

.gitignore

@@ -0,0 +1 @@
+.stack-work/

LICENSE

@@ -0,0 +1,27 @@
+Copyright (c) 2011 Evgeny Tarasov.
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions
+are met:
+1. Redistributions of source code must retain the above copyright
+   notice, this list of conditions and the following disclaimer.
+2. Redistributions in binary form must reproduce the above copyright
+   notice, this list of conditions and the following disclaimer in the
+   documentation and/or other materials provided with the distribution.
+3. Neither the name of the author nor the names of contributors
+   may be used to endorse or promote products derived from this software
+   without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE AUTHOR AND CONTRIBUTORS ``AS IS'' AND
+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR OR CONTRIBUTORS BE LIABLE
+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
+SUCH DAMAGE.
+

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

pam.cabal

@@ -0,0 +1,32 @@
+Name:           pam
+Version:        0.1
+Cabal-Version:  >= 1.2.3
+Build-type:     Simple
+License:        BSD3
+License-File:   LICENSE
+Copyright:      Copyright (c) 2011 Evgeny Tarasov
+Maintainer:     [email protected]
+Stability:      alpha
+Synopsis:       Haskell binding for C PAM API
+Description:    This package provides PAM interface for Haskell programs. It contains subset of C PAM API bindings. The bindings don't include functions for writing PAM modules.
+Category:       System
+Tested-with:    GHC==6.12.3
+Extra-source-files: Setup.hs
+
+Library
+    exposed-modules: System.Posix.PAM
+                     System.Posix.PAM.LowLevel
+                     System.Posix.PAM.Types
+                     System.Posix.PAM.Internals
+
+    --other-modules:   System.Posix.PAM.Internals
+
+    extensions: ForeignFunctionInterface
+
+    Build-Depends:  base >= 4 && < 5
+    Hs-Source-Dirs: src
+    Ghc-options:    -Wall
+
+    extra-libraries : pam
+
+    build-tools: c2hs

src/System/Posix/PAM.hs

@@ -0,0 +1,71 @@
+
+module System.Posix.PAM where
+
+import Foreign.Ptr
+import System.Posix.PAM.LowLevel
+import System.Posix.PAM.Types
+
+authenticate :: String -> String -> String -> IO (Either Int ())
+authenticate serviceName userName password = do
+    let custConv :: String -> PamConv
+        custConv pass _ messages = do
+            let rs = map (\ _ -> PamResponse pass) messages
+            return rs
+    (pamH, r1) <- pamStart serviceName userName (custConv password, nullPtr)
+    case r1 of
+        PamRetCode code -> return $ Left $ fromInteger $ toInteger code
+        PamSuccess -> do
+            r2 <- pamAuthenticate pamH (PamFlag 0)
+            case r2 of
+                PamRetCode code -> return $ Left $ fromInteger $ toInteger code
+                PamSuccess -> do
+                    r3 <- pamEnd pamH r2
+                    case r3 of
+                        PamSuccess -> return $ Right ()
+                        PamRetCode code -> return $ Left $ fromInteger $ toInteger code
+
+checkAccount :: String -> String -> IO (Either Int ())
+checkAccount = undefined
+
+
+pamCodeToMessage :: Int -> String
+pamCodeToMessage = snd . pamCodeDetails
+
+pamCodeToCDefine :: Int -> String
+pamCodeToCDefine = fst . pamCodeDetails
+
+pamCodeDetails :: Int -> (String, String)
+pamCodeDetails code = case code of
+    0 -> ("PAM_SUCCESS", "Successful function return")
+    1 -> ("PAM_OPEN_ERR", "dlopen() failure when dynamically loading a service module")
+    2 -> ("PAM_SYMBOL_ERR", "Symbol not found")
+    3 -> ("PAM_SERVICE_ERR", "Error in service module")
+    4 -> ("PAM_SYSTEM_ERR", "System error")
+    5 -> ("PAM_BUF_ERR", "Memory buffer error")
+    6 -> ("PAM_PERM_DENIED", "Permission denied")
+    7 -> ("PAM_AUTH_ERR", "Authentication failure")
+    8 -> ("PAM_CRED_INSUFFICIENT", "Can not access authentication data due to insufficient credentials")
+    9 -> ("PAM_AUTHINFO_UNAVAIL", "Underlying authentication service can not retrieve authentication information")
+    10 -> ("PAM_USER_UNKNOWN", "User not known to the underlying authenticaiton module")
+    11 -> ("PAM_MAXTRIES", "An authentication service has maintained a retry count which has been reached.  No further retries should be attempted")
+    12 -> ("PAM_NEW_AUTHTOK_REQD", "New authentication token required. This is normally returned if the machine security policies require that the password should be changed beccause the password is NULL or it has aged")
+    13 -> ("PAM_ACCT_EXPIRED", "User account has expired")
+    14 -> ("PAM_SESSION_ERR", "Can not make/remove an entry for the specified session")
+    15 -> ("PAM_CRED_UNAVAIL", "Underlying authentication service can not retrieve user credentials unavailable")
+    16 -> ("PAM_CRED_EXPIRED", "User credentials expired")
+    17 -> ("PAM_CRED_ERR", "Failure setting user credentials")
+    18 -> ("PAM_NO_MODULE_DATA", "No module specific data is present")
+    19 -> ("PAM_CONV_ERR", "Conversation error")
+    20 -> ("PAM_AUTHTOK_ERR", "Authentication token manipulation error")
+    21 -> ("PAM_AUTHTOK_RECOVERY_ERR", "Authentication information cannot be recovered")
+    22 -> ("PAM_AUTHTOK_LOCK_BUSY", "Authentication token lock busy")
+    23 -> ("PAM_AUTHTOK_DISABLE_AGING", "Authentication token aging disabled")
+    24 -> ("PAM_TRY_AGAIN", "Preliminary check by password service")
+    25 -> ("PAM_IGNORE", "Ignore underlying account module regardless of whether the control flag is required, optional, or sufficient")
+    26 -> ("PAM_ABORT", "Critical error (?module fail now request)")
+    27 -> ("PAM_AUTHTOK_EXPIRED", "user's authentication token has expired")
+    28 -> ("PAM_MODULE_UNKNOWN", "module is not known")
+    29 -> ("PAM_BAD_ITEM", "Bad item passed to pam_*_item()")
+    30 -> ("PAM_CONV_AGAIN", "conversation function is event driven and data is not available yet")
+    31 -> ("PAM_INCOMPLETE", "please call this function again to complete authentication stack. Before calling again, verify that conversation is completed")
+    a -> ("PAM_UNKNOWN", "There is no code description in haskell pam library: " ++ show a)

src/System/Posix/PAM/Internals.chs

@@ -0,0 +1,61 @@
+{-# LANGUAGE CPP, ForeignFunctionInterface #-}
+module System.Posix.PAM.Internals where
+
+import Control.Applicative
+import Foreign.C
+import Foreign.Ptr
+import Foreign.Storable
+
+#include <security/pam_appl.h>
+
+data CPamMessage = CPamMessage { msg_style :: CInt
+                               , msg :: CString
+                               }
+                               deriving (Show,Eq)
+
+instance Storable CPamMessage where
+    alignment _ = alignment (undefined :: CDouble)
+    sizeOf _ = sizeOf (undefined :: CInt) + sizeOf (undefined :: CString)
+    peek p = CPamMessage <$> ({#get pam_message.msg_style #} p)
+                         <*> ({#get pam_message.msg #} p)
+    poke p (CPamMessage ms m) = do
+        {#set pam_message.msg_style #} p ms
+        {#set pam_message.msg #} p m
+
+data CPamResponse = CPamResponse { resp :: CString
+                                 , resp_retcode :: CInt
+                                 }
+                                 deriving (Show,Eq)
+
+instance Storable CPamResponse where
+    alignment _ = alignment (undefined :: CDouble)
+    sizeOf _ = sizeOf (undefined :: CString) + sizeOf (undefined :: CInt)
+    peek p = CPamResponse <$> ({#get pam_response.resp #} p)
+                          <*> ({#get pam_response.resp_retcode #} p)
+    poke p (CPamResponse r rc) = do
+        {#set pam_response.resp #} p r
+        {#set pam_response.resp_retcode #} p rc
+
+data CPamConv = CPamConv { conv :: FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
+                         , appdata_ptr :: Ptr ()
+                         }
+                         deriving (Show, Eq)
+
+type ConvFunc = CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt
+foreign import ccall "wrapper" mkconvFunc :: ConvFunc -> IO (FunPtr ConvFunc)
+
+instance Storable CPamConv where
+    alignment _ = alignment (undefined :: CDouble)
+    sizeOf _ = sizeOf (undefined :: FunPtr ()) + sizeOf (undefined :: Ptr ())
+    peek p = CPamConv <$> ({#get pam_conv.conv #} p)
+                      <*> ({#get pam_conv.appdata_ptr #} p)
+    poke p (CPamConv c ap) = do
+        {#set pam_conv.conv #} p c
+        {#set pam_conv.appdata_ptr #} p ap
+
+type CPamHandleT = ()
+
+foreign import ccall "security/pam_appl.h pam_start" c_pam_start :: CString -> CString -> Ptr CPamConv -> Ptr (Ptr CPamHandleT) -> IO CInt
+foreign import ccall "security/pam_appl.h pam_end" c_pam_end :: Ptr CPamHandleT -> CInt -> IO CInt
+foreign import ccall "security/pam_appl.h pam_authenticate" c_pam_authenticate :: Ptr CPamHandleT -> CInt -> IO CInt
+foreign import ccall "security/pam_appl.h pam_acct_mgmt" c_pam_acct_mgmt :: Ptr CPamHandleT -> CInt -> IO CInt

src/System/Posix/PAM/LowLevel.hs

@@ -0,0 +1,125 @@
+
+module System.Posix.PAM.LowLevel where
+
+import Foreign.C
+import Foreign.Marshal.Array
+import Foreign.Marshal.Alloc
+import Foreign.Ptr
+import Foreign.Storable
+import System.Posix.PAM.Types
+import System.Posix.PAM.Internals hiding (resp, conv)
+
+retCodeFromC :: CInt -> PamRetCode
+retCodeFromC rc = case rc of
+            0 -> PamSuccess
+            a -> PamRetCode $ fromInteger $ toInteger a
+
+retCodeToC :: PamRetCode -> CInt
+retCodeToC PamSuccess = 0
+retCodeToC (PamRetCode a) = fromInteger $ toInteger 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 (fromInteger $ toInteger 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 (fromInteger $ toInteger 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 = case r1 of
+            0 -> PamSuccess
+            a -> PamRetCode $ fromInteger $ toInteger a
+
+    free cServiceName
+    free cUserName
+    free convPtr
+
+    free pamhPtr
+
+    return (PamHandle cPamHandle_ pamConvPtr, retCode)
+
+pamEnd :: PamHandle -> PamRetCode -> IO PamRetCode
+pamEnd pamHandle inRetCode = do
+    let cRetCode = case inRetCode of
+            PamSuccess -> 0
+            PamRetCode a -> fromInteger $ toInteger a
+    r <- c_pam_end (cPamHandle pamHandle) cRetCode
+    freeHaskellFunPtr $ cPamCallback pamHandle
+
+    return $ retCodeFromC r
+
+pamAuthenticate :: PamHandle -> PamFlag -> IO PamRetCode
+pamAuthenticate pamHandle (PamFlag flag) = do
+    let cFlag = fromInteger $ toInteger flag
+    r <- c_pam_authenticate (cPamHandle pamHandle) cFlag
+    return $ retCodeFromC r
+
+pamAcctMgmt :: PamHandle -> PamFlag -> IO PamRetCode
+pamAcctMgmt pamHandle (PamFlag flag) = do
+    let cFlag = fromInteger $ toInteger flag
+    r <- c_pam_acct_mgmt (cPamHandle pamHandle) cFlag
+    return $ retCodeFromC r

src/System/Posix/PAM/Types.hs

@@ -0,0 +1,36 @@
+
+module System.Posix.PAM.Types where
+
+import Foreign.C
+import Foreign.Ptr
+
+data PamMessage = PamMessage { pmString :: String
+                             , pmStyle :: PamStyle
+                             }
+                             deriving (Show, Eq)
+
+data PamStyle = PamPromptEchoOff
+              | PamPromptEchoOn
+              | PamErrorMsg
+              | PamTextInfo
+              deriving (Show, Eq)
+
+{- | http://www.kernel.org/pub/linux/libs/pam/Linux-PAM-html/adg-interface-of-app-expected.html#adg-pam_conv
+ - resp_code member in C sturct is unused and should be set to zero, that's why there is no code field in the haskell data type
+ -}
+data PamResponse = PamResponse String
+                 deriving (Show, Eq)
+
+data PamRetCode = PamSuccess
+                | PamRetCode Int
+                deriving (Show, Eq)
+
+data PamFlag = PamFlag Int
+
+type PamConv = Ptr () -> [PamMessage] -> IO [PamResponse]
+
+
+data PamHandle = PamHandle { cPamHandle :: Ptr ()
+                           , cPamCallback :: FunPtr (CInt -> Ptr (Ptr ()) -> Ptr (Ptr ()) -> Ptr () -> IO CInt)
+                           }
+                           deriving (Show, Eq)