module System.Posix.ACL.C
(
AclT
, newACL, dupACL
, EntryT
, createEntry, getEntries, getEntry
, copyEntry
, deleteEntry
, valid
, PermsetT, Perm(..)
, changePermset
, addPerm
, calcMask
, clearPerms
, deletePerm
, Tag(..)
, getTag, setTag
, Type(..)
, deleteDefaultACL
, getFdACL
, getFileACL
, setFdACL
, setFileACL
, 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
data Perm = Read
| Write
| Execute
deriving (Eq, Read, Show)
fromPerm :: Perm -> AclPermT
fromPerm Read = aclRead
fromPerm Write = aclWrite
fromPerm Execute = aclExecute
data Type = Access
| Default
deriving (Eq, Read, Show)
fromType :: Type -> AclTypeT
fromType Access = aclTypeAccess
fromType Default = aclTypeDefault
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
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)
newACL :: MonadBaseControl IO m => Int -> AclT m a -> m a
newACL = runAclT . throwErrnoIfNull "acl_init" . acl_init . fromIntegral
dupACL :: MonadBaseControl IO m =>
AclT m a
-> AclT m a
dupACL aclt =
AclT $ ReaderT $ \p ->
runAclT (peek p >>= (throwErrnoIfNull "acl_dup" . acl_dup)) aclt
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
fromText :: MonadBaseControl IO m => String -> AclT m a -> m a
fromText str =
runAclT $ withCString str $ throwErrnoIfNull "acl_from_text" . acl_from_text
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
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
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
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
getEntry :: MonadBase IO m => Int -> EntryT m a -> AclT m a
getEntry n ent =
(!!n) <$> runListT (getEntries (replicate n (return undefined) ++ [ent]))
deleteEntry :: MonadBase IO m => EntryT m ()
deleteEntry =
EntryT $ ReaderT $ \(entry, acl) -> liftBase $
throwErrnoIfMinus1_ "acl_delete_entry" $ acl_delete_entry acl entry
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
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
addPerm :: MonadBase IO m => Perm -> PermsetT m ()
addPerm perm =
PermsetT $ ReaderT $ \ps ->
liftBase $ throwErrnoIfMinus1_ "acl_add_perm" $ acl_add_perm ps $
fromPerm perm
clearPerms :: MonadBase IO m => PermsetT m ()
clearPerms =
PermsetT $ ReaderT $
liftBase . throwErrnoIfMinus1_ "acl_clear_perms" . acl_clear_perms
deletePerm :: MonadBase IO m => Perm -> PermsetT m ()
deletePerm perm =
PermsetT $ ReaderT $ \ps ->
liftBase $ throwErrnoIfMinus1_ "acl_delete_perm" $ acl_delete_perm ps $
fromPerm perm
valid :: MonadBase IO m => AclT m Bool
valid =
AclT $ ReaderT $ liftBase .
(peek >=> fmap (== 0) . acl_valid)
calcMask :: MonadBase IO m => AclT m ()
calcMask =
AclT $ ReaderT $
liftBase . mask_ . throwErrnoIfMinus1_ "acl_calc_mask" . acl_calc_mask
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)
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
newtype ExtRepr = ExtRepr ByteString
deriving Eq
instance Show ExtRepr where
show (ExtRepr bs) = unpack bs
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)
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))
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)))
getFdACL :: MonadBaseControl IO m => Fd -> AclT m a -> m a
getFdACL (Fd n) =
runAclT $ throwErrnoIfNull "acl_get_fd" $ acl_get_fd n
setFdACL :: MonadBase IO m => Fd -> AclT m ()
setFdACL (Fd n) =
AclT $ ReaderT $
liftBase . (peek >=> throwErrnoIfMinus1_ "acl_set_fd" . acl_set_fd n)
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
deleteDefaultACL :: FilePath -> IO ()
deleteDefaultACL file =
withCString file $
throwErrnoIfMinus1_ "acl_delete_def_file" . acl_delete_def_file