diff --git a/CONTRIBUTING.md b/CONTRIBUTING.md new file mode 100644 --- /dev/null +++ b/CONTRIBUTING.md @@ -0,0 +1,26 @@ +# Contributing: + +## Feature requests: +If you have a feature request open an issue and use the `enhancement` label. Make sure you describe the feature you want in sufficient detail + +## Issues: +If you find an issue then firstly search to see if it has already been reported. If not then open a new issue with the label `bug`. Make sure you include details of: +- The events leading to the issue +- What the issue is/how it manifests +- The PAM logs relating to the issue + +Try to give the "minimum" example to reproduce the bug where possible + +## Pull requests: +When opening a pull request: +- Open a draft PR when you start working. This allows others to see you are working on a bug/feature and avoids duplicate work +- Ensure your code meets the coding conventions listed below +- Try to stick to 1 feature/bug per PR +- Include details of what your changes do, for example what feature you implement or which bug you fix + +## Code Conventions: +- Use 4 spaces for tabs +- Include type signatures for all top level functions +- Include Haddock comments for all functions/type definitions, as well as inline comments explaining logic where it may not be clear +- Try to avoid long lines - if a line is looking long then split it across 2 lines, or use `let...in...` or `...where` if it makes your code more readable +- Update the README with new features or changes to existing ones diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,13 @@ +# Change Log: + +## v0.2.0.0: +- `authenticate` function now returns `MonadIO m => m PamRetCode` rather than `IO (Either Int ())` +- `authSuccess :: PamRetCode -> Bool` added which checks if the given `PamRetCode` is `PamSuccess` or not +- `whenSuccess :: MonadIO m => PamRetCode -> m PamRetCode -> m PamRetCode` added, which returns the second argument if the given response code is `PamSuccess`, otherwise it returns the given response code (useful for continuing only if the PAM action succeeded). +- `pamCodeToMessage`, `pamCodeToCDefine` and `pamCodeDetails` now take a `PamRetCode` rather than an `Int` +- `checkAccount` function has now been implemented +- Switched to PVP versioning +- Some documentation added + +## v0.1: +Initial release diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,43 @@ +# pam + +![Haskell CI](https://github.com/oscar-h64/pam-haskell/workflows/Haskell%20CI/badge.svg) +![Hackage](https://img.shields.io/hackage/v/pam.svg) + +Haskell bindings for PAM. Note that this does not currently include the required bindings to write PAM modules + +## Usage: + +To authenticate a user `test` using the `system-local-login` PAM configuration: +```haskell +authenticate "system-local-login" "test" "PASSWORD" +``` + +To check if a user `test` exists using the `system-auth` PAM configuration: +```haskell +checkAccount "system-auth" "test" +``` + +If the operation was successful then `PamSuccess` will be returned, otherwise `PamCode a`, where `a` represents the reason for the failure. + +`pamCodeToMessage`, `pamCodeToCDefine` and `pamCodeDetails` can be used to get further details about the response, and `isSuccess` can be used to check if the operation was successful. See the Haddock documentation for more details on these functions. + +## Documentation: + +The documentation is available on [Hackage](https://hackage.haskell.org/package/pam) + +## Changes in v0.2.0.0: +- `authenticate` function now returns `MonadIO m => m PamRetCode` rather than `IO (Either Int ())` +- `authSuccess :: PamRetCode -> Bool` added which checks if the given `PamRetCode` is `PamSuccess` or not +- `whenSuccess :: MonadIO m => PamRetCode -> m PamRetCode -> m PamRetCode` added, which returns the second argument if the given response code is `PamSuccess`, otherwise it returns the given response code (useful for continuing only if the PAM action succeeded). +- `pamCodeToMessage`, `pamCodeToCDefine` and `pamCodeDetails` now take a `PamRetCode` rather than an `Int` +- `checkAccount` function has now been implemented + +## Planned Changes: +- Document and refactoring the code (started) +- Add ability to give multiple passwords (for 2FA systems) (see [#2](https://github.com/oscar-h64/pam-haskell/issues/2)) +- Add functions that do the prompting rather than being given details - useful as if a program using the library is intended to be distributed the number of prompts will not be known (see [#3](https://github.com/oscar-h64/pam-haskell/issues/3)) +- Add functions to allow writing PAM modules in Haskell (see [#8](https://github.com/oscar-h64/pam-haskell/issues/8)) + +## Contributing: + +See [here](https://github.com/oscar-h64/pam-haskell/blob/master/CONTRIBUTING.md) for more information diff --git a/pam.cabal b/pam.cabal --- a/pam.cabal +++ b/pam.cabal @@ -1,32 +1,45 @@ -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: etarasov.ekb@gmail.com -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 +cabal-version: 3.0 +name: pam +version: 0.2.0.0 +build-type: Simple +license: BSD-3-Clause +license-file: LICENSE +copyright: (c) 2011 Evgeny Tarasov + (c) 2020 Oscar Harris +author: Evgeny Tarasov +maintainer: Oscar Harris +stability: provisional +synopsis: Haskell binding for C PAM API +description: This package provides PAM interface for Haskell programs. See the README on GitHub at for more information. +bug-reports: https://github.com/oscar-h64/pam-haskell/issues +category: System, Authentication +tested-with: GHC==8.8.3 +homepage: https://github.com/oscar-h64/pam-haskell -Library +extra-source-files: + Setup.hs + +extra-doc-files: + README.md + CONTRIBUTING.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/oscar-h64/pam-haskell + +library + default-language: Haskell2010 + 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 + build-depends: base >= 4 && < 5 + hs-source-dirs: src + ghc-options: -Wall - extra-libraries : pam + extra-libraries: pam - build-tools: c2hs + build-tool-depends: c2hs:c2hs diff --git a/src/System/Posix/PAM.hs b/src/System/Posix/PAM.hs --- a/src/System/Posix/PAM.hs +++ b/src/System/Posix/PAM.hs @@ -1,42 +1,62 @@ module System.Posix.PAM where +import Control.Monad.IO.Class ( MonadIO, liftIO ) + import Foreign.Ptr + import System.Posix.PAM.LowLevel import System.Posix.PAM.Types -authenticate :: String -> String -> String -> IO (Either Int ()) +-- | `isSuccess` @responseCode@ checks if @responseCode@ is equal to `PamSuccess`, +-- i.e. checking if the account check/authentication succeeded +isSuccess :: PamRetCode -> Bool +isSuccess = (== PamSuccess) + +-- | `whenSuccess` @responseCode action@ returns @action@ if @responseCode@ is +-- `PamSuccess`, otherwise returns @responseCode@ +whenSuccess :: MonadIO m => PamRetCode -> m PamRetCode -> m PamRetCode +whenSuccess code action = if isSuccess code then action else pure code + +-- | `authenticate` @service user password@ attempts to authenticate @user@ and +-- @password@ with PAM using @service@ to determine which file in /etc/pam.d to +-- use +authenticate :: MonadIO m => String -> String -> String -> m PamRetCode 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 + let custConv :: PamConv + custConv _ messages = return $ map (\ _ -> PamResponse password) messages -checkAccount :: String -> String -> IO (Either Int ()) -checkAccount = undefined + (pamH, r1) <- liftIO $ pamStart serviceName userName (custConv, nullPtr) + whenSuccess r1 $ do + status <- liftIO $ pamAuthenticate pamH PamSilent + whenSuccess status $ liftIO $ pamEnd pamH PamSuccess -pamCodeToMessage :: Int -> String +-- | `checkAccount` @service user@ checks if @user@ is a valid user. @service@ is +-- is the service name given to PAM (see `authenticate`) +checkAccount :: MonadIO m => String -> String -> m PamRetCode +checkAccount serviceName userName = do + (pamH, r1) <- liftIO $ pamStart serviceName userName (\_ _ -> pure [], nullPtr) + + whenSuccess r1 $ do + status <- liftIO $ pamAcctMgmt pamH PamSilent + whenSuccess status $ liftIO $ pamEnd pamH PamSuccess + +-- | `pamCodeToMessage` @responseCode@ returns a description of @responseCode@ +-- in the context of PAM +pamCodeToMessage :: PamRetCode -> String pamCodeToMessage = snd . pamCodeDetails -pamCodeToCDefine :: Int -> String +-- | `pamCodeToMessage` @responseCode@ returns the name of the define used in C +-- to represent @responseCode@ +pamCodeToCDefine :: PamRetCode -> String pamCodeToCDefine = fst . pamCodeDetails -pamCodeDetails :: Int -> (String, String) -pamCodeDetails code = case code of - 0 -> ("PAM_SUCCESS", "Successful function return") +-- | `pamCodeDetails` @responseCode@ returns a tuple of the name of the C define +-- and a description of @responseCode@ +pamCodeDetails :: PamRetCode -> (String, String) +pamCodeDetails PamSuccess = ("PAM_SUCCESS", "Successful function return") +pamCodeDetails (PamRetCode code) = case code of 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") diff --git a/src/System/Posix/PAM/Internals.chs b/src/System/Posix/PAM/Internals.chs --- a/src/System/Posix/PAM/Internals.chs +++ b/src/System/Posix/PAM/Internals.chs @@ -1,7 +1,6 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-} module System.Posix.PAM.Internals where -import Control.Applicative import Foreign.C import Foreign.Ptr import Foreign.Storable diff --git a/src/System/Posix/PAM/LowLevel.hs b/src/System/Posix/PAM/LowLevel.hs --- a/src/System/Posix/PAM/LowLevel.hs +++ b/src/System/Posix/PAM/LowLevel.hs @@ -2,21 +2,26 @@ module System.Posix.PAM.LowLevel where import Foreign.C -import Foreign.Marshal.Array 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 -import System.Posix.PAM.Internals hiding (resp, conv) +-- | `retCodeFromC` @responseCode@ converts @responseCode@ from PAM to +-- a PamRetCode retCodeFromC :: CInt -> PamRetCode retCodeFromC rc = case rc of 0 -> PamSuccess - a -> PamRetCode $ fromInteger $ toInteger a + 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) = fromInteger $ toInteger a +retCodeToC PamSuccess = 0 +retCodeToC (PamRetCode a) = fromIntegral a responseToC :: PamResponse -> IO CPamResponse responseToC (PamResponse resp) = do @@ -47,7 +52,7 @@ let mesArr = castPtr voidArr :: Ptr CPamMessage -- peek message list from array - cMessages <- peekArray (fromInteger $ toInteger num) mesArr + cMessages <- peekArray (fromIntegral num) mesArr -- convert messages into high-level types messages <- mapM messageFromC cMessages @@ -59,7 +64,7 @@ cResponses <- mapM responseToC responses -- alloc memory for response array - respArr <- mallocArray (fromInteger $ toInteger num) + respArr <- mallocArray (fromIntegral num) -- poke resonse list into array pokeArray respArr cResponses @@ -90,9 +95,7 @@ cPamHandle_ <- peek pamhPtr - let retCode = case r1 of - 0 -> PamSuccess - a -> PamRetCode $ fromInteger $ toInteger a + let retCode = retCodeFromC r1 free cServiceName free cUserName @@ -104,22 +107,19 @@ 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 + r <- c_pam_end (cPamHandle pamHandle) $ retCodeToC inRetCode freeHaskellFunPtr $ cPamCallback pamHandle return $ retCodeFromC r pamAuthenticate :: PamHandle -> PamFlag -> IO PamRetCode -pamAuthenticate pamHandle (PamFlag flag) = do - let cFlag = fromInteger $ toInteger flag +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 (PamFlag flag) = do - let cFlag = fromInteger $ toInteger flag +pamAcctMgmt pamHandle flag = do + let cFlag = fromIntegral $ fromEnum flag r <- c_pam_acct_mgmt (cPamHandle pamHandle) cFlag return $ retCodeFromC r diff --git a/src/System/Posix/PAM/Types.hs b/src/System/Posix/PAM/Types.hs --- a/src/System/Posix/PAM/Types.hs +++ b/src/System/Posix/PAM/Types.hs @@ -5,7 +5,7 @@ import Foreign.Ptr data PamMessage = PamMessage { pmString :: String - , pmStyle :: PamStyle + , pmStyle :: PamStyle } deriving (Show, Eq) @@ -25,7 +25,15 @@ | PamRetCode Int deriving (Show, Eq) -data PamFlag = PamFlag Int +data PamFlag = PamSilent + | PamDisallowNullAuthTok + | PamEstablishCred + | PamDeleteCred + | PamReinitializeCred + | PamRefreshCred + | PamChangeExpiredAuthTok + | PamNone + deriving (Show, Eq, Enum) type PamConv = Ptr () -> [PamMessage] -> IO [PamResponse] diff --git a/stack.yaml b/stack.yaml new file mode 100644 --- /dev/null +++ b/stack.yaml @@ -0,0 +1,66 @@ +# This file was automatically generated by 'stack init' +# +# Some commonly used options have been documented as comments in this file. +# For advanced use and comprehensive documentation of the format, please see: +# https://docs.haskellstack.org/en/stable/yaml_configuration/ + +# Resolver to choose a 'specific' stackage snapshot or a compiler version. +# A snapshot resolver dictates the compiler version and the set of packages +# to be used for project dependencies. For example: +# +# resolver: lts-3.5 +# resolver: nightly-2015-09-21 +# resolver: ghc-7.10.2 +# +# The location of a snapshot can be provided as a file or url. Stack assumes +# a snapshot provided as a file might change, whereas a url resource does not. +# +# resolver: ./custom-snapshot.yaml +# resolver: https://example.com/snapshots/2018-01-01.yaml +resolver: lts-16.2 + +# User packages to be built. +# Various formats can be used as shown in the example below. +# +# packages: +# - some-directory +# - https://example.com/foo/bar/baz-0.0.2.tar.gz +# subdirs: +# - auto-update +# - wai +packages: +- . +# Dependency packages to be pulled from upstream that are not in the resolver. +# These entries can reference officially published versions as well as +# forks / in-progress versions pinned to a git hash. For example: +# +# extra-deps: +# - acme-missiles-0.3 +# - git: https://github.com/commercialhaskell/stack.git +# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a +# +# extra-deps: [] + +# Override default flag values for local packages and extra-deps +# flags: {} + +# Extra package databases containing global packages +# extra-package-dbs: [] + +# Control whether we use the GHC we find on the path +# system-ghc: true +# +# Require a specific version of stack, using version ranges +# require-stack-version: -any # Default +# require-stack-version: ">=2.3" +# +# Override the architecture used by stack, especially useful on Windows +# arch: i386 +# arch: x86_64 +# +# Extra directories used by stack for building +# extra-include-dirs: [/path/to/dir] +# extra-lib-dirs: [/path/to/dir] +# +# Allow a newer minor version of GHC than the snapshot specifies +# compiler-check: newer-minor