#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)
#else
#warning "This module is not using SafeHaskell"
#endif
module LIO.Handle ( DirectoryOps(..)
, CloseOps (..)
, HandleOps (..)
, LHandle
, hlabelOf
, mkDir, mkLHandle
, readFile, writeFile
, createDirectoryPR, openFilePR, writeFilePR
, createDirectoryP, openFileP, writeFileP
, IOMode(..)
) where
import LIO.TCB
import LIO.FS
#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)
import safe Prelude hiding (readFile, writeFile)
import qualified Data.ByteString.Lazy as L
#warning "Did not safely import Data.ByteString.Lazy"
import qualified System.Directory as IO
#warning "Did not safely import System.Directory"
import safe System.IO (IOMode)
import safe qualified System.IO as IO
import safe qualified System.IO.Error as IO
#else
import Prelude hiding (readFile, writeFile)
import qualified Data.ByteString.Lazy as L
import qualified System.Directory as IO
import System.IO (IOMode)
import qualified System.IO as IO
import qualified System.IO.Error as IO
#endif
class (Monad m) => DirectoryOps h m | m -> h where
getDirectoryContents :: FilePath -> m [FilePath]
createDirectory :: FilePath -> m ()
openFile :: FilePath -> IO.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 ()
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 h s = L.hPut h $ L.append s $ L.singleton 0xa
data LHandle l h = LHandleTCB l h
instance (Label l) => MintTCB (LHandle l IO.Handle) (IO.Handle, l) where
mintTCB (h, l) = LHandleTCB l h
instance (Label l) => DirectoryOps (LHandle l IO.Handle) (LIO l s) where
getDirectoryContents d = do
root <- rootDir
node <- lookupNode NoPrivs root d False
rtioTCB $ getDirectoryContentsNode node
createDirectory path = do
root <- rootDir
l <- getLabel
mkDir NoPrivs l root path
openFile path mode = do
root <- rootDir
l <- getLabel
mkLHandle NoPrivs l root path mode
instance (Label l) => CloseOps (LHandle l IO.Handle) (LIO l s) where
hClose (LHandleTCB l h) = wguard l >> rtioTCB (hClose h)
hFlush (LHandleTCB l h) = wguard l >> rtioTCB (hFlush h)
instance (Label l, CloseOps (LHandle l h) (LIO l s), HandleOps h b IO)
=> HandleOps (LHandle l h) b (LIO l s) where
hGet (LHandleTCB l h) n = wguard l >> rtioTCB (hGet h n)
hGetNonBlocking (LHandleTCB l h) n =
wguard l >> rtioTCB (hGetNonBlocking h n)
hGetContents (LHandleTCB l h) = wguard l >> rtioTCB (hGetContents h)
hPut (LHandleTCB l h) s = wguard l >> rtioTCB (hPut h s)
hPutStrLn (LHandleTCB l h) s = wguard l >> rtioTCB (hPutStrLn h s)
hlabelOf :: (Label l) => LHandle l h -> l
hlabelOf (LHandleTCB l _) = l
mkDir :: (Priv l p) =>
p
-> l
-> Name l
-> FilePath
-> LIO l s ()
mkDir priv l start path = do
aguard l
name <- lookupName priv start path
dirlabel <- ioTCB $ labelOfName name
wguardP priv dirlabel
new <- ioTCB $ mkNodeDir l
_ <- rtioTCB $ linkNode new name
return ()
mkLHandle :: (Priv l p) =>
p
-> l
-> Name l
-> FilePath
-> IO.IOMode
-> LIO l s (LHandle l IO.Handle)
mkLHandle priv l start path mode = do
aguard l
name <- lookupName priv start path
dirlabel <- ioTCB $ labelOfName name
taintP priv dirlabel
newl <- getLabel
mnode <- ioTCB $ tryPred IO.isDoesNotExistError (nodeOfName name)
case (mnode, mode) of
(Right node, _) ->
do nodel <- ioTCB $ labelOfNode node
let hl = if mode == IO.ReadMode
then l `lub` newl `lub` nodel
else nodel
aguard hl
h <- rtioTCB $ openNode node mode
return $ LHandleTCB hl h
(Left e, IO.ReadMode) -> throwIO e
_ -> do wguardP priv dirlabel
aguard l
(h, new) <- rtioTCB $ mkNodeReg mode l
mn <- rtioTCB $ tryPred IO.isAlreadyExistsError
(linkNode new name `onException` hClose h)
case mn of
Right _ -> return $ LHandleTCB l h
Left _ -> mkLHandle priv l name "" mode
readFile :: (DirectoryOps h m, HandleOps h b m) => FilePath -> m b
readFile path = openFile path IO.ReadMode >>= hGetContents
writeFile :: (DirectoryOps h m, HandleOps h b m,
OnExceptionTCB m) => FilePath -> b -> m ()
writeFile path contents = bracketTCB (openFile path IO.WriteMode) hClose
(flip hPut contents)
createDirectoryPR :: (Priv l p) => p -> Name l -> FilePath -> LIO l s ()
createDirectoryPR privs start path = do
l <- getLabel
mkDir privs l start path
writeFilePR :: (Priv l p, HandleOps IO.Handle b IO) =>
p -> Name l -> FilePath -> b -> LIO l s ()
writeFilePR privs start path contents =
bracketTCB (openFilePR privs start path IO.WriteMode) hClose
(flip hPut contents)
openFilePR :: (Priv l p) =>
p -> Name l -> FilePath -> IOMode -> LIO l s (LHandle l IO.Handle)
openFilePR privs start path mode = do
l <- getLabel
mkLHandle privs l start path mode
createDirectoryP :: (Priv l p) => p -> FilePath -> LIO l s ()
createDirectoryP privs path = do
root <- rootDir
l <- getLabel
mkDir privs l root path
writeFileP :: (Priv l p, HandleOps IO.Handle b IO) =>
p -> FilePath -> b -> LIO l s ()
writeFileP privs path contents =
bracketTCB (openFileP privs path IO.WriteMode) hClose
(flip hPut contents)
openFileP :: (Priv l p) =>
p -> FilePath -> IOMode -> LIO l s (LHandle l IO.Handle)
openFileP privs path mode = do
root <- rootDir
l <- getLabel
mkLHandle privs l root path mode