lio-fs (empty) → 0.0.0.1
raw patch · 7 files changed
+857/−0 lines, 7 filesdep +SHAdep +basedep +bytestringsetup-changed
Dependencies added: SHA, base, bytestring, containers, directory, filepath, lio, xattr
Files
- LICENSE +17/−0
- LIO/FS/Simple.hs +435/−0
- LIO/FS/Simple/DCLabel.hs +32/−0
- LIO/FS/TCB.hs +235/−0
- Setup.hs +2/−0
- examples/simpleFS.hs +83/−0
- lio-fs.cabal +53/−0
+ LICENSE view
@@ -0,0 +1,17 @@+This program is free software; you can redistribute it and/or+modify it under the terms of the GNU General Public License as+published by the Free Software Foundation; either version 2, or (at+your option) any later version.++This program is distributed in the hope that it will be useful, but+WITHOUT ANY WARRANTY; without even the implied warranty of+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU+General Public License for more details.++You can obtain copies of permitted licenses from these URLs:++ http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt+ http://www.gnu.org/licenses/gpl-3.0.txt++or by writing to the Free Software Foundation, Inc., 59 Temple Place,+Suite 330, Boston, MA 02111-1307 USA
+ LIO/FS/Simple.hs view
@@ -0,0 +1,435 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ConstraintKinds,+ FlexibleInstances,+ FlexibleContexts,+ TypeSynonymInstances,+ MultiParamTypeClasses #-}+{- | ++This module provides a very simple API for interacting with a labeled+filesystem. Each file and directory hsa an associated label that is+used to track and control the information flowing to/from the+file/directory. The API exposed by this module is analogous to a+subset of the "System.IO" API. We currently do not allow operations on+file handles. Rather, files must be read read and written to in whole+(as strict ByteStrings).++The actual storage of labeled files is handled by the "LIO.FS.TCB"+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.++An example use case shown below: ++> import LIO.FS.Simple.DCLabel+>+> main = evalDCWithRoot "/tmp/lioFS" $ do+> createDirectoryP p lsecrets "secrets"+> writeFileP p ("secrets" </> "alice" ) "I like Bob!"+> where p = ...+> lsecrets = ....+>++The file store for the labeled filesystem (see "LIO.FS.TCB") will+be created in @\/tmp\/lioFS@, but this is transparent and the user+can think of the filesystem as having root @/@. Note that for this to+work the filesystem must be mounted with the @user_xattr@ option.+For example, on GNU/Linux, you can remount your drive:++> mount -o remount -o user_xattr devicename++In the current version of the filesystem, there is no notion of+changeable current working directory in the 'LIO' Monad, nor symbolic+links.++-}+module LIO.FS.Simple (+ -- * Filesystem support for LIO+ evalLIOWithRoot, tryLIOWithRoot+ -- * File operations+ , readFile, readFileP+ , writeFile, writeFileP+ , appendFile, appendFileP+ , removeFile, removeFileP+ , labelOfFile, labelOfFileP+ -- * Directory operations+ , getDirectoryContents, getDirectoryContentsP+ , createDirectory, createDirectoryP+ , removeDirectory, removeDirectoryP+ -- * Filesystem errors+ , FSError(..)+ ) where++import Prelude hiding (readFile, writeFile, appendFile)++import safe qualified Data.ByteString.Char8 as S8++import safe Control.Monad+import safe Control.Exception (throwIO)+++import safe System.IO (IOMode(..))+import safe qualified System.IO as IO+import safe qualified System.IO.Error as IO+import safe qualified System.Directory as IO+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+--++-- | Get the contents of a directory. The current label is raised to the+-- join of the current label and that of all the directories traversed to+-- the leaf directory. Note that, unlike the standard Haskell+-- 'getDirectoryContents', we first normalise the path by collapsing all+-- the @..@'s. The function uses 'unlabelFilePath' when raising the+-- current label and thus may throw an exception if the clearance is+-- too low.+-- /Note:/ The current LIO filesystem does not support links.+getDirectoryContents :: MonadLIO l m => FilePath -> m [FilePath]+getDirectoryContents = getDirectoryContentsP noPrivs++-- | Same as 'getDirectoryContents', but uses privileges when raising+-- the current label.+getDirectoryContentsP :: (MonadLIO l m, PrivDesc l p)+ => Priv p -- ^ Privilege+ -> FilePath -- ^ Directory+ -> m [FilePath]+getDirectoryContentsP p dir = liftLIO $ withContext "getDirectoryContentsP" $ do+ path <- taintObjPathP p dir+ ioTCB $ IO.getDirectoryContents path++-- | Create a directory at the supplied path with the given label. The+-- given label must be bounded by the the current label and clearance, as+-- checked by 'guardAlloc'. The current label (after traversing the+-- filesystem to the directory path) must flow to the supplied label,+-- which must, in turn, flow to the current label as required by+-- 'guardWrite'.+createDirectory :: MonadLIO l m => l -> FilePath -> m ()+createDirectory = createDirectoryP noPrivs++-- | Same as 'createDirectory', but uses privileges when raising the+-- current label and checking IFC restrictions.+createDirectoryP :: (MonadLIO l m, PrivDesc l p)+ => Priv p -- ^ Privilege+ -> l -- ^ Label of new directory+ -> FilePath -- ^ Path of directory+ -> m ()+createDirectoryP p l file' = liftLIO $ withContext "createDirectoryP" $ do+ file <- cleanUpPath file'+ let containingDir = takeDirectory file+ fileName = takeFileName file+ -- Check that the label is bounded by the current label and clearance:+ guardAllocP p l+ -- Taint up to containing dir:+ path <- taintObjPathP p containingDir+ -- Get label of containing dir:+ ldir <- ioTCB $ getPathLabelTCB path+ -- Can write to containing dir:+ guardWriteP p ldir+ -- Can still create dir:+ guardAllocP p l+ -- Create actual directory:+ createDirectoryTCB l $ path </> fileName+++-- | Same as 'readFile' but uses privilege in opening the file.+readFileP :: (MonadLIO l m, PrivDesc l p)+ => Priv p -- ^ Privileges+ -> FilePath -- ^ File to open+ -> m S8.ByteString+readFileP p file' = liftLIO $ withContext "readFileP" $ do+ file <- cleanUpPath file'+ let containingDir = takeDirectory file+ fileName = takeFileName file+ -- Taint up to containing dir:+ path <- taintObjPathP p containingDir+ -- Create actual file path:+ let objPath = path </> fileName+ -- Check if file exists:+ exists <- ioTCB $ IO.doesFileExist objPath+ when (exists) $ do+ -- Get label of file:+ l <- ioTCB $ getPathLabelTCB objPath+ -- Make sure we can read from the file+ taintP p l+ ioTCB $ S8.readFile objPath++-- | Reads a file and returns the contents of the file as a strict+-- ByteString. The current label is raised to reflect all the+-- traversed directories. If the file exists it is further raised to+-- the label of the file to reflect the read.+readFile :: MonadLIO l m => FilePath -> m S8.ByteString+readFile = readFileP noPrivs++-- | Same as 'writeFile' but uses privilege when writing to the file.+writeFileP :: (PrivDesc l p, MonadLIO l m)+ => Priv p -> Maybe l -> FilePath -> S8.ByteString -> m ()+writeFileP p ml file' contents = liftLIO $ withContext "writeFileP" $ do+ file <- cleanUpPath file'+ let containingDir = takeDirectory file+ fileName = takeFileName file+ -- Check that the supplied label is bounded by current label and clearance:+ maybe (return ()) (guardAllocP p) ml+ -- Taint up to containing dir:+ path <- taintObjPathP p containingDir+ -- Create actual file path:+ let objPath = path </> fileName+ -- Check if file exists:+ exists <- ioTCB $ IO.doesFileExist objPath+ if exists+ then do+ -- Get label of file:+ l <- ioTCB $ getPathLabelTCB objPath+ -- Make sure that the provided label (if any) can flow to this+ -- label: the user of this function may assume that the+ -- supplied label is used to protect the contents, so we should+ -- ensure that they get /at least/ that degree of protection+ case ml of+ Just lopt | not (canFlowTo lopt l) ->+ labelError "Supplied label does not flow to label of file" [lopt, l]+ _ -> return ()+ -- Make sure we can write to the file:+ guardWriteP p l+ ioTCB $ S8.writeFile objPath contents+ else case ml of+ Nothing -> throwLIO FSObjNeedLabel+ Just l -> do+ -- Get label of containing dir:+ ldir <- ioTCB $ getPathLabelTCB path+ -- Make sure we can write to containing dir:+ guardWriteP p ldir+ -- Make sure that we can still create file+ guardAllocP p l+ -- Write to the file+ bracket (createBinaryFileTCB l objPath WriteMode)+ (ioTCB . IO.hClose) + (\h -> ioTCB $ S8.hPut h contents)+++-- | Given an optional label, file path and string, write the string+-- to the file at specified path. The optional label (which must be+-- bounded by the current label and clearance, as enforced by+-- 'guardAlloc') is used to set the label on the file, if the file+-- does not already exist; otherwise the label must flow to the label+-- of the file. (Supplying a 'Nothing' is the same as 'Just' supplying+-- the current label.) This function ensures that current label is+-- raised to reflect all the traversed directories. Note that if the+-- file does not already exist, it is further required that the+-- current computation be able to write to the containing directory,+-- as imposed by 'guardWrite'.+writeFile :: MonadLIO l m => Maybe l -> FilePath -> S8.ByteString -> m ()+writeFile = writeFileP noPrivs++-- | Same as 'appendFile' but uses privilege when writing to the file.+appendFileP :: (PrivDesc l p, MonadLIO l m)+ => Priv p -> FilePath -> S8.ByteString -> m ()+appendFileP p file' contents = liftLIO $ withContext "appendFileP" $ do+ file <- cleanUpPath file'+ let containingDir = takeDirectory file+ fileName = takeFileName file+ -- Taint up to containing dir:+ path <- taintObjPathP p containingDir+ -- Create actual file path:+ let objPath = path </> fileName+ -- Check if file exists:+ exists <- ioTCB $ IO.doesFileExist objPath+ if exists+ then do+ -- Get label of file:+ l <- ioTCB $ getPathLabelTCB objPath+ -- Make sure we can write-only to the file:+ guardAllocP p l+ ioTCB $ S8.appendFile objPath contents+ else throwLIO $ IO.mkIOError IO.doesNotExistErrorType+ "appendFileP" Nothing (Just objPath)++-- | Given a file path and string, append the string to the file at+-- specified path. This function ensures that current label is raised+-- to reflect all the traversed directories. Moreover, it requires+-- that the file this is appending to exists and its label is bounded+-- by the current label and clearance (as enforced by 'guardAlloc').+appendFile :: MonadLIO l m => FilePath -> S8.ByteString -> m ()+appendFile = appendFileP noPrivs++-- | Get the label of a file/director at the supplied file path. The+-- current label is raised to reflect all the traversed directories.+labelOfFile :: MonadLIO l m => FilePath -> m l+labelOfFile = labelOfFileP noPrivs++-- | Same as 'labelOfFile' but uses privilege in traversing+-- directories.+labelOfFileP :: (MonadLIO l m, PrivDesc l p)+ => Priv p -- ^ Privileges+ -> FilePath -- ^ File to get the label of+ -> m l+labelOfFileP p file' = liftLIO $ withContext "labelOfFileP" $ do+ file <- cleanUpPath file'+ let containingDir = takeDirectory file+ fileName = takeFileName file+ -- Taint up to containing dir:+ path <- taintObjPathP p containingDir+ -- Create actual file path:+ let objPath = path </> fileName+ -- Check if file exists:+ exists <- ioTCB $ IO.doesFileExist objPath+ -- Get the label of the file+ if exists + then ioTCB $ getPathLabelTCB objPath+ else throwLIO $ IO.mkIOError + IO.doesNotExistErrorType+ "labelOfFileP" Nothing (Just objPath)++-- | Remove the file at the specified path. The current computation+-- must be able to both write to the file and containing directory.+-- Moreover, the current label is raised to reflect the traversal of+-- directories up to the file.+removeFile :: MonadLIO l m => FilePath -> m ()+removeFile f = liftLIO $ withContext "removeFile" $ + removeFileOrDirP "removeFile" False noPrivs f++-- | Same as 'removeFile', but uses privileges to carry out the+-- actions.+removeFileP :: (MonadLIO l m, PrivDesc l p) => Priv p -> FilePath -> m ()+removeFileP p f = liftLIO $ withContext "removeFileP" $ + removeFileOrDirP "removeFileP" False p f++-- | Same as 'removeFile', but removes a directory.+removeDirectory :: MonadLIO l m => FilePath -> m ()+removeDirectory f = liftLIO $ withContext "removeDirectory" $ + removeFileOrDirP "removeDirectory" True noPrivs f++-- | Same as 'removeDirectory', but uses privileges to carry out the+-- actions.+removeDirectoryP :: (MonadLIO l m, PrivDesc l p) + => Priv p -> FilePath -> m ()+removeDirectoryP p f = liftLIO $ withContext "removeDirectoryP" $ + removeFileOrDirP "removeDirectoryP" True p f+++-- | Remove a file or directory. See 'removeFile' for a high level+-- description of the underlying actions.+removeFileOrDirP :: PrivDesc l p+ => String -> Bool -> Priv p -> FilePath -> LIO l ()+removeFileOrDirP ctx isDir p file' = do+ file <- cleanUpPath file'+ let containingDir = takeDirectory file+ fileName = takeFileName file+ -- Taint up to containing dir:+ path <- taintObjPathP p containingDir+ -- Get label of containing dir:+ ldir <- ioTCB $ getPathLabelTCB path+ -- Can write to containing dir:+ guardWriteP p ldir+ -- Create actual file path:+ let objPath = path </> fileName+ -- Check if file exists:+ ok <- ioTCB $ exists objPath+ if ok+ then do -- Get label of file:+ l <- ioTCB $ getPathLabelTCB objPath+ -- Make sure we can write to the file:+ guardWriteP p l+ ioTCB $ remove objPath+ else throwLIO $ IO.mkIOError IO.doesNotExistErrorType+ ctx Nothing (Just objPath)+ where (exists, remove) = if isDir+ then (IO.doesDirectoryExist, IO.removeDirectory)+ else (IO.doesFileExist, IO.removeFile)++--+-- Internal helpers+--++-- | Given a pathname to a labeled filesystem object, traverse all the+-- directories up to the object, while correspondingly raising the+-- current label. Note that if the object or a parent-directory does not+-- exist, an exception will be thrown; the label of the exception will be+-- the join of all the directory labels up to the lookup failure.+--+-- /Note:/ this function cleans up the path before doing the+-- lookup, so e.g., path @/foo/bar/..@ will first be rewritten to @/foo@+-- and thus no traversal to @bar@. Note that this is a more permissive+-- behavior than forcing the read of @..@ from @bar@.+-- @taintObjPath@ returns this cleaned up path.+taintObjPathP :: (MonadLIO l m, PrivDesc l p)+ => Priv p -- ^ Privilege + -> FilePath -- ^ Path to object+ -> m FilePath+taintObjPathP p path0 = liftLIO $ do+ -- Clean up supplied path:+ path <- cleanUpPath path0+ -- Get root directory:+ root <- getRootDirTCB+ let dirs = splitDirectories . stripSlash $ path+ -- "Traverse" all directories up to object:+ forM_ ("" : allSubDirs dirs) $ \dir -> do+ l <- ioTCB $ getPathLabelTCB (root </> dir)+ taintP p l+ return $ root </> joinPath dirs++-- | Take a list of directories (e.g., @[\"a\",\"b\",\"c\"]@) and return+-- all the subtrees up to the node (@[\"a\",\"a/b\",\"a/b/c\"]@).+allSubDirs :: [FilePath] -> [FilePath]+allSubDirs dirs = reverse $ allSubDirs' dirs "" []+ where allSubDirs' [] _ acc = acc+ allSubDirs' (dir:[]) pfix acc = (pfix </> dir) : acc+ allSubDirs' (dir:ds) pfix acc = let ndir = pfix </> dir+ in allSubDirs' ds ndir (ndir : acc)++-- | Remove any 'pathSeparator's from the front of a file path.+stripSlash :: FilePath -> FilePath +stripSlash [] = []+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
+ LIO/FS/Simple/DCLabel.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE Safe #-}+{- |++This module exposes some wrapper functions for executing 'LIO' actions+using 'DCLabel's with simple ("LIO.FS.Simple") filesystem support.++-}++module LIO.FS.Simple.DCLabel (+ evalDCWithRoot + , tryDCWithRoot + ) where++import safe LIO+import safe LIO.DCLabel+import safe LIO.FS.Simple++-- | 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++-- | 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
+ LIO/FS/TCB.hs view
@@ -0,0 +1,235 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}+{- |++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,+trusted code should implement all the IO functions in terms of+'createFileTCB', 'createDirectoryTCB', and 'getPathLabelTCB' and+'setPathLabelTCB'.++The current implementation uses the 'Show' and 'Read' instance to+serialize and de-serialize labels, respectively. While this is+inefficient, it make it easy to use tools like /getfattr/ to inspect+the labels of files. In a future version we may modify this+implementation to use binary encoding and/or compression (since+filesystem extended attributes are large, but limited).++-}+module LIO.FS.TCB (+ -- * Initializing labeled filesystem+ initFSTCB, mkFSTCB, setFSTCB+ , getRootDirTCB+ -- * Handling path labels+ , setPathLabelTCB+ , getPathLabelTCB+ -- * Helpers for creating labeled objects+ , createFileTCB, createBinaryFileTCB+ , createDirectoryTCB+ -- * Filesystem errors+ , FSError(..)+ ) where++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+import safe qualified Data.Digest.Pure.SHA as SHA++import safe Control.Monad+import safe Control.Exception+import safe qualified Control.Exception as E+ +import safe System.FilePath+import safe System.Directory+import safe System.IO+import System.IO.Unsafe+import safe System.Xattr++import safe LIO+import safe LIO.Error+import LIO.TCB+ +--+-- Exception thrown by the file store interface+--++-- | Filesystem errors+data FSError = FSRootCorrupt -- ^ Root structure is corrupt.+ | FSRootInvalid -- ^ Root is invalid (must be absolute).+ | FSRootExists -- ^ Root already exists.+ | FSRootNoExist -- ^ Root does not exists.+ | FSRootNeedLabel -- ^ Cannot create root, missing label.+ | FSObjNeedLabel -- ^ FSobjectcannot be created without a label.+ | FSLabelCorrupt FilePath -- ^ Object label is corrupt.+ | FSIllegalFileName -- ^ Supplied file name is illegal.+ deriving Typeable++instance Exception FSError++instance Show FSError where+ show FSRootCorrupt = "Root structure is corrupt."+ show FSRootInvalid = "Root path is invalid, must be absolute."+ show FSRootExists = "Root already exists."+ show FSRootNoExist = "Root directory does not exist."+ show FSRootNeedLabel = "Root cannot be created without a label."+ show (FSLabelCorrupt f) = "Label of " ++ show f ++ " is corrupt/non-existant."+ show FSObjNeedLabel = "FS object cannot be created without a label."+ show FSIllegalFileName = "Supplied file name is illegal."++--+-- Handling root of FS+--++magicAttr :: AttrName+magicAttr = "user._lio_magic"++-- | Content written to magic key. +magicContent :: AttrValue+magicContent = S.pack [ 0x7f, 0x45, 0x4c, 0x46, 0x01+ , 0x01, 0x01, 0x00, 0x00, 0x00+ , 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++-- | Create a the 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'.+mkFSTCB :: Label l+ => FilePath -- ^ Path to the filesystem root+ -> l -- ^ Label of root+ -> LIO l ()+mkFSTCB path l = withContext "mkFSTCB" $ ioTCB $ do+ unless (isAbsolute path) $ throwIO FSRootInvalid+ -- Create root of filesystem:+ createDirectory path+ -- Set root label:+ setPathLabelTCB path l+ -- Create magic attribute:+ lsetxattr path magicAttr magicContent CreateMode+ -- Set the root filesystem:+ writeIORef rootDir path++-- | 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+ -- Path must be absolute+ unless (isAbsolute path) $ throwIO FSRootInvalid+ -- Path must be a directory+ checkDirExists+ -- Check magic attribute:+ checkMagic+ -- Get the label of the root+ l <- getPathLabelTCB path+ -- Set the root directory+ writeIORef rootDir path+ return l+ where checkMagic = do+ magicOK <-(==magicContent) `liftM` + (throwOnFail $ lgetxattr path magicAttr)+ unless magicOK doFail+ checkDirExists = do+ e <- doesDirectoryExist path+ unless e $ throwIO FSRootNoExist+ 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').+--+-- 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+ ++--+-- Objects+-- ++-- | Label attribute name.+labelAttr :: AttrName+labelAttr = "user._lio_label"++-- | Hash-of-label attribute name.+labelHashAttr :: AttrName+labelHashAttr = "user._lio_label_sha"++-- | Encode a label into an attribute value.+encodeLabel :: Label l => l -> AttrValue+encodeLabel = S8.pack . show++-- | Descode label from an attribute value.+decodeLabel :: Label l => AttrValue -> Maybe l+decodeLabel = fmap fst . listToMaybe . reads . S8.unpack++-- | Set the label of a given path. This function sets the 'labelAttr'+-- attribute to the encoded label, and the hash to 'labelHashAttr'.+setPathLabelTCB :: Label l => FilePath -> l -> IO ()+setPathLabelTCB path l = do+ lsetxattr path labelAttr lEnc RegularMode+ lsetxattr path labelHashAttr (hash lEnc) RegularMode+ where lEnc = encodeLabel l+ hash = L8.toStrict . SHA.bytestringDigest . SHA.sha1 . L8.fromStrict++-- | 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'.+getPathLabelTCB :: Label l => FilePath -> IO l+getPathLabelTCB path = do+ (b, h) <- throwOnFail $ do b <- lgetxattr path labelAttr+ h <- lgetxattr path labelHashAttr+ return (b, h)+ let b' = L8.fromStrict b+ h' = L8.toStrict . SHA.bytestringDigest . SHA.sha1 $ b'+ case decodeLabel b of+ Just l | h == h' -> return l+ _ -> doFail+ where doFail = throwIO $ FSLabelCorrupt path+ throwOnFail act = act `E.catch` (\(_:: SomeException) -> doFail)++-- | Create a file object with the given label and return a handle to+-- the new file.+createFileTCB :: Label l => l -> FilePath -> IOMode -> LIO l Handle+createFileTCB l path mode = withContext "createFileTCB" $ ioTCB $ do+ h <- openFile path mode+ setPathLabelTCB path l+ return h++-- | Same as 'createFileTCB' but opens the file in binary mode.+createBinaryFileTCB :: Label l => l -> FilePath -> IOMode -> LIO l Handle+createBinaryFileTCB l path mode = withContext "createBinaryFileTCB" $ioTCB $ do+ h <- openBinaryFile path mode+ setPathLabelTCB path l+ return h++-- | Create a directory object with the given label.+createDirectoryTCB :: Label l => l -> FilePath -> LIO l ()+createDirectoryTCB l path = withContext "createDirectoryTCB" $ ioTCB $ do+ createDirectory path+ setPathLabelTCB path l
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/simpleFS.hs view
@@ -0,0 +1,83 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ScopedTypeVariables #-}+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.DCLabel+import safe qualified Data.ByteString.Char8 as S8+import LIO.TCB++++alice = PrivTCB $ toCNF "alice"+bob = PrivTCB $ toCNF "bob"++main = tryDCWithRoot "/tmp/fslio/root" $ do+ putStrLnTCB "ALICE:"+ aliceCode+ putStrLnTCB "\nBOB:"+ bobCode+ putStrLnTCB "\nALICE:"+ aliceCode2++aliceCode = withClearance (alice %% cTrue) $ do+ -- directory for alice and bob+ createDirectoryP alice (alice \/ bob %% alice) "/ab"+ `catch` (\(e::SomeException) -> putStrLnTCB $ " ignorin error: "++ show e)++ -- alice's secret:+ writeFileP alice (Just $ alice %% alice) "/ab/alice" $ secretContent++ -- alice's message to bob:+ writeFileP alice (Just $ alice \/ bob %% alice \/ bob) "/ab/bob" $ abContent++ -- Check to make sure that we wrote the right things:+ lsecret <- labelOfFileP alice "/ab/alice"+ putStrLnTCB $ " secret label is ok? " ++ show (lsecret == alice %% alice)++ secretContent' <- readFileP alice "/ab/alice"+ putStrLnTCB $ " secret content is ok? " ++ show (secretContent' == secretContent)++ abContent' <- readFileP alice "/ab/bob"+ putStrLnTCB $ " bob content is ok? " ++ show (abContent' == abContent)++ where secretContent = S8.pack "w00t w00t"+ abContent = S8.pack "411(3 was here"++bobCode = withClearance (bob %% cTrue) $ do+ -- Try to read and write to everything in the /ab directory+ files <- getDirectoryContentsP bob "/ab"+ let files' = filter (\x -> x `notElem` [".", ".."]) files+ forM_ files' $ \file -> do+ lfile <- labelOfFileP bob $ "/ab/"++file+ cfile <- (S8.unpack `liftM` readFileP bob ("/ab/"++file))+ `catch` (\(e::SomeException) -> return $ "Failed to read: "++ show e)+ (appendFileP bob ("/ab/"++file) baContent)+ `catch` (\(e::SomeException) -> putStrLnTCB $ "Failed to write: "++ show e)+ putStrLnTCB $ " label: " ++ show lfile+ putStrLnTCB $ " text: " ++ cfile++ where baContent = S8.pack "\nb0b was here"+++aliceCode2 = withClearance (alice %% cTrue) $ do+ -- Read message from bob and remove all files and containing directory++ abContent <- readFileP alice "/ab/bob"+ putStrLnTCB $ " from bob: " ++ show abContent++ files <- getDirectoryContentsP alice "/ab"+ let files' = filter (\x -> x `notElem` [".", ".."]) files+ forM_ files' $ \file -> do+ putStrLnTCB $ " removing " ++ file+ removeFileP alice $ "/ab/" ++ file+ removeDirectoryP alice "/ab"+ putStrLnTCB $ "Remaining files: "+ files <- getDirectoryContentsP alice "/"+ forM_ files' $ \file ->+ putStrLnTCB $ " " ++ file++putStrLnTCB :: String -> DC ()+putStrLnTCB = ioTCB . putStrLn
+ lio-fs.cabal view
@@ -0,0 +1,53 @@+Name: lio-fs+Version: 0.0.0.1+Cabal-Version: >= 1.8+Build-type: Simple+License: GPL+License-File: LICENSE+Author: Hails team+Maintainer: Hails team <hails at scs dot stanford dot edu>+Synopsis: Labeled File System interface for LIO+Category: Security+Stability: Experimental+Description:+ A very simple file system interface for LIO. Labels are associated+ with files and directories in the form of extended attributes. This+ library exposes a simple API for on files and directories that+ abides by information flow control: a label on the file protects its+ contents, while a directory label protects the containing files'+ attributes (names and labels).++ .++ See "LIO.FS.TCB" for a description of the filestore implementation+ and "LIO.FS.Simple" for a description of the actual API.++ .++ This library is still under development, use with care.++Extra-source-files:+ examples/simpleFS.hs+++Source-repository head+ Type: git+ Location: git://github.com/scslab/lio.git++Library+ Build-Depends:+ base >= 4.5 && < 5.0+ , containers+ , bytestring+ , filepath+ , directory+ , lio+ , xattr+ , SHA++ GHC-options: -Wall -fno-warn-orphans++ Exposed-modules:+ LIO.FS.Simple.DCLabel+ LIO.FS.Simple+ LIO.FS.TCB