lio-fs 0.0.1.0 → 0.0.1.2

raw patch · 3 files changed

+41/−13 lines, 3 filesdep +unixPVP: minor bump suggested

API additions: PVP suggests at least a minor version bump

Dependencies added: unix

API changes (from Hackage documentation)

Files

• LIO/FS/Simple.hs +23/−1
• LIO/FS/TCB.hs +16/−11
• lio-fs.cabal +2/−1

@@ -63,7 +63,7 @@   -- * Filesystem errors   , FSError(..)   -- * Misc helpers-  , cleanUpPath+  , cleanUpPath, taintObjPathP, labelDirectoryRecursively    ) where  import Prelude hiding (readFile, writeFile, appendFile)@@ -79,6 +79,7 @@ import safe qualified System.IO.Error as IO import safe qualified System.Directory as IO import safe System.FilePath+import safe System.Posix.Files  import safe LIO import safe LIO.Error@@ -412,3 +413,24 @@  instance Label l => CleanUpPath (LIO l) where   cleanUpPath = ioTCB . cleanUpPath+++-- | Label the directory and every file within recursively with the+-- supplied label. Note this funciton expects a full path.+labelDirectoryRecursively :: Label l => l -> FilePath -> IO ()+labelDirectoryRecursively l dir = do+  exists <- IO.doesDirectoryExist dir+  unless exists $ throwIO $ IO.mkIOError IO.doesNotExistErrorType+                                        ctx Nothing (Just dir)+  setPathLabelTCB dir l+  fs <- filter (\f -> f `notElem` [".", ".."]) `liftM` IO.getDirectoryContents dir+  forM_ fs $ \f -> do+    let file = dir </> f+    stat <- getFileStatus file+    case () of+      _ | isRegularFile stat -> setPathLabelTCB file l+      _ | isDirectory stat   -> labelDirectoryRecursively l file+      _ -> throwIO $ IO.mkIOError IO.illegalOperationErrorType ctx+                                  Nothing (Just file)++  where ctx = "labelDirectoryRecursively"

@@ -68,7 +68,7 @@              | FSObjNeedLabel          -- ^ FSobjectcannot be created without a label.              | FSLabelCorrupt FilePath -- ^ Object label is corrupt.              | FSIllegalFileName       -- ^ Supplied file name is illegal.-      deriving Typeable+      deriving (Eq, Typeable)  instance Exception FSError @@ -112,7 +112,7 @@ mkFSTCB path l = do   unless (isAbsolute path) $ throwIO FSRootInvalid   -- Create root of filesystem:-  createDirectory path+  createDirectoryIfMissing False path   -- Set root label:   setPathLabelTCB path l   -- Create magic attribute:@@ -121,9 +121,12 @@   return l  -- | Check that the supplied pathis a vaild labeled filesystem root.--- This function throws a 'FSLabelCorrupt' if the directory does not--- contain a valid label, and  a 'FSRootCorrupt' if the 'magicAttr'--- attribute is missing.+-- This function throws:+--+--   * 'FSLabelCorrupt' if the directory does not contain a valid label+--   * 'FSRootCorrupt' if the 'magicAttr' attribute is invalid+--   * 'FSRootNoExist' if the directory does not exist or 'magicAttr' is missing+-- checkFSTCB :: Label l => FilePath -> IO l checkFSTCB path = do   -- Path must be absolute@@ -135,14 +138,12 @@   -- Get the label of the root   getPathLabelTCB path    where checkMagic = do-           magicOK <-(==magicContent) `liftM` -                      (throwOnFail $ lgetxattr path magicAttr)-           unless magicOK doFail+           magic <- lgetxattr path magicAttr `E.catch`+                      (\(_:: SomeException) -> throwIO FSRootNoExist)+           unless (magic == magicContent) $ throwIO FSRootCorrupt          checkDirExists = do           e <- doesDirectoryExist path           unless e $ throwIO FSRootNoExist-         doFail = throwIO FSRootCorrupt-         throwOnFail act = act `E.catch` (\(_:: SomeException) -> doFail)  -- | TVar containing per process filestore root. rootDir :: MVar (Maybe FilePath)@@ -176,7 +177,11 @@ initializeLIOFS path ml = do  unless (isAbsolute path) $ throwIO FSRootInvalid  exists <- doesDirectoryExist path- l <- (if exists then checkFSTCB else mkFSTCB') path+ l <- if exists+        then checkFSTCB path `E.catch` (\e -> if e == FSRootNoExist+                                               then mkFSTCB' path+                                               else throwIO e)+        else mkFSTCB' path  setRoot path  -- If setRoot fails, we leave the filesystem dirty  return l

@@ -1,5 +1,5 @@ Name:           lio-fs-Version:        0.0.1.0+Version:        0.0.1.2 Cabal-Version:  >= 1.8 Build-type:     Simple License:        GPL@@ -41,6 +41,7 @@    , bytestring    , filepath    , directory+   , unix    , lio    , xattr    , SHA