module LIO.Handle ( evalWithRootFS
, SLabel
, SMonadLIO
, LabeledHandle, Handle
, IOMode(..)
, BufferMode(..)
, openFile, openFileP
, hClose, hCloseP
, hFlush, hFlushP
, HandleOps(..)
, hGetP
, hGetNonBlockingP
, hGetContentsP
, hGetLineP
, hPutP
, hPutStrP
, hPutStrLnP
, readFile, readFileP
, writeFile, writeFileP
, getDirectoryContents, getDirectoryContentsP
, createDirectory, createDirectoryP
, hSetBuffering, hSetBufferingP
, hGetBuffering, hGetBufferingP
, hSetBinaryMode, hSetBinaryModeP
, hIsEOF, hIsEOFP
, hIsOpen, hIsOpenP
, hIsClosed, hIsClosedP
, hIsReadable, hIsReadableP
, hIsWritable, hIsWritableP
) where
import Prelude hiding (readFile, writeFile)
import Data.Serialize
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy.Char8 as L8
import Control.Monad
import Control.Exception (throwIO)
import System.IO (IOMode(..), BufferMode(..), Handle)
import qualified System.IO as IO
import qualified System.Directory as IO
import System.FilePath
import LIO
import LIO.Labeled.TCB
import LIO.TCB
import LIO.FS.TCB
type SMonadLIO l m = (SLabel l, MonadLIO l m)
evalWithRootFS :: SLabel l
=> FilePath
-> Maybe l
-> LIO l a
-> LIOState l
-> IO a
evalWithRootFS path ml act = evalLIO (initFSTCB path ml >> act)
getDirectoryContents :: SMonadLIO l m => FilePath -> m [FilePath]
getDirectoryContents = getDirectoryContentsP NoPrivs
getDirectoryContentsP :: (SMonadLIO l m, Priv l p)
=> p
-> FilePath
-> m [FilePath]
getDirectoryContentsP p dir = do
path <- taintObjPathP p dir
liftLIO . rethrowIoTCB $ IO.getDirectoryContents path
createDirectory :: SMonadLIO l m => l -> FilePath -> m ()
createDirectory = createDirectoryP NoPrivs
createDirectoryP :: (SMonadLIO l m, Priv l p)
=> p
-> l
-> FilePath
-> m ()
createDirectoryP p l dir0 = do
guardAllocP p l
dir <- cleanUpPath dir0
let (containingDir, dName) = breakDir dir
path <- taintObjPathP p containingDir
ldir <- liftLIO $ getPathLabelTCB path
guardWriteP p ldir
guardAllocP p l
liftLIO $ createDirectoryTCB l $ path </> dName
where breakDir dir = let ds = splitDirectories dir
cd' = joinPath $ init ds
cd = if null cd' then [pathSeparator] else cd'
in (cd, last ds)
type LabeledHandle l = Labeled l Handle
openFile :: SMonadLIO l m
=> Maybe l
-> FilePath
-> IOMode
-> m (LabeledHandle l)
openFile = openFileP NoPrivs
openFileP :: (SMonadLIO l m, Priv l p)
=> p
-> Maybe l
-> FilePath
-> IOMode
-> m (LabeledHandle l)
openFileP p ml file' mode = do
file <- cleanUpPath file'
let containingDir = takeDirectory file
fileName = takeFileName file
maybe (return ()) (guardAllocP p) ml
path <- taintObjPathP p containingDir
ldir <- liftLIO $ getPathLabelTCB path
let objPath = path </> fileName
exists <- liftLIO . rethrowIoTCB $ IO.doesFileExist objPath
if exists
then do
l <- liftLIO $ getPathLabelTCB objPath
guardAllocP p l
h <- liftLIO . rethrowIoTCB $ IO.openFile objPath mode
return $ labelTCB l h
else case ml of
Nothing -> throwLIO FSObjNeedLabel
Just l -> do
guardWriteP p ldir
guardAllocP p l
h <- liftLIO $ createFileTCB l objPath mode
return $ labelTCB l h
hClose :: SMonadLIO l m => LabeledHandle l -> m ()
hClose = hCloseP NoPrivs
hCloseP :: (SMonadLIO l m, Priv l p) => p -> LabeledHandle l -> m ()
hCloseP p lh = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB . IO.hClose $ unlabelTCB lh
hFlush :: SMonadLIO l m => LabeledHandle l -> m ()
hFlush = hFlushP NoPrivs
hFlushP :: (SMonadLIO l m, Priv l p) => p -> LabeledHandle l -> m ()
hFlushP p lh = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB . IO.hFlush $ unlabelTCB lh
class Monad m => HandleOps h b m where
hGet :: h -> Int -> m b
hGetNonBlocking :: h -> Int -> m b
hGetContents :: h -> m b
hGetLine :: h -> m b
hPut :: h -> b -> m ()
hPutStr :: h -> b -> m ()
hPutStr = hPut
hPutStrLn :: h -> b -> m ()
instance HandleOps IO.Handle L8.ByteString IO where
hGet = L8.hGet
hGetNonBlocking = L8.hGetNonBlocking
hGetContents = L8.hGetContents
hGetLine h = (L8.fromChunks . (:[])) `liftM` S8.hGetLine h
hPut = L8.hPut
hPutStrLn = L8.hPutStrLn
instance HandleOps IO.Handle S8.ByteString IO where
hGet = S8.hGet
hGetNonBlocking = S8.hGetNonBlocking
hGetContents = S8.hGetContents
hGetLine = S8.hGetLine
hPut = S8.hPut
hPutStrLn = S8.hPutStrLn
instance (SLabel l, HandleOps IO.Handle b IO) =>
HandleOps (LabeledHandle l) b (LIO l) where
hGet = hGetP NoPrivs
hGetNonBlocking = hGetNonBlockingP NoPrivs
hGetContents = hGetContentsP NoPrivs
hGetLine = hGetLineP NoPrivs
hPut = hPutP NoPrivs
hPutStrLn = hPutStrLnP NoPrivs
hGetP :: (Priv l p, Serialize l, HandleOps IO.Handle b IO)
=> p
-> LabeledHandle l
-> Int
-> LIO l b
hGetP p lh n = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ hGet (unlabelTCB lh) n
hGetNonBlockingP :: (Priv l p, Serialize l, HandleOps IO.Handle b IO)
=> p -> LabeledHandle l -> Int -> LIO l b
hGetNonBlockingP p lh n = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ hGetNonBlocking (unlabelTCB lh) n
hGetContentsP :: (Priv l p, Serialize l, HandleOps IO.Handle b IO)
=> p -> LabeledHandle l -> LIO l b
hGetContentsP p lh = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ hGetContents (unlabelTCB lh)
hGetLineP :: (Priv l p, Serialize l, HandleOps IO.Handle b IO)
=> p -> LabeledHandle l -> LIO l b
hGetLineP p lh = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ hGetLine (unlabelTCB lh)
hPutP :: (Priv l p, Serialize l, HandleOps IO.Handle b IO)
=> p -> LabeledHandle l -> b -> LIO l ()
hPutP p lh s = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ hPut (unlabelTCB lh) s
hPutStrP :: (Priv l p, Serialize l, HandleOps IO.Handle b IO)
=> p -> LabeledHandle l -> b -> LIO l ()
hPutStrP = hPutP
hPutStrLnP :: (Priv l p, Serialize l, HandleOps IO.Handle b IO)
=> p -> LabeledHandle l -> b -> LIO l ()
hPutStrLnP p lh s = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ hPutStrLn (unlabelTCB lh) s
readFile :: (HandleOps Handle b IO, SLabel l)
=> FilePath -> LIO l b
readFile = readFileP NoPrivs
readFileP :: (HandleOps Handle b IO, Priv l p, Serialize l)
=> p -> FilePath -> LIO l b
readFileP p file = openFileP p Nothing file ReadMode >>= hGetContentsP p
writeFile :: (HandleOps Handle b IO, SLabel l)
=> l -> FilePath -> b -> LIO l ()
writeFile = writeFileP NoPrivs
writeFileP :: (HandleOps Handle b IO, Priv l p, Serialize l)
=> p -> l -> FilePath -> b -> LIO l ()
writeFileP p l file contents = do
bracket (openFileP p (Just l) file WriteMode) (hCloseP p)
(flip (hPutP p) contents)
hSetBuffering :: SMonadLIO l m => LabeledHandle l -> BufferMode -> m ()
hSetBuffering = hSetBufferingP NoPrivs
hSetBufferingP :: (SMonadLIO l m, Priv l p)
=> p -> LabeledHandle l -> BufferMode -> m ()
hSetBufferingP p lh m = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hSetBuffering (unlabelTCB lh) m
hGetBuffering :: SMonadLIO l m => LabeledHandle l -> m BufferMode
hGetBuffering = hGetBufferingP NoPrivs
hGetBufferingP :: (SMonadLIO l m, Priv l p)
=> p -> LabeledHandle l -> m BufferMode
hGetBufferingP p lh = do
taintP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hGetBuffering (unlabelTCB lh)
hSetBinaryMode :: SMonadLIO l m => LabeledHandle l -> Bool -> m ()
hSetBinaryMode = hSetBinaryModeP NoPrivs
hSetBinaryModeP :: (SMonadLIO l m, Priv l p)
=> p -> LabeledHandle l -> Bool -> m ()
hSetBinaryModeP p lh m = do
guardWriteP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hSetBinaryMode (unlabelTCB lh) m
hIsEOF :: SMonadLIO l m => LabeledHandle l -> m Bool
hIsEOF = hIsEOFP NoPrivs
hIsEOFP :: (SMonadLIO l m, Priv l p) => p -> LabeledHandle l -> m Bool
hIsEOFP p lh = do
taintP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hIsEOF (unlabelTCB lh)
hIsOpen :: SMonadLIO l m => LabeledHandle l -> m Bool
hIsOpen = hIsOpenP NoPrivs
hIsOpenP :: (SMonadLIO l m, Priv l p) => p -> LabeledHandle l -> m Bool
hIsOpenP p lh = do
taintP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hIsOpen (unlabelTCB lh)
hIsClosed :: SMonadLIO l m => LabeledHandle l -> m Bool
hIsClosed = hIsClosedP NoPrivs
hIsClosedP :: (SMonadLIO l m, Priv l p) => p -> LabeledHandle l -> m Bool
hIsClosedP p lh = do
taintP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hIsClosed (unlabelTCB lh)
hIsReadable :: SMonadLIO l m => LabeledHandle l -> m Bool
hIsReadable = hIsReadableP NoPrivs
hIsReadableP :: (SMonadLIO l m, Priv l p) => p -> LabeledHandle l -> m Bool
hIsReadableP p lh = do
taintP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hIsReadable (unlabelTCB lh)
hIsWritable :: SMonadLIO l m => LabeledHandle l -> m Bool
hIsWritable = hIsWritableP NoPrivs
hIsWritableP :: (SMonadLIO l m, Priv l p) => p -> LabeledHandle l -> m Bool
hIsWritableP p lh = do
taintP p (labelOf lh)
liftLIO . rethrowIoTCB $ IO.hIsWritable (unlabelTCB lh)
taintObjPathP :: (SMonadLIO l m, Priv l p)
=> p
-> FilePath
-> m FilePath
taintObjPathP p path0 = do
path <- cleanUpPath path0
root <- liftLIO $ getRootDirTCB
let dirs = splitDirectories . stripSlash $ path
forM_ ("" : allSubDirs dirs) $ \dir -> do
l <- liftLIO $ getPathLabelTCB (root </> dir)
taintP p l
return $ root </> joinPath dirs
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)
stripSlash :: FilePath -> FilePath
stripSlash [] = []
stripSlash xx@(x:xs) | x == pathSeparator = stripSlash xs
| otherwise = xx
cleanUpPath :: MonadLIO l m => FilePath -> m FilePath
cleanUpPath = liftLIO . rethrowIoTCB . 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