module LIO.FS.TCB (
initFSTCB, mkFSTCB, setFSTCB
, getRootDirTCB
, setPathLabelTCB
, getPathLabelTCB
, createFileTCB
, createDirectoryTCB
, LFilePath(..)
, FSError(..)
, SLabel
, lazyEncodeLabel, encodeLabel, decodeLabel
) where
import Data.Serialize
import Data.Typeable
import Data.IORef
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as L8
import qualified Data.Digest.Pure.SHA as SHA
import Codec.Compression.Zlib hiding (compress)
import Control.Monad
import Control.Exception
import qualified Control.Exception as E
import System.FilePath
import System.Directory
import System.IO
import System.IO.Unsafe
import System.Xattr
import LIO.Label
import LIO.Core
import LIO.TCB
type S8 = S8.ByteString
type L8 = L8.ByteString
type SLabel l = (Label l, Serialize l)
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 :: SLabel l => LIO l FilePath
getRootDirTCB = ioTCB $ readIORef rootDir
mkFSTCB :: SLabel l
=> FilePath
-> l
-> LIO l ()
mkFSTCB path l = do
unless (isAbsolute path) $ ioTCB $ throwIO FSRootInvalid
ioTCB $ createDirectory path
setPathLabelTCB path l
ioTCB $ lsetxattr path magicAttr magicContent CreateMode
ioTCB $ writeIORef rootDir path
setFSTCB :: SLabel l => FilePath -> LIO l ()
setFSTCB path = do
unless (isAbsolute path) $ ioTCB $ throwIO FSRootInvalid
checkDirExists
checkMagic
void $ getPathLabelTCB path
ioTCB $ writeIORef rootDir path
where checkMagic = ioTCB $ do
magicOK <-(==magicContent) `liftM`
(throwOnFail $ lgetxattr path magicAttr)
unless magicOK doFail
checkDirExists = ioTCB $ do
e <- doesDirectoryExist path
unless e $ throwIO FSRootNoExist
doFail = throwIO FSRootCorrupt
throwOnFail act = act `E.catch` (\(_:: SomeException) -> doFail)
initFSTCB :: SLabel l => FilePath -> Maybe l -> LIO l ()
initFSTCB path ml = do
unless (isAbsolute path) $ ioTCB $ throwIO FSRootInvalid
exists <- ioTCB $ doesDirectoryExist path
(if exists then setFSTCB else mkFSTCB') path
where mkFSTCB' p = maybe (ioTCB $ throwIO FSRootNeedLabel) (mkFSTCB p) ml
labelAttr :: AttrName
labelAttr = "user._lio_label"
labelHashAttr :: AttrName
labelHashAttr = "user._lio_label_sha"
lazyEncodeLabel :: SLabel l => l -> L8
lazyEncodeLabel = compress . encodeLazy
encodeLabel :: SLabel l => l -> AttrValue
encodeLabel = strictify . lazyEncodeLabel
decodeLabel :: SLabel l => AttrValue -> Either String l
decodeLabel = decodeLazy . decompress . lazyfy
setPathLabelTCB :: SLabel l => FilePath -> l -> LIO l ()
setPathLabelTCB path l = ioTCB $ do
lsetxattr path labelAttr (strictify lEnc) RegularMode
lsetxattr path labelHashAttr lHsh RegularMode
where lEnc = lazyEncodeLabel l
lHsh = strictify . SHA.bytestringDigest . SHA.sha1 $ lEnc
getPathLabelTCB :: SLabel l => FilePath -> LIO l l
getPathLabelTCB path = rethrowIoTCB $ do
(b, h) <- throwOnFail $ do b <- lgetxattr path labelAttr
h <- lgetxattr path labelHashAttr
return (b, h)
let b' = lazyfy b
h' = strictify . SHA.bytestringDigest . SHA.sha1 $ b'
case decodeLabel b of
Right l | h == h' -> return l
_ -> doFail
where doFail = throwIO $ FSLabelCorrupt path
throwOnFail act = act `E.catch` (\(_:: SomeException) -> doFail)
createDirectoryTCB :: (SLabel l) => l -> FilePath -> LIO l ()
createDirectoryTCB l path = do
rethrowIoTCB $ createDirectory path
setPathLabelTCB path l
createFileTCB :: (SLabel l) => l -> FilePath -> IOMode -> LIO l Handle
createFileTCB l path mode = do
h <- rethrowIoTCB $ openFile path mode
setPathLabelTCB path l
return h
data LFilePath l = LFilePathTCB { labelOfFilePath :: l
, unlabelFilePathTCB :: FilePath
}
strictify :: L8 -> S8
strictify = S8.concat . L.toChunks
lazyfy :: S8 -> L8
lazyfy x = L8.fromChunks [x]
compress :: L8 -> L8
compress = compressWith (defaultCompressParams { compressLevel = bestSpeed })