module LIO.FS.TCB (
initializeLIOFS, withLIOFS
, getRootDirTCB
, setPathLabelTCB
, getPathLabelTCB
, createFileTCB, createBinaryFileTCB
, createDirectoryTCB
, FSError(..)
) where
import safe Data.Maybe (listToMaybe)
import safe Data.Typeable
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 Control.Concurrent.MVar
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
data FSError = FSRootCorrupt
| FSRootInvalid
| FSRootExists
| FSRootNoExist
| FSRootNeedLabel
| FSObjNeedLabel
| FSLabelCorrupt FilePath
| FSIllegalFileName
deriving (Eq, 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."
magicAttr :: AttrName
magicAttr = "user._lio_magic"
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]
getRootDirTCB :: Label l => LIO l FilePath
getRootDirTCB = withContext "getRootDirTCB" $ do ioTCB $ getRoot
mkFSTCB :: Label l
=> FilePath
-> l
-> IO l
mkFSTCB path l = do
unless (isAbsolute path) $ throwIO FSRootInvalid
createDirectoryIfMissing False path
setPathLabelTCB path l
lsetxattr path magicAttr magicContent CreateMode
return l
checkFSTCB :: Label l => FilePath -> IO l
checkFSTCB path = do
unless (isAbsolute path) $ throwIO FSRootInvalid
checkDirExists
checkMagic
getPathLabelTCB path
where checkMagic = do
magic <- lgetxattr path magicAttr `E.catch`
(\(_:: SomeException) -> throwIO FSRootNoExist)
unless (magic == magicContent) $ throwIO FSRootCorrupt
checkDirExists = do
e <- doesDirectoryExist path
unless e $ throwIO FSRootNoExist
rootDir :: MVar (Maybe FilePath)
rootDir = unsafePerformIO $ newMVar Nothing
getRoot :: IO FilePath
getRoot = do
mfp <- readMVar rootDir
maybe (throwIO FSRootNoExist) return mfp
setRoot :: FilePath -> IO ()
setRoot fp = do
act <- modifyMVarMasked rootDir $ \mfp ->
case mfp of
Just _ -> return $ (mfp, throwIO FSRootExists)
Nothing -> return $ (Just fp, return ())
act
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 path `E.catch` (\e -> if e == FSRootNoExist
then mkFSTCB' path
else throwIO e)
else mkFSTCB' path
setRoot path
return l
where mkFSTCB' f = maybe (throwIO FSRootNeedLabel) (mkFSTCB f) ml
withLIOFS :: Label l => FilePath -> Maybe l -> IO a -> IO a
withLIOFS path ml act = do
void $ initializeLIOFS path ml
act
labelAttr :: AttrName
labelAttr = "user._lio_label"
labelHashAttr :: AttrName
labelHashAttr = "user._lio_label_sha"
encodeLabel :: Label l => l -> AttrValue
encodeLabel = S8.pack . show
decodeLabel :: Label l => AttrValue -> Maybe l
decodeLabel = fmap fst . listToMaybe . reads . S8.unpack
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
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)
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
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
createDirectoryTCB :: Label l => l -> FilePath -> LIO l ()
createDirectoryTCB l path = withContext "createDirectoryTCB" $ ioTCB $ do
createDirectory path
setPathLabelTCB path l