module System.Posix.ACL
( Permset(..)
, emptyPermset
, fullPermset
, unionPermsets
, intersectPermsets
, ACL(..)
, longTextForm
, shortTextFrom
, getACL
, getDefaultACL
, fdGetACL
, setACL
, setDefaultACL
, fdSetACL
, deleteDefaultACL
) where
import Control.Applicative (empty, (<$>), (<*>), (<|>))
import Control.Arrow (first)
import Control.Monad (void, when)
import Control.Monad.Base (MonadBase)
import Data.Function (on)
import Data.List (find, nubBy, partition)
import Data.Map hiding (empty, map, partition)
import Data.Maybe (catMaybes)
import System.Posix.Types (Fd, GroupID, UserID)
import System.Posix.User
import Text.ParserCombinators.ReadP
import Text.Read hiding (get, look, (<++))
import System.Posix.ACL.C
data Permset = Permset { hasRead :: Bool
, hasWrite :: Bool
, hasExecute :: Bool
} deriving Eq
emptyPermset :: Permset
emptyPermset = Permset False False False
fullPermset :: Permset
fullPermset = Permset True True True
unionPermsets :: Permset -> Permset -> Permset
unionPermsets (Permset r1 w1 e1) (Permset r2 w2 e2) =
Permset (r1 || r2) (w1 || w2) (e1 || e2)
intersectPermsets :: Permset -> Permset -> Permset
intersectPermsets (Permset r1 w1 e1) (Permset r2 w2 e2) =
Permset (r1 && r2) (w1 && w2) (e1 && e2)
instance Show Permset where
showsPrec = showsPermset
showsPermset :: Int -> Permset -> ShowS
showsPermset _ (Permset r w x) = (if r then ('r':) else ('-':)) .
(if w then ('w':) else ('-':)) .
(if x then ('x':) else ('-':))
showsPermsetShort :: Int -> Permset -> ShowS
showsPermsetShort _ (Permset r w x) = (if r then ('r':) else id) .
(if w then ('w':) else id) .
(if x then ('x':) else id)
parseRead :: ReadP Permset
parseRead = do _ <- char 'r'
return (Permset True False False)
parseWrite :: ReadP Permset
parseWrite = do _ <- char 'w'
return (Permset False True False)
parseExecute :: ReadP Permset
parseExecute = do _ <- char 'x'
return (Permset False False True)
parseDash :: ReadP Permset
parseDash = do _ <- satisfy (== '-')
return emptyPermset
parseLongTextPermset :: ReadP Permset
parseLongTextPermset = do
r <- parseRead <|> parseDash
w <- parseWrite <|> parseDash
x <- parseExecute <|> parseDash
return (r `unionPermsets` w `unionPermsets` x)
parseShortTextPermset :: ReadP Permset
parseShortTextPermset = do
r <- parseRead <++ return emptyPermset
w <- parseWrite <++ return emptyPermset
x <- parseExecute <++ return emptyPermset
return (r `unionPermsets` w `unionPermsets` x)
parsePermset :: ReadP Permset
parsePermset = skipSpaces >> parseLongTextPermset <|> parseShortTextPermset
instance Read Permset where
readPrec = lift parsePermset
data Entry = Entry
{ entryTag :: Tag
, entryPermset :: Permset
} deriving (Eq, Read, Show)
data TextForm = Long
| Short
deriving Eq
parseEntry :: TextForm -> [UserEntry] -> [GroupEntry] -> ReadP Entry
parseEntry tf udb gdb =
parseSingleEntry tf 'u' "ser" (Right UserObj) <|>
parseSingleEntry tf 'u' "ser"
(Left $ User <$> parseUser udb <++ readPrec_to_P readPrec 0) <|>
parseSingleEntry tf 'g' "roup" (Right GroupObj) <|>
parseSingleEntry tf 'g' "roup"
(Left $ Group <$> parseGroup gdb <++ readPrec_to_P readPrec 0) <|>
parseSingleEntry tf 'm' "ask" (Right Mask) <|>
parseSingleEntry tf 'o' "ther" (Right Other)
skipBlanks :: ReadP ()
skipBlanks = do str <- look
skip str
where skip ('\t' : str) = get >> skip str
skip (' ' : str) = get >> skip str
skip _ = return ()
parseSingleEntry :: TextForm -> Char -> String -> Either (ReadP Tag) Tag
-> ReadP Entry
parseSingleEntry tf x xs eit =
case tf of
Long -> do void $ string (x:xs)
Entry <$> secondField <*> parseLongTextPermset
Short -> do void $ char x
optional (string xs)
Entry <$> secondField <*> parseShortTextPermset
where secondField = do skipBlanks
void $ char ':'
t <- case eit of
Left qual -> skipBlanks >> qual
Right tag -> return tag
skipBlanks
void $ char ':'
skipBlanks
return t
comment :: ReadP String
comment = char '#' >> munch (/= '\n')
parseLongTextEntries :: [UserEntry] -> [GroupEntry] -> ReadP [Entry]
parseLongTextEntries udb gdb = do ls <- many line
skipSpaces
return $ catMaybes ls
where line = do skipSpaces
(comment >> return Nothing) <|> (do e <- parseEntry
Long udb gdb
skipBlanks
optional comment
eol
return $ Just e)
eol = do str <- look
case str of
"" -> return ()
'\n':_ -> return ()
_ -> empty
parseShortTextEntries :: [UserEntry] -> [GroupEntry] -> ReadP [Entry]
parseShortTextEntries udb gdb =
parseEntry Short udb gdb `sepBy1` (skipBlanks >> char ',' >> skipBlanks)
data ACL = MinimumACL { ownerPerms :: Permset
, owningGroupPerms :: Permset
, otherPerms :: Permset
}
| ExtendedACL { ownerPerms :: Permset
, usersPerms :: Map UserID Permset
, owningGroupPerms :: Permset
, groupsPerms :: Map GroupID Permset
, mask :: Permset
, otherPerms :: Permset
}
deriving Eq
validACL :: [Entry] -> Maybe ACL
validACL es =
let (uos,es1) = partition isUserObj es
(us, es2) = partition isUser es1
(gos,es3) = partition isGroupObj es2
(gs, es4) = partition isGroup es3
(ms, es5) = partition isMask es4
(os, [] ) = partition isOther es5
in case (uos,us,gos,gs,ms,os) of
([u],[],[g],[],[] ,[o]) -> Just $ MinimumACL (entryPermset u)
(entryPermset g)
(entryPermset o)
([u],_ ,[g],_ ,[m],[o]) ->
case (toMap tagUserID us, toMap tagGroupID gs) of
(Just mu, Just mg) -> Just $ ExtendedACL (entryPermset u)
mu
(entryPermset g)
mg
(entryPermset m)
(entryPermset o)
_ -> Nothing
_ -> Nothing
where isUserObj (Entry UserObj _) = True
isUserObj _ = False
isUser (Entry (User _) _) = True
isUser _ = False
isGroupObj (Entry GroupObj _) = True
isGroupObj _ = False
isGroup (Entry (Group _) _) = True
isGroup _ = False
isMask (Entry Mask _) = True
isMask _ = False
isOther (Entry Other _) = True
isOther _ = False
toMap f xs =
if nubBy ((==) `on` (f . entryTag)) xs == xs
then Just $ fromList $
map (\e -> (f $ entryTag e, entryPermset e)) xs
else Nothing
instance Show ACL where
showsPrec = showsShortText
longTextForm :: ACL -> String
longTextForm acl = showsLongText 0 acl ""
showsLongText :: Int -> ACL -> ShowS
showsLongText n (MinimumACL ow og ot) = ("user::" ++) . showsPrec n ow .
("\ngroup::" ++) . showsPrec n og .
("\nother::" ++) . showsPrec n ot .
('\n' :)
showsLongText n (ExtendedACL ow us og gr m ot) =
("user::" ++) . showsPrec n ow .
foldlWithKey showsNamedUser id us .
("\ngroup::" ++) . showsPrec n og . showsEffective og .
foldlWithKey showsNamedGroup id gr .
("\nmask::" ++) . showsPrec n m .
("\nother::" ++) . showsPrec n ot .
('\n' :)
where showsNamed iD perm = showsPrec n iD . (':' :) . showsPrec n perm .
showsEffective perm
showsNamedUser sh uid perm = sh . ("\nuser:" ++) . showsNamed uid perm
showsNamedGroup sh gid perm = sh . ("\ngroup:" ++) .
showsNamed gid perm
showsEffective perm = let int = intersectPermsets m perm
in if int == perm
then id
else ("\t#effective:" ++) . showsPrec n int
shortTextFrom :: ACL -> String
shortTextFrom acl = showsShortText 0 acl ""
showsShortText :: Int -> ACL -> ShowS
showsShortText n (MinimumACL ow og ot) = ("u::" ++) . showsPermsetShort n ow .
(",g::" ++) . showsPermsetShort n og .
(",o::" ++) . showsPermsetShort n ot
showsShortText n (ExtendedACL ow us og gr m ot) =
("u::" ++) .
showsPermsetShort n ow .
foldlWithKey showsNamedUser id us .
(",g::" ++) . showsPermsetShort n og .
foldlWithKey showsNamedGroup id gr .
(",m::" ++) . showsPermsetShort n m .
(",o::" ++) . showsPermsetShort n ot
where showsNamed ident perm = showsPrec n ident . (':' :)
. showsPermsetShort n perm
showsNamedUser sh uid perm = sh . (",u:" ++) . showsNamed uid perm
showsNamedGroup sh gid perm = sh . (",g:" ++) . showsNamed gid perm
instance Read ACL where
readPrec =
lift $ parseValidLongTextACL [] [] <|> parseValidShortTextACL [] []
parseValidLongTextACL :: [UserEntry] -> [GroupEntry] -> ReadP ACL
parseValidLongTextACL udb gdb =
parseLongTextEntries udb gdb >>= maybe empty return . validACL
parseValidShortTextACL :: [UserEntry] -> [GroupEntry] -> ReadP ACL
parseValidShortTextACL udb gdb =
skipSpaces >>
parseShortTextEntries udb gdb >>= maybe empty return . validACL
resolveUser :: [UserEntry] -> String -> Maybe UserID
resolveUser db name = userID <$> find ((== name) . userName) db
resolveGroup :: [GroupEntry] -> String -> Maybe GroupID
resolveGroup db name = groupID <$> find ((== name) . groupName) db
parseUser :: [UserEntry] -> ReadP UserID
parseUser db = do name <- munch1 (`notElem` "\t :")
case resolveUser db name of
Just uid -> return uid
Nothing -> fail ("cannot find " ++ name ++
" in user database")
parseGroup :: [GroupEntry] -> ReadP GroupID
parseGroup db = do name <- munch1 (`notElem` "\t :")
case resolveGroup db name of
Just gid -> return gid
Nothing -> fail ("cannot find " ++ name ++
" in group database")
toAclT :: MonadBase IO m => ACL -> AclT m ()
toAclT (MinimumACL ow og ot) =
do newEntry UserObj ow
newEntry GroupObj og
newEntry Other ot
toAclT (ExtendedACL ow us og gr m ot) =
do newEntry UserObj ow
mapM_ (uncurry newEntry . first User) (toList us)
newEntry GroupObj og
mapM_ (uncurry newEntry . first Group) (toList gr)
newEntry Mask m
newEntry Other ot
addPermset :: MonadBase IO m => Permset -> PermsetT m ()
addPermset (Permset r w x) = do when r (addPerm Read)
when w (addPerm Write)
when x (addPerm Execute)
newEntry :: MonadBase IO m => Tag -> Permset -> AclT m ()
newEntry t p = createEntry (setTag t >> changePermset (addPermset p))
genericSet :: AclT IO () -> ACL -> IO ()
genericSet aclt acl =
case acl of
MinimumACL{} -> newACL 3 $ do toAclT acl
aclt
ExtendedACL _ us _ gr _ _ -> newACL (4 + size us + size gr) $
do toAclT acl
aclt
setACL :: FilePath -> ACL -> IO ()
setACL path = genericSet (setFileACL path Access)
setDefaultACL :: FilePath -> ACL -> IO ()
setDefaultACL path = genericSet (setFileACL path Default)
fdSetACL :: Fd -> ACL -> IO ()
fdSetACL fd = genericSet (setFdACL fd)
genericGetACL :: IO String -> IO ACL
genericGetACL f = do udb <- getAllUserEntries
gdb <- getAllGroupEntries
readLong udb gdb <$> f
readLong :: [UserEntry] -> [GroupEntry] -> String -> ACL
readLong udb gdb str =
case [ x | (x, "") <- readP_to_S (parseValidLongTextACL udb gdb) str ] of
[x] -> x
[] -> error "getACL: ambiguous parse of ACL long text form"
_ -> error "getACL: no parse of ACL long text form"
getACL :: FilePath -> IO ACL
getACL path = genericGetACL $ getFileACL path Access toText
getDefaultACL :: FilePath -> IO (Maybe ACL)
getDefaultACL path = do udb <- getAllUserEntries
gdb <- getAllGroupEntries
readLong' udb gdb <$> getFileACL path Default toText
where readLong' _ _ "" = Nothing
readLong' udb gdb str = Just $ readLong udb gdb str
fdGetACL :: Fd -> IO ACL
fdGetACL fd = genericGetACL $ getFdACL fd toText