module LIO.FS.TCB (
initFSTCB, mkFSTCB, setFSTCB
, getRootDirTCB
, setPathLabelTCB
, getPathLabelTCB
, createFileTCB, createBinaryFileTCB
, createDirectoryTCB
, 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
data FSError = FSRootCorrupt
| FSRootInvalid
| FSRootExists
| FSRootNoExist
| FSRootNeedLabel
| FSObjNeedLabel
| FSLabelCorrupt FilePath
| FSIllegalFileName
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."
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]
rootDir :: IORef FilePath
rootDir = unsafePerformIO $ newIORef (error "LIO Filesystem not initialized.")
getRootDirTCB :: Label l => LIO l FilePath
getRootDirTCB = withContext "getRootDirTCB" $ ioTCB $ readIORef rootDir
mkFSTCB :: Label l
=> FilePath
-> l
-> LIO l ()
mkFSTCB path l = withContext "mkFSTCB" $ ioTCB $ do
unless (isAbsolute path) $ throwIO FSRootInvalid
createDirectory path
setPathLabelTCB path l
lsetxattr path magicAttr magicContent CreateMode
writeIORef rootDir path
setFSTCB :: Label l => FilePath -> LIO l l
setFSTCB path = withContext "setFSTCB" $ ioTCB $ do
unless (isAbsolute path) $ throwIO FSRootInvalid
checkDirExists
checkMagic
l <- getPathLabelTCB path
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)
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
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