{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- | -- Module : $Header$ -- Copyright : © 2013-2014 Nicola Squartini -- License : BSD3 -- -- Maintainer : Nicola Squartini -- Stability : experimental -- Portability : portable -- -- Functions in this module are bindings to the C API defined in -- . -- The design goal is to be as low level as possible without having to allocate -- or deallocate memory, and remaining type-safe. In order to reach this goal, -- all pointers to opaque C structures are represented by monad transformers -- representing actions on those pointers. Here is the pointer to monad -- transformer correspondence: -- -- @ -- acl_t \<--\> 'AclT' -- acl_entry_t \<--\> 'EntryT' -- acl_permset_t \<--\> 'PermsetT' -- @ -- -- A common usage pattern is to modify the permset of an entry inside an ACL. -- This is done in three steps: -- -- 1. convert the @'PermsetT' m a@ modification of permset into an @'EntryT' m -- a@ modification of entry; -- -- 2. convert the @'EntryT' m a@ into an @'AclT' m a@ modification of ACL; -- -- 3. execute the @'AclT' m a@ in the base monad @m@. -- -- For example in -- -- @ -- 'fromText' "u::rw,g::r,o::r" $ 'getEntry' 0 $ 'changePermset' $ 'addPerm' 'Execute' -- @ -- -- @'addPerm' 'Execute'@ is the @'PermsetT'@ that adds the execute permission, -- @'changePermset'@ converts @'PermsetT'@ into @'EntryT'@, @'getEntry' 0@ -- modifies the 1st entry of the ACL according to the action contained in -- @'EntryT'@ (thus converts @'EntryT'@ into @'AclT'@), and finally @'fromText' -- "u::rw,g::r,o::r"@ runs the @'AclT'@ action on the ACL represented by the -- short text form @u::rw,g::r,o::r@. In words, it adds execute permission to -- the 1st entry of @u::rw,g::r,o::r@, producing @u::rwx,g::r,o::r@. -- -------------------------------------------------------------------------------- module System.Posix.ACL.C ( -- * ACL initialization AclT , newACL, dupACL -- * ACL entry manipulation , EntryT , createEntry, getEntries, getEntry , copyEntry , deleteEntry , valid , PermsetT, Perm(..) , changePermset , addPerm , calcMask , clearPerms , deletePerm , Tag(..) , getTag, setTag -- * Get, set and delete ACLs from a file , Type(..) , deleteDefaultACL , getFdACL , getFileACL , setFdACL , setFileACL -- * ACL format translation , ExtRepr , copyExt , fromExt , fromText , toText ) where import Control.Applicative (Alternative, Applicative, empty, (<$>), (<*>)) import Control.Exception.Lifted (bracket, mask_) import Control.Monad (MonadPlus, (>=>)) import Control.Monad.Base (MonadBase, liftBase) import Control.Monad.Fix (MonadFix) import Control.Monad.IO.Class (MonadIO) import Control.Monad.Trans.Class (MonadTrans) import Control.Monad.Trans.Control import Control.Monad.Trans.List (ListT (..)) import Control.Monad.Trans.Maybe (MaybeT (..)) import Control.Monad.Trans.Reader (ReaderT (..), runReaderT) import Data.ByteString.Char8 (ByteString, packCStringLen, unpack) import Data.ByteString.Unsafe (unsafeUseAsCStringLen) import Foreign import Foreign.C import System.Posix.Types (Fd (..), GroupID, UserID) import System.Posix.ACL.Acl_h hiding (AclT) import qualified System.Posix.ACL.Acl_h as C -- | A single permission. data Perm = Read | Write | Execute deriving (Eq, Read, Show) fromPerm :: Perm -> AclPermT fromPerm Read = aclRead fromPerm Write = aclWrite fromPerm Execute = aclExecute -- | The type of an ACL (see section 23.1.3 of -- ). data Type = Access | Default deriving (Eq, Read, Show) fromType :: Type -> AclTypeT fromType Access = aclTypeAccess fromType Default = aclTypeDefault -- | Tag type and qualifier of an ACL. data Tag = UserObj | User { tagUserID :: UserID } | GroupObj | Group { tagGroupID :: GroupID } | Mask | Other | Undefined deriving (Eq, Read, Show) aclFree :: Ptr a -> IO () aclFree = throwErrnoIfMinus1_ "acl_free" . acl_free . castPtr -- | Action to be performed on an ACL. The action contained in the transformer -- @'AclT'@ can be executed in the base monad using one of the functions -- @'newACL'@, @'getFdACL'@, @'getFileACL'@, @'fromExt'@ or @'fromText'@. newtype AclT m a = AclT { unAclT :: ReaderT (Ptr C.AclT) m a } deriving ( Alternative, Applicative, Functor, Monad, MonadBase b, MonadFix , MonadIO, MonadPlus, MonadTrans ) instance MonadTransControl AclT where type StT AclT a = StT (ReaderT (Ptr C.AclT)) a liftWith = defaultLiftWith AclT unAclT restoreT = defaultRestoreT AclT instance MonadBaseControl b m => MonadBaseControl b (AclT m) where type StM (AclT m) a = ComposeSt AclT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM runAclT :: MonadBaseControl IO m => IO C.AclT -> AclT m a -> m a runAclT gen (AclT rd) = bracket (liftBase (gen >>= new)) (\p -> liftBase $ do peek p >>= aclFree free p) (runReaderT rd) -- | Run the given action on a newly created ACL with enough preallocated memory -- to hold @n@ entries. Use @'createEntry'@ to create entries in the -- preallocated memory. -- -- Call to @acl_init()@. newACL :: MonadBaseControl IO m => Int -> AclT m a -> m a newACL = runAclT . throwErrnoIfNull "acl_init" . acl_init . fromIntegral -- | Create a copy of the current ACL and run the given action on the duplicate. -- For example -- -- @ -- 'fromText' "u::rw,g::r,o::r" $ 'dupACL' ('calcMask' >> 'toText' >>= 'Control.Monad.Trans.Class.lift' . 'print') >> 'toText' >>= 'Control.Monad.Trans.Class.lift' . 'print' -- @ -- -- copies the ACL represented by @u::rw,g::r,o::r@ to a new ACL, calculates and -- sets the permissions of @'Mask'@ (see @'calcMask'@) in the newly created ACL -- and prints out the result. It also prints out the original ACL. -- -- Call to @acl_dup()@. dupACL :: MonadBaseControl IO m => AclT m a -- ^ action to be run on the duplicate -> AclT m a dupACL aclt = AclT $ ReaderT $ \p -> runAclT (peek p >>= (throwErrnoIfNull "acl_dup" . acl_dup)) aclt -- | Run the given action on an ACL created according to the given external -- representation. -- -- Call to @acl_copy_int()@. fromExt :: MonadBaseControl IO m => ExtRepr -> AclT m a -> m a fromExt (ExtRepr bs) = runAclT $ unsafeUseAsCStringLen bs $ throwErrnoIfNull "acl_copy_int" . acl_copy_int . castPtr . fst -- | Run the given action on an ACL created according to the given textual -- representation (both the /Long Text Form/ and /Short Text Form/ are -- accepted). -- -- Call to @acl_from_text()@. fromText :: MonadBaseControl IO m => String -> AclT m a -> m a fromText str = runAclT $ withCString str $ throwErrnoIfNull "acl_from_text" . acl_from_text -- | Action to be performed on an ACL entry. In order to execute the action -- contained in the @'EntryT'@ transformer in the base monad, @'EntryT'@ must -- first be converted into @'AclT'@ using one of the functions @'createEntry'@, -- @'getEntries'@ or @'getEntry'@. newtype EntryT m a = EntryT { unEntryT :: ReaderT (AclEntryT, C.AclT) m a } deriving ( Alternative, Applicative, Functor, Monad, MonadBase b, MonadFix , MonadIO, MonadPlus, MonadTrans ) instance MonadTransControl EntryT where type StT EntryT a = StT (ReaderT (AclEntryT, C.AclT)) a liftWith = defaultLiftWith EntryT unEntryT restoreT = defaultRestoreT EntryT instance MonadBaseControl b m => MonadBaseControl b (EntryT m) where type StM (EntryT m) a = ComposeSt EntryT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM -- | Create a new entry in the ACL an run the given action on it. If necessary, -- the ACL will allocate memory for the new entry. -- -- Call to @acl_create_entry()@. createEntry :: MonadBase IO m => EntryT m a -> AclT m a createEntry (EntryT rd) = AclT $ ReaderT $ \p -> liftBase ((,) <$> alloca (\q -> do mask_ $ throwErrnoIfMinus1_ "acl_create_entry" $ acl_create_entry p q peek q) <*> peek p) >>= runReaderT rd -- | Copy the contents of an ACL entry to an existing ACL entry of a possibly -- different ACL. For example -- -- @ -- 'fromText' "u::rw,u:2:rwx,g::r,m:rwx,o::r" $ 'getEntry' 1 $ 'fromText' "u::rw,u:1:rw,u:8:rw,g::r,m:rwxo::r" ('getEntry' 2 'copyEntry' >> 'toText') -- @ -- -- copies the 2nd entry of @u::rw,u:2:rwx,g::r,m:rwx,o::r@ (namely @u:2:rwx@) -- into the 3rd entry of @u::rw,u:1:rw,u:8:rw,g::r,m:rwxo::r@ (namely @u:8:rw@) -- and prints the result. -- -- Call to @acl_copy_entry()@. copyEntry :: MonadBase IO m => EntryT (EntryT m) () copyEntry = EntryT $ ReaderT $ \(dest, _) -> EntryT $ ReaderT $ liftBase . throwErrnoIfMinus1_ "acl_copy_entry" . acl_copy_entry dest . fst getEntry' :: MonadBase IO m => CInt -> EntryT m a -> MaybeT (AclT m) a getEntry' n (EntryT rd) = MaybeT $ AclT $ ReaderT $ \p -> do acl <- liftBase $ peek p ment <- liftBase $ alloca $ \q -> do r <- throwErrnoIfMinus1 "acl_get_entry" $ acl_get_entry acl n q if r == 1 then Just <$> peek q else return Nothing case ment of Nothing -> return Nothing Just entry -> Just <$> runReaderT rd (entry, acl) getFirstEntry :: MonadBase IO m => EntryT m a -> MaybeT (AclT m) a getFirstEntry = getEntry' aclFirstEntry getNextEntry :: MonadBase IO m => EntryT m a -> MaybeT (AclT m) a getNextEntry = getEntry' aclNextEntry -- | Run the list of given actions on the list of entries of the ACL. -- -- /Warning/: using @'setTag'@ as one of the @'EntryT'@s of @'getEntries'@ is -- not recommended, as it may rearrange the list of entries inside the ACL, -- yielding unexpected results. -- -- Call to @acl_get_entry()@. getEntries :: MonadBase IO m => [EntryT m a] -> ListT (AclT m) a getEntries [] = empty getEntries (e:es) = ListT $ do m <- runMaybeT $ getFirstEntry e case m of Nothing -> return [] Just a -> (a:) <$> getNextEntries es where getNextEntries [] = return [] getNextEntries (x:xs) = do m <- runMaybeT $ getNextEntry x case m of Nothing -> return [] Just a -> (a:) <$> getNextEntries xs -- | Run the given action on the @n@-th entry of the ACL (entry enumeration -- begins from 0). -- -- Call to @acl_get_entry()@. getEntry :: MonadBase IO m => Int -> EntryT m a -> AclT m a getEntry n ent = (!!n) <$> runListT (getEntries (replicate n (return undefined) ++ [ent])) -- | Delete the entry. -- -- Call to @acl_delete_entry()@. -- -- /Warning/: no further action should be performed on this entry. deleteEntry :: MonadBase IO m => EntryT m () deleteEntry = EntryT $ ReaderT $ \(entry, acl) -> liftBase $ throwErrnoIfMinus1_ "acl_delete_entry" $ acl_delete_entry acl entry -- | Action to be performed on the permission set of an ACL entry. In order to -- execute the action contained in the @'PermsetT'@ transformer in the base -- monad, @'PermsetT'@ must first be converted into @'EntryT'@ using -- @'changePermset'@, and then into @'AclT'@. newtype PermsetT m a = PermsetT { unPermsetT :: ReaderT AclPermsetT m a } deriving ( Alternative, Applicative, Functor, Monad, MonadBase b, MonadFix , MonadIO, MonadPlus, MonadTrans ) instance MonadTransControl PermsetT where type StT PermsetT a = StT (ReaderT AclPermsetT) a liftWith = defaultLiftWith PermsetT unPermsetT restoreT = defaultRestoreT PermsetT instance MonadBaseControl b m => MonadBaseControl b (PermsetT m) where type StM (PermsetT m) a = ComposeSt PermsetT m a liftBaseWith = defaultLiftBaseWith restoreM = defaultRestoreM -- | Change the permission set of the entry. -- -- Call to @acl_get_permset()@ and @acl_set_permset()@. changePermset :: MonadBase IO m => PermsetT m a -> EntryT m a changePermset (PermsetT rd) = EntryT $ ReaderT $ \(entry, _) -> do ps <- liftBase $ alloca $ \p -> do throwErrnoIfMinus1_ "acl_get_permset" $ acl_get_permset entry p peek p ret <- runReaderT rd ps liftBase $ throwErrnoIfMinus1_ "acl_set_permset" $ acl_set_permset entry ps return ret -- | Add a specific permission. -- -- Call to @acl_add_perm()@. addPerm :: MonadBase IO m => Perm -> PermsetT m () addPerm perm = PermsetT $ ReaderT $ \ps -> liftBase $ throwErrnoIfMinus1_ "acl_add_perm" $ acl_add_perm ps $ fromPerm perm -- | Clear all permissions from the permission set. -- -- Call to @acl_clear_perms()@. clearPerms :: MonadBase IO m => PermsetT m () clearPerms = PermsetT $ ReaderT $ liftBase . throwErrnoIfMinus1_ "acl_clear_perms" . acl_clear_perms -- | Remove a specific permission. -- -- Call to @acl_delete_perm()@. deletePerm :: MonadBase IO m => Perm -> PermsetT m () deletePerm perm = PermsetT $ ReaderT $ \ps -> liftBase $ throwErrnoIfMinus1_ "acl_delete_perm" $ acl_delete_perm ps $ fromPerm perm -- | Run a validity check on the ACL (see @acl_valid()@ in section 23.4.28 of -- ). -- -- Call to @acl_valid()@. valid :: MonadBase IO m => AclT m Bool valid = AclT $ ReaderT $ liftBase . (peek >=> fmap (== 0) . acl_valid) -- | Calculate and set the permissions associated with the @'Mask'@ ACL entry of -- the ACL. The value of the new permissions is the union of the permissions -- granted by all entries of tag type @'Group'@, @'GroupObj'@, or @'User'@. If -- the ACL already contains a @'Mask'@ entry, its permissions are overwritten; -- if it does not contain a @'Mask'@ entry, one is added. -- -- Call to @acl_calc_mask()@. calcMask :: MonadBase IO m => AclT m () calcMask = AclT $ ReaderT $ liftBase . mask_ . throwErrnoIfMinus1_ "acl_calc_mask" . acl_calc_mask -- | Get the entry's tag. -- -- Call to @acl_get_tag_type()@ and possibly @acl_get_qualifier()@. getTag :: MonadBase IO m => EntryT m Tag getTag = EntryT $ ReaderT $ \(entry, _) -> liftBase $ do tag <- alloca $ \p -> do throwErrnoIfMinus1_ "acl_get_tag_type" $ acl_get_tag_type entry p peek p if | tag == aclUserObj -> return UserObj | tag == aclUser -> User <$> getQualifier entry | tag == aclGroupObj -> return GroupObj | tag == aclGroup -> Group <$> getQualifier entry | tag == aclMask -> return Mask | tag == aclOther -> return Other | tag == aclUndefinedTag -> return Undefined | otherwise -> error "not a valid ACL tag type" where getQualifier e = bracket (throwErrnoIfNull "acl_get_qualifier" $ acl_get_qualifier e) aclFree (peek . castPtr) -- | Set the tag of the entry. -- -- Call to @acl_set_tag_type()@ and possibly @acl_set_qualifier()@. -- -- /Warning/: using @'setTag'@ may rearrange the list of entries inside the ACL, -- yielding unexpected results when used together with @'getEntries'@. setTag :: MonadBase IO m => Tag -> EntryT m () setTag tag = EntryT $ ReaderT $ \(entry, _) -> liftBase $ case tag of UserObj -> setTagType entry aclUserObj User uid -> do setTagType entry aclUser setQualifier uid entry GroupObj -> setTagType entry aclGroupObj Group gid -> do setTagType entry aclGroup setQualifier gid entry Mask -> setTagType entry aclMask Other -> setTagType entry aclOther Undefined -> setTagType entry aclUndefinedTag where setTagType e = throwErrnoIfMinus1_ "acl_set_tag_type" . acl_set_tag_type e setQualifier qual e = with qual $ throwErrnoIfMinus1_ "acl_set_qualifier" . acl_set_qualifier e . castPtr -- | The /external representation/ of an ACL is an unspecified binary format -- stored in a contiguous portion of memory. newtype ExtRepr = ExtRepr ByteString deriving Eq instance Show ExtRepr where show (ExtRepr bs) = unpack bs -- | Return the external representation of the ACL. -- -- Call to @acl_copy_ext()@ and @acl_size()@. copyExt :: MonadBase IO m => AclT m ExtRepr copyExt = AclT $ ReaderT $ \p -> liftBase $ do acl <- peek p s <- throwErrnoIfMinus1 "acl_size" $ acl_size acl allocaBytes (fromIntegral s) $ \q -> do throwErrnoIfMinus1_ "acl_copy_ext" $ acl_copy_ext q acl s ExtRepr <$> packCStringLen (castPtr q,fromIntegral s) -- | Return the /Long Text Form/ of the ACL (section 23.3.1 of -- ). -- -- Call to @acl_to_text()@. toText :: MonadBase IO m => AclT m String toText = AclT $ ReaderT $ \p -> liftBase $ do acl <- peek p alloca $ \q -> bracket (throwErrnoIfNull "acl_to_text" $ acl_to_text acl q) aclFree (\cstr -> do size <- peek q peekCStringLen (cstr, fromIntegral size)) -- | Run the action on the ACL of type @'Type'@ of the given file. -- -- Call to @acl_get_file()@. getFileACL :: MonadBaseControl IO m => FilePath -> Type -> AclT m a -> m a getFileACL path typ = runAclT (withCString path $ \x -> throwErrnoIfNull "acl_get_file" (acl_get_file x (fromType typ))) -- | Run the action on the ACL of the given file descriptor. -- -- Call to @acl_get_fd()@. getFdACL :: MonadBaseControl IO m => Fd -> AclT m a -> m a getFdACL (Fd n) = runAclT $ throwErrnoIfNull "acl_get_fd" $ acl_get_fd n -- | Set the ACL of the given file descriptor. -- -- Call to @acl_set_fd()@. setFdACL :: MonadBase IO m => Fd -> AclT m () setFdACL (Fd n) = AclT $ ReaderT $ liftBase . (peek >=> throwErrnoIfMinus1_ "acl_set_fd" . acl_set_fd n) -- | Set the ACL of type @'Type'@ of the given file. -- -- Call to @acl_set_file()@. setFileACL :: MonadBase IO m => FilePath -> Type -> AclT m () setFileACL path typ = AclT $ ReaderT $ \p -> liftBase $ do acl <- peek p withCString path $ \x -> throwErrnoIfMinus1_ "acl_set_file" $ acl_set_file x (fromType typ) acl -- | Delete the default ACL from a directory. -- -- Call to @acl_delete_def_file()@. deleteDefaultACL :: FilePath -> IO () deleteDefaultACL file = withCString file $ throwErrnoIfMinus1_ "acl_delete_def_file" . acl_delete_def_file