diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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 diff --git a/LIO/FS/Simple.hs b/LIO/FS/Simple.hs new file mode 100644 --- /dev/null +++ b/LIO/FS/Simple.hs @@ -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 diff --git a/LIO/FS/Simple/DCLabel.hs b/LIO/FS/Simple/DCLabel.hs new file mode 100644 --- /dev/null +++ b/LIO/FS/Simple/DCLabel.hs @@ -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 diff --git a/LIO/FS/TCB.hs b/LIO/FS/TCB.hs new file mode 100644 --- /dev/null +++ b/LIO/FS/TCB.hs @@ -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 diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/simpleFS.hs b/examples/simpleFS.hs new file mode 100644 --- /dev/null +++ b/examples/simpleFS.hs @@ -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 diff --git a/lio-fs.cabal b/lio-fs.cabal new file mode 100644 --- /dev/null +++ b/lio-fs.cabal @@ -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 +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