#if __GLASGOW_HASKELL__ >= 702
#endif
module LIO.Handle (
evalWithRoot
, DirectoryOps(..)
, CloseOps(..)
, HandleOps(..)
, readFile, writeFile, writeFileL
, IOMode(..)
, LHandle, labelOfHandle
, getDirectoryContentsP
, createDirectoryP
, openFileP
, hCloseP
, hFlushP
, hGetP
, hGetNonBlockingP
, hGetContentsP
, hPutP
, hPutStrP
, hPutStrLnP
, readFileP, writeFileP, writeFileLP
) where
#if __GLASGOW_HASKELL__ >= 702
import safe Prelude hiding (catch, readFile, writeFile)
import safe System.IO (IOMode(..))
import safe qualified System.IO as IO
#else
import Prelude hiding (catch, readFile, writeFile)
import System.IO (IOMode(..))
import qualified System.IO as IO
#endif
import LIO.TCB
import LIO.FS
import Data.Serialize
import qualified System.Directory as IO
import System.FilePath
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as LC
class (Monad m) => DirectoryOps h m | m -> h where
getDirectoryContents :: FilePath -> m [FilePath]
createDirectory :: FilePath -> m ()
openFile :: FilePath -> IOMode -> m h
class (Monad m) => CloseOps h m where
hClose :: h -> m ()
hFlush :: h -> m ()
class (CloseOps h m) => HandleOps h b m where
hGet :: h -> Int -> m b
hGetNonBlocking :: h -> Int -> m b
hGetContents :: h -> m b
hPut :: h -> b -> m ()
hPutStr :: h -> b -> m ()
hPutStr = hPut
hPutStrLn :: h -> b -> m ()
instance DirectoryOps IO.Handle IO where
getDirectoryContents = IO.getDirectoryContents
createDirectory = IO.createDirectory
openFile = IO.openBinaryFile
instance CloseOps IO.Handle IO where
hClose = IO.hClose
hFlush = IO.hFlush
instance HandleOps IO.Handle L.ByteString IO where
hGet = L.hGet
hGetNonBlocking = L.hGetNonBlocking
hGetContents = L.hGetContents
hPut = L.hPut
hPutStrLn = LC.hPutStrLn
data LHandle l = LHandleTCB l IO.Handle
labelOfHandle :: Label l => LHandle l -> l
labelOfHandle (LHandleTCB l _) = l
instance (Serialize l, LabelState l p s)
=> DirectoryOps (LHandle l) (LIO l p s) where
getDirectoryContents = getDirectoryContentsP noPrivs
createDirectory f = do l <- getLabel
createDirectoryP noPrivs l f
openFile f m = do l <- getLabel
openFileP noPrivs (Just l) f m
getDirectoryContentsP :: (LabelState l p s, Serialize l)
=> p
-> FilePath
-> LIO l p s [FilePath]
getDirectoryContentsP p' dir = withCombinedPrivs p' $ \p -> do
path <- lookupObjPathP p dir >>= unlabelFilePathP p
rtioTCB $ IO.getDirectoryContents path
createDirectoryP :: (LabelState l p s, Serialize l)
=> p
-> l
-> FilePath
-> LIO l p s ()
createDirectoryP p ldir path' = withCombinedPrivs p $ \priv -> do
path <- cleanUpPath path'
aguardP priv ldir
lcDir <- lookupObjPathP priv (containingDir path)
wguardP priv $ labelOfFilePath lcDir
rtioTCB $ createDirectoryTCB ldir path
where stripLastSlash = (reverse . stripSlash . reverse)
containingDir = takeDirectory . ([pathSeparator] </>)
. stripLastSlash
openFileP :: (LabelState l p s, Serialize l)
=> p
-> Maybe l
-> FilePath
-> IOMode
-> LIO l p s (LHandle l)
openFileP p mlfile path' mode = withCombinedPrivs p $ \priv -> do
path <- cleanUpPath path'
let containingDir = takeDirectory path
fileName = takeFileName path
maybe (return ()) (aguardP priv) mlfile
lcDir <- lookupObjPathP priv containingDir
actualCDir <- unlabelFilePathP priv lcDir
let objPath = actualCDir </> fileName
exists <- rtioTCB $ IO.doesFileExist objPath
if exists
then do l <- getObjLabelTCB objPath
aguardP priv l
h <- rtioTCB $ IO.openFile objPath mode
return $ LHandleTCB l h
else case mlfile of
Nothing -> throwIO $ userError "openFileP: File label missing."
Just l -> do
wguardP priv (labelOfFilePath lcDir)
aguardP priv l
h <- ioTCB $ createFileTCB l objPath mode
return $ LHandleTCB l h
instance (LabelState l p s) => CloseOps (LHandle l) (LIO l p s) where
hClose = hCloseP noPrivs
hFlush = hFlushP noPrivs
instance (LabelState l p s, CloseOps (LHandle l) (LIO l p s)
, HandleOps IO.Handle b IO) =>
HandleOps (LHandle l) b (LIO l p s) where
hGet = hGetP noPrivs
hGetNonBlocking = hGetNonBlockingP noPrivs
hGetContents = hGetContentsP noPrivs
hPut = hPutP noPrivs
hPutStrLn = hPutStrLnP noPrivs
hCloseP :: (LabelState l p s) => p -> LHandle l -> LIO l p s ()
hCloseP p' (LHandleTCB l h) = withCombinedPrivs p' $ \p ->
wguardP p l >> rtioTCB (hClose h)
hFlushP :: (LabelState l p s) => p -> LHandle l -> LIO l p s ()
hFlushP p' (LHandleTCB l h) = withCombinedPrivs p' $ \p ->
wguardP p l >> rtioTCB (hFlush h)
hGetP :: (LabelState l p s, HandleOps IO.Handle b IO)
=> p
-> LHandle l
-> Int
-> LIO l p s b
hGetP p' (LHandleTCB l h) n = withCombinedPrivs p' $ \p ->
wguardP p l >> rtioTCB (hGet h n)
hGetNonBlockingP :: (LabelState l p s, HandleOps IO.Handle b IO)
=> p -> LHandle l -> Int -> LIO l p s b
hGetNonBlockingP p' (LHandleTCB l h) n = withCombinedPrivs p' $ \p ->
wguardP p l >> rtioTCB (hGetNonBlocking h n)
hGetContentsP :: (LabelState l p s, HandleOps IO.Handle b IO)
=> p -> LHandle l -> LIO l p s b
hGetContentsP p' (LHandleTCB l h) = withCombinedPrivs p' $ \p ->
wguardP p l >> rtioTCB (hGetContents h)
hPutP :: (LabelState l p s, HandleOps IO.Handle b IO)
=> p -> LHandle l -> b -> LIO l p s ()
hPutP p' (LHandleTCB l h) s = withCombinedPrivs p' $ \p ->
wguardP p l >> rtioTCB (hPut h s)
hPutStrP :: (LabelState l p s, HandleOps IO.Handle b IO)
=> p -> LHandle l -> b -> LIO l p s ()
hPutStrP = hPutP
hPutStrLnP :: (LabelState l p s, HandleOps IO.Handle b IO)
=> p -> LHandle l -> b -> LIO l p s ()
hPutStrLnP p' (LHandleTCB l h) s = withCombinedPrivs p' $ \p ->
wguardP p l >> rtioTCB (hPutStrLn h s)
readFile :: (DirectoryOps h m, HandleOps h b m) => FilePath -> m b
readFile path = openFile path ReadMode >>= hGetContents
writeFile :: (DirectoryOps h m, HandleOps h b m, OnExceptionTCB m)
=> FilePath -> b -> m ()
writeFile path contents = bracketTCB (openFile path WriteMode) hClose
(flip hPut contents)
readFileP :: (HandleOps IO.Handle b IO, LabelState l p s, Serialize l) =>
p -> FilePath -> LIO l p s b
readFileP p' path = withCombinedPrivs p' $ \p ->
openFileP p Nothing path ReadMode >>= hGetContentsP p
writeFileP :: (HandleOps IO.Handle b IO, LabelState l p s, Serialize l) =>
p -> FilePath -> b -> LIO l p s ()
writeFileP p' path contents = withCombinedPrivs p' $ \privs -> do
l <- getLabel
bracketTCB (openFileP privs (Just l) path WriteMode) (hCloseP privs)
(flip (hPutP privs) contents)
writeFileL :: (HandleOps IO.Handle b IO, LabelState l p s, Serialize l) =>
l -> FilePath -> b -> LIO l p s ()
writeFileL = writeFileLP noPrivs
writeFileLP :: (HandleOps IO.Handle b IO, LabelState l p s, Serialize l) =>
p -> l -> FilePath -> b -> LIO l p s ()
writeFileLP p' l path contents = withCombinedPrivs p' $ \privs -> do
bracketTCB (openFileP privs (Just l) path WriteMode) (hCloseP privs)
(flip (hPutP privs) contents)