/io-layer/System/IO9/NameSpaceT.hs
Haskell | 414 lines | 272 code | 58 blank | 84 comment | 9 complexity | b900a7d720b062c8f26d48666bf0e515 MD5 | raw file
Possible License(s): BSD-3-Clause
- {-# Language PatternGuards #-}
- ------------------------------------------------------------------
- -- |
- -- Module : System.IO9.NameSpaceT
- -- Copyright : (c) Dmitry Golubovsky, 2010
- -- License : BSD-style
- --
- -- Maintainer : golubovsky@gmail.com
- -- Stability : experimental
- -- Portability : GHC >= 6.12.2
- --
- --
- --
- -- NameSpace Layer and Monad Transformer
- ------------------------------------------------------------------
- module System.IO9.NameSpaceT (
- BindFlag (..)
- ,NameSpaceT
- ,nsInit
- ,nsFork
- ,nsWait
- ,nsBuiltIn
- ,dbgPrint
- ,dbgChunks
- ,PathHandle (phCanon)
- ,nsBind
- ,nsEval
- ,nsCreate
- ,nsRemove
- ,nsStat
- ,nsWstat
- ,nsWithText
- ,nsWithBin
- ,nsEnumText
- ,nsEnumBin
- ,nsEnumDir
- ,nsThrow
- ,nsCatch
- ,nsFinally
- ,nsStdIn
- ,nsStdOut
- ,Filter (..)
- ,Application (..)
- ,AppTable (..)
- ,AppHandle
- ,appTable
- ,appEntry
- ,nestText
- ,nestLines
- ,nestBin
- ) where
- import Data.Bits
- import Data.Word
- import Data.NineP
- import Data.Maybe
- import Data.NineP.Bits
- import Control.Monad
- import Control.Monad.Trans.Class
- import Control.Monad.IO.Class
- import Control.Monad.Trans.Reader
- import Control.Concurrent
- import qualified Control.Concurrent.Forkable as F
- import System.FilePath
- import System.IO9.DevLayer
- import System.IO9.Error
- import Control.Exception
- import Control.Concurrent
- import System.Environment
- import qualified Data.Map as M
- import System.IO9.NameSpace.Monad
- import System.IO9.NameSpace.Types
- import System.IO9.NameSpace.Util
- import System.IO9.NameSpace.Enumerator
- import System.IO9.DevCons
- import System.IO9.DevApps
- import qualified Data.Text as T
- import qualified Data.ByteString as B
- import qualified Control.Monad.CatchIO as C
- import Data.Nesteratee
- import Data.Enumerator (run, ($$))
- -- | Run the "init" program with the given device list and empty namespace
- -- (it is expected that it builds the namespace from scratch). The parent
- -- thread handle is set to this thread's handle. Standard input and output
- -- are directed to the console. Console device and the builtin applications
- -- device are always initialized.
- nsInit :: (MonadIO m, C.MonadCatchIO m)
- => AppTable m -- ^ Builtin applications table
- -> [DevTable] -- ^ User-configurable devices table
- -> NameSpaceT m () -- ^ Initialization code
- -> m ()
- nsInit aptb dts nsi = do
- mv <- liftIO $ newMVar (M.empty)
- hu <- liftIO logName
- cons <- liftIO devCons
- apps <- liftIO $ devApps aptb
- thr <- liftIO myThreadId
- attcons <- liftIO (devAttach cons Init "/" >>= flip devWalk "cons")
- let consph = PathHandle {phAttach = attcons, phCanon = "#c/cons", phAdvisory = AdviceAny}
- let bids = [cons, apps]
- dts' = dts ++ bids
- let dvm = M.fromList $ zip (map devchar dts') dts'
- env = NsEnv {
- hown = hu
- ,priv = Init
- ,kdtbl = dvm
- ,nspace = mv
- ,stdinp = consph
- ,stdoutp = consph
- ,parent = thr
- ,runapp = runBuiltIn aptb
- }
- runNameSpaceT nsi `runReaderT` env
- runBuiltIn :: (MonadIO m, C.MonadCatchIO m)
- => AppTable m
- -> FilePath
- -> [Argument]
- -> NameSpaceT m NineError
- runBuiltIn aptb nbi args = case M.lookup nbi aptb of
- Nothing -> return $ Located nbi Enonexist
- Just (Monadic appf) -> appf args
- Just (TextFilter appf) -> do
- appin <- nsStdIn
- appout <- nsStdOut
- nsWithText appout 0 $ \out -> do
- r <- run (nsEnumText appin $$ appf args . nestYield EmptyStatus $ out)
- case r of
- Left err -> return $ Located nbi $ OtherError $ show err
- Right res -> return res
- Just (BinFilter appf) -> do
- appin <- nsStdIn
- appout <- nsStdOut
- nsWithBin appout 0 $ \out -> do
- r <- run (nsEnumBin 1024 appin $$ appf args . nestYield EmptyStatus $ out)
- case r of
- Left err -> return $ Located nbi $ OtherError $ show err
- Right res -> return res
-
- -- | Run a built-in function by name. Given the application descriptor, retrieve
- -- the builtin function name, find the function in the application table, and
- -- invoke the function with arguments provided. Usually this is done as the
- -- final part of running an application.
- nsBuiltIn :: (MonadIO m, C.MonadCatchIO m)
- => AppDescr -- ^ Application descriptor
- -> [Argument] -- ^ Arguments including redirections
- -> NameSpaceT m NineError -- ^ Application result
- nsBuiltIn ad args = do
- runf <- NameSpaceT $ asks runapp
- let nbi = appBuiltIn ad
- runf nbi args
- -- | Fork a new thread. This is the "privileged" part of running an application: actions
- -- allowed at the user level are handled in the 'System.IO9.Application' module,
- -- such as building an application descriptor, adjusting redirected path handles, etc.
- -- This function sets the relevant parts of the application context and either
- -- forks a thread for a new application or continues running in the original thread
- -- (the latter is only allowed if running with the 'Init' privileges, and is not to be
- -- generally used).
- --
- -- This function takes an 'AppDescr' (application descriptor) data structure, and
- -- runs the supplied application function with type @Monad m => NameSpaceT m NineError@.
- -- Note that this is not yet application itself which is supposed to be a 'Nesteratee'
- -- in order to access the file I/O. The user supplied code is expected to handle that itself.
- --
- -- The following rules apply:
- --
- -- - Jumping to an application is only allowed if the current process privilege level is 'Init'.
- --
- -- - If the application descriptor requests certain privilege level, it can only be same
- -- or lower than the parent thread has. Default ('appPriv' = 'Nothing') corresponds to
- -- 'HostOwner' privileges; 'Admin' or 'Init' or 'None' must be requested explicitly.
- -- 'World' cannot be requested: this privilege level can appear only in the 'DevAttach'
- -- structure.
- --
- -- - If the application descriptor requests the namespace to be shared, the requested
- -- privilege level should be the same as the parent thread has.
- --
- -- - If the 'AppJump' mode is requested, new thread is not created, and the value returned
- -- is an 'AppHandle' representing a completed thread. Namespace may only be shared (in fact,
- -- the current thread's environment is just reused).
- --
- -- If any of the above checks fails, 'nsFork' throws an exception. Execution of the new thread
- -- does not even start in such case.
- nsFork :: (MonadIO m, F.ForkableMonad m, C.MonadCatchIO m)
- => AppDescr -- ^ Application descriptor
- -> NameSpaceT m NineError -- ^ To run in the forked thread
- -> NameSpaceT m AppHandle -- ^ Returned value
- nsFork ad thr = do
- let runerr = NameSpaceT . liftIO . throwIO . Located "nsFork"
- env <- NameSpaceT $ ask
- let ppriv = priv env
- ptid <- NameSpaceT $ liftIO myThreadId
- case appMode ad of
- AppJump -> do
- when (ppriv < Init) $ runerr Eperm
- thr >>= return . AppCompleted
- AppFork -> do
- let epriv = case appPriv ad of
- Nothing -> HostOwner
- Just p -> p
- world (World _ _) = True
- world _ = False
- nshare NsShare = True
- nshare _ = False
- when (world epriv) $ runerr Ebadarg
- when (epriv > ppriv) $ runerr Eperm
- when (epriv /= ppriv && nshare (appNsAdjust ad)) $ runerr Ebadarg
- let redir x y = case x of
- Nothing -> return y
- Just p -> nsEval p
- appinph <- nsStdIn >>= redir (appStdIn ad)
- appoutph <- nsStdOut >>= redir (appStdOut ad)
- NameSpaceT $ do
- mvwait <- liftIO $ newEmptyMVar
- child <- F.forkIO $ lift $ do
- newns <- liftIO $ case appNsAdjust ad of
- NsBuild _ -> newMVar (M.empty)
- NsShare -> return $ nspace env
- NsClone -> do
- nmv <- newEmptyMVar
- omv <- readMVar (nspace env)
- putMVar nmv omv
- return nmv
- let newenv = env {
- priv = epriv
- ,nspace = newns
- ,parent = ptid
- ,stdinp = appinph
- ,stdoutp = appoutph
- }
- (runNameSpaceT thr `runReaderT` newenv >>= liftIO . putMVar mvwait) `C.catches`
- [ C.Handler (liftIO . putMVar mvwait)
- ,C.Handler (\(e :: SomeException) -> liftIO $ putMVar mvwait $ OtherError $ show e)]
- return $ AppRunning child mvwait
- -- | Given an 'AppHandle', wait/check for application thread completion.
- nsWait :: MonadIO m
- => Bool -- ^ 'True' to wait, 'False' otherwise
- -> AppHandle -- ^ Handle of the application thread
- -> NameSpaceT m NineError -- ^ Process status ('StillRunning' or error value)
- nsWait _ (AppCompleted e) = return e
- nsWait w (AppRunning _ v) = NameSpaceT $ liftIO $ case w of
- True -> takeMVar v
- False -> tryTakeMVar v >>= return . fromMaybe StillRunning
- -- | Bind a path somewhere in the namespace. Both paths should be absolute or device, and will be
- -- evaluated. One exception however applies when binding to the "/" old path to the empty
- -- namespace, evaluation does not occur provided that the new path is a device path.
- -- If any of paths is neither absolute nor device, failure occurs.
- nsBind :: MonadIO m
- => BindFlag -- ^ Bind options (before, after, create etc.)
- -> FilePath -- ^ New path
- -> FilePath -- ^ Old path
- -> NameSpaceT m () -- ^ No return value, namespace updated under the hood
- nsBind _ new old | not ((isAbsolute new || isDevice new) && (isAbsolute old || isDevice old)) =
- NameSpaceT $ liftIO $ throwIO $ Located new Efilename
- nsBind fl new old | old == "/" && isDevice new = NameSpaceT $ do
- mv <- asks nspace
- dtb <- asks kdtbl
- pv <- asks priv
- liftIO $ withNameSpace mv $ \ns -> case M.null ns of
- True -> do
- let newnorm = normalise new
- attnew <- attdev newnorm `runReaderT` (dtb, ns, pv)
- let phnew = PathHandle {phAttach = attnew, phCanon = newnorm, phAdvisory = AdviceAny}
- ud = unionDir phnew
- return $ M.insert old (UnionPoint ud new) ns
- False -> bind_common fl new old dtb pv ns
- nsBind fl new old = NameSpaceT $ do
- mv <- asks nspace
- dtb <- asks kdtbl
- pv <- asks priv
- liftIO $ withNameSpace mv $ bind_common fl new old dtb pv
- -- | Evaluate a file path (absolute or device) using the current namespace. The function will try
- -- to evaluate the entire path given, so for file creation, strip the last (not-existing-yet) part
- -- of the path off. If successful, an attachment descriptor for the path is returned. Otherwise
- -- the function fails (e. g. if a device driver returns an error message).
- nsEval :: (MonadIO m) => FilePath -> NameSpaceT m PathHandle
- nsEval fp | not (isAbsolute fp || isDevice fp) =
- NameSpaceT $ liftIO $ throw $ Located fp Efilename
- nsEval fp = NameSpaceT $ do
- ns <- asks nspace >>= liftIO . readMVar
- kd <- asks kdtbl
- pv <- asks priv
- liftIO $ eval_common fp `runReaderT` (kd, ns, pv)
- -- | Create a new file or directory (set 'c_DMDIR' in the @mode@ argument).
- -- Creation in an union directory follows the Plan9 semantics by finding the
- -- first member of the union that allows creation. The 'FilePath' supplied should not
- -- contain slashes, otherwise an error will be thrown.
- nsCreate :: MonadIO m
- => PathHandle -- ^ Handle of the directory
- -> FilePath -- ^ Name of the file or directory to create
- -> Word32 -- ^ Creation mode/permissions
- -> NameSpaceT m PathHandle -- ^ Handle of the created object
- nsCreate dph fp mode | '/' `elem` fp = NameSpaceT $ liftIO $ throwIO $ Located fp Ebadarg
- nsCreate dph fp mode = NameSpaceT $ do
- when (((qid_typ $ devqid $ phAttach dph) .&. c_QTDIR) == 0) $
- liftIO $ throwIO $ Located (show dph) Enotdir
- ns <- asks nspace >>= liftIO . readMVar
- let un = findunion (phCanon dph) ns
- dirs = filter dircr un
- dda = case dirs of
- [] -> phAttach dph
- (d:_) -> phAttach $ dirph d
- when (null dirs && not (null un)) $ liftIO $ throwIO $ Located (show dph) Enocreate
- da <- liftIO $ devCreate dda fp mode
- let newpath = tail $ normalise ("x" ++ phCanon dph ++ "/" ++ fp)
- return PathHandle {
- phCanon = newpath
- ,phAdvisory = AdviceAny
- ,phAttach = da}
-
- -- | Remove a file or a directory whose 'PathHandle' is provided. Fails if a non-empty
- -- directory is to be removed.
- nsRemove :: MonadIO m
- => PathHandle -- ^ Handle of the object to be removed
- -> NameSpaceT m () -- ^ Nothing is returned
- nsRemove ph = NameSpaceT $ liftIO $ devRemove $ phAttach ph
- -- | Obtain attributes of a file or directory. Note that for directories,
- -- attributes of their server objects will be returned rather than of anything
- -- unioned with them.
- nsStat :: MonadIO m
- => PathHandle -- ^ Handle of the object whose attributes are requested
- -> NameSpaceT m Stat -- ^ Result
- nsStat ph = NameSpaceT $ do
- st <- liftIO $ devStat (phAttach ph)
- u <- asks hown
- return $ mapUser u st
- -- | Change some attributes of a file or directory. See <http://man.cat-v.org/plan_9/5/stat>.
- -- If the 'st_name' member of the provided 'Stat' structure contains a slash, error
- -- will be thrown.
- nsWstat :: (MonadIO m)
- => PathHandle -- ^ Handle of the object whose attributes to change
- -> Stat -- ^ A 'Stat' structure whose fields specify changes
- -> NameSpaceT m PathHandle -- ^ Handle of the same object with updated attrs.
- nsWstat ph st | '/' `elem` st_name st = NameSpaceT $
- liftIO $ throwIO $ Located (st_name st) Ebadarg
- nsWstat ph st = NameSpaceT $ liftIO $ do
- nda <- devWstat (phAttach ph) st
- nst <- devStat nda
- let ncn = replaceFileName (phCanon ph) (st_name nst)
- return PathHandle {
- phCanon = ncn
- ,phAdvisory = phAdvisory ph
- ,phAttach = nda}
- -- | Create a 'PathHandle' for the standard input (as set in the Namespace environment)
- nsStdIn :: (MonadIO m)
- => NameSpaceT m PathHandle
- nsStdIn = NameSpaceT (asks stdinp)
-
- -- | Create a 'PathHandle' for the standard output (as set in the Namespace environment)
- nsStdOut :: (MonadIO m)
- => NameSpaceT m PathHandle
- nsStdOut = NameSpaceT (asks stdoutp)
-
- -- | A smart constructor for an 'AppTable' making it not necessary to explicitly
- -- import "Data.Map". Each application module is expected to provide its own 'AppTable'
- appTable :: Monad m => [AppTable m] -> AppTable m
- appTable = M.unions
- -- | A smart constructor for an individual application exporting one or more entry point.
- -- It expects a list of tuples where first elements are application names, and second
- -- elements are entry points.
- appEntry :: (Monad m) => [(FilePath, Application m)] -> AppTable m
- appEntry = M.fromList . filter (not . null . fst)