lio-fs 0.0.0.1 → 0.0.1.0

raw patch · 5 files changed

+113/−112 lines, 5 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• LIO/FS/Simple.hs +26/−47
• LIO/FS/Simple/DCLabel.hs +12/−20
• LIO/FS/TCB.hs +71/−41
• examples/simpleFS.hs +2/−2
• lio-fs.cabal +2/−2

@@ -18,15 +18,16 @@ module.  The filesystem is implemented as a file store in which labels are associated with files and directories using, extended attributes. -/IMPORTANT:/ To use the labeled filesystem you must use-'evalLIOWithRoot' (or other initializers from "LIO.FS.TCB"), otherwise-any actions built using the combinators of this module will crash.+/IMPORTANT:/ To use the labeled filesystem you must use 'withLIOFS'+(or other initializers), otherwise any actions built using the+combinators of this module will crash.  An example use case shown below:  +>  import LIO.FS.Simple >  import LIO.FS.Simple.DCLabel >->  main = evalDCWithRoot "/tmp/lioFS" $ do+>  main = withDCFS "/tmp/lioFS" $ evalDC $ do >    createDirectoryP p lsecrets "secrets" >    writeFileP p ("secrets" </> "alice" ) "I like Bob!" >      where p = ...@@ -47,8 +48,8 @@  -} module LIO.FS.Simple (-  -- * Filesystem support for LIO-    evalLIOWithRoot, tryLIOWithRoot+  -- * Initializing labeled filesystem+    initializeLIOFS, withLIOFS    -- * File operations   , readFile, readFileP   , writeFile, writeFileP@@ -61,6 +62,8 @@   , removeDirectory, removeDirectoryP   -- * Filesystem errors   , FSError(..)+  -- * Misc helpers+  , cleanUpPath   ) where  import Prelude hiding (readFile, writeFile, appendFile)@@ -78,42 +81,11 @@ import safe System.FilePath  import safe LIO-import safe LIO.Run (tryLIO) import safe LIO.Error import LIO.TCB import LIO.FS.TCB ------ LIO related--- ---- | Same as 'evalLIO', but takes two additional parameters--- corresponding to the path of the labeled filesystem store and the--- label of the root. If the labeled filesystem store does not exist,--- it is created at the specified path with the root having the--- supplied label.--- If the filesystem does exist, the supplied label is /ignored/.--- However, if the root label is not provided and the filesystem has--- not been initialized, a 'FSRootNeedLabel' exception will be thrown.-evalLIOWithRoot :: Label l-                => FilePath   -- ^ Filesystem root-                -> Maybe l    -- ^ Label of root-                -> LIO l a    -- ^ LIO action-                -> LIOState l -- ^ Initial state-                -> IO a-evalLIOWithRoot path ml act = evalLIO (initFSTCB path ml >> act)---- | Same as 'evalLIOWithRoot', but using 'tryLIO' to exectute the LIO--- action and thus catch all exceptions.-tryLIOWithRoot :: Label l-               => FilePath   -- ^ Filesystem root-               -> Maybe l    -- ^ Label of root-               -> LIO l a    -- ^ LIO action-               -> LIOState l -- ^ Initial state-               -> IO (Either SomeException a, LIOState l)-tryLIOWithRoot path ml act = tryLIO (initFSTCB path ml >> act)- -- -- LIO directory operations --@@ -423,13 +395,20 @@ stripSlash xx@(x:xs) | x == pathSeparator = stripSlash xs                      | otherwise          = xx --- | Cleanup a file path, if it starts out with a @..@, we consider this--- invalid as it can be used explore parts of the filesystem that should--- otherwise be unaccessible. Similarly, we remove any @.@ from the path.-cleanUpPath :: MonadLIO l m => FilePath -> m FilePath -cleanUpPath = liftLIO . ioTCB . doit . splitDirectories . normalise . stripSlash-  where doit []          = return []-        doit ("..":_)    = throwIO FSIllegalFileName-        doit (_:"..":xs) = doit xs-        doit (".":xs)    = doit xs-        doit (x:xs)      = (x </>) `liftM` doit xs+-- | Class for generating clean filepaths+class CleanUpPath m where+  -- | Cleanup a file path, if it starts out with a @..@, we consider this+  -- invalid as it can be used explore parts of the filesystem that should+  -- otherwise be unaccessible. Similarly, we remove any @.@ from the path.+  cleanUpPath :: FilePath -> m FilePath ++instance CleanUpPath IO where+  cleanUpPath = doit . splitDirectories . normalise . stripSlash+    where doit []          = return []+          doit ("..":_)    = throwIO FSIllegalFileName+          doit (_:"..":xs) = doit xs+          doit (".":xs)    = doit xs+          doit (x:xs)      = (x </>) `liftM` doit xs++instance Label l => CleanUpPath (LIO l) where+  cleanUpPath = ioTCB . cleanUpPath

@@ -1,32 +1,24 @@ {-# LANGUAGE Safe #-} {- | -This module exposes some wrapper functions for executing 'LIO' actions-using 'DCLabel's with simple ("LIO.FS.Simple") filesystem support.+This module exposes a function for initializing a labeled filestore+with the default label 'dcPublic'.  -}  module LIO.FS.Simple.DCLabel (-    evalDCWithRoot -  , tryDCWithRoot +    initializeDCFS+  , withDCFS   ) where -import safe LIO+import safe Control.Monad (void) import safe LIO.DCLabel-import safe LIO.FS.Simple+import safe LIO.FS.Simple (initializeLIOFS, withLIOFS) --- | Like 'evalDC', execute a 'DC' action, but with filesystem--- support. The filesystme root is supplied, while the root label is--- 'dcPublic'. See "LIO.FS.Simple" for a description of the simple--- filesystem API.-evalDCWithRoot :: FilePath -- ^ Filesystem root-               -> DC a     -- ^ LIO action-               -> IO a-evalDCWithRoot root dc = evalLIOWithRoot root (Just dcPublic) dc dcDefaultState+-- | Initialize root filesystem at supplied path with public label.+initializeDCFS :: FilePath -> IO ()+initializeDCFS path = void $ initializeLIOFS path (Just dcPublic) --- | Similar to 'evalDCWithRoot', but catches the end exception. See--- 'tryDC'.-tryDCWithRoot :: FilePath -- ^ Filesystem root-              -> DC a     -- ^ LIO action-              -> IO (Either SomeException a, LIOState DCLabel)-tryDCWithRoot root dc = tryLIOWithRoot root (Just dcPublic) dc dcDefaultState+-- | Top-level IO wrapper for using filesystem.+withDCFS :: FilePath -> IO a -> IO a+withDCFS path = withLIOFS path (Just dcPublic)

@@ -6,7 +6,7 @@  This module exports the basic interface for creating and using the labeled file system, implemented as a file store. Trusted code should-use 'initFSTCB' to set the root of the labeled file system. Moreover,+use 'initializeLIOFS' to set the root of the labeled file system. Moreover, trusted code should implement all the IO functions in terms of 'createFileTCB', 'createDirectoryTCB', and 'getPathLabelTCB' and 'setPathLabelTCB'.@@ -21,7 +21,7 @@ -} module LIO.FS.TCB (   -- * Initializing labeled filesystem-    initFSTCB, mkFSTCB, setFSTCB+    initializeLIOFS, withLIOFS    , getRootDirTCB   -- * Handling path labels   , setPathLabelTCB@@ -35,7 +35,6 @@  import safe Data.Maybe (listToMaybe) import safe Data.Typeable-import safe Data.IORef import safe qualified Data.ByteString.Char8 as S8 import safe qualified Data.ByteString as S import safe qualified Data.ByteString.Lazy.Char8 as L8@@ -43,6 +42,7 @@  import safe Control.Monad import safe Control.Exception+import safe Control.Concurrent.MVar import safe qualified Control.Exception as E                   import safe System.FilePath@@ -96,23 +96,20 @@                        , 0x00, 0x00, 0x00, 0x00, 0x00                        , 0x00, 0xde, 0xad, 0xbe, 0xef] --- | Root of labeled filesystem.-rootDir :: IORef FilePath-{-# NOINLINE rootDir #-}-rootDir = unsafePerformIO $ newIORef (error "LIO Filesystem not initialized.")- -- | Get the root directory. getRootDirTCB :: Label l => LIO l FilePath-getRootDirTCB = withContext "getRootDirTCB" $ ioTCB $ readIORef rootDir+getRootDirTCB = withContext "getRootDirTCB" $ do ioTCB $ getRoot --- | Create a the file store (i.e., labeled file system) with a given+-- | Create a file store (i.e., labeled file system) with a given -- label and root file path.  The path must be an absolute path,--- otherwise @initFSTCB@ throws 'FSRootInvalid'.+-- otherwise @initializeLIOFS@ throws 'FSRootInvalid'.+-- This function simply returns the label of the filesystem for+-- conveniance. mkFSTCB :: Label l         => FilePath      -- ^ Path to the filesystem root         -> l             -- ^ Label of root-        -> LIO l ()-mkFSTCB path l = withContext "mkFSTCB" $ ioTCB $ do+        -> IO l+mkFSTCB path l = do   unless (isAbsolute path) $ throwIO FSRootInvalid   -- Create root of filesystem:   createDirectory path@@ -120,15 +117,15 @@   setPathLabelTCB path l   -- Create magic attribute:   lsetxattr path magicAttr magicContent CreateMode-  -- Set the root filesystem:-  writeIORef rootDir path+  -- Return label:+  return l --- | Set the given file path as the root of the labeled filesystem.  This--- function throws a 'FSLabelCorrupt' if the directory does not contain a--- valid label, and  a 'FSRootCorrupt' if the 'magicAttr' attribute is--- missing.-setFSTCB :: Label l => FilePath -> LIO l l-setFSTCB path = withContext "setFSTCB" $ ioTCB $ do+-- | 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.+checkFSTCB :: Label l => FilePath -> IO l+checkFSTCB path = do   -- Path must be absolute   unless (isAbsolute path) $ throwIO FSRootInvalid   -- Path must be a directory@@ -136,10 +133,7 @@   -- Check magic attribute:   checkMagic   -- Get the label of the root-  l <- getPathLabelTCB path-  -- Set the root directory-  writeIORef rootDir path-  return l+  getPathLabelTCB path    where checkMagic = do            magicOK <-(==magicContent) `liftM`                        (throwOnFail $ lgetxattr path magicAttr)@@ -150,25 +144,55 @@          doFail = throwIO FSRootCorrupt          throwOnFail act = act `E.catch` (\(_:: SomeException) -> doFail) --- | Initialize filesystem at the given path. The supplied path must be--- absolute, otherwise @initFSTCB@ throw 'FSRootInvalid'.  If the FS has--- already been created then @initFSTCB@ solely verifies that the root--- directory is not corrupt (see 'setFSTCB') and returns the label of--- the root. Otherwise, a new FS is created with the supplied label--- (see 'mkFSTCB').+-- | TVar containing per process filestore root.+rootDir :: MVar (Maybe FilePath)+{-# NOINLINE rootDir #-}+rootDir = unsafePerformIO $ newMVar Nothing++-- | Get the filestore root.+getRoot :: IO FilePath+getRoot = do+  mfp <- readMVar rootDir+  maybe (throwIO FSRootNoExist) return mfp+ +-- | Set the filestore root, throw 'FSRootExists' if already set.+setRoot :: FilePath -> IO ()+setRoot fp = do+  act <- modifyMVarMasked rootDir $ \mfp ->+    case mfp of+      Just _  -> return $ (mfp, throwIO FSRootExists)+      Nothing -> return $ (Just fp, return ())+  act++-- | Initialize filesystem at the given path. The supplied path must+-- be absolute, otherwise @initializeLIOFS@ throw 'FSRootInvalid'.  If+-- the FS has already been created then @initializeLIOFS@ solely+-- verifies that the root directory is not corrupt (see 'checkFSTCB')+-- and returns the label of the root. Otherwise, a new FS is created+-- with the supplied label (see 'mkFSTCB'). ----- This function performs several checks that 'setFSTCB' and 'mkFSTCB' perform,--- so when considering performance they should be called directly.-initFSTCB :: Label l => FilePath -> Maybe l -> LIO l l-initFSTCB path ml = withContext "initFSTCB" $ do- unless (isAbsolute path) $ ioTCB $ throwIO FSRootInvalid- exists <- ioTCB $ doesDirectoryExist path- (if exists then setFSTCB else mkFSTCB') path-  where mkFSTCB' f = maybe (throwLIO FSRootNeedLabel) -                           (\l -> mkFSTCB f l >> return l) ml-                    +-- NOTE: This function should only be called once per process.+initializeLIOFS :: Label l => FilePath -> Maybe l -> IO l+initializeLIOFS path ml = do+ unless (isAbsolute path) $ throwIO FSRootInvalid+ exists <- doesDirectoryExist path+ l <- (if exists then checkFSTCB else mkFSTCB') path+ setRoot path+ -- If setRoot fails, we leave the filesystem dirty+ return l+  where mkFSTCB' f = maybe (throwIO FSRootNeedLabel) (mkFSTCB f) ml +-- | Top-level wrapper thatexecutes 'initializeLIOFS' followed by the+-- supplied action. --+-- NOTE: This function should only be called once per process.+withLIOFS :: Label l => FilePath -> Maybe l -> IO a -> IO a+withLIOFS path ml act = do+  void $ initializeLIOFS path ml+  act+  ++-- -- Objects --  @@ -190,6 +214,9 @@  -- | Set the label of a given path. This function sets the 'labelAttr' -- attribute to the encoded label, and the hash to 'labelHashAttr'.+--+-- NOTE: This function takes an arbitrary path, hence must not be+-- available to untrusted code. setPathLabelTCB :: Label l => FilePath -> l -> IO () setPathLabelTCB path l = do   lsetxattr path labelAttr     lEnc        RegularMode@@ -200,6 +227,9 @@ -- | Get the label of a given path. If the object does not have an -- associated label or the hash of the label and stored-hash are not -- equal, this function throws 'FSLabelCorrupt'.+--+-- NOTE: This function takes an arbitrary path, hence must not be+-- available to untrusted code. getPathLabelTCB :: Label l => FilePath -> IO l getPathLabelTCB path = do   (b, h) <- throwOnFail $ do b <- lgetxattr path labelAttr

@@ -3,8 +3,8 @@ import safe Control.Monad import safe Prelude hiding (writeFile, readFile) import safe LIO-import safe LIO.FS.Simple import safe LIO.DCLabel+import safe LIO.FS.Simple import safe LIO.FS.Simple.DCLabel import safe qualified Data.ByteString.Char8 as S8 import LIO.TCB@@ -14,7 +14,7 @@ alice = PrivTCB  $ toCNF "alice" bob   = PrivTCB  $ toCNF "bob" -main = tryDCWithRoot "/tmp/fslio/root" $ do+main = withDCFS "/tmp/fslio/root" $ tryDC $ do   putStrLnTCB "ALICE:"   aliceCode   putStrLnTCB "\nBOB:"

@@ -1,5 +1,5 @@ Name:           lio-fs-Version:        0.0.0.1+Version:        0.0.1.0 Cabal-Version:  >= 1.8 Build-type:     Simple License:        GPL@@ -48,6 +48,6 @@   GHC-options: -Wall -fno-warn-orphans    Exposed-modules:-    LIO.FS.Simple.DCLabel     LIO.FS.Simple+    LIO.FS.Simple.DCLabel     LIO.FS.TCB