lio 0.9.0.1 → 0.9.1.0

raw patch · 4 files changed

+101/−40 lines, 4 filesdep ~SHAdep ~timePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: SHA, time

API changes (from Hackage documentation)

Files

• LIO/Concurrent.hs +55/−31
• examples/bracket.hs +33/−0
• examples/waitAndCatch.hs +8/−5
• lio.cabal +5/−4

@@ -33,7 +33,7 @@   , threadDelay   -- * Forcing computations (EXPERIMENTAL)   , AsyncException(..)-  , lForce, lForceP+  , lBracket, lBracketP   ) where  @@ -53,7 +53,7 @@                   import           LIO.Concurrent.TCB import           LIO.Concurrent.LMVar-import           LIO.Concurrent.LMVar.TCB (putLMVarTCB)+import           LIO.Concurrent.LMVar.TCB (tryTakeLMVarTCB, putLMVarTCB)   -- | Get the 'ThreadId' of the calling thread.@@ -125,6 +125,7 @@       in if canFlowToP p endLabel l            then res            else Left $! LabeledExceptionTCB le (toException e)+    forever $ return ()   return $ LabeledResultTCB { lresThreadIdTCB = tid, lresResultTCB = mv }     where -- raise the label of the exception to the join of the           -- exception label and supplied lForkP upper bound@@ -152,6 +153,8 @@ lWaitP :: (MonadLIO l m, Priv l p) => p -> LabeledResult l a -> m a lWaitP p m = do   v <- readLMVarP p $ lresResultTCB m+  -- kill thread:+  liftLIO . ioTCB . killThread . lresThreadIdTCB $ m   case v of     Right x -> return x     Left e  -> liftLIO $ unlabeledThrowTCB e@@ -167,6 +170,8 @@   mv <- tryTakeLMVarP p mvar   case mv of     Just v -> do putLMVarP p mvar v+                 -- kill thread:+                 liftLIO . ioTCB . killThread . lresThreadIdTCB $ m                  case v of                    Right x -> return $! Just x                    Left e  -> liftLIO $ unlabeledThrowTCB e@@ -181,33 +186,52 @@ -- Forcing computations -- --- | Force execution of a thread spawned with 'lFork' or 'lForkP'.--- If the computation completed without raising an exception, then the--- result is wrapped in a 'Just', otherwise this function returns--- 'Nothing'. Note that the current computation must be able to read--- and write at the security level of the labeled result.-lForce :: MonadLIO l m => LabeledResult l a -> m (Labeled l (Maybe a))-lForce = lForceP NoPrivs --- | Same as 'lForce', but uses privileges when raising current label--- to the join of the current label and result label.-lForceP :: (MonadLIO l m, Priv l p)-        => p -> LabeledResult l a -> m (Labeled l (Maybe a))-lForceP p m = do-  let l = labelOf m-      mv = lresResultTCB m-  guardWriteP p l-  -- kill thread:-  liftLIO . ioTCB . killThread . lresThreadIdTCB $ m-  -- check to see if it wrote to MVar:-  v <- tryTakeLMVarP p mv-  return . labelTCB l =<< case v of-    Nothing -> do-      let e = toException ThreadKilled-      putLMVarTCB mv $ Left (LabeledExceptionTCB l e)-      return Nothing-    Just v' -> do-      putLMVarTCB mv v'-      case v' of-        Left _  -> return Nothing-        Right x -> return (Just x)+-- | Though in most cases using a 'LabeledResult' is sufficient, in+-- certain scenarios it is desirable to produce a pure 'Labeled' value+-- that is the result of other potentially sensitive values. As such, we+-- provide @lBracket@.+-- +-- @lBracket@ is like 'lFork', but rather than returning a+-- 'LabeledResult', it returns a 'Labeled' value. The key difference+-- between the two is that @lBracket@ takes an additional parameter+-- specifying the number of microseconds the inner computation will take.+-- As such, @lBracket@ will block for the specified duration and the+-- result of the inner computation be /forced/. That is, if the+-- computation terminated /cleanly/, i.e., it did not throw an+-- exception and it finished in the time specified, then 'Just' the+-- result is returned, otherwise 'Nothing' is returned.+--+-- Note that the original LIO (before version 0.9) included a similar+-- \"primitive\" called @toLabeled@. We have chosen to call this+-- @lBracket@ in part because it is a more descriptive name and to+-- avoid confusion with the previous @toLabeled@ where time was not +-- considered.+lBracket :: (MonadLIO l m)+          => l                -- ^ Label of result+          -> Int              -- ^ Duration of computation in microseconds+          -> LIO l a          -- ^ Computation to execute in separate thread+          -> m (Labeled l (Maybe a)) -- ^ Labeled result+lBracket = lBracketP NoPrivs++-- | Same as 'lBracket', but uses privileges when forking the new+-- thread.+lBracketP :: (MonadLIO l m, Priv l p)+           => p                -- ^ Privileges+           -> l                -- ^ Label of result+           -> Int              -- ^ Duration of computation in microseconds+           -> LIO l a          -- ^ Computation to execute in separate thread+           -> m (Labeled l (Maybe a)) -- ^ Labeled result+lBracketP p l t act = do+  f <- liftLIO $ lForkP p l act+  threadDelay t+  force f+    where force m = do+            let mv = lresResultTCB m+            -- check to see if it wrote to MVar:+            -- kill thread:+            liftLIO . ioTCB . killThread . lresThreadIdTCB $ m+            v <- tryTakeLMVarTCB mv+            return . labelTCB l =<< case v of+              Just (Right x) -> return (Just x)+              _  -> return Nothing

@@ -0,0 +1,33 @@++module Main where -- (main) where++import Control.Monad++import LIO+import LIO.Concurrent+import LIO.DCLabel++import System.Clock++cmp :: DCLabeled Int+        -> DCLabeled Int+        -> DC (DCLabeled (Maybe Bool))+cmp la lb = lBracket (lub (labelOf la) (labelOf lb)) (500) $ do+  a <- unlabel la+  b <- unlabel lb+  when (a == b) $ forever (return ())+  return (a == b)++exec :: Int -> Int -> IO ()+exec x y = runDC' $ do+  a <- label (dcLabel (toComponent "alice") dcTrue) x+  b <- label (dcLabel (toComponent "bob") dcTrue) y+  c <- cmp a b+  unlabel c+    where runDC' act = do+            t0 <- getTime Monotonic+            res <- runDC act+            t1 <- getTime Monotonic+            let micro t = (sec t * 1000000) + (nsec t `div` 1000)+            putStrLn $ "Result   = " ++ show res+                    ++ "Duration = " ++ show (micro t1 - micro t0)

@@ -1,4 +1,7 @@ {-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where+ import Prelude hiding (catch) import LIO import LIO.TCB (ioTCB)@@ -13,13 +16,13 @@ h = dcLabel ("A" /\ "B")      dcTrue  main =  do-  (_,l) <- runDC $ do-    lb <- label m 6-    f <- lFork (if doFail then m else l) $ do+  (_,lr) <- runDC $ do+    lb <- label m (6 :: Int)+    f <- lFork (if doFail then l else m) $ do       v <- unlabel lb       return (3+v)     catchLIO (do r <- lWait f                  ioTCB . putStrLn $ "No exception: " ++ show r               ) (\(_::SomeException) -> ioTCB . putStrLn $ "Exception")-  print l-    where doFail = True+  print lr+    where doFail = not True

@@ -1,5 +1,5 @@ Name:           lio-Version:        0.9.0.1+Version:        0.9.1.0 Cabal-Version:  >= 1.8 Build-type:     Simple License:        GPL@@ -51,6 +51,7 @@   examples/dclabel.hs   examples/gate.hs   examples/waitAndCatch.hs+  examples/bracket.hs   examples/fsExample.hs   examples/LambdaChair/LambdaChair.hs   examples/LambdaChair/LambdaChair/TCB.hs@@ -61,7 +62,7 @@  Source-repository head   Type:     git-  Location: http://www.gitstar.com/scs/lio.git+  Location: ssh://anonymous@gitstar.com/scs/lio.git  Flag toLabeled   Description:@@ -80,8 +81,8 @@    ,directory    >= 1.1.0.2    ,xattr        >= 0.6.1    ,zlib         >= 0.5.3.1-   ,SHA          >= 1.5.0.0 && < 1.6-   ,time         >= 1.2.0.5 && < 1.5+   ,SHA          >= 1.5.0.0+   ,time         >= 1.2.0.5    GHC-options: -Wall -fno-warn-orphans