lio 0.1.1 → 0.1.2

raw patch · 18 files changed

+169/−133 lines, 18 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• LIO/Concurrent.hs +23/−13
• LIO/Concurrent/LMVar/TCB.hs +4/−1
• LIO/DCLabel.hs +2/−2
• LIO/FS.hs +3/−3
• LIO/Handle.hs +13/−16
• LIO/LIORef.hs +1/−1
• LIO/LIORef/TCB.hs +4/−1
• LIO/MonadCatch.hs +1/−1
• LIO/MonadLIO.hs +1/−1
• LIO/Safe.hs +7/−3
• LIO/TCB.hs +97/−80
• System/Posix/Tmp.hsc +3/−3
• examples/LambdaChair/AliceCode.hs +1/−1
• examples/LambdaChair/BobCode.hs +1/−1
• examples/LambdaChair/LambdaChair.hs +1/−2
• examples/LambdaChair/Main.hs +5/−2
• examples/LambdaChair/Safe.hs +1/−1
• lio.cabal +1/−1

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif -- |This module exposes the concurrent interface to LIO. Specifically,@@ -20,7 +20,7 @@ forkLIO :: (LabelState l p s) => LIO l p s () -> LIO l p s ThreadId forkLIO m = do   s <- getTCB-  ioTCB . forkIO $ evalLIO m s >> return ()+  ioTCB . forkIO $ runLIO m s >> return ()   -- | Same as 'lFork', but the supplied set of priviliges are accounted@@ -29,15 +29,21 @@        => p -> l -> LIO l p s a -> LIO l p s (LRes l a) lForkP p' l m = withCombinedPrivs p' $ \p -> do   mv <- newEmptyLMVarP p l-  _ <- forkLIO $ do res <- (Right <$> m) `catchTCB` (return . Left .  lubErr)-                    lastL <- getLabel-                    putLMVarTCB mv (if leqp p lastL l-                                      then res-                                      else (mkErr lastL LerrLow))+  _ <- forkLIO $ do+         res <- (Right <$> m) `catchTCB` (return . Left . (lubErr l))+         lastL <- getLabel+         putLMVarTCB mv (if leqp p lastL l+                           then res+                           else let l' = lub lastL l+                                in Left . mkErr . (lub l') $+                                      either getELabel (const l') res+                        )    return $ LRes mv-    where mkErr cl e = Left . (LabeledExceptionTCB cl) . toException $ e-          lubErr (LabeledExceptionTCB le e) = LabeledExceptionTCB (l `lub` le) e+    where mkErr le = LabeledExceptionTCB le $ toException LerrLow+          lubErr lnew (LabeledExceptionTCB le e) =+                  LabeledExceptionTCB (le `lub` lnew) e+          getELabel (LabeledExceptionTCB le _) = le  -- | Labeled fork. @lFork@ allows one to invoke computations taht -- would otherwise raise the current label, but without actually@@ -52,8 +58,12 @@ -- result. It is require that this label is above the current label, -- and below the current clearance. Moreover, the supplied computation -- must not read anything more sensitive, i.e., with a label above the--- supplied label --- doing so will result in an exception being--- thrown. +-- supplied label --- doing so will result in an exception (whose+-- label will reflect this observation) being thrown. +--+-- If an exception is thrown in the inner computation, the exception+-- label will be raised to the join of the result label and original+-- exception label. --  -- Not that, compared to 'toLabeled', @lFork@ immediately returns a -- labeled result of type 'LRes', which is essentially a \"future\",@@ -64,7 +74,7 @@       => l                    -- ^ Label of result       -> LIO l p s a          -- ^ Computation to execute in separate thread       -> LIO l p s (LRes l a) -- ^ Labeled result-lFork l m = getPrivileges >>= \p -> lForkP p l m+lFork = lForkP noPrivs  -- | A labeled thread result is simply a wrapper for a labeled MVar. A -- thread can observe the result of another thread, only after raising@@ -89,4 +99,4 @@ -- the thread reads values above the result label, an exception is -- thrown in place of the result. lWait :: (LabelState l p s) => LRes l a -> LIO l p s a-lWait v = getPrivileges >>= \p -> lWaitP p v+lWait = lWaitP noPrivs

@@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) && (__GLASGOW_HASKELL__ < 704) {-# LANGUAGE SafeImports #-}+#endif+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 704)+{-# LANGUAGE Unsafe #-} #endif {-| This module provides an implementation for labeled MVars.  A labeled

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif @@ -26,7 +26,7 @@  import LIO.Handle (evalWithRoot) -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 import safe Data.Typeable #else import Data.Typeable

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 704 {-# LANGUAGE SafeImports #-} #endif {-# LANGUAGE DeriveDataTypeable #-}@@ -494,7 +494,7 @@ -- open the file. unlabelFilePath :: LabelState l p s                  => LFilePath l -> LIO l p s FilePath-unlabelFilePath f = getPrivileges >>= \p -> unlabelFilePathP p f+unlabelFilePath = unlabelFilePathP noPrivs  -- | Given a pathname (forced to be relative to the root of the -- labeled filesystem), find the path to the corresponding object.@@ -511,7 +511,7 @@ lookupObjPath :: (LabelState l p s, Serialize l)               => FilePath  -- ^ Path to object               -> LIO l p s (LFilePath l)-lookupObjPath f = getPrivileges >>= \p -> lookupObjPathP p f+lookupObjPath = lookupObjPathP noPrivs  -- | Same as 'lookupObjPath' but takes an additional privilege object -- that is exercised when raising the current label.

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses #-}@@ -60,7 +60,7 @@                   ) where  -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 import safe Prelude hiding (catch, readFile, writeFile) import safe System.IO (IOMode(..)) import safe qualified System.IO as IO@@ -139,13 +139,11 @@  instance (Serialize l, LabelState l p s)           => DirectoryOps (LHandle l) (LIO l p s) where-  getDirectoryContents f = getPrivileges >>= \p -> getDirectoryContentsP p f+  getDirectoryContents = getDirectoryContentsP noPrivs   createDirectory  f   = do l <- getLabel -                            p <- getPrivileges-                            createDirectoryP p l f+                            createDirectoryP noPrivs l f   openFile f m         = do l <- getLabel -                            p <- getPrivileges-                            openFileP p (Just l) f m+                            openFileP noPrivs (Just l) f m  -- | Get the contents of a directory. The current label is raised to -- the join of the current label and that of all the directories@@ -233,17 +231,17 @@               instance (LabelState l p s) => CloseOps (LHandle l) (LIO l p s) where-  hClose h = getPrivileges >>= \p -> hCloseP p h-  hFlush h = getPrivileges >>= \p -> hFlushP p h+  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 h i            = getPrivileges >>= \p -> hGetP p h i-  hGetNonBlocking h i = getPrivileges >>= \p -> hGetNonBlockingP p h i-  hGetContents h      = getPrivileges >>= \p -> hGetContentsP p h-  hPut h b            = getPrivileges >>= \p -> hPutP p h b-  hPutStrLn h b       = getPrivileges >>= \p -> hPutStrLnP p h b+  hGet            = hGetP noPrivs+  hGetNonBlocking = hGetNonBlockingP noPrivs+  hGetContents    = hGetContentsP noPrivs+  hPut            = hPutP noPrivs+  hPutStrLn       = hPutStrLnP noPrivs  -- | Close a labeled file handle. hCloseP :: (LabelState l p s) => p -> LHandle l -> LIO l p s ()@@ -334,8 +332,7 @@ -- | Same as 'writeFile' but also takes the label of the file. writeFileL  :: (HandleOps IO.Handle b IO, LabelState l p s, Serialize l) =>                l -> FilePath -> b -> LIO l p s ()-writeFileL l path contents = getPrivileges >>= \p ->-                             writeFileLP p l path contents+writeFileL = writeFileLP noPrivs  -- | Same as 'writeFileL' but uses privilege in opening the file. writeFileLP  :: (HandleOps IO.Handle b IO, LabelState l p s, Serialize l) =>

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif -- |This module implements labeled IORefs.  The interface is analogous

@@ -1,6 +1,9 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) && (__GLASGOW_HASKELL__ < 704) {-# LANGUAGE SafeImports #-}+#endif+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 704)+{-# LANGUAGE Unsafe #-} #endif -- |This module implements labeled IORefs.  The interface is analogous -- to "Data.IORef", but the operations take place in the LIO monad.

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif {-# LANGUAGE FlexibleInstances #-}

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif {-# LANGUAGE MultiParamTypeClasses #-}

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif @@ -8,7 +8,9 @@ -- module for documentation.  module LIO.Safe ( Label(..)-                 , Priv(..), NoPrivs(..)+                 , Priv(..), noPrivs+                 , getPrivileges, withPrivileges+                 , withCombinedPrivs                   , LIO, LabelState                  , evalLIO                  , getLabel, setLabelP@@ -27,7 +29,9 @@                  ) where  import LIO.TCB ( Label(..)-               , Priv(..), NoPrivs(..)+               , Priv(..), noPrivs+               , getPrivileges, withPrivileges+               , withCombinedPrivs                 , LIO, LabelState                , evalLIO                , getLabel, setLabelP

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702+#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 704 {-# LANGUAGE SafeImports #-} #endif #if __GLASGOW_HASKELL__ >= 704@@ -55,12 +55,12 @@                 Label(..)                 -- * Basic Privilige Functions                 -- $privs-               , Priv(..), NoPrivs(..)+               , Priv(..), noPrivs                , getPrivileges, withPrivileges                , withCombinedPrivs                 -- * Labeled IO Monad (LIO)                -- $LIO-               , LIO, LabelState+               , LIO(..), LabelState                , evalLIO, runLIO                , newState                , getLabel, setLabelP@@ -95,6 +95,7 @@                -- ** Labeled IO Monad (LIO)                , LIOstate(..)                , getTCB, putTCB+               , getLabelStateTCB, putLabelStateTCB                , setLabelTCB, lowerClrTCB                -- ** Labeled Values                , ShowTCB(..), ReadTCB(..)@@ -265,7 +266,7 @@      -- | Roughly speaking, @L_r = lostar p L L_g@ computes how close     -- one can come to downgrading data labeled @L@ to the goal label-    -- @L_g@, given privileges @p@.  When @p == 'NoPrivs'@, the resulting+    -- @L_g@, given privileges @p@.  When @p == 'noPrivs'@, the resulting     -- label @L_r == L ``lub``L_g@.  If @p@ contains all possible privileges,     -- then @L_r == L_g@.     --@@ -301,16 +302,9 @@     -- can define instances of mintTCB.     mintTCB :: i -> t --- |A generic 'Priv' instance that works for all 'Label's and confers--- no downgrading privileges.-data NoPrivs = NoPrivs-instance PrivTCB NoPrivs-instance Monoid NoPrivs where-    mempty      = NoPrivs-    mappend _ _ = NoPrivs-instance (Label l) => Priv l NoPrivs where-    leqp _ a b      = leq a b-    lostar _ l goal = lub l goal+-- | Alias for 'mempty'.+noPrivs :: Monoid p => p+noPrivs = mempty  --------------------------------------------------------------------- -- Labeled IO -------------------------------------------------------@@ -348,21 +342,24 @@ newtype LIO l p s a = LIO (StateT (LIOstate l p s) IO a)     deriving (Functor, Applicative, Monad) -get :: (LabelState l p s) => LIO l p s (LIOstate l p s)-get = mkLIO $ \s -> return (s, s) -put :: (LabelState l p s) => LIOstate l p s -> LIO l p s ()-put s = mkLIO $ \_ -> return (() , s)+-- | Get internal state.+getTCB :: (LabelState l p s) => LIO l p s (LIOstate l p s)+getTCB = mkLIO $ \s -> return (s, s) +-- | Put internal state.+putTCB :: (LabelState l p s) => LIOstate l p s -> LIO l p s ()+putTCB s = mkLIO $ \_ -> return (() , s)+ -- | Returns label-specific state of the 'LIO' monad.  This is the -- data specified as the second argument of 'evalLIO', whose type is -- @s@ in the monad @LIO l s@.-getTCB :: (LabelState l p s) => LIO l p s s-getTCB = labelState <$> get+getLabelStateTCB :: (LabelState l p s) => LIO l p s s+getLabelStateTCB = labelState <$> getTCB  -- | Sets the label-specific state of the 'LIO' monad.  See 'getTCB'.-putTCB :: (LabelState l p s) => s -> LIO l p s ()-putTCB ls = get >>= put . update+putLabelStateTCB :: (LabelState l p s) => s -> LIO l p s ()+putLabelStateTCB ls = getTCB >>= putTCB . update     where update s = s { labelState = ls }  -- | Generate a fresh state to pass 'runLIO' when invoking it for the@@ -373,7 +370,7 @@ newState s = LIOstate { labelState = s                       , lioL = lbot                       , lioC = ltop-                      , lioP = mempty }+                      , lioP = noPrivs }  -- | Lift an IO computation into @LIO@. mkLIO :: (LabelState l p s)@@ -409,16 +406,16 @@  -- | Returns the current value of the thread's label. getLabel :: (LabelState l p s) => LIO l p s l-getLabel = lioL <$> get+getLabel = lioL <$> getTCB  -- | Returns the current value of the thread's clearance. getClearance :: (LabelState l p s) => LIO l p s l-getClearance = lioC <$> get+getClearance = lioC <$> getTCB   -- | Returns the current privileges. getPrivileges :: (LabelState l p s) => LIO l p s p-getPrivileges = lioP <$> get+getPrivileges = lioP <$> getTCB  -- | Execute an LIO action with a set of underlying privileges. Within -- a @withPrivileges@ block, the supplied privileges are used in every @@ -440,11 +437,11 @@ -- @withPrivileges@ block. withPrivileges :: (LabelState l p s) => p -> LIO l p s a -> LIO l p s a withPrivileges p m = do-  s <- get+  s <- getTCB   p0 <- getPrivileges-  put s { lioP = p `mappend` p0 }+  putTCB s { lioP = p `mappend` p0 }   a <- m-  put s { lioP = p0 }+  putTCB s { lioP = p0 }   return a  -- | If the current label is @oldLabel@ and the current clearance is@@ -456,41 +453,41 @@ -- functionality that @setLabel@ would. setLabelP :: (LabelState l p s) => p -> l -> LIO l p s () setLabelP p' l = withCombinedPrivs p' $ \p -> do-  s <- get+  s <- getTCB   if leqp p (lioL s) l-    then put s { lioL = l }+    then putTCB s { lioL = l }     else throwIO LerrPriv  -- | Set the current label to anything, with no security check. setLabelTCB :: (LabelState l p s) => l -> LIO l p s ()-setLabelTCB l = do s <- get+setLabelTCB l = do s <- getTCB                    if l `leq` lioC s-                      then put s { lioL = l }+                      then putTCB s { lioL = l }                       else throwIO LerrClearance  -- | Reduce the current clearance. One cannot raise the current label -- or create object with labels higher than the current clearance. lowerClr :: (LabelState l p s) => l -> LIO l p s ()-lowerClr l = get >>= doit+lowerClr l = getTCB >>= doit     where doit s | not $ l `leq` lioC s = throwIO LerrClearance                  | not $ lioL s `leq` l = throwIO LerrLow-                 | otherwise            = put s { lioC = l }+                 | otherwise            = putTCB s { lioC = l }  -- | Raise the current clearance (undoing the effects of 'lowerClr'). -- This requires privileges. lowerClrP :: (LabelState l p s) => p -> l -> LIO l p s ()-lowerClrP p' l = withCombinedPrivs p' $ \p -> get >>= doit p+lowerClrP p' l = withCombinedPrivs p' $ \p -> getTCB >>= doit p     where doit p s | not $ leqp p l $ lioC s = throwIO LerrPriv                    | not $ lioL s `leq` l = throwIO LerrLow-                   | otherwise            = put s { lioC = l }+                   | otherwise            = putTCB s { lioC = l }  -- | Set the current clearance to anything, with no security check. lowerClrTCB :: (LabelState l p s) => l -> LIO l p s ()-lowerClrTCB l = get >>= doit+lowerClrTCB l = getTCB >>= doit     where doit s | not $ lioL s `leq` l =             throwIO $ LerrInval ("Cannot lower the current clearance"                                  ++ " below current label.")-                 | otherwise            = put s { lioC = l }+                 | otherwise            = putTCB s { lioC = l }  -- | Lowers the clearance of a computation, then restores the -- clearance to its previous value.  Useful to wrap around a@@ -506,10 +503,10 @@ -- supplied argument using 'lowerClrP'. withClearance :: (LabelState l p s) => l -> LIO l p s a -> LIO l p s a withClearance l m = do-  s <- get-  put s { lioC = l `glb` lioC s }+  s <- getTCB+  putTCB s { lioC = l `glb` lioC s }   a <- m-  put s { lioC = lioC s }+  putTCB s { lioC = lioC s }   return a  -- | Lifts an 'IO' computation into the 'LIO' monad.  Note that@@ -547,7 +544,7 @@ -- @ccurrent@, then the label @l@ specified must satisfy -- @lcurrent ``leq`` l && l ``leq`` ccurrent@. label :: (LabelState l p s) => l -> a -> LIO l p s (Labeled l a)-label l a = getPrivileges >>= \p -> labelP p l a+label = labelP noPrivs  -- | Constructs a 'Labeled' using privilege to allow the `Labeled`'s label -- to be below the current label.  If the current label is @lcurrent@@@ -558,7 +555,7 @@ -- use 'lowerClrP' to raise the clearance first if you wish to -- create an 'Labeled' at a higher label than the current clearance. labelP :: (LabelState l p s) => p -> l -> a -> LIO l p s (Labeled l a)-labelP p' l a = withCombinedPrivs p' $ \p -> get >>= doit p+labelP p' l a = withCombinedPrivs p' $ \p -> getTCB >>= doit p     where doit p s | not $ l `leq` lioC s    = throwIO LerrClearance                    | not $ leqp p (lioL s) l = throwIO LerrLow                    | otherwise               = return $ LabeledTCB l a@@ -579,7 +576,7 @@ -- However, you can use 'labelOf' to check if 'unlabel' will succeed -- without throwing an exception. unlabel :: (LabelState l p s) => Labeled l a -> LIO l p s a-unlabel x = getPrivileges >>= \p -> unlabelP p x+unlabel = unlabelP noPrivs  -- | Extracts the value of an 'Labeled' just like 'unlabel', but takes a -- privilege argument to minimize the amount the current label must be@@ -605,26 +602,39 @@   return $ LabeledTCB (lub l la) a  --- | @toLabeled@ is the dual of @unlabel@.  It allows one to invoke+-- | @toLabeled@ is the dual of 'unlabel'.  It allows one to invoke -- computations that would raise the current label, but without--- actually raising the label.  Instead, the result of the computation--- is packaged into a 'Labeled' with a supplied label.--- Thus, to get at the result of the--- computation one will have to call 'unlabel' and raise the label, but--- this can be postponed, or done inside some other call to 'toLabeled'.--- This suggests that the provided label must be above the current--- label and below the current clearance.+-- actually raising the label.  Instead, the result of the+-- computation is packaged into a 'Labeled' with a supplied+-- label. (Of couse, the computation executed by @toLabeled@ must+-- most observe any data whose label exceeds the supplied label.) ----- Note that @toLabeled@ always restores the clearance to whatever it was--- when it was invoked, regardless of what occurred in the computation--- producing the value of the 'Labeled'. --- This highlights one main use of clearance: to ensure that a @Labeled@--- computed does not exceed a particular label.+-- To get at the result of the computation one will have to call+-- 'unlabel' and raise the label, but this can be postponed, or+-- done inside some other call to 'toLabeled'.  This suggests that+-- the provided label must be above the current label and below+-- the current clearance. --+-- Note that @toLabeled@ always restores the clearance to whatever+-- it was when it was invoked, regardless of what occurred in the+-- computation producing the value of the 'Labeled'.  This highlights+-- one main use of clearance: to ensure that a @Labeled@ computed+-- does not exceed a particular label.+--+-- If an exception is thrown a a @toLabeled@ block, the join of+-- the exception label and supplied label will be used as the new+-- label.  If the current label of the inner computation is above+-- the supplied label, an exception (whose label will reflect this+-- observatoin) is throw by @toLabeled@.+-- -- WARNING: @toLabeled@ is susceptible to termination attacks. ---toLabeled :: (LabelState l p s) => l -> LIO l p s a -> LIO l p s (Labeled l a)-toLabeled l x = getPrivileges >>= \p -> toLabeledP p l x+toLabeled :: (LabelState l p s)+          => l -- ^ Label of result and upper bound on+               --  inner-computations' observation+          -> LIO l p s a -- ^ Inner computation+          -> LIO l p s (Labeled l a)+toLabeled = toLabeledP noPrivs {-# WARNING toLabeled "toLabeled is susceptible to termination attacks" #-}  -- | Same as 'toLabeled' but allows one to supply a privilege object@@ -636,13 +646,20 @@            => p -> l -> LIO l p s a -> LIO l p s (Labeled l a) toLabeledP p' l m = withCombinedPrivs p' $ \p -> do   aguardP p l-  save_s <- get-  a <- m `catchTCB` (\(LabeledExceptionTCB le se) -> ioTCB $ throwIO-                       (LabeledExceptionTCB (l `lub` le) se))-  s <- get-  put s { lioL = lioL save_s, lioC = lioC save_s}-  unless (leqp p (lioL s) l) $ throwIO LerrLow -- l is too low-  return $ LabeledTCB l a+  save_s <- getTCB+  --+  res <- (Right <$> m) `catchTCB` (return . Left .  (lubErr l))+  s <- getTCB+  let lastL = lioL s+  putTCB s { lioL = lioL save_s, lioC = lioC save_s, lioP = lioP save_s }+  if leqp p lastL l+    then either (ioTCB . throwIO) (return . LabeledTCB l) res+    else let l' = lub lastL l+         in ioTCB . throwIO . mkErr . (lub l') $ either getELabel (const l') res+    where mkErr le = LabeledExceptionTCB le $ toException LerrLow+          lubErr lnew (LabeledExceptionTCB le e) =+                  LabeledExceptionTCB (le `lub` lnew) e+          getELabel (LabeledExceptionTCB le _) = le {-# WARNING toLabeledP "toLabeledP is susceptible to termination attacks" #-}  -- | Executes a computation that would raise the current label, but@@ -663,7 +680,7 @@ -- WARNING: discard is susceptible to termination attacks. -- discard :: (LabelState l p s) =>  l -> LIO l p s a -> LIO l p s ()-discard l x = getPrivileges >>= \p -> discardP p l x+discard = discardP noPrivs {-# WARNING discard "discard is susceptible to termination attacks" #-}  -- | Same as 'discard', but uses privileges when comparing initial and@@ -756,10 +773,10 @@        -> l                     -- ^ @l@ - Label to taint with        -> LIO l p s () gtaint mylub l = do-  s <- get+  s <- getTCB   let lnew = l `mylub` (lioL s)   if lnew `leq` lioC s-     then put s { lioL = lnew }+     then putTCB s { lioL = lnew }      else ioTCB $ E.throwIO $ LabeledExceptionTCB (lioL s)           (toException LerrClearance) @@ -785,7 +802,7 @@ -- @l' ``leq`` l@ before doing the same thing as @'taint' l@.  Throws -- @'LerrHigh'@ if the current label @l'@ is too high. wguard :: (LabelState l p s) => l -> LIO l p s ()-wguard l = getPrivileges >>= \p -> wguardP p l+wguard = wguardP noPrivs  -- |Like 'wguard', but takes privilege argument to be more permissive. wguardP :: (LabelState l p s) => p -> l -> LIO l p s ()@@ -800,14 +817,14 @@ -- objects--untrusted code shouldn't be able to create an object -- labeled @l@ unless @aguard l@ does not throw an exception. aguard :: (LabelState l p s) => l -> LIO l p s ()-aguard l = getPrivileges >>= \p -> aguardP p l+aguard = aguardP noPrivs  -- | Like 'aguardP', but takes privilege argument to be more permissive. aguardP :: (LabelState l p s) => p -> l -> LIO l p s () aguardP p' newl = withCombinedPrivs p' $ \p -> do   c <- getClearance   l <- getLabel-  unless (leqp p newl c) $ throwIO LerrClearance+  unless (newl `leq` c)  $ throwIO LerrClearance   unless (leqp p l newl) $ throwIO LerrLow  @@ -914,9 +931,9 @@     -- | Basic function for catching labeled exceptions. (The fact that     -- they are labeled is hidden from the handler.)     ---    -- > catch = catchP NoPrivs+    -- > catch = catchP noPrivs     ---    catch x h = getPrivileges >>= \p -> catchP p x h+    catch = catchP noPrivs   -- | Catches an exception, so long as the label at the point where the@@ -930,16 +947,16 @@        -> (e -> LIO l p s a) -- ^ Exception handler        -> LIO l p s a        -- ^ Result of computation or handler catchP p' io handler = withCombinedPrivs p' $ \p -> do-  s <- get+  s <- getTCB   clr <- getClearance   (a, s') <- ioTCB $ do     (unLIO io s) `catch` (\e@(LabeledExceptionTCB le se) ->       case fromException se of         Nothing -> throwIO e-        Just e' -> if leqp p le clr+        Just e' -> if le `leq` clr                      then unLIO (taintP p le >> handler e') s                      else throwIO e)-  put s'+  putTCB s'   return a  -- | Trusted catch functin.@@ -948,10 +965,10 @@          -> (LabeledException l -> LIO l p s a) -- ^ Exception handler          -> LIO l p s a        -- ^ Result of computation or handler catchTCB io handler = do-  s <- get+  s <- getTCB   (a, s') <- ioTCB $ do     (unLIO io s) `E.catch` (\e -> unLIO (handler e) s)-  put s'+  putTCB s'   return a  -- | Version of 'catchP' with arguments swapped.

@@ -42,7 +42,7 @@ #endif  #if HAVE_MKSTEMP-foreign import ccall unsafe "HsUnix.h __hscore_mkstemp"+foreign import ccall unsafe "HsUnix.h __hstmp_mkstemp"   c_mkstemp :: CString -> IO CInt #endif @@ -64,7 +64,7 @@ #endif  #if HAVE_MKSTEMPS-foreign import ccall unsafe "HsUnix.h __hscore_mkstemps"+foreign import ccall unsafe "HsUnix.h __hstmp_mkstemps"   c_mkstemps :: CString -> CInt -> IO CInt #endif @@ -92,7 +92,7 @@ #endif  #if HAVE_MKDTEMP-foreign import ccall unsafe "HsUnix.h __hscore_mkdtemp"+foreign import ccall unsafe "HsUnix.h __hstmp_mkdtemp"   c_mkdtemp :: CString -> IO CString #endif 

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif module AliceCode ( mainReview ) where

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Safe #-} #endif module BobCode ( mainReview ) where

@@ -26,7 +26,6 @@ import Control.Monad.State import Data.Maybe import Data.List-import Data.Monoid  import LIO.TCB import LIO.LIORef@@ -146,7 +145,7 @@ getPrivs :: ReviewDC DCPrivTCB getPrivs = do    u <- getCurUser-  return $ maybe mempty (genPrivTCB . name) u+  return $ maybe noPrivs (genPrivTCB . name) u  -- ^ Write new users putUsers :: [User] -> ReviewDC ()

@@ -1,11 +1,14 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 && __GLASGOW_HASKELL__ < 704 {-# LANGUAGE SafeImports #-} #endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Unsafe #-}+#endif import LambdaChair import DCLabel.PrettyShow -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 import safe AliceCode as Alice import safe BobCode as Bob #else

@@ -1,5 +1,5 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+#if __GLASGOW_HASKELL__ >= 702 {-# LANGUAGE Trustworthy #-} #endif module Safe ( module LambdaChair ) where

@@ -1,5 +1,5 @@ Name:           lio-Version:        0.1.1+Version:        0.1.2 build-type:     Simple License:        GPL License-File:   LICENSE