module LIO.FS.TCB (
initFSTCB, mkFSTCB, setFSTCB
, getRootDirTCB
, setPathLabelTCB
, getPathLabelTCB
, createFileTCB
, createDirectoryTCB
, LFilePath(..)
, FSError(..)
, SLabel
, lazyEncodeLabel, encodeLabel, decodeLabel
) where
import Prelude hiding (catch)
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 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 `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 `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 })