lio 0.0.2 → 0.1.0
raw patch · 41 files changed
+7309/−2832 lines, 41 filesdep +base64-bytestringdep +cerealdep ~dclabeldep ~unix
Dependencies added: base64-bytestring, cereal
Dependency ranges changed: dclabel, unix
Files
- Examples/LambdaChair/AliceCode.hs +0/−27
- Examples/LambdaChair/BobCode.hs +0/−22
- Examples/LambdaChair/LambdaChair.hs +0/−417
- Examples/LambdaChair/Main.hs +0/−37
- Examples/LambdaChair/Safe.hs +0/−12
- LIO.hs +67/−0
- LIO/Armor.hs +0/−71
- LIO/Base.hs +0/−48
- LIO/Concurrent.hs +92/−0
- LIO/Concurrent/LMVar.hs +14/−0
- LIO/Concurrent/LMVar/Safe.hs +22/−0
- LIO/Concurrent/LMVar/TCB.hs +267/−0
- LIO/DCLabel.hs +21/−17
- LIO/FS.hs +652/−583
- LIO/Handle.hs +290/−166
- LIO/HiStar.hs +0/−151
- LIO/LIO.hs +0/−81
- LIO/LIORef.hs +3/−8
- LIO/LIORef/Safe.hs +6/−4
- LIO/LIORef/TCB.hs +113/−49
- LIO/MonadCatch.hs +58/−29
- LIO/MonadLIO.hs +12/−18
- LIO/Safe.hs +46/−0
- LIO/TCB.hs +1025/−922
- LIO/TmpFile.hs +0/−146
- System/Posix/Tmp.hsc +112/−0
- cbits/HsTmp.c +19/−0
- configure +3666/−0
- configure.ac +13/−0
- examples/LambdaChair/AliceCode.hs +25/−0
- examples/LambdaChair/BobCode.hs +20/−0
- examples/LambdaChair/LambdaChair.hs +420/−0
- examples/LambdaChair/Main.hs +35/−0
- examples/LambdaChair/Safe.hs +10/−0
- examples/fsExample.hs +129/−0
- examples/maskExample.hs +19/−0
- examples/waitAndCatch.hs +25/−0
- include/HsTmp.h +22/−0
- include/HsTmpConfig.h +29/−0
- include/HsTmpConfig.h.in +28/−0
- lio.cabal +49/−24
− Examples/LambdaChair/AliceCode.hs
@@ -1,27 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-{-# LANGUAGE Safe #-}-#else-#warning "This module is not using SafeHaskell"-#endif-module AliceCode ( mainReview ) where--import Safe--findPaper' s = do- ep <- findPaper s- case ep of- Left e -> error $ "Failed with" ++ e- Right p -> return p--mainReview = do- p1 <- findPaper' "Flexible Dynamic"- p2 <- findPaper' "A Static"-- readPaper p1-- appendToReview p1 "Interesting work!"-- readPaper p2- readReview p2- appendToReview p2 "What about adding new users?"
− Examples/LambdaChair/BobCode.hs
@@ -1,22 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-{-# LANGUAGE Safe #-}-#else-#warning "This module is not using SafeHaskell"-#endif-module BobCode ( mainReview ) where--import Safe--findPaper' s = do- ep <- findPaper s- case ep of- Left e -> error $ "Failed with" ++ e- Right p -> return p--mainReview = do- p1 <- findPaper' "Flexible Dynamic..."- p2 <- findPaper' "A Static..."- appendToReview p2 "Hmm, IFC.."- readReview p2- readReview p1
− Examples/LambdaChair/LambdaChair.hs
@@ -1,417 +0,0 @@-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ScopedTypeVariables #-}-module LambdaChair ( evalReviewDC- , addUser- , addPaper- , addConflict- , addAssignment- , asUser- ---- , findPaper- , retrievePaper, readPaper- , retrieveReview, readReview- , appendToReview- , reviewDCPutStrLn - -- TCB- , printUsersTCB- , printReviewsTCB- , reviewDCPutStrLnTCB - , dcPutStrLnTCB - ) where--import Prelude hiding (catch)-import Control.Monad-import Control.Exception (SomeException, ErrorCall(..))-import Control.Monad.State-import Data.Maybe-import Data.List-import Data.Monoid--import LIO.TCB-import LIO.LIORef-import LIO.LIORef.TCB (readLIORefTCB)-import LIO.MonadLIO-import LIO.MonadCatch (throwIO)-import LIO.DCLabel-import DCLabel.Safe-import DCLabel.TCB (Disj(..), Conj(..), Label(..))-import DCLabel.PrettyShow---type ErrorStr = String-type DCLabeled = Labeled DCLabel-type DCRef = LIORef DCLabel---- ^ Clss to with sideffectful show-class DCShowTCB s where- dcShowTCB :: s -> DC String--dcPutStrLnTCB :: String -> DC ()-dcPutStrLnTCB = ioTCB . putStrLn--dcGetLineTCB :: DC String-dcGetLineTCB = ioTCB getLine--type Name = String-type Password = String-type Content = String-type Reviews = String--type Id = Int-data Paper = Paper Content-data Review = Review Content--data User = User { name :: Name- , password :: Password- , conflicts :: [Id]- , assignments :: [Id] }--instance Eq User where- u1 == u2 = name u1 == name u2--instance DCShowTCB User where- dcShowTCB u = do- return $ "Name: " ++ (name u) ++ "\n"- ++ "Password: " ++ (password u) ++ "\n"- ++ "Conflicts: " ++ (show . conflicts $ u) ++ "\n"- ++ "Assignments: " ++ (show . assignments $ u)--data ReviewEnt = ReviewEnt { paperId :: Id- , paper :: DCRef Paper- , review :: DCRef Review }--instance Eq ReviewEnt where- r1 == r2 = paperId r1 == paperId r2--instance DCShowTCB ReviewEnt where- dcShowTCB r = do- (Paper pap) <- readLIORefTCB (paper r)- (Review rev) <- readLIORefTCB (review r)- return $ "ID:" ++ (show . paperId $ r)- ++ "\nPaper:" ++ pap- ++ "\nReviews:" ++ rev----- State related-data ReviewState = ReviewState { users :: [User]- , reviewEntries :: [ReviewEnt]- , curUser :: Maybe Name }--emptyReviewState :: ReviewState-emptyReviewState = ReviewState [] [] Nothing--newtype ReviewDC a = ReviewDC (StateT ReviewState DC a)- deriving (Monad, MonadFix)--liftReviewDC :: DC a -> ReviewDC a-liftReviewDC = ReviewDC . liftLIO--get' :: ReviewDC ReviewState-get' = ReviewDC . StateT $ \s -> return (s,s)--put' :: ReviewState -> ReviewDC ()-put' s = ReviewDC . StateT $ \_ -> return ((),s)--runReviewDC :: ReviewDC a -> ReviewState -> DC (a, ReviewState)-runReviewDC (ReviewDC m) s = runStateT m s--evalReviewDC :: ReviewDC a -> IO (a, DCLabel)-evalReviewDC m = evalDC $ do- (a, s') <- runReviewDC m emptyReviewState- return a------- ^ Get all users-getUsers :: ReviewDC [User]-getUsers = get' >>= return . users---- ^ Get all review entries-getReviews :: ReviewDC [ReviewEnt]-getReviews = get' >>= return . reviewEntries---- ^ Get priviliges-getCurUserName :: ReviewDC (Maybe Name)-getCurUserName = get' >>= return . curUser---- ^ Get curren tuser name-getCurUser :: ReviewDC (Maybe User)-getCurUser = do- n <- getCurUserName- maybe (return Nothing) findUser n---- ^ Get priviliges-getPrivs :: ReviewDC DCPrivTCB-getPrivs = do - u <- getCurUser- return $ maybe mempty (genPrivTCB . name) u---- ^ Write new users-putUsers :: [User] -> ReviewDC ()-putUsers us = do- rs <- getReviews- u <- getCurUserName- put' $ ReviewState us rs u---- ^ Write new reviews-putReviews :: [ReviewEnt] -> ReviewDC ()-putReviews rs = do- us <- getUsers- u <- getCurUserName- put' $ ReviewState us rs u---- ^ Write new privs-putCurUserName :: Name -> ReviewDC ()-putCurUserName u = do- us <- getUsers- rs <- getReviews- put' $ ReviewState us rs (Just u)---- ^ Clear user naem-clearCurUserName :: ReviewDC ()-clearCurUserName = do- us <- getUsers- rs <- getReviews- put' $ ReviewState us rs Nothing---- ^ Find review entry by id-findReview :: Id -> ReviewDC (Maybe ReviewEnt)-findReview pId = do- reviews <- getReviews- return $ find (\e -> paperId e == pId) reviews---- ^ Find user by name-findUser :: Name -> ReviewDC (Maybe User)-findUser n = do- users <- getUsers- return $ find (\u -> name u == n) users ---- ^ Add new (fresh) user-addUser :: Name -> Password -> ReviewDC ()-addUser n p = do- u <- findUser n- unless (isJust u) $ do- let newUser = User { name = n- , password = p- , conflicts = []- , assignments = [] }- us <- getUsers- putUsers (newUser:us)---- ^ Add conflicting paper to user-addConflict :: Name -> Id -> ReviewDC ()-addConflict n i = do- usr <- findUser n- pap <- findReview i- case (usr, pap) of- (Just u, Just _) -> - if i `elem` (assignments u)- then return ()- else do let u' = u { conflicts = i : (conflicts u)}- usrs <- getUsers- putUsers $ u' : (filter (/= u) usrs)- _ -> return ()---- ^ Assign a paper for the user to review-addAssignment :: Name -> Id -> ReviewDC ()-addAssignment n i = do- usr <- findUser n- pap <- findReview i- case (usr, pap) of- (Just u, Just _) -> - if i `elem` (conflicts u)- then return ()- else do let u' = u { assignments = i : (assignments u)}- usrs <- getUsers- putUsers $ u' : (filter (/= u) usrs)- _ -> return ()---- ^ Print users-printUsersTCB :: ReviewDC ()-printUsersTCB = do- users <- getUsers- mapM (liftReviewDC . dcShowTCB) users >>=- reviewDCPutStrLnTCB . (intercalate "\n--\n")---- ^ Print papers and reviews-printReviewsTCB :: ReviewDC ()-printReviewsTCB = do- reviews <- getReviews- mapM (liftReviewDC . dcShowTCB) reviews >>=- reviewDCPutStrLnTCB . (intercalate "\n--\n")---- | Generate privilege from a string-genPrivTCB :: NewPriv a => a -> DCPrivTCB-genPrivTCB = mintTCB . newPriv ---- ^ Create new paper given id and content-newReviewEnt :: Id -> Content -> ReviewDC ReviewEnt-newReviewEnt pId content = do- let p1 = "Paper" ++ (show pId)- r1 = "Review" ++ (show pId)- pLabel = newDC (<>) p1 - rLabel = newDC r1 r1 - privs = genPrivTCB (p1 ./\. r1)- liftReviewDC $ do- rPaper <- newLIORefP privs pLabel (Paper content)- rReview <- newLIORefP privs rLabel (Review "")- return $ ReviewEnt pId rPaper rReview---- ^ Adda new paper to be reviewed-addPaper :: Content -> ReviewDC Id-addPaper content = do- reviews <- getReviews- let pId = 1 + (length reviews)- ent <- newReviewEnt pId content- putReviews (ent:reviews)- return pId----- ^ Given a paper number return the paper-retrievePaper :: Id -> ReviewDC (Either ErrorStr Content)-retrievePaper pId = do- mu <- getCurUser- case mu of- Nothing -> return $ Left "Need to be logged in"- Just u -> do- mRev <- findReview pId - case mRev of - Nothing -> return $ Left "Invalid Id"- Just rev -> let as = assignments u- priv = genPrivTCB (listToLabel $ map id2cat as)- in doReadPaper priv rev- where doReadPaper priv rev = liftReviewDC $ do- (Paper lPaper) <- readLIORefP priv (paper rev)- return (Right lPaper)- id2cat i = MkDisj [principal $ "Review"++(show i)]---- ^ Given a paper number print the paper--- NOTE: in the paper, the functionality of @readPaper@ corresponds to--- that of @retrievePaper@; here, we print out the content.-readPaper :: Id -> ReviewDC ()-readPaper i = retrievePaper i >>= \r -> reviewDCPutStrLn $ show r----- ^ Given a paper/review number return the review, if the entry exists-retrieveReview :: Id -> ReviewDC (Either ErrorStr Content)-retrieveReview pId = do- mRev <- findReview pId - case mRev of - Nothing -> return $ Left "Invalid Id"- Just rev -> do mu <- getCurUser- case mu of- Nothing -> return $ Left "Must login first"- Just u -> doReadReview rev- where doReadReview rev = liftReviewDC $ do- (Review r) <- readLIORef (review rev)- return (Right r)---- ^ Given a paper/review number print the review, if the entry exists-readReview :: Id -> ReviewDC ()-readReview i = retrieveReview i >>= \r -> reviewDCPutStrLn $ show r---- ^ Computer the label of the output' channel-getOutputChLbl :: ReviewDC (DCLabel) -getOutputChLbl = do- mu <- getCurUser- case mu of- Nothing -> liftReviewDC $ throwIO (ErrorCall "No user is logged in.")- Just u -> do- as <- getReviews >>= return . map paperId -- all reviews- let cs = conflicts u -- conflicting reviews- c_cat = map id2conf_cat (cs) -- conflicting categories- nc_cat = map id2cat (as \\ cs) -- noconflicting categories- return $ newDC (listToLabel $ c_cat ++ nc_cat) (<>)- where id2cat i = MkDisj [ principal $ "Review"++(show i)]- id2conf_cat i = MkDisj [ principal $ "Review" ++ (show i)- , principal $ "CONFLICT" ]- --- ^ Print if the current label flows to the output channel label, i.e.,--- there is no conflict of interest.-dcPutStrLn :: DCLabel -> Content -> DC ()-dcPutStrLn lo cont = do- l <- getLabel- if l `leq` lo- then dcPutStrLnTCB cont- else throwIO . ErrorCall $ "Trying to print conflicting review:\n" ++- (prettyShow l) ++ " [/= " ++ (prettyShow lo)---- ^ Main printing function. Print to a labeled output channel.-reviewDCPutStrLn :: String -> ReviewDC ()-reviewDCPutStrLn s = do - l <- getOutputChLbl- liftReviewDC $ dcPutStrLn l $ "-> "++ s--reviewDCPutStrLnTCB :: String -> ReviewDC ()-reviewDCPutStrLnTCB = liftReviewDC . dcPutStrLnTCB---- ^ Given a paper number and review content append to the current review.-appendToReview :: Id -> Content -> ReviewDC (Either ErrorStr ())-appendToReview pId content = do- mRev <- findReview pId - case mRev of - Nothing -> return $ Left "Invalid Id"- Just rev -> do privs <- getPrivs- doWriteReview privs rev content- return $ Right ()- where doWriteReview privs rev content = liftReviewDC $ do- toLabeledP privs ltop $ do- (Review rs) <- readLIORef (review rev)- -- restrict writes: - writeLIORef (review rev) (Review (rs++content))---- ^ Set the current label to the assignments-assign2curLabel :: [Id] -> ReviewDC() -assign2curLabel as = liftReviewDC $ do- let l = newDC (<>) (listToLabel $ map id2cat as)- setLabelTCB l- where id2cat i = MkDisj [principal $ "Review"++(show i)]- --- ^ Safely execute untrusted code-safeExecTCB :: ReviewDC () -> ReviewDC ()-safeExecTCB m = do- s <- get'- s' <- liftReviewDC $ do- cc <- getClearance- cl <- getLabel- (_, s') <- (runReviewDC m s) `catch` - (\(e::SomeException) -> do- dcPutStrLnTCB "-> ERROR: IFC violated\n"- return ((), s))- lowerClrTCB cc- setLabelTCB cl- return s'- put' s'---- ^ Execute on behalf of user-asUser :: Name -> ReviewDC a -> ReviewDC ()-asUser n m = do- putCurUserName n- mu <- getCurUser- case mu of- Nothing -> return ()- Just u -> do- reviewDCPutStrLnTCB $ "| Hi, "++ (name u)++".\n| Password>"- p <- liftReviewDC dcGetLineTCB- if p /= (password u)- then reviewDCPutStrLnTCB "| Failed, try again" >> asUser n m- else do- reviewDCPutStrLnTCB $ "| Executing on behalf of "++(name u)++"...\n"- safeExecTCB $ assign2curLabel (assignments u) >> m >> return ()- clearCurUserName---- | Given a paper prefix return either an error string, if the paper cannot be--- found or the paper id.-findPaper :: String -> ReviewDC (Either ErrorStr Id)-findPaper s = do- revs <- getReviews- res <- mapM (simpleMatch s) revs >>= return . find isJust- case res of- Nothing -> return . Left $ "Could not find paper"- Just i -> return . Right $ fromJust i- -- ^ Fing paper by checking for prefix- where simpleMatch :: String -> ReviewEnt -> ReviewDC (Maybe Id)- simpleMatch s ent = do- (Paper pap) <- liftReviewDC $ readLIORefTCB (paper ent)- if s `isPrefixOf` pap- then return . Just $ paperId ent- else return Nothing
− Examples/LambdaChair/Main.hs
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-{-# LANGUAGE SafeImports #-}-#else-#warning "This module is not using SafeHaskell"-#endif-import LambdaChair-import DCLabel.PrettyShow--#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-import safe AliceCode as Alice-import safe BobCode as Bob-#else-import AliceCode as Alice-import BobCode as Bob-#endif---main :: IO ()-main = printL . evalReviewDC $ do- addUser "Alice" "password"- - p1 <- addPaper "Flexible Dynamic..."- p2 <- addPaper "A Static..."- - addAssignment "Alice" p1- addAssignment "Alice" p2- - asUser "Alice" $ Alice.mainReview- - addUser "Bob" "password"- - addAssignment "Bob" p2- addConflict "Bob" p1-- asUser "Bob" $ Bob.mainReview- where printL m = m >>= (putStrLn . prettyShow . snd)
− Examples/LambdaChair/Safe.hs
@@ -1,12 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-{-# LANGUAGE Trustworthy #-}-#else-#warning "This module is not using SafeHaskell"-#endif-module Safe ( module LambdaChair ) where-import LambdaChair ( findPaper- , retrievePaper, readPaper- , retrieveReview, readReview- , appendToReview- , reviewDCPutStrLn )
+ LIO.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif++{- | This is the main module to be included by code using the Labeled+ IO (LIO) library. The core of the library is documented in the+ "LIO.TCB" module. Note, however, that unprivileged code must not+ be allowed to import "LIO.TCB"--instead, a module "LIO.Safe"+ exports just the safe symbols from "LIO.TCB". This module,+ "LIO", re-exports "LIO.Safe" as well as a few other handy+ modules. For many modules it should be the only import necessary.++ Certain symbols in the LIO library supersede variants in the+ standard Haskell libraries. Thus, depending on the modules+ imported and functions used, you may wish to import LIO with+ commands like these:++ @+ import Prelude hiding ('catch')+ import Control.Exception hiding ('throwIO', 'catch', 'handle', 'onException'+ , 'bracket', 'block', 'unblock')+ import LIO+ @++ The LIO variants of the system functions hidden in the above import+ commands are designed to work in both the IO and LIO monads, making+ it easier to have both types of code in the same module.+++ Warning: For security, at a minimum untrusted code must not be+ allowed to do any of the following:++ * Import "LIO.TCB",++ * Use any symbols with names ending @...TCB@,++ * Use the @foreign@ keyword,++ * Use functions such as 'unsafePerformIO', 'unsafeInterleaveIO',+ 'inlinePerformIO',++ * Use language extensions such as Generalized Newtype+ Deriving and Stand-alone Deriving to extend LIO types+ (such as by deriving an instance of @'Show'@ for 'Lref',+ or deriving an instance of the @'MonadTrans'@ class for+ 'LIO', which would allow untrusted code to bypass all+ security with 'lift'),++ * Manually define @typeOf@ methods (as this would cause the+ supposedly safe 'cast' method to make usafe casts); automatically+ deriving @Typeable@ should be safe.++ * Define new 'Ix' instances (which could produce out of bounds+ array references).++ In general, pragmas and imports should be highly scrutinized.+ For example, most of the "Foreign" class of modules are probably+ dangerous. With GHC 7.2, we use the SafeHaskell extension to enforce+ these restrictions.+-}+module LIO ( module LIO.Safe+ , module LIO.MonadLIO+ ) where++import safe LIO.Safe+import safe LIO.MonadLIO
− LIO/Armor.hs
@@ -1,71 +0,0 @@--- | These functions support a simple base-32 encoding of binary data,--- in which 5 bytes of binary data are mapped onto 8 characters from--- the set {a, ..., k, m, n, p, ..., z, 2, ..., 9} (i.e., all--- lower-case letters and digits except for l, o, 0, and 9).------ The 'armor32' function encodes binary using this base-32 encoding,--- while 'dearmor32' reverses the encoding.------ Binary data is assumed to come from the "Data.ByteString.Lazy" type.-module LIO.Armor (armor32, dearmor32, a2b, b2a, a32Valid) where--import Control.Monad-import Data.Array.Unboxed-import Data.Bits-import qualified Data.ByteString.Lazy as L--- import qualified Data.ByteString.Lazy.Char8 as LC-import Data.Char-import Data.Word--a2b :: UArray Word8 Char-a2b = listArray (0, 31) $ do c <- ['a'..'z'] ++ ['0' .. '9']- guard $ not $ elem c "lo01"- return c--armor32 :: L.ByteString -> String-armor32 str = doit 0 $ L.unpack str- where- doit _ [] = []- doit skip s@(c1:s1) =- let hi = shift c1 (skip - 3) .&. 0x1f- lo = if skip <= 3 || s1 == []- then 0- else shift (head s1) (skip - 11)- c = a2b ! (hi .|. lo)- in if skip >= 3- then c : doit (skip - 3) s1- else c : doit (skip + 5) s--inval :: Word8-inval = -1-b2a :: UArray Char Word8-b2a = accumArray (\_ b -> b) inval (chr 0, chr 255)- $ [(y, x) | (x, y) <- assocs a2b]- -- ++ [(toUpper y, x) | (x, y) <- assocs a2b]--dearmor32 :: String -> L.ByteString-dearmor32 str = doit 0 0 str- where- doit _ _ [] = L.empty- doit carryVal carrySize (c1:s) =- let v = b2a ! c1- in if v == inval- then L.empty- else let needbits = 8 - carrySize- nextCarrySize = 5 - needbits- b = carryVal .|. (shift v (negate nextCarrySize))- nextCarry = shift v (8 - nextCarrySize)- in if nextCarrySize < 0- then doit b (nextCarrySize + 8) s- else L.cons b $ doit nextCarry nextCarrySize s---- | Return 'True' iff the caracter could have been in the output of--- 'armor32'.-a32Valid :: Char -> Bool-a32Valid c = b2a ! c /= inval --{--mask n = complement $ shift (fromInteger $ -1) n-pack s = LC.pack s--}-
− LIO/Base.hs
@@ -1,48 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-{-# LANGUAGE Trustworthy #-}-#else-#warning "This module is not using SafeHaskell"-#endif---- |This file exports the subset of symbols in the "LIO.TCB" module--- that are safe for untrusted code to access. See the "LIO.TCB"--- module for documentation.--module LIO.Base ( POrdering(..), POrd(..), o2po, Label(..)- , Priv(..), NoPrivs(..)- , LIO- , getLabel, setLabelP- , getClearance, lowerClr, lowerClrP, withClearance- , taint, taintP- , wguard, wguardP, aguard, aguardP- , Labeled- , label, labelP- , unlabel, unlabelP- , toLabeled, toLabeledP, discard- , labelOf- , taintLabeled- , LabelFault(..)- , catchP, onExceptionP, bracketP, handleP- , evaluate- , evalLIO- ) where--import LIO.TCB ( POrdering(..), POrd(..), o2po, Label(..)- , Priv(..), NoPrivs(..)- , LIO- , getLabel, setLabelP- , getClearance, lowerClr, lowerClrP, withClearance- , taint, taintP- , wguard, wguardP, aguard, aguardP- , Labeled- , label, labelP- , unlabel, unlabelP- , toLabeled, toLabeledP, discard- , labelOf- , taintLabeled- , LabelFault(..)- , catchP, onExceptionP, bracketP, handleP- , evaluate- , evalLIO- )
+ LIO/Concurrent.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Trustworthy #-}+#endif+-- |This module exposes the concurrent interface to LIO. Specifically,+-- it implements labeled /fork/ ('lFork') and /wait/ ('lWait'). We+-- strongly suggest these primitives over 'toLabeled' as they are+-- termination-senstivie.+module LIO.Concurrent ( lForkP, lFork+ , lWaitP, lWait+ ) where++import LIO.TCB+import LIO.Concurrent.LMVar.TCB+import Control.Concurrent+import Control.Exception (toException)+import Data.Functor++-- | An LIO fork.+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 ()+++-- | Same as 'lFork', but the supplied set of priviliges are accounted+-- for when performing label comparisons.+lForkP :: (LabelState l p s)+ => 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))++ return $ LRes mv+ where mkErr cl e = Left . (LabeledExceptionTCB cl) . toException $ e+ lubErr (LabeledExceptionTCB le e) = LabeledExceptionTCB (l `lub` le) e++-- | Labeled fork. @lFork@ allows one to invoke computations taht+-- would otherwise raise the current label, but without actually+-- raising the label. The computation is executed in a separate thread+-- and writes its result into a labeled result (whose label is+-- supplied). To observe the result of the computation, or if the+-- computation has terminated, one will have to call 'lWait' and+-- raise the current label. Of couse, as in 'toLabeled', this can be+-- postponed until the result is needed.+--+-- @lFork@ takes a label, which corresponds to the label of the+-- 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. +-- +-- Not that, compared to 'toLabeled', @lFork@ immediately returns a+-- labeled result of type 'LRes', which is essentially a \"future\",+-- or \"promise\". Moreover, to guarantee that the computation has+-- completed, it is important that some thread actually touch the+-- future, i.e., perform an 'lWait'.+lFork :: (LabelState l p s)+ => 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++-- | A labeled thread result is simply a wrapper for a labeled MVar. A+-- thread can observe the result of another thread, only after raising+-- its label to the label of the result.+data LRes l a = LRes (LMVar l (Either (LabeledException l) a))++-- | Same as 'lWait', but uses priviliges in label checks and raises.+lWaitP :: (LabelState l p s) => p -> LRes l a -> LIO l p s a+lWaitP p' (LRes mv) = withCombinedPrivs p' $ \p -> do+ ea <- takeLMVarP p mv+ case ea of+ Right x -> return x+ Left e -> ioTCB $ throwIO e++-- | Given a labeled result (a future), @lWait@ returns the unwrapped+-- result (blocks, if necessary). For @lWait@ to succeed, the label of+-- the result must be above the current label and below the current+-- clearnce. Moreover, before block-reading, @lWait@ raises the current+-- label to the join of the current label and label of result.+-- If the thread @lWait@ is terminates with an exception (for example+-- if it violates clearance), the exceptin is rethrown. Similarly, if +-- 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
+ LIO/Concurrent/LMVar.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif+-- |This module implements labeled @MVar@s. The interface is analogous+-- to "Control.Concurrent.MVar", but the operations take place in+-- the LIO monad. Moreover, taking and putting @MVars@ calls a write+-- guard @wguard@ as every read implies a write and vice versa. This+-- module exports only the safe subset (non-TCB) of the @LMVar@ module+-- trusted code can import "LIO.Concurrent.LMVar.TCB".+-- The interface is documented in "LIO.Concurrent.LMVar.TCB".+module LIO.Concurrent.LMVar ( module LIO.Concurrent.LMVar.Safe ) where++import LIO.Concurrent.LMVar.Safe
+ LIO/Concurrent/LMVar/Safe.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Trustworthy #-}+#endif++-- | This module exports a safe subset of the labeled MVar interface.+-- See "LIO.Concurrent.LMVar.TCB" for the documentation.+module LIO.Concurrent.LMVar.Safe ( module LIO.Concurrent.LMVar.TCB ) where++import LIO.Concurrent.LMVar.TCB ( LMVar+ , labelOfLMVar+ , newEmptyLMVar, newEmptyLMVarP+ , newLMVar, newLMVarP+ , takeLMVar, takeLMVarP+ , putLMVar, putLMVarP+ , readLMVar, readLMVarP+ , swapLMVar, swapLMVarP+ , tryTakeLMVar, tryTakeLMVarP+ , tryPutLMVar, tryPutLMVarP+ , isEmptyLMVar, isEmptyLMVarP+ , withLMVar, withLMVarP + )
+ LIO/Concurrent/LMVar/TCB.hs view
@@ -0,0 +1,267 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE SafeImports #-}+#endif+{-|+This module provides an implementation for labeled MVars. A labeled+MVar, of type @'LMVar' l a@, is a mutable location that can be in+of of two states; an 'LMVar' can be empty, or it can be full (with+a value of tye @a@). The location is protected by a label of type+'l'. As in the case of @LIORef@s (see "LIO.LIORef"), this label+is static and does not change according to the content placed into+the location.++'LMVar's can be used to build synchronization primitives and+communication channels ('LMVar's themselves are single-place+channels). We refer to "Control.Concurrent.MVar" for the full+documentation on MVars.+-}+module LIO.Concurrent.LMVar.TCB ( -- * Basic Functions+ LMVar+ , labelOfLMVar+ , newEmptyLMVar, newEmptyLMVarP+ , newLMVar, newLMVarP+ , takeLMVar, takeLMVarP+ , putLMVar, putLMVarP+ , readLMVar, readLMVarP+ , swapLMVar, swapLMVarP+ , tryTakeLMVar, tryTakeLMVarP+ , tryPutLMVar, tryPutLMVarP+ , isEmptyLMVar, isEmptyLMVarP+ , withLMVar, withLMVarP + -- * Unsafe (TCB) Functions+ , newEmptyLMVarTCB+ , newLMVarTCB+ , takeLMVarTCB+ , putLMVarTCB+ , readLMVarTCB+ , swapLMVarTCB+ , tryTakeLMVarTCB+ , tryPutLMVarTCB+ , isEmptyLMVarTCB+ , withLMVarTCB+ ) where++import Control.Concurrent.MVar+import LIO.TCB++-- | An @LMVar@ is a labeled synchronization variable (an 'MVar') that+-- can be used by concurrent threads to communicate.+data LMVar l a = LMVarTCB l (MVar a)++-- | This function returns the label of a labeled MVar.+labelOfLMVar :: Label l => LMVar l a -> l+labelOfLMVar (LMVarTCB l _) = l++-- | Same as 'newEmptyLMVar' except it takes a set of+-- privileges which are accounted for in comparing the label of+-- the MVar to the current label and clearance.+newEmptyLMVarP :: (LabelState l p s) => p -> l -> LIO l p s (LMVar l a)+newEmptyLMVarP p' l = withCombinedPrivs p' $ \p -> do+ aguardP p l+ iom <- ioTCB $ newEmptyMVar+ return $ LMVarTCB l iom++-- | Create a new labeled MVar, in an empty state. Note that the+-- supplied label must be above the current label and below the current+-- clearance.+newEmptyLMVar :: (LabelState l p s)+ => l -- ^ Label of @LMVar@+ -> LIO l p s (LMVar l a) -- ^ New mutable location+newEmptyLMVar l = getPrivileges >>= \p -> newEmptyLMVarP p l++-- | Trusted function used to create an empty @LMVar@, ignoring IFC.+newEmptyLMVarTCB :: (LabelState l p s) => l -> LIO l p s (LMVar l a)+newEmptyLMVarTCB l = do+ iom <- ioTCB $ newEmptyMVar+ return $ LMVarTCB l iom++-- | Same as 'newLMVar' except it takes a set of privileges which are+-- accounted for in comparing the label of the MVar to the current label+-- and clearance.+newLMVarP :: (LabelState l p s) => p -> l -> a -> LIO l p s (LMVar l a)+newLMVarP p' l a = withCombinedPrivs p' $ \p -> do+ aguardP p l+ m <- ioTCB $ newMVar a+ return $ LMVarTCB l m++-- | Create a new labeled MVar, in an filled state with the supplied+-- value. Note that the supplied label must be above the current label+-- and below the current clearance.+newLMVar :: (LabelState l p s)+ => l -- ^ Label of @LMVar@+ -> a -- ^ Initial value of @LMVar@+ -> LIO l p s (LMVar l a) -- ^ New mutable location+newLMVar l a = getPrivileges >>= \p -> newLMVarP p l a++-- | Trusted function used to create an @LMVar@ with the supplied+-- value, ignoring IFC.+newLMVarTCB :: (LabelState l p s) => l -> a -> LIO l p s (LMVar l a)+newLMVarTCB l a = do+ m <- ioTCB $ newMVar a+ return $ LMVarTCB l m++-- | Same as 'takeLMVar' except @takeLMVarP@ takes a privilege object+-- which is used when the current label is raised.+takeLMVarP :: (LabelState l p s) => p -> LMVar l a -> LIO l p s a+takeLMVarP p' (LMVarTCB l m) = withCombinedPrivs p' $ \p -> do+ wguardP p l+ ioTCB $ takeMVar m++-- | Return contents of the 'LMVar'. Note that a take consists of a read+-- and a write, since it observes whether or not the 'LMVar' is full,+-- and thus the current label must be the same as that of the+-- 'LMVar' (of course, this is not the case when using privileges).+-- Hence, if the label of the 'LMVar' is below the current clearance,+-- we raise the current label to the join of the current label and the+-- label of the MVar and read the contents of the @MVar@. If the+-- 'LMVar' is empty, @takeLMVar@ blocks.+takeLMVar :: (LabelState l p s) => LMVar l a -> LIO l p s a+takeLMVar x = getPrivileges >>= \p -> takeLMVarP p x++-- | Read the contents of an 'LMVar', ignoring IFC.+takeLMVarTCB :: (LabelState l p s) => LMVar l a -> LIO l p s a+takeLMVarTCB (LMVarTCB _ m) = ioTCB $ takeMVar m++-- | Same as 'putLMVar' except @putLMVarP@ takes a privilege object+-- which is used when the current label is raised.+putLMVarP :: (LabelState l p s) => p -> LMVar l a -> a -> LIO l p s ()+putLMVarP p' (LMVarTCB l m) a = withCombinedPrivs p' $ \p -> do+ wguardP p l+ val <- ioTCB $ putMVar m a+ return val++-- | Puts a value into an 'LMVar'. Note that a put consists of a read+-- and a write, since it observes whether or not the 'LMVar' is empty,+-- and so the current label must be the same as that of the 'LMVar'+-- (of course, this is not the case when using privileges). As in the+-- 'takeLMVar' case, if the label of the 'LMVar' is below the current+-- clearance, we raise the current label to the join of the current+-- label and the label of the MVar and put the value into the @MVar@.+-- If the 'LMVar' is full, @putLMVar@ blocks.+putLMVar :: (LabelState l p s)+ => LMVar l a -- ^ Source 'LMVar'+ -> a -- ^ New value+ -> LIO l p s ()+putLMVar x a = getPrivileges >>= \p -> putLMVarP p x a++-- | Put a value into an 'LMVar', ignoring IFC.+putLMVarTCB :: (LabelState l p s) => LMVar l a -> a -> LIO l p s ()+putLMVarTCB (LMVarTCB _ m) a = ioTCB $ putMVar m a++-- | Same as 'readLMVar' except @readLMVarP@ takes a privilege object+-- which is used when the current label is raised.+readLMVarP :: (LabelState l p s) => p -> LMVar l a -> LIO l p s a+readLMVarP p' (LMVarTCB l m) = withCombinedPrivs p' $ \p -> do+ wguardP p l+ ioTCB $ readMVar m ++-- | Combination of 'takeLMVar' and 'putLMVar'. Read the value, and just+-- put it back. As specified for 'readMVar', this operation is atomic+-- iff there is no other thread calling 'putLMVar' for this 'LMVar'.+readLMVar :: (LabelState l p s) => LMVar l a -> LIO l p s a+readLMVar x = getPrivileges >>= \p -> readLMVarP p x++-- | Trusted function used to read (take and put) an 'LMVar', ignoring IFC.+readLMVarTCB :: (LabelState l p s) => LMVar l a -> LIO l p s a+readLMVarTCB (LMVarTCB _ m) = ioTCB $ readMVar m++-- | Same as 'swapLMVar' except @swapLMVarP@ takes a privilege object+-- which is used when the current label is raised.+swapLMVarP :: (LabelState l p s) => p -> LMVar l a -> a -> LIO l p s a+swapLMVarP p' (LMVarTCB l m) x = withCombinedPrivs p' $ \p -> do+ wguardP p l+ ioTCB $ swapMVar m x++-- | Takes a value from an 'LMVar', puts a new value into the 'LMvar',+-- and returns the taken value. Like the other 'LMVar' operations it+-- is required that the label of the 'LMVar' be above the current label+-- and below the current clearance. Moreover, the current label is raised+-- to accommodate for the observation. This operation is atomic iff+-- there is no other thread calling 'putLMVar' for this 'LMVar'.+swapLMVar :: LabelState l p s + => LMVar l a -- ^ Source @LMVar@+ -> a -- ^ New value+ -> LIO l p s a -- ^ Taken value+swapLMVar x a = getPrivileges >>= \p -> swapLMVarP p x a++-- | Trusted function that swaps value of 'LMVar', ignoring IFC.+swapLMVarTCB :: LabelState l p s => LMVar l a -> a -> LIO l p s a+swapLMVarTCB (LMVarTCB _ m) x = ioTCB $ swapMVar m x++-- | Same as 'tryTakeLMVar', but uses priviliges when raising current label.+tryTakeLMVarP :: (LabelState l p s)+ => p -> LMVar l a -> LIO l p s (Maybe a)+tryTakeLMVarP p' (LMVarTCB l m) = withCombinedPrivs p' $ \p -> do+ wguardP p l+ ioTCB $ tryTakeMVar m++-- | Non-blocking version of 'takeLMVar'. It returns @Nothing@ if the+-- 'LMVar' is empty, otherwise it returns @Just@ value, emptying the 'LMVar'.+tryTakeLMVar :: LabelState l p s => LMVar l a -> LIO l p s (Maybe a)+tryTakeLMVar x = getPrivileges >>= \p -> tryTakeLMVarP p x++-- | Same as 'tryTakeLMVar', but ignorses IFC.+tryTakeLMVarTCB :: LabelState l p s => LMVar l a -> LIO l p s (Maybe a)+tryTakeLMVarTCB (LMVarTCB _ m) = ioTCB $ tryTakeMVar m++-- | Same as 'tryPutLMVar', but uses privileges when raising current label.+tryPutLMVarP :: (LabelState l p s)+ => p -> LMVar l a -> a -> LIO l p s Bool+tryPutLMVarP p' (LMVarTCB l m) x = withCombinedPrivs p' $ \p -> do+ wguardP p l+ ioTCB $ tryPutMVar m x++-- | Non-blocking version of 'putLMVar'. It returns @True@ if the+-- 'LMVar' was empty and the put succeeded, otherwise it returns @False@.+tryPutLMVar :: LabelState l p s => LMVar l a -> a -> LIO l p s Bool+tryPutLMVar x a = getPrivileges >>= \p -> tryPutLMVarP p x a++-- | Same as 'tryPutLMVar', but ignorses IFC.+tryPutLMVarTCB :: LabelState l p s => LMVar l a -> a -> LIO l p s Bool+tryPutLMVarTCB (LMVarTCB _ m) x = ioTCB $ tryPutMVar m x+++-- | Same as 'isEmptyLMVar', but uses privileges when raising current label.+isEmptyLMVarP :: (LabelState l p s) => p -> LMVar l a -> LIO l p s Bool+isEmptyLMVarP p' (LMVarTCB l m) = withCombinedPrivs p' $ \p -> do+ taintP p l+ ioTCB $ isEmptyMVar m++-- | Check the status of an 'LMVar', i.e., whether it is empty. The+-- function succeeds if the label of the 'LMVar' is below the current+-- clearance -- the current label is raised to the join of the 'LMVar'+-- label and the current label. Note that this function only returns a+-- snapshot of the state.+isEmptyLMVar :: LabelState l p s => LMVar l a -> LIO l p s Bool+isEmptyLMVar x = getPrivileges >>= \p -> isEmptyLMVarP p x++-- | Same as 'isEmptyLMVar', but ignorses IFC.+isEmptyLMVarTCB :: LabelState l p s => LMVar l a -> LIO l p s Bool+isEmptyLMVarTCB (LMVarTCB _ m) = ioTCB $ isEmptyMVar m++-- | Same as 'withLMVar', but uses privileges when performing label+-- comparisons/raises.+withLMVarP :: (LabelState l p s)+ => p -> LMVar l a -> (a -> LIO l p s b) -> LIO l p s b+withLMVarP p' m@(LMVarTCB l _) io = withCombinedPrivs p' $ \p -> do+ wguardP p l+ withLMVarTCB m io++-- | Exception-safe wrapper for working with an 'LMVar'. The original+-- contents of the 'LMVar' will be restored if the supplied action throws+-- an exception. The function is atomic only if there is no other+-- thread that performs a 'putLMVar'.+withLMVar :: LabelState l p s+ => LMVar l a -> (a -> LIO l p s b) -> LIO l p s b+withLMVar m io = getPrivileges >>= \p -> withLMVarP p m io++-- | Same as 'withLMVar', but ignores IFC.+withLMVarTCB :: LabelState l p s+ => LMVar l a -> (a -> LIO l p s b) -> LIO l p s b+withLMVarTCB m io =+ mask $ \restore -> do+ a <- takeLMVarTCB m+ b <- restore (io a) `onExceptionTCB` putLMVarTCB m a+ putLMVarTCB m a+ return b
LIO/DCLabel.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) {-# LANGUAGE Trustworthy #-}-#else-#warning "This module is not using SafeHaskell" #endif {-| This module provides bindings for the @DCLabel@ module, with some @@ -21,19 +19,20 @@ -- * Renamed privileges , DCPriv, DCPrivTCB -- * Useful aliases for the LIO Monad- , DCLabeled, DC, evalDC+ , DCLabeled, DC, evalDC, evalDCWithRoot )where import LIO.TCB +import LIO.Handle (evalWithRoot)+ #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) import safe Data.Typeable #else import Data.Typeable #endif -import DCLabel.Safe hiding ( Label- , Priv+import DCLabel.Safe hiding ( Priv , bottom , top , join@@ -43,17 +42,16 @@ deriving instance Typeable DCL.Disj deriving instance Typeable DCL.Conj-deriving instance Typeable DCL.Label+deriving instance Typeable DCL.Component deriving instance Typeable DCL.DCLabel -instance POrd DCLabel where- leq = DCL.canflowto instance Label DCLabel where lbot = DCL.bottom ltop = DCL.top lub = DCL.join glb = DCL.meet+ leq = DCL.canflowto instance PrivTCB DCL.TCBPriv @@ -87,21 +85,21 @@ , not (lp `DCL.implies` (c2l [c]))] rs'' = c2l [c | c <- getCats gs , not (rs' `DCL.implies` (c2l [c]))]- rs = rs' `DCL.and_label` rs''- ri = (li `DCL.and_label` lp) `DCL.or_label` gi+ rs = rs' `DCL.and_component` rs''+ ri = (li `DCL.and_component` lp) `DCL.or_component` gi in DCL.toLNF $ simpleNewLabel p (newDC rs ri)- where getCats = DCL.conj . DCL.label- c2l = DCL.MkLabel . DCL.MkConj- simpleNewLabel p lr | p == DCL.rootPrivTCB = g - | p == DCL.noPriv = l `lub` g- | otherwise = lr+ where getCats = DCL.conj . DCL.component+ c2l = DCL.MkComponent . DCL.MkConj+ simpleNewLabel pr lr | pr == DCL.rootPrivTCB = g + | pr == DCL.noPriv = l `lub` g+ | otherwise = lr -- -- Renaming -- -- | A @DCLabel@ category set.-type DCCatSet = DCL.Label+type DCCatSet = DCL.Component -- | A @DCLabel@ (untrusted) privilege. type DCPriv = DCL.Priv -- | A @DCLabel@ privilege.@@ -112,13 +110,19 @@ -- LIO aliases -- +instance LabelState DCLabel DCPrivTCB () where+ -- | The type for 'Labeled' values uinsg 'DCLabel' as the label. type DCLabeled a = Labeled DCLabel a -- | The monad for LIO computations using 'DCLabel' as the label.-type DC = LIO DCLabel ()+type DC = LIO DCLabel DCPrivTCB () -- | Runs a computation in the LIO Monad, returning both the -- computation's result and the label of the result. evalDC :: DC a -> IO (a, DCLabel) evalDC m = evalLIO m ()++-- | Same as 'evalDC', but with support for filesystem.+evalDCWithRoot :: FilePath -> Maybe DCLabel -> DC a -> IO (a, DCLabel)+evalDCWithRoot path ml act = evalWithRoot path ml act ()
LIO/FS.hs view
@@ -1,583 +1,652 @@-{-# LANGUAGE DeriveDataTypeable #-}--{- |This module manages a file store in which a label is associated- with every file and directory. The file store is grouped into- directories by label. Files are stored under names like:-- > LabelHash/OpaqueName-- where LabelHash is a SHA-224 hash of the label, and OpaqueName is- either a regular file (containing contents) or a directory- populated exclusively by symbolic links pointing back into- LabelHash directories. Each LabelHash directory also has a file- called-- > LabelHash/LABEL-- which actually contains the label of all the files in that directory.-- There is also a symbolic link @root@, pointing to the root- directory. For efficiency, @LabelHash@ actually consists of- multiple directories.-- There are two externally-visible abstractions. The first is- 'Name', which refers to a file name in a user directory, of the- form:-- > LabelHash/OpaqueName/UserName-- There is also a special 'Name', 'rootDir', which refers to the- root directory. Untrusted user code has access to the 'rootDir'- 'Name', and can walk the tree from there using the 'lookupName'- function. The "LIO.Handle" module contains functions 'mkDir' and- 'mkLHandle' which permit untrusted code to make new 'Name's as- well as to do handle-based IO on protected files.-- The second is 'Node', which refers to one of the @OpaqueName@s- that 'Name's point to. Currently, any functions that operate on- 'Node's are in the IO Monad so as not to be executable by- untrusted code. This is important because in order to use a file,- someone must have the right to know know that the file exists, and- this requires read permission on the file's 'Name'. It would be- insecure if untrusted code could execute openNode in the LIO- Monad.-- Note that if a machine crashes, the code in this module could- leave the filesystem in an inconsistent state. However, the code- tries to maitain the invariant that any inconsistencies will- either be:-- 1. temporary files or directories whose names end with the- \"@~@\" character, or-- 2. dangling symbolic links.-- Both of these inconsistencies can be checked and cleaned up- locally without examining the whole file system. The code tries- to fix up these inconsistencies on-the-fly as it encounters them.- However, it could possibly lieave some stranded temporary- @LABEL...~@ files. You could also end up with some weirdness like- a file that shows up in getDirectoryContents, but that you can't- open for reading.-- To keep from having to examine the whole file system to fix- errors, the code tries to maintain the invariant that if a- 'Node'\'s file name doesn't end with @~@, then there must be a- link pointing to it somewhere. This is why the code uses a- separate 'NewNode' type to represent a 'Node' whose name ends @~@.- The function 'linkNode' renames the 'NewNode' to a name without a- trailing @~@ only after creating a 'Name' that points to the- permenent 'Node' path.-- Assuming a file system that preserves the order of metadata- operations, the code should mostly be okay to recover from any- crashes. If using soft updates, which can re-order metadata- operations, you could end up with symbolic links that point- nowhere.-- In the worst case scenario if inconsistencies develop, you can- manually fix up the file system by deleting all danglinng symbolic- links and all files and directories ending @~@. Make sure no- application is concurrently accessing the file system, however.---}--module LIO.FS ( -- * The opaque name object- Name -- Do not Export constructor! Names are TRUSTED- , rootDir- , getRootDir, mkRootDir- , lookupName, mkTmpDirL- -- * Initializing the file system- , initFS- -- * Internal data structures- , Node- -- * Helper functions in the IO Monad- , labelOfName, labelOfNode, nodeOfName- , mkNode, mkNodeDir, mkNodeReg, linkNode- , lookupNode, openNode, getDirectoryContentsNode- -- * Misc. utility functions- , tryPred- ) where--import LIO.Armor-import LIO.TCB-import LIO.TmpFile--import Prelude hiding (catch)--import Control.Exception hiding (throwIO, catch, onException)-import Control.Monad-import qualified Data.ByteString.Lazy.Char8 as LC-import Data.Typeable--- import qualified GHC-import qualified GHC.IO.Exception as GHC (IOErrorType(..))-import System.Directory-import System.FilePath-import System.IO-import System.IO.Error hiding (catch, try)--- import System.FilePath-import System.Posix.Files-import System.Posix.Process--import Data.Digest.Pure.SHA-------- Utility functions-----strictReadFile :: FilePath -> IO LC.ByteString-strictReadFile f = withFile f ReadMode readit- where readit h = do- size <- hFileSize h- LC.hGet h $ fromInteger size--catchIO :: IO a -> IO a -> IO a-catchIO a h = catch a ((const :: a -> IOException -> a) h)--catchPred :: Exception e => (e -> Bool) -> IO a -> IO a -> IO a-catchPred predicate a h = catchJust test a runh- where- test e = if predicate e then Just () else Nothing- runh () = h--tryPred :: Exception e => (e -> Bool) -> IO a -> IO (Either e a)-tryPred predicate a = tryJust test a- where- test e = if predicate e then Just e else Nothing--ignoreErr :: IO () -> IO ()-ignoreErr m = catch m ((\_ -> return ()) :: IOException -> IO ())---- |Delete a name whether it's a file or directory, by trying both.--- This is slow, but only used for error conditions when performance--- shouldn't matter.-clean :: FilePath -> IO ()-clean path =- removeFile path `catchIO` (removeDirectory path `catchIO` return ())------- Exceptions thrown by this module-----data FSErr- = FSCorruptLabel FilePath -- ^ File Containing Label is Corrupt- deriving (Show, Typeable)-instance Exception FSErr------- LDir functions-----prefix :: FilePath-prefix = "ls"---- | File name in which labels are stored in 'LDir's.-labelFile :: FilePath-labelFile = "LABEL"---- | File name of root directory for each label-rootFile :: FilePath-rootFile = "ROOT"---- | Type containing the pathname of a @LabelHash@ directory (which--- must contain a file named 'labelFile').-newtype LDir = LDir FilePath deriving (Show)---- | The subdirectory depth of 'LDir's. Because many file systems--- have linear lookup time in large directories, it is better to use--- the first few characters of the hash of a label as subdirectories.--- Putting all hash values into one huge directory would get slow.-lDirNdirs :: Int-lDirNdirs = 3---- | Hash a label down to the directory storing all 'Node's with that--- label.-lDirOfLabel :: (Label l) => l -> LDir-lDirOfLabel l =- LDir $ doit lDirNdirs prefix hash- where- hash = armor32 $ bytestringDigest $ sha224 $ LC.pack $ show l- doit 0 out h = out </> h- doit n out (c:h) = doit (n - 1) (out </> [c]) h- doit _ _ _ = error "lDirOfLabel bad sha"--{---- | Minimally validate that an LDir is in the right part of the file--- system, or throw 'FSIllegalPath'.-checkLDir :: LDir -> IO ()-checkLDir (LDir path) = do- dirlist <- liftM splitDirectories $ checkpref path- unless (length dirlist == 1 + lDirNdirs && all (all a32Valid) dirlist) bad- where- bad = throwIO $ FSIllegalPath path- checkpref p = case stripPrefix prefix p of- Just (c:r) | isPathSeparator c -> return r- _ -> bad--}---- | 'LDir' that contains a 'Node'-lDirOfNode :: Node -> LDir-lDirOfNode (NodeTCB n) = LDir $ takeDirectory n---- | 'LDir' that contains the directory that contains a file name.-lDirOfName :: (Label l) => Name l -> LDir-lDirOfName (NameTCB n) = LDir $ takeDirectory $ takeDirectory n-lDirOfName (RootDir l) = lDirOfLabel l---- |Takes an LDir and returns the label stored in 'labelFile' in that--- directory. May throw 'FSCorruptLabel'.-labelOfLDir :: (Label l) => LDir -> IO l-labelOfLDir (LDir p) = do- s <- strictReadFile target `catch` diagnose- parseit s- where- target = (p </> labelFile)- parseit s = case reads $ LC.unpack s of- (l, "\n"):_ -> return l- _ -> throwIO $ FSCorruptLabel target- diagnose e | isDoesNotExistError e = do- exists <- doesDirectoryExist p- if exists- then throwIO $ FSCorruptLabel target- else throwIO e- | otherwise = throwIO e---- |Gets the LDir for a particular label. Creates it if it does not--- exist. May throw 'FSCorruptLabel'.-getLDir :: Label l => l -> IO LDir-getLDir l = try (labelOfLDir ldir) >>= handler- where- ldir@(LDir dir) = lDirOfLabel l- handler (Right l')- | l' == l = return ldir- | otherwise = dumplabel >> throwIO (FSCorruptLabel dir)- handler (Left e) =- case fromException e of- Just e' | isDoesNotExistError e' -> makedir- _ -> dumplabel >> throwIO e- makelabel path = withFile path WriteMode $ \h -> do- hPutStr h $ shows l "\n"- hSync h- -- Mostly unnecessary paranoia here, but one thread could create- -- the label file, then another thread could overwrite it as the- -- first thread is renaming the LDir~ -> LDir. If after that- -- there's a power failure, then the label file could be- -- corrupted. This way we ensure that once the LABEL file is in- -- place, it never gets overwritten.- makesafelabel path = do- pid <- getProcessID- tmp <- tmpName- let tpath = path ++ "." ++ show pid ++ "." ++ tmp ++ newNodeExt- makelabel tpath- flip finally (ignoreErr $ removeLink tpath) $- catch (createLink tpath path) $- \e -> unless (isAlreadyExistsError e) (throwIO e)- makedir = do- let tdir = dir ++ newNodeExt- createDirectoryIfMissing True tdir- makesafelabel $ tdir </> labelFile- rename tdir dir- return ldir- dumplabel = ignoreErr $ makelabel $ dir </> (labelFile ++ ".correct")------- Node functions------- |The @Node@ type represents filenames of the form--- @LabelHash\/OpaqueName@. These names must always point to regular--- files or directories (not symbolic links). There must always exist--- a file @LabalHash\/LABEL@ specifying the label of a @Node@.-newtype Node = NodeTCB FilePath deriving (Show)---- |When a @Node@ is first created, it has a file name with a \'~\'--- character at the end. This is so that in the case of a crash, a--- node that was not linked to can be easily recognized and deleted.--- The @NewNode@ type wrapper represents a node that is not yet linked--- to.-newtype NewNode = NewNode Node deriving (Show)---- |String that gets appended to new file names. After a crash these--- may need to be garbage collected.-newNodeExt :: String-newNodeExt = "~"---- |Label protecting the contents of a node.-labelOfNode :: (Label l) => Node -> IO l-labelOfNode = labelOfLDir . lDirOfNode---- | Create new Node in the appropriate directory for a given label.--- The node gets created with an extra ~ appended, and wrapped in the--- type 'NewNode' to reflect this fact.-mkNode :: (Label l) => l- -- ^Label for the new node- -> (FilePath -> String -> IO (a, FilePath))- -- ^Either 'mkTmpDir' or 'mkTmpFile' with curried 'IOMode'- -> IO (a, NewNode)- -- ^Returns file handle or () and destination path-mkNode l f = do- (LDir d) <- getLDir l- (a, p) <- f d newNodeExt- -- We are done, except if we got really unlucky someone else may- -- have created a node with the same name at the same time. (The- -- node creation is exclusive, but we append newNodeExt, so someone- -- might have renamed it before we created the newNodeExt file- -- exclusively.) We simply start over if someone claimed the name- -- in the mean time.- let p' = take (length p - length newNodeExt) p- exists <- catchIO (getFileStatus p' >> return True) (return False)- if not exists- then return (a, NewNode $ NodeTCB p')- else do- hPutStrLn stderr $ "mkNode: file " ++ p' ++ " already exists." -- XXX- clean p- mkNode l f---- |Wrapper around mkNode to create a directory.-mkNodeDir :: (Label l) => l -> IO NewNode-mkNodeDir l = liftM snd (mkNode l mkTmpDir)---- |Wrapper around mkNode to create a regular file.-mkNodeReg :: (Label l) => IOMode -> l -> IO (Handle, NewNode)-mkNodeReg m l = mkNode l (mkTmpFile m)---- | Used when creating a symbolic link named @src@ that points to--- @dst@. If both @src@ and @dst@ are relative to the current working--- directory and in subdirectories, then the contents of the symbolic--- link cannot just be @dst@, instead it is @makeRelativeTo dst src@.-makeRelativeTo :: FilePath -- ^ Destination of symbolic link- -> FilePath -- ^ Name of symbolic link- -> FilePath -- ^ Returns contents to put in symbolic link-makeRelativeTo dest src =- doit (splitDirectories dest) (init $ splitDirectories src)- where- doit [] [] = "."- doit (d1:ds) (s1:ss) | d1 == s1 = doit ds ss- doit d s = joinPath (replicate (length s) ('.':'.':pathSeparator:[]) ++ d)---- | Assign a 'Name' to a 'NewNode', turning it into a 'Node'. Note--- that unlike the Unix file system, only a single link may be created--- to each node.-linkNode :: (Label l) => NewNode -> Name l -> IO Node-linkNode (NewNode (NodeTCB path)) name' = do- let name = pathOfName name'- tpath = path ++ newNodeExt- createSymbolicLink (path `makeRelativeTo` name) name `onException` clean tpath- -- The next line really shouldn't fail except for some catastrophic- -- IO error. See the comment in mkNode.- rename tpath path `onException` removeFile name- return $ NodeTCB path---- | It's possible that either a program crashed before renaming a--- 'NewNode' into a 'Node', or that another thread is calling--- 'linkNode' and for some reason is being slow betweeen the--- 'createSymbolicLink' and 'rename' calls. Either way it should be--- fine for us just to 'rename' the 'NewNode', because the 'Name'--- would not exist if the 'NewNode' were not ready to be renamed.-fixNode :: Node -> (FilePath -> IO a) -> IO a-fixNode (NodeTCB file) action = action file `catch` fixup- where- fixup e | isDoesNotExistError e = do- ignoreErr $ rename (file ++ newNodeExt) file- action file- fixup e = throwIO e---- | Thie function just calls 'openFile' on the filename in a 'Node'.--- However, on the off chance that the file system is in an--- inconsistent state (e.g., because of a crash during a call to--- 'linkNode'), it tries to finish creating a partially created--- 'Node'.-openNode :: Node -> IOMode -> IO Handle-openNode node mode = fixNode node $ flip openFile mode---- | Thie function is a wrapper around 'getDirectoryContents' that--- tries to fixup errors analogously to 'openNode'.-getDirectoryContentsNode :: Node -> IO [FilePath]-getDirectoryContentsNode node = fixNode node getDirectoryContents------- Name functions---- --- |The @Name@ type represents user-chosen (non-opaque) filenames of--- symbolic links, either @\"root\"@ or pathnames of the form--- @LabelHash\/OpaqueName\/filename@. Intermediary components of the--- file name must not be symbolic links.-data Name l = NameTCB FilePath- | RootDir l- deriving (Show)---- |Label protecting the name of a file. Note that this is the label--- of the directory containing the file name, not the label of the--- Node that the file name designates.-labelOfName :: (Label l) => Name l -> IO l-labelOfName (RootDir l) = return l-labelOfName n = labelOfLDir $ lDirOfName n--{--unlinkName :: (FilePath -> IO ()) -> Name -> IO ()-unlinkName f (NameTCB name) = do- (Node node) <- nodeOfName (NameTCB name)- f node- removeFile name---- |Remove a directory by name.-unlinkNameDir = unlinkName removeDirectory---- |Remove a regular file by name.-unlinkNameReg = unlinkName removeFile--}- --- | This function reads the contents of a symbolic link and returns--- the pathname of its destination, relative to the current working--- directory. It elides ".." components at the begining of the--- symbolic link contents, so that if the link @foo\/bar -> ..\/baz@--- exists, @expandLink \"foo\/bar\"@ will return @\"foo\/baz\"@.------ /Warning:/ This function assumes no itermediary components of the--- path to the symbolic link are also symbolic links.-expandLink :: FilePath -> IO FilePath-expandLink path = do- suffix <- catchPred (\e -> ioeGetErrorType e == GHC.InvalidArgument)- (readSymbolicLink path) (return "")- return $ if (isAbsolute suffix)- then suffix- else domerge (takeDirectory path) suffix- where- domerge [] suffix = suffix- domerge p [] = p- domerge p ('.':'.':ps:suffix) | ps == pathSeparator =- domerge (takeDirectory p) suffix- domerge p suffix = p </> suffix--pathOfName :: (Label l) => Name l -> FilePath-pathOfName (NameTCB n) = n-pathOfName (RootDir l) = case lDirOfLabel l of (LDir ldir) -> ldir </> rootFile---- | 'Node' that a 'Name' is pointing to.-nodeOfName :: (Label l) => Name l -> IO Node-nodeOfName n = liftM NodeTCB $ expandLink $ pathOfName n---- | Gives the 'Name' of a directory entry in a directory 'Node'.-nodeEntry :: (Label l) => Node -> FilePath -> Name l-nodeEntry (NodeTCB node) name = NameTCB (node </> name)---mkRootDirIO :: (Label l) => l -> IO (Name l)-mkRootDirIO label = do- let name = RootDir label- exists <- doesDirectoryExist $ pathOfName name- unless exists $ do- new <- mkNodeDir label- linkNode new name >> return ()- return name--defRoot :: FilePath-defRoot = prefix </> rootFile--initFS :: (Label l) => l -> IO ()-initFS l = do- name <- mkRootDirIO l- (NodeTCB node) <- nodeOfName name- let root = node `makeRelativeTo` defRoot- root' <- catchIO (readSymbolicLink defRoot) $- createSymbolicLink root defRoot >> return root- when (root' /= root) $ error "default root doesn't match requested label"- ------- LIO Monad function------- | Return the root directory for the default root label. (There is--- a root directory for each label, but only one label is the--- default.)-rootDir :: (Label l) => LIO l s (Name l)-rootDir = return $ NameTCB $ defRoot---- | Get the root directory for a particular label.-getRootDir :: (Label l) => l -> Name l-getRootDir l = RootDir l---- | Creates a root directory for a particular label.-mkRootDir :: (Priv l p) => p -> l -> LIO l s (Name l)-mkRootDir priv label = do- wguardP priv label- name <- rtioTCB $ mkRootDirIO label- return name---- | Looks up a FilePath, turning it into a 'Name', and raising to--- current label to reflect all directories traversed. Note that this--- only looks up a 'Name'; it does not ensure the 'Name' actually--- exists. The intent is that you call @lookupName@ before creating--- or opening files.------ Note that this function will touch bad parts of the file system if--- it is supplied with a malicous 'Name'. Thus, it is important to--- keep the constructor of 'Name' private, so that the only way for--- user code to generate names is to start with 'rootDir' and call--- @lookupName@.-lookupName :: (Priv l p) =>- p -- ^ Privileges to limit tainting- -> Name l -- ^ Start point- -> FilePath -- ^ Name to look up- -> LIO l s (Name l)-lookupName priv start path = - dolookup start (stripslash $ splitDirectories path)- where- stripslash ((c:_):t) | c == pathSeparator = t- stripslash t = t- dolookup name [] = return name- dolookup name (".":rest) = dolookup name rest- dolookup _ ("..":_) = throwIO $ mkIOError doesNotExistErrorType- "illegal filename" Nothing (Just ".." )- dolookup name@(RootDir label) (cn:rest) = do- taintP priv label- node <- rtioTCB $ nodeOfName name- dolookup (nodeEntry node cn) rest- dolookup name (cn:rest) = do- -- XXX next thing should deal with partially created nodes- node <- rtioTCB $ nodeOfName name -- Could fail if name deleted- label <- ioTCB $ labelOfNode node -- Shouldn't fail- taintP priv label- dolookup (nodeEntry node cn) rest--lookupNode :: (Priv l p) =>- p -- ^ Privileges to limit tainting- -> Name l -- ^ Start point (e.g., 'rootDir')- -> FilePath -- ^ Name to look up- -> Bool -- ^ True if you want to write it- -> LIO l s Node-lookupNode priv start path write = do- name <- lookupName priv start path- node <- rtioTCB $ nodeOfName name- label <- ioTCB $ labelOfNode node- if write then wguardP priv label else taintP priv label- return node---- | Creates a temporary directory in an existing directory (or--- label-specific root directory, if the 'Name' argument comes from--- 'getRootDir').-mkTmpDirL :: (Priv l p) =>- p -- ^ Privileges to minimize tainting- -> l -- ^ Label for the new directory- -> Name l -- ^ 'Name' of dir in which to create directory- -> String -- ^ Suffix for name of directory- -> LIO l s (FilePath, Name l)- -- ^ Returns both name in directory and 'Name' of new directory-mkTmpDirL priv label name suffix = do- aguard label- ensureRoot name- (NodeTCB node) <- lookupNode priv name "" True- aguard label- (NewNode (NodeTCB new)) <- rtioTCB $ mkNodeDir label- let tnew = new ++ newNodeExt- target = new `makeRelativeTo` (node </> "x")- (_, tname) <- rtioTCB $ mkTmp (createSymbolicLink target) node suffix- `onExceptionTCB` clean tnew- rtioTCB $ rename tnew new `onExceptionTCB` removeFile tname- return $ (takeFileName tname, NameTCB tname)- where- ensureRoot (RootDir l) = mkRootDir priv l >> return ()- ensureRoot _ = return ()+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE SafeImports #-}+#endif+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE ScopedTypeVariables #-}++{- | This module implements a labeled filesystem as a file store in+ which a label is associated with every file and directory. The+ module "LIO.Handle" provides an interface for working with labeled+ directories and files -- this module provides the underlying+ low-level (mostly trusted) interface.++ The file store contains 3 components:++ * @.magic@ file containing a sequence of pre-defined bytes. The+ existence of this file and correct contents indicates that+ the file store and root of the labeled filesystem were created+ before any system crash.++ * @.obj@ directory containing all the objects (files and+ directories) in the filesystem, organized according to the+ object's label.++ * @ROOT@ symbolic link pointing to a directory object in @.obj@,+ representing the root of the filesystem.++ As the details of @.magic@ and @ROOT@ are straight forward, we+ now focus on the details of @.obj@.++ Each object is stored in @.obj@ in a directory corresponding+ to the label of the file. For example, an object protected by+ @bob@'s label will exist as:++ > .obj/oTAUzOt5YoQAyThw89eSgWuig-0=/obj012345++ where @oTAUzOt5YoQAyThw89eSgWuig-0=@ is the base64url encoding of+ the (SHA-224 hash of) label @bob@, and @obj012345@ is the object's+ name. Each label directory also contains a @.label@ file whose+ contents correspond to the serialization of the label. Hence, for+ example,++ > .obj/oTAUzOt5YoQAyThw89eSgWuig-0=/.label++ would have @bob@'s label.+ + Every object in a label directory is either a file or a directory.+ If the object is a directory, its contents will strictly have+ symbolic links to objects in the file store. This is more easily+ understood using an example.++ Consider the following familiar filesystem layout, containing 4+ directories and 2 files:++ >+ > /+ > |-- bobOralice (type: directory, label: bob \/ alice)+ > | |-- alice (type: directory, label: alice)+ > | |-- bob (type: directory, label: bob)+ > | | '-- secret (type: file , label: bob)+ > | '-- messages (type: file , label: bob \/ alice)+ > '-- clarice (type: directory, label: clarice)+ >++ Suppose we take @/lioFS@ as the location of the file store for our+ labeled filesystem. The above files and directories will have the+ same layout in our file system, but each file/directory points to+ an object in the object store (@.obj@), as shown below. ++ >+ > /lioFS/ROOT+ > |-- bobOralice -> ../../c_EkXYGrmrSit9j_8VjP_-8DgaM=/objXIBabq+ > | |-- alice -> ../../12to8q3vDp7ApyKEQk2LQ_2nrvs=/objqZeR5w+ > | |-- bob -> ../../oTAUzOt5YoQAyThw89eSgWuig-0=/objtsePnc+ > | | '-- secret -> ../../oTAUzOt5YoQAyThw89eSgWuig-0=/objFIQCIm+ > | '-- messages -> ../../c_EkXYGrmrSit9j_8VjP_-8DgaM=/objQaiwuA+ > '-- clarice -> ../../wordEFmBzWc7Q6qP-TetDgZaG8A=/objOMh0mj+ >++ Note that, to a user, the interface (see "LIO.Handle") is+ unchanged and they do not need to handle or understand the+ underlying file store. We refer to this view as \"friendly\". The+ file store for the above layout is:++ >+ > /lioFS/+ > |-- .magic+ > |-- .obj+ > | |-- 12to8q3vDp7ApyKEQk2LQ_2nrvs=+ > | | |-- .label (=alice's label)+ > | | '-- objqZeR5w+ > | |-- c_EkXYGrmrSit9j_8VjP_-8DgaM=+ > | | |-- .label (=label bob \/ alice)+ > | | |-- objQaiwuA+ > | | '-- objXIBabq+ > | | |-- alice -> ../../12to8q3vDp7ApyKEQk2LQ_2nrvs=/objqZeR5w+ > | | |-- bob -> ../../oTAUzOt5YoQAyThw89eSgWuig-0=/objtsePnc+ > | | '-- messages -> ../../c_EkXYGrmrSit9j_8VjP_-8DgaM=/objQaiwuA+ > | |-- jX7q5Kb8_G4GsjgNpOHB17kypQo=+ > | | |-- .label (=label of the filesystem root)+ > | | '-- objTj5JZD+ > | | |-- bobOralice -> ../../c_EkXYGrmrSit9j_8VjP_-8DgaM=/objXIBabq+ > | | '-- clarice -> ../../wordEFmBzWc7Q6qP-TetDgZaG8A=/objOMh0mj+ > | |-- oTAUzOt5YoQAyThw89eSgWuig-0=+ > | | |-- .label (=bob's label)+ > | | |-- objFIQCIm+ > | | '-- objtsePnc+ > | | '-- secret -> ../../oTAUzOt5YoQAyThw89eSgWuig-0=/objFIQCIm+ > | '-- wordEFmBzWc7Q6qP-TetDgZaG8A=+ > | |-- .label (=clarice's label)+ > | '-- objOMh0mj+ > '-- ROOT -> .obj/jX7q5Kb8_G4GsjgNpOHB17kypQo=/objTj5JZD+ >++ Observe that every directory object contains symbolic links+ pointing to file or directory objects in the store.++ Accessing any file or directory in the \"friendly\" view requires+ a lookup ('lookupObjPath') of the corresponding object. Each+ path is, however, relative to the root. So, for example,+ looking up @\/aliceOrbob\/bob\/@ actually corresponds to looking+ up @\/lioFS\/ROOT\/aliceOrbob\/bob\/@. This prevents untrusted code+ from accessing objects by guessing filenames and further allows+ untrusted code to pick arbitrary filenames (including @.label@,+ @.obj@, etc.).++ Several precautions are taken to keep the filesystem in a working+ state in case of a crash. The code tries to maintain the invariant+ that any inconsistencies will either be:++ 1. temporary files or directories whose names start with the+ \"@#@\" character, or++ 2. dangling symbolic links.++ Both of these inconsistencies can be checked and cleaned up+ locally without examining the whole file system. The code tries+ to fix up these inconsistencies on-the-fly as it encounters them.+ However, it could possibly leave some stranded temporary+ @.label@ files. ++-}+++module LIO.FS ( evalWithRoot+ -- * Creating and finding (labeled) objects+ , lookupObjPath, lookupObjPathP+ , getObjLabelTCB+ , createFileTCB, createDirectoryTCB+ -- * Labeled 'FilePath'+ , LFilePath, labelOfFilePath+ , unlabelFilePath+ , unlabelFilePathP+ , unlabelFilePathTCB+ -- * Misc helper functions+ , cleanUpPath, stripSlash+ ) where+++import Prelude hiding (catch)+import LIO.TCB +import Control.Monad (unless)+import System.FilePath+import System.Posix.Files+import System.Directory+import Control.Exception (Exception)+import qualified Control.Exception as E+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as LB+import qualified Data.ByteString.Char8 as C+import Data.Serialize+import Data.IORef+import Data.Functor+import Data.Tuple (swap)+import Data.Foldable (foldlM)+import Data.Typeable+import Data.List (isPrefixOf)+import System.IO.Unsafe+import System.IO+import qualified System.IO.Error as IOError++import qualified Data.ByteString.Base64.URL as Codec+import qualified Data.Digest.Pure.SHA as SHA++#if __GLASGOW_HASKELL__ >= 706+import System.Posix.Temp +#else+-- Patch to unix package will not be up on Hackage until GHC 7.6, so+-- we include the implementation with LIO until this is the case+import System.Posix.Tmp +#endif+++--+-- Filesystem root+--+++-- | Root of labeled filesystem.+rootDir :: IORef FilePath+{-# NOINLINE rootDir #-}+rootDir = unsafePerformIO $ newIORef undefined++getRootDir :: IO FilePath+getRootDir = readIORef rootDir++-- | Temporary files have the prefix \'#\'.+tmpPrefix :: FilePath+tmpPrefix = "#"++-- | Prefix of object filenames.+objPrefix :: FilePath+objPrefix = "obj"++-- | Shadow directory containing the actual FS objects.+objDir :: FilePath+objDir = ".obj"++-- | We need to serialize the label in each label directory.+labelFile :: FilePath+labelFile = ".label"++-- | Root of the filesystem.+rootLink :: FilePath+rootLink = "ROOT"++-- | Magic file. Last file created when the the filesystem is+-- initially created. If the magic file is invalid, then it is likely+-- that a failure occured in the set up process.+magicFile :: FilePath+magicFile = ".magic"++-- | Content written to magic file. +magicContent :: B.ByteString+magicContent = B.pack [ 0x7f, 0x45, 0x4c, 0x46, 0x01+ , 0x01, 0x01, 0x00, 0x00, 0x00+ , 0x00, 0x00, 0x00, 0x00, 0x00+ , 0x00, 0xde, 0xad, 0xbe, 0xef]++-- | Filesystem errors+data FSErr = FSRootCorrupt -- ^ Root structure is corrupt+ | FSRootInvalid -- ^ Root is invalid (must be absolute).+ deriving Typeable++instance Exception FSErr++instance Show FSErr where+ show FSRootCorrupt = "Root structure is corrupt"+ show FSRootInvalid = "Root is invalid (must be absolute)"+ ++-- | Same as 'evalLIO', but takes two additional parameters+-- corresponding to the path of the labeled filesystem store and the+-- label of the root. If the labeled filesystem store does not exist,+-- it is created at the specified path with the root having the+-- supplied label.+-- If the filesystem does exist, the supplied label is ignored and thus+-- unnecessary. However, if the root label is not provided and the+-- filesystem has not been initialized, then 'lbot' is used as the+-- root label.+evalWithRoot :: (Serialize l, LabelState l p s)+ => FilePath -- ^ Filesystem root+ -> Maybe l -- ^ Label of root+ -> LIO l p s a -- ^ LIO action+ -> s -- ^ Initial state+ -> IO (a, l)+evalWithRoot path ml act s = setRootOrInitFS >> evalLIO act s+ where setRootOrInitFS = do+ unless (isAbsolute path) $ throwIO FSRootInvalid+ exists <- doesDirectoryExist path+ let l = maybe lbot id ml+ if exists+ then checkFS path+ else initFS l path++-- | Initialize the filesystem with a given label and root file path.+initFS :: (Label l, Serialize l)+ => l -- ^ Label of root+ -> FilePath -- ^ Path to the filesystem root+ -> IO ()+initFS l path = do+ unless (isAbsolute path) $ throwIO FSRootInvalid+ -- Create root of filesystem+ createDirectory path+ -- Create the shadow object store+ createDirectory (path </> objDir)+ `onException` (removeDirectory path)+ -- Set the root filesystem:+ writeIORef rootDir path+ rootObj <- newDirObj l+ linkRoot rootObj+ -- Create magic file:+ B.writeFile (path </> magicFile) magicContent++-- | Check the filesystem structure.+checkFS :: FilePath -> IO ()+checkFS path = do+ -- check that the ROOT link exists+ rootStat <- getSymbolicLinkStatus $ path </> rootLink+ unless (isSymbolicLink rootStat) $ throwIO FSRootCorrupt+ -- find obj dir:+ hasObjDir <- doesDirectoryExist $ path </> objDir+ unless hasObjDir $ throwIO FSRootCorrupt+ -- check magic file:+ magicOK <- (B.readFile (path </> magicFile) >>= \c -> return (c==magicContent))+ `catchIO` (return False)+ unless magicOK $ throwIO FSRootCorrupt+ writeIORef rootDir path+++--+-- Objects+-- ++-- | Encoding of a label into a filepath. We need to take the hash+-- of a label (as opposed to e.g. just 64-base encoding of the label)+-- in order to keep the filename lengths to a reasonable size.+encodeLabel :: (Serialize l, Label l) => l -> FilePath+encodeLabel l = enc . SHA.bytestringDigest . SHA.sha1 $ encodeLazy l+ where enc = C.unpack . Codec.encode . B.concat . LB.toChunks++-- | An object can be a directory or a file.+data Object = DirObj FilePath -- ^ Directory object+ | FileObj Handle FilePath -- ^ File object+ deriving (Eq, Show)++-- | A wrapper for a new, not yet commited, object.+newtype NewObject = New Object+ deriving (Eq, Show)++-- | Create a new directory object with a given label.+newDirObj :: (Serialize l, Label l) => l -> IO NewObject+newDirObj l = newObj l $ \p -> (New . DirObj) <$> mkTmpObjDir p++-- | Create a new file object with a given label and 'IOMode'.+newFileObj :: (Serialize l, Label l) => l -> IOMode -> IO NewObject+newFileObj l m = newObj l $ \p -> (New . uncurry FileObj) <$> mkTmpObjFile m p++-- | Create a new temporary unique object directory. The function retries if+-- there exists an object with the same name but no 'tmpPrefix'.+mkTmpObjDir :: FilePath -> IO FilePath+mkTmpObjDir path = do+ dir <- mkdtemp $ path </> (tmpPrefix ++ objPrefix) + exists <- doesDirectoryExist (rmTmpPrefix dir)+ if exists+ then do ignoreErr $ removeDirectory dir+ mkTmpObjDir path+ else return dir+++-- | Create a new temporary unique object file. The function retries if+-- there exists an object with the same name but no 'tmpPrefix'.+mkTmpObjFile :: IOMode -> FilePath -> IO (Handle, FilePath)+mkTmpObjFile mode path = do+ res@(file, h) <- mkstemp $ path </> (tmpPrefix ++ objPrefix)+ exists <- doesFileExist (rmTmpPrefix file)+ if exists+ then do hClose h + ignoreErr $ removeFile file+ mkTmpObjFile mode path+ else return . swap $ res++-- | Create a new file or directory object (given the make temporary+-- object functino). For example, we can create a new file object as:+--+-- > newDirObj l = newObj l $ \p -> (New . DirObj) <$> mkTmpObjDir p+--+-- or a new directory object as+--+-- > newFileObj l m = newObj l $ \p ->+-- > (New . uncurry FileObj) <$> mkTmpObjFile m p)+-- +newObj :: (Serialize l, Label l)+ => l -- ^ Label of object+ -> (FilePath -> IO NewObject) -- ^ Object creation function+ -> IO NewObject+newObj l mkFunc = getLabelDir l >>= mkFunc++-- | Create the label directory (and corresponding 'labelFile') in 'objDir'.+getLabelDir :: (Serialize l, Label l) => l -> IO FilePath+getLabelDir l = do+ oRoot <- (</> objDir) <$> getRootDir+ let dir = oRoot </> encodeLabel l+ createDirectoryIfMissing True dir+ createLabelFileIfMissing dir l+ return dir++-- | This function creates a 'labelFile' for the given label+-- directory. It also verifies that the label in the file is the+-- same as the given label (as another thread might have created the+-- file, or a previous write might have corrupted the file). If the+-- file is invalid, it removes the existing label file and writes+-- the given label. An assumption made here is that there is a 1-to-1+-- correspondence between a label and its encoding (i.e., 'encodeLabel'+-- is a bijection).+createLabelFileIfMissing :: (Serialize l, Label l) => FilePath -> l -> IO ()+createLabelFileIfMissing dir l = do+ let file = dir </> labelFile+ exists <- doesFileExist file+ unless exists $ createLabelFile file+ -- It's possible for another thread to have created the file, and so+ -- we need to make sure that we agree on the label:+ valid <- checkLabelFile file+ unless valid $ (ignoreErr $ removeFile file) >> createLabelFileIfMissing dir l+ where createLabelFile file = do+ (h,f) <- mkTmpObjFile WriteMode dir+ C.hPutStr h (encode l)+ hClose h+ rename f file `E.catch` (\e -> + removeFile f >> unless (IOError.isAlreadyExistsError e) (throwIO e))+ checkLabelFile file = do+ c <- B.readFile file+ case decode c of+ Left _ -> return False+ Right l' -> return (l == l')+++-- | Link the 'rootLink' to an object directory.+linkRoot :: NewObject -> IO ()+linkRoot newO@(New o) = do+ root <- getRootDir+ newObjPath <- case o of+ DirObj p -> return p+ _ -> throwIO . userError $ "Root must be a directory."+ let objPath = rmTmpPrefix newObjPath+ let name = root </> rootLink+ createSymbolicLink (objPath `rmPrefixDir` root) name+ `onException` (cleanUpNewObj newO)+ rename newObjPath objPath `onException` (do ignoreErr $ removeFile name+ cleanUpNewObj newO)++-- | Link without returning object.+linkObj_ :: FilePath -> NewObject -> IO ()+linkObj_ f n = linkObj f n >> return ()+++-- | Link a filepath to an object.+linkObj :: FilePath -> NewObject -> IO Object+linkObj name' newO@(New o) = do+ root <- getRootDir+ let newObjPath = case o of+ DirObj p -> p+ FileObj _ p -> p+ objPath = rmTmpPrefix newObjPath+ let name = root </> rootLink </> name'+ relObjPath = (".." </> ".." </> (objPath `rmPrefixDir` (root </> objDir)))+ createSymbolicLink relObjPath name `onException` (cleanUpNewObj newO)+ rename newObjPath objPath `onException` (do ignoreErr $ removeFile name+ cleanUpNewObj newO)+ return $ case o of+ DirObj _ -> DirObj objPath+ FileObj h _ -> FileObj h objPath++-- | It's possible that either a program crashed before renaming a+-- 'NewObject' into a 'Object', or that another thread is calling+-- 'linkObj' and for some reason is being slow between the+-- 'createSymbolicLink' and 'rename' calls. Either way it should be+-- fine for us just to 'rename' the 'NewObject', because the link to+-- the object would not exist if the 'NewObject' were not ready to be+-- renamed. This function is primarily used when traversing the+-- filesystem tree with 'pathTaintTCB'.+fixObjLink :: FilePath -> IO ()+fixObjLink f = do+ exists <- catchIO (getFileStatus f >> return True) (return False)+ unless exists $ ignoreErr $ rename (tmpPrefix ++ f) f++-- | Clean up a newly created object. If the object is a temporary+-- directory, remove it. If it's a file, close the handle, and remove+-- the file.+cleanUpNewObj :: NewObject -> IO ()+cleanUpNewObj (New o) = ignoreErr $ case o of + DirObj p -> removeDirectory p+ FileObj h p -> hClose h >> removeFile p++-- | 'Label' associated with a 'FilePath'.+newtype LFilePath l = LFilePathTCB (Labeled l FilePath)++-- | Get the label of a labeled filepath.+labelOfFilePath :: Label l => LFilePath l -> l+labelOfFilePath (LFilePathTCB x) = labelOf x++-- | Trusted version of 'unlabelFilePath' that ignores IFC.+unlabelFilePathTCB :: (Label l) => LFilePath l -> FilePath+unlabelFilePathTCB (LFilePathTCB l) = unlabelTCB l++-- | Same as 'unlabelFilePath' but uses privileges to unlabel the+-- filepath.+unlabelFilePathP :: (LabelState l p s)+ => p -> LFilePath l -> LIO l p s FilePath+unlabelFilePathP p' (LFilePathTCB l) = withCombinedPrivs p' $ \p -> unlabelP p l++-- | Unlabel a filepath. If the path corresponds to a directory, you+-- can now get the contents of the directory; if it's a file, you can+-- open the file.+unlabelFilePath :: LabelState l p s+ => LFilePath l -> LIO l p s FilePath+unlabelFilePath f = getPrivileges >>= \p -> unlabelFilePathP p f++-- | Given a pathname (forced to be relative to the root of the+-- labeled filesystem), find the path to the corresponding object.+-- The current label is raised to reflect all the directories traversed.+-- Note that if the object does not exist an exception will be thrown;+-- the label of the exception will be the join of all the directory labels +-- up to the lookup failure.+--+-- Additionally, this function cleans up the+-- path before doing the lookup, so e.g., path @/foo/bar/..@ will+-- first be rewritten to @/foo@ and thus no traversal to @bar@.+-- Note that this is a more permissive behavior than forcing the read+-- of @..@ from @bar@.+lookupObjPath :: (LabelState l p s, Serialize l)+ => FilePath -- ^ Path to object+ -> LIO l p s (LFilePath l)+lookupObjPath f = getPrivileges >>= \p -> lookupObjPathP p f++-- | Same as 'lookupObjPath' but takes an additional privilege object+-- that is exercised when raising the current label.+lookupObjPathP :: (LabelState l p s, Serialize l)+ => p -- ^ Privilege + -> FilePath -- ^ Path to object+ -> LIO l p s (LFilePath l)+lookupObjPathP p' f' = withCombinedPrivs p' $ \p -> do+ f <- cleanUpPath f'+ root <- ioTCB $ getRootDir+ pathTaintTCB p root rootLink+ let dirs = splitDirectories f+ dir <- foldlM (\a b -> pathTaintTCB p a b >> return (a </> b))+ (root </> rootLink)+ (safeinit dirs)+ let objPath = (dir </> safelast dirs)+ l <- getObjLabelTCB objPath+ return . LFilePathTCB $ labelTCB l objPath+ where safelast [] = ""+ safelast x = last x+++-- | Read the label file of an object. Note that because the format+-- of the supplied path is not checked this function is considered to+-- be in the @TCB@.+getObjLabelTCB :: (Serialize l, LabelState l p s) => FilePath -> LIO l p s l+getObjLabelTCB objPath = rtioTCB $ do+ root <- getRootDir+ symLink <- readSymbolicLink objPath+ let absObjPath = root </> objDir </>+ ((symLink `rmPrefixDir` (".." </> ".."))+ `rmPrefixDir` objDir)+ lS <- C.readFile $ (takeDirectory absObjPath) </> labelFile+ case decode lS of+ Left _ -> throwIO . userError $ "Invalid label file."+ Right l -> return l ++-- | Given a privilege, root-path prefix and a directory/file within+-- the prefix, read the 'labelFile' of the root-path prefix, raising+-- the current label to reflect this. This function is used to taint +-- a process that traverses a filesystem tree. The function is @TCB@+-- because we do not check any properties of the root -- it is+-- primarily used by 'lookupObjPathP'.+pathTaintTCB :: (Serialize l, LabelState l p s)+ => p -> FilePath -> FilePath -> LIO l p s ()+pathTaintTCB p root f' = do+ let f = stripSlash f'+ rootL <- rtioTCB $ readSymbolicLink (root </> f)+ let objPath = root </> rootL+ ioTCB $ fixObjLink objPath+ lS <- rtioTCB $ C.readFile (objPath </> ".." </> labelFile)+ case decode lS of+ Left _ -> throwIO . userError $ "Invalid label file."+ Right l -> taintP p l++-- | Remove any 'pathSeparator's from the front of a file path.+stripSlash :: FilePath -> FilePath +stripSlash [] = []+stripSlash xx@(x:xs) | x == pathSeparator = stripSlash xs+ | otherwise = xx++-- | Cleanup a file path, if it starts out with a @..@, we consider+-- this invalid as it can be used explore parts of the filesystem+-- that should otherwise be unaccessible. Similarly, we remove any @.@+-- from the path.+cleanUpPath :: LabelState l p s => FilePath -> LIO l p s FilePath +cleanUpPath f = rtioTCB $ doit $ splitDirectories . normalise . stripSlash $ f+ where doit [] = return []+ doit ("..":[]) = return "/"+ doit ("..":_) = throwIO $ IOError.mkIOError IOError.doesNotExistErrorType+ "Illegal filename" Nothing (Just ".." )+ doit (_:"..":xs) = doit xs+ doit (".":xs) = doit xs+ doit (x:xs) = (x </>) <$> doit xs+ ++--+-- Creating and linking directory and file objects+--++-- | Create a directory object with the given label and link the+-- supplied path to the object.+createDirectoryTCB :: (Serialize l, Label l) => l -> FilePath -> IO ()+createDirectoryTCB l p = do+ obj <- newDirObj l+ linkObj_ p obj++-- | Create a file object with the given label and link the+-- supplied path to the object. The handle to the file is returned.+createFileTCB :: (Serialize l, Label l) => l -> FilePath -> IOMode -> IO Handle+createFileTCB l p m = do+ obj <- newFileObj l m+ (FileObj h _) <- linkObj p obj+ return h++++--+-- Helper functions+--++-- | Remove the prefix from a list (usually 'FilePath').+rmPrefix :: Eq a => [a] -- ^ String+ -> [a] -- ^ Prefix+ -> [a]+rmPrefix s pre = if pre `isPrefixOf` s+ then drop (length pre) s+ else s++-- | Remove the 'tmpPrefix' prefix from a file or directory.+rmTmpPrefix :: FilePath -> FilePath+rmTmpPrefix path =+ let ds = splitDirectories path+ in (joinPath $ safeinit ds) + </> ((last ds) `rmPrefix` tmpPrefix)+++-- | @rmPrefixDir path prefix@ removes @prefix@ from @path@.+rmPrefixDir :: FilePath -> FilePath -> FilePath+rmPrefixDir path prefix = + if prefix `isPrefixOf` path+ then let p = splitDirectories path+ x = splitDirectories prefix+ in joinPath $ drop (length x) p+ else path++-- | Ignore 'IOException's.+ignoreErr :: IO () -> IO ()+ignoreErr m = catchIO m (return ())++-- | Same as 'catch', but only catches 'IOException's.+catchIO :: IO a -> IO a -> IO a+catchIO a h = E.catch a ((const :: a -> E.IOException -> a) h)++-- | Same as 'init', but does not crash on empty list.+safeinit :: [a] -> [a]+safeinit [] = []+safeinit x = init x
LIO/Handle.hs view
@@ -1,221 +1,345 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) {-# LANGUAGE Trustworthy #-}-#else-#warning "This module is not using SafeHaskell" #endif {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FunctionalDependencies #-} --- |This module abstracts the basic 'FileHandle' methods provided by--- the system library, and provides an 'LHandle' (Labeled Handle) type--- that can be manipulated from within the 'LIO' Monad. Two lower--- level functions, 'mkDir' and 'mkLHandle' may be useful for--- functions that wish to open file names that are not relative to--- 'rootDir'. (There is no notion of changeable current working--- directory in the 'LIO' Monad.)+-- | This module abstracts the basic 'FileHandle' methods provided by+-- the system library, and provides an 'LHandle' ('Labeled' 'Handle')+-- type that can be manipulated from within the 'LIO' Monad.+-- (There is no notion of changeable current working directory in+-- the 'LIO' Monad, nor symbolic links.) -- -- The actual storage of labeled files is handled by the "LIO.FS" -- module.-module LIO.Handle ( DirectoryOps(..)- , CloseOps (..)- , HandleOps (..)- , LHandle- , hlabelOf- , mkDir, mkLHandle- , readFile, writeFile- , createDirectoryPR, openFilePR, writeFilePR- , createDirectoryP, openFileP, writeFileP+--+-- /IMPORTANT:/ To use a labeled filesystem you must use 'evalWithRoot',+-- otherwise any actions built using the combinators of this module will+-- crash.+--+-- An example use is shown below: +--+-- >+-- > main = dcEvalWithRoot "/tmp/lioFS" $ do+-- > createDirectoryP p lsecrets "secrets"+-- > writeFileP p ("secrets" </> "alice" ) "I like Bob!"+-- > where p = ...+-- > lsecrets = ....+-- >+--+-- The file store for the labeled filesystem (see "LIO.FS") will+-- be created in @\/tmp\/lioFS@, but this is transparent and the user+-- can think of the filesystem as having root @/@.+module LIO.Handle (+ -- * LIO with filesystem support+ evalWithRoot+ -- * Generic Handle operations+ , DirectoryOps(..)+ , CloseOps(..)+ , HandleOps(..)+ , readFile, writeFile, writeFileL , IOMode(..)+ -- * LIO Handle+ , LHandle, labelOfHandle + -- ** Privileged combinators+ , getDirectoryContentsP+ , createDirectoryP+ , openFileP+ , hCloseP+ , hFlushP + , hGetP+ , hGetNonBlockingP+ , hGetContentsP+ , hPutP+ , hPutStrP+ , hPutStrLnP+ , readFileP, writeFileP, writeFileLP ) 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 Prelude hiding (catch, readFile, writeFile)+import safe System.IO (IOMode(..)) import safe qualified System.IO as IO-import safe qualified System.IO.Error as IO- #else+import Prelude hiding (catch, readFile, writeFile)+import System.IO (IOMode(..))+import qualified System.IO as IO+#endif -import Prelude hiding (readFile, writeFile)-import qualified Data.ByteString.Lazy as L+import LIO.TCB+import LIO.FS+import Data.Serialize import qualified System.Directory as IO-import System.IO (IOMode)-import qualified System.IO as IO-import qualified System.IO.Error as IO+import System.FilePath+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as LC -#endif +-- | Class used to abstract reading and creating directories, and+-- opening (possibly creating) files. class (Monad m) => DirectoryOps h m | m -> h where- getDirectoryContents :: FilePath -> m [FilePath]- createDirectory :: FilePath -> m ()- openFile :: FilePath -> IO.IOMode -> m h+ -- | Get the contents of a directory.+ getDirectoryContents :: FilePath -> m [FilePath]+ -- | Create a directory at the supplied path.+ -- The LIO instance labels the directory with the current label.+ createDirectory :: FilePath -> m ()+ -- | Open handle to manage the file at the supplied path.+ openFile :: FilePath -> IOMode -> m h +-- | Class used to abstract close and flush operations on handles. class (Monad m) => CloseOps h m where- hClose :: h -> m ()- hFlush :: h -> m ()+ hClose :: h -> m ()+ hFlush :: h -> m () +-- | Class used to abstract reading and writing from and to handles,+-- respectively. 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 ()+ 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 () +--+-- Standard IO Handle Operations+--+ instance DirectoryOps IO.Handle IO where- getDirectoryContents = IO.getDirectoryContents- createDirectory = IO.createDirectory- openFile = IO.openBinaryFile+ getDirectoryContents = IO.getDirectoryContents+ createDirectory = IO.createDirectory+ openFile = IO.openBinaryFile instance CloseOps IO.Handle IO where- hClose = IO.hClose- hFlush = IO.hFlush+ 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+ hGet = L.hGet+ hGetNonBlocking = L.hGetNonBlocking+ hGetContents = L.hGetContents+ hPut = L.hPut+ hPutStrLn = LC.hPutStrLn -data LHandle l h = LHandleTCB l h+--+-- LIO Handle Operations+-- -instance (Label l) => MintTCB (LHandle l IO.Handle) (IO.Handle, l) where- mintTCB (h, l) = LHandleTCB l h+-- | A labeled handle.+data LHandle l = LHandleTCB l IO.Handle -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+-- | Get the label of a labeled handle.+labelOfHandle :: Label l => LHandle l -> l+labelOfHandle (LHandleTCB l _) = l -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 (Serialize l, LabelState l p s)+ => DirectoryOps (LHandle l) (LIO l p s) where+ getDirectoryContents f = getPrivileges >>= \p -> getDirectoryContentsP p f+ createDirectory f = do l <- getLabel + p <- getPrivileges+ createDirectoryP p l f+ openFile f m = do l <- getLabel + p <- getPrivileges+ openFileP p (Just l) f m -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)+-- | Get the contents of a directory. The current label is raised to+-- the join of the current label and that of all the directories+-- traversed to the leaf directory (of course, using privileges to+-- keep the current label unchanged when possible). Note that, unlike+-- the standard Haskell 'getDirectoryContents', we first normalise the+-- path by collapsing all the @..@'s. (The LIO filesystem does not+-- support links.)+getDirectoryContentsP :: (LabelState l p s, Serialize l)+ => p -- ^ Privilege+ -> FilePath -- ^ Directory+ -> LIO l p s [FilePath]+getDirectoryContentsP p' dir = withCombinedPrivs p' $ \p -> do+ path <- lookupObjPathP p dir >>= unlabelFilePathP p+ rtioTCB $ IO.getDirectoryContents path +-- | Create a directory at the supplied path with the given label.+-- The current label (after traversing the filesystem to the+-- directory path) must flow to the supplied label which in turn must+-- flow to the current label (of course, using privileges to bypass+-- certain restrictions). If this information flow restriction is+-- satisfied, the directory is created.+createDirectoryP :: (LabelState l p s, Serialize l)+ => p -- ^ Privilege+ -> l -- ^ Label of new directory+ -> FilePath -- ^ Path of directory+ -> 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 -hlabelOf :: (Label l) => LHandle l h -> l-hlabelOf (LHandleTCB l _) = l +-- | Given a set of privileges, a new (maybe) label of a file, a filepath+-- and the handle mode, open (and possibly create) the file. If the file +-- exists the supplied label is not necessary; otherwise it must be supplied.+-- The current label is raised to reflect all the traversed directories +-- (of course, using privileges to minimize the taint). Additionally the+-- label of the file (new or existing) must be between the current label+-- and clearance. If the file is created, it is further required that the +-- current process be able to write to the containing directory.+openFileP :: (LabelState l p s, Serialize l)+ => p -- ^ Privileges+ -> Maybe l -- ^ Label of file if created+ -> FilePath -- ^ File to open+ -> IOMode -- ^ Mode of handle+ -> 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+ -- check that the supplied label is bounded by current label and clearance:+ maybe (return ()) (aguardP priv) mlfile+ -- lookup object corresponding to containing dir:+ lcDir <- lookupObjPathP priv containingDir + -- unlabel the containing dir object:+ actualCDir <- unlabelFilePathP priv lcDir + let objPath = actualCDir </> fileName -- actual object path+ exists <- rtioTCB $ IO.doesFileExist objPath+ if exists+ then do l <- getObjLabelTCB objPath -- label of object+ aguardP priv l -- make sure we can actually read the file+ -- NOTE: if mode == ReadMode, we might want to instead do+ -- aguardP priv (l `lub` currentLabel) to allow opening + -- a handle for an object whose label is below the current+ -- label. Some Unix systems still update a file's atime+ -- when performing a read and so, for now, a read always+ -- implies a write.+ 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) -- can write to containing dir+ aguardP priv l -- make sure we can actually read the file+ -- NOTE: the latter is necessary as looking up the containing+ -- directory object might have raised the current label.+ h <- ioTCB $ createFileTCB l objPath mode+ return $ LHandleTCB l h+ +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 -mkDir :: (Priv l p) =>- p -- ^Privileges- -> l -- ^Label for the new directory- -> Name l -- ^Start point- -> FilePath -- ^Name to create- -> LIO l s () -mkDir priv l start path = do- -- No privs when checking clearance, as we assume it was lowered for a reason- aguard l - name <- lookupName priv start path- dirlabel <- ioTCB $ labelOfName name- wguardP priv dirlabel- new <- ioTCB $ mkNodeDir l- _ <- rtioTCB $ linkNode new name- return ()+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 -mkLHandle :: (Priv l p) =>- p -- ^Privileges to minimize taint- -> l -- ^Label if new file is created- -> Name l -- ^Starting point of pathname- -> FilePath -- ^Path of file relative to prev- -> IO.IOMode -- ^Mode of handle- -> 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 -- lookupName may have changed label- (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+-- | Close a labeled file handle.+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) -readFile :: (DirectoryOps h m, HandleOps h b m) => FilePath -> m b-readFile path = openFile path IO.ReadMode >>= hGetContents+-- | Flush a labeled file handle.+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) -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)+-- | Read @n@ bytes from the labeled handle, using privileges when+-- performing label comparisons and tainting.+hGetP :: (LabelState l p s, HandleOps IO.Handle b IO)+ => p -- ^ Privileges+ -> LHandle l -- ^ Labeled handle+ -> Int -- ^ Number of bytes to read+ -> LIO l p s b+hGetP p' (LHandleTCB l h) n = withCombinedPrivs p' $ \p ->+ wguardP p l >> rtioTCB (hGet h n) -createDirectoryPR :: (Priv l p) => p -> Name l -> FilePath -> LIO l s ()-createDirectoryPR privs start path = do- l <- getLabel- mkDir privs l start path+-- | Same as 'hGetP', but will not block waiting for data to become+-- available. Instead, it returns whatever data is available.+-- Privileges are used in the label comparisons and when raising+-- the current label.+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) -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)+-- | Read the entire labeled handle contents and close handle upon+-- reading @EOF@. Privileges are used in the label comparisons+-- and when raising the current label.+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) -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+-- | Output the given (Byte)String to the specified labeled handle.+-- Privileges are used in the label comparisons and when raising+-- the current label.+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) -createDirectoryP :: (Priv l p) => p -> FilePath -> LIO l s ()-createDirectoryP privs path = do- root <- rootDir- l <- getLabel- mkDir privs l root path+-- | Synonym for 'hPutP'.+hPutStrP :: (LabelState l p s, HandleOps IO.Handle b IO)+ => p -> LHandle l -> b -> LIO l p s ()+hPutStrP = hPutP -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)+-- | Output the given (Byte)String with an appended newline to the+-- specified labeled handle. Privileges are used in the label+-- comparisons and when raising the current label.+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) -openFileP :: (Priv l p) =>- p -> FilePath -> IOMode -> LIO l s (LHandle l IO.Handle)-openFileP privs path mode = do- root <- rootDir+--+-- Special cases+--++-- | Reads a file and returns the contents of the file as a (Byte)String.+readFile :: (DirectoryOps h m, HandleOps h b m) => FilePath -> m b+readFile path = openFile path ReadMode >>= hGetContents++-- | Write a (Byte)String to a file.+writeFile :: (DirectoryOps h m, HandleOps h b m, OnExceptionTCB m)+ => FilePath -> b -> m ()+writeFile path contents = bracketTCB (openFile path WriteMode) hClose+ (flip hPut contents)++-- | Same as 'readFile' but uses privilege in opening the file.+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++-- | Same as 'writeFile' but uses privilege in opening the file.+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- mkLHandle privs l root path mode+ bracketTCB (openFileP privs (Just l) path WriteMode) (hCloseP privs)+ (flip (hPutP privs) contents) +-- | 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++-- | Same as 'writeFileL' but uses privilege in opening the file.+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)
− LIO/HiStar.hs
@@ -1,151 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveDataTypeable #-}--module LIO.HiStar ( module LIO.HiStar- , module LIO.Base- ) where--import LIO.TCB-import LIO.Base--import Data.IORef-import Data.List-import Data.Monoid-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Typeable------- Some generic code-----withDefaults :: a -> a -> (a -> a -> b) -> Maybe a -> Maybe a- -> b-withDefaults d1 d2 f a1 a2 = f (unJust d1 a1) (unJust d2 a2)- where- unJust :: a -> Maybe a -> a- unJust _ (Just v) = v- unJust def Nothing = def--assocs2 :: Ord k => (Map k v1) -> (Map k v2) -> [(k, Maybe v1, Maybe v2)]-assocs2 m1 m2 = merge (Map.assocs m1) (Map.assocs m2)- where- merge [] [] = []- merge ((kx, vx):xs) [] = (kx, Just vx, Nothing) : merge xs []- merge [] ((ky, vy):ys) = (ky, Nothing, Just vy) : merge [] ys- merge x@((kx, vx):xs) y@((ky, vy):ys) =- case compare kx ky of- EQ -> (kx, Just vx, Just vy) : merge xs ys- LT -> (kx, Just vx, Nothing) : merge xs y- GT -> (ky, Nothing, Just vy) : merge x ys--mergeWith :: Ord k =>- (Maybe a -> Maybe b -> Maybe c) -> Map k a -> Map k b- -> Map k c-mergeWith f m1 m2 = domerge Map.empty $ assocs2 m1 m2- where- domerge m [] = m- domerge m ((k, v1, v2):as) = domerge (action k (f v1 v2) m) as- action k Nothing m = m- action k (Just v) m = Map.insert k v m-------- Now for the HSLabel Label------- XXX Note HSC should be TCB as # of categories allocated leaks info-newtype HSCategory = HSC Integer deriving (Eq, Ord, Read, Show)--{--instance Enum HSCategory where- toEnum i = HSC i- fromEnum (HSC i) = i--}--data HSLevel = L0 | L1 | L2 | L3 deriving (Eq, Ord, Enum, Read, Show)--instance POrd HSLevel where- pcompare a b = o2po $ compare a b---- Second component of HSLabel is the default level for categories not--- in the map. Invariant: Map must not contain any entries mapping--- categories to the default level.-data HSLabel = HSL (Map HSCategory HSLevel) HSLevel- deriving (Read, Show, Typeable)--instance Eq HSLabel where- a == b = pcompare a b == PEQ--instance POrd HSLabel where- pcompare (HSL m1 d1) (HSL m2 d2) = foldl each mempty (assocs2 m1 m2)- where- each r (k, v1, v2) = r `mappend` comp v1 v2- comp = withDefaults d1 d2 pcompare- -combineLabel :: (HSLevel -> HSLevel -> HSLevel)- -> HSLabel -> HSLabel -> HSLabel-combineLabel fn (HSL m1 d1) (HSL m2 d2) =- HSL (mergeWith combiner m1 m2) d- where- d = fn d1 d2- no_d v | v == d = Nothing- | otherwise = Just v- combiner v1 v2 = no_d $ withDefaults d1 d2 fn v1 v2--instance Label HSLabel where - lbot = HSL Map.empty L1- ltop = HSL Map.empty L3- lub = combineLabel max- glb = combineLabel min-------- Functions for manipulating labels-----lupdate :: HSLabel -> HSCategory -> HSLevel -> HSLabel-lupdate (HSL m d) cat lev = HSL m' d- where- m' = if lev == d then Map.delete cat m else Map.insert cat lev m--lupdates :: HSLabel -> [HSCategory] -> HSLevel -> HSLabel-lupdates lab cats lev = foldl (\lab' cat -> lupdate lab' cat lev) lab cats- -lapply :: HSLabel -> HSCategory -> HSLevel-lapply (HSL m d) cat = Map.findWithDefault d cat m--lcat L0 c = HSL (Map.singleton c L0) L3-lcat L2 c = HSL (Map.singleton c L2) L0-lcat L3 c = HSL (Map.singleton c L3) L0--newtype HSPrivs = HSPrivs [HSCategory]-data HSState = HSState { nextCat :: IORef HSCategory } deriving Typeable-type HS a = LIO HSLabel HSState a--instance Monoid HSPrivs where- mempty = HSPrivs []- mappend (HSPrivs a) (HSPrivs b) = HSPrivs $ union a b--instance PrivTCB HSPrivs-instance Priv HSLabel HSPrivs where- lostar (HSPrivs p) l min = lupdates l p L0 `lub` min- leqp (HSPrivs p) a b = lupdates a p L0 `leq` b--noprivs = mempty :: HSPrivs--newcat :: HSLevel -> HS (HSPrivs, HSLabel)-newcat lev = do ls <- getTCB- cat <- ioTCB $ atomicModifyIORef (nextCat ls) bumpcat- return (HSPrivs [cat], lcat lev cat)- where- bumpcat (HSC c) = (HSC $ c + 1, HSC c)--newHS = do- ref <- newIORef $ HSC 1000- return HSState { nextCat = ref }--evalHS :: HS t -> IO (t, HSLabel)-evalHS m = newHS >>= evalLIO m--
− LIO/LIO.hs
@@ -1,81 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-{-# LANGUAGE Safe #-}-#else-#warning "This module is not using SafeHaskell"-#endif--{- | This is the main module to be included by code using the Labeled- IO (LIO) library. The core of the library is documented in the- "LIO.TCB" module. Note, however, that unprivileged code must not- be allowed to import "LIO.TCB"--instead, a module "LIO.Base"- exports just the safe symbols from "LIO.TCB". This module,- "LIO.LIO", re-exports "LIO.Base" as well as a few other handy- modules. For many modules it should be the only import necessary.-- Certain symbols in the LIO library supersede variants in the- standard Haskell libraries. Thus, depending on the modules- imported and functions used, you may wish to import LIO with- commands like these:-- @- import Prelude hiding ('readFile', 'writeFile', 'catch')- import Control.Exception hiding ('throwIO', 'catch', 'handle', 'onException'- , 'bracket', 'block', 'unblock')- import LIO.LIO- @-- The LIO variants of the system functions hidden in the above import- commands are designed to work in both the IO and LIO monads, making- it easier to have both types of code in the same module.--- Warning: For security, at a minimum untrusted code must not be- allowed to do any of the following:-- * Import "LIO.TCB",-- * Use any symbols with names ending @...TCB@,-- * Use the @foreign@ keyword,-- * Use functions such as 'unsafePerformIO', 'unsafeInterleaveIO',- 'inlinePerformIO',-- * Use language extensions such as Generalized Newtype- Deriving and Stand-alone Deriving to extend LIO types- (such as by deriving an instance of @'Show'@ for 'Lref',- or deriving an instance of the @'MonadTrans'@ class for- 'LIO', which would allow untrusted code to bypass all- security with 'lift'),-- * Manually define @typeOf@ methods (as this would cause the- supposedly safe 'cast' method to make usafe casts); automatically- deriving @Typeable@ should be safe.-- * Define new 'Ix' instances (which could produce out of bounds- array references).-- In general, pragmas and imports should be highly scrutinized.- For example, most of the "Foreign" class of modules are probably- dangerous. With GHC 7.2, we use the SafeHaskell extension to enforce- these.--}-module LIO.LIO ( module LIO.Base- , module LIO.Handle- , module LIO.LIORef- , module LIO.MonadLIO- ) where--#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)--- import Prelude hiding (readFile, writeFile, catch)-import safe LIO.Base-import safe LIO.Handle-import safe LIO.LIORef-import safe LIO.MonadLIO-#else-import LIO.Base-import LIO.Handle-import LIO.LIORef-import LIO.MonadLIO-#endif
LIO/LIORef.hs view
@@ -1,18 +1,13 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) {-# LANGUAGE Safe #-}-#else-#warning "This module is not using SafeHaskell" #endif -- |This module implements labeled IORefs. The interface is analogous -- to "Data.IORef", but the operations take place in the LIO monad.+-- (See "LIO.LIORef.TCB" for documentation.) -- Moreover, reading the LIORef calls taint, while writing it calls--- wguard. This module exports only the safe subset (non TCB) of the--- "LIORef" module -- trusted code can import "LIO.LIORef.TCB".+-- aguard. This module exports only the safe subset (non TCB) of the+-- @LIORef@ module -- trusted code can import "LIO.LIORef.TCB". module LIO.LIORef ( module LIO.LIORef.Safe) where -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-import safe LIO.LIORef.Safe-#else import LIO.LIORef.Safe-#endif
LIO/LIORef/Safe.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) {-# LANGUAGE Trustworthy #-}-#else-#warning "This module is not using SafeHaskell" #endif -- |This module exports the safe subset of the "LIO.LIORef.TCB" module.@@ -11,7 +9,11 @@ module LIO.LIORef.Safe ( module LIO.LIORef.TCB ) where import LIO.LIORef.TCB ( LIORef , newLIORef, labelOfLIORef- , readLIORef, writeLIORef, atomicModifyLIORef+ , readLIORef, writeLIORef+ , modifyLIORef+ , atomicModifyLIORef , newLIORefP- , readLIORefP, writeLIORefP, atomicModifyLIORefP+ , readLIORefP, writeLIORefP+ , modifyLIORefP+ , atomicModifyLIORefP )
LIO/LIORef/TCB.hs view
@@ -1,22 +1,25 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) {-# LANGUAGE SafeImports #-}-#else-#warning "This module is not using SafeHaskell" #endif -- |This module implements labeled IORefs. The interface is analogous -- to "Data.IORef", but the operations take place in the LIO monad.--- Moreover, reading the LIORef calls taint, while writing it calls--- wguard.-module LIO.LIORef.TCB (LIORef+module LIO.LIORef.TCB (-- * Basic Functions+ LIORef , newLIORef, labelOfLIORef- , readLIORef, writeLIORef, atomicModifyLIORef- -- * With privileges+ , readLIORef, writeLIORef+ , modifyLIORef+ , atomicModifyLIORef+ -- * Privileged Functions , newLIORefP- , readLIORefP, writeLIORefP, atomicModifyLIORefP- -- * TCB+ , readLIORefP, writeLIORefP+ , modifyLIORefP+ , atomicModifyLIORefP+ -- * Unsafe (TCB) Functions , newLIORefTCB- , readLIORefTCB, writeLIORefTCB, atomicModifyLIORefTCB+ , readLIORefTCB, writeLIORefTCB+ , modifyLIORefTCB+ , atomicModifyLIORefTCB ) where import LIO.TCB@@ -28,68 +31,129 @@ #endif +-- | An @LIORef@ is an @IORef@ with an associated, static label. +-- The restriction of an immutable label come from the fact that it+-- is possible to leak information through the label itself.+-- Hence, LIO is /flow-insensitive/. Of course, you can create an+-- @LIORef@ of 'Labeled' to get a limited form of flow-sensitivity. data LIORef l a = LIORefTCB l (IORef a) -newLIORefP :: (Priv l p) => p -> l -> a -> LIO l s (LIORef l a)-newLIORefP p l a = do+-- | Same as 'newLIORef' except @newLIORefP@ takes a set of+-- privileges which are accounted for in comparing the label of+-- the reference to the current label and clearance.+newLIORefP :: (LabelState l p s)+ => p -> l -> a -> LIO l p s (LIORef l a)+newLIORefP p' l a = withCombinedPrivs p' $ \p -> do aguardP p l- ior <- ioTCB $ newIORef a+ ior <- rtioTCB $ newIORef a return $ LIORefTCB l ior -newLIORef :: (Label l) => l -> a -> LIO l s (LIORef l a)-newLIORef = newLIORefP NoPrivs+-- | To create a new reference the label of the reference must be+-- below the thread's current clearance and above the current label.+-- If this is the case, the reference is built.+newLIORef :: (LabelState l p s)+ => l -- ^ Label of reference+ -> a -- ^ Initial value+ -> LIO l p s (LIORef l a) -- ^ Mutable reference+newLIORef l x = getPrivileges >>= \p -> newLIORefP p l x -newLIORefTCB :: (Label l) => l -> a -> LIO l s (LIORef l a)+-- | Trusted constructor that creates labeled references.+newLIORefTCB :: (LabelState l p s) => l -> a -> LIO l p s (LIORef l a) newLIORefTCB l a = do- ior <- ioTCB $ newIORef a+ ior <- rtioTCB $ newIORef a return $ LIORefTCB l ior ----+-- | Get the label of a reference. labelOfLIORef :: (Label l) => LIORef l a -> l labelOfLIORef (LIORefTCB l _) = l ---+-- | Same as 'readLIORef' except @readLIORefP@ takes a privilege object+-- which is used when the current label is raised.+readLIORefP :: (LabelState l p s) => p -> LIORef l a -> LIO l p s a+readLIORefP p' (LIORefTCB l r) = withCombinedPrivs p' $ \p -> do+ taintP p l + rtioTCB $ readIORef r -readLIORefP :: (Priv l p) => p -> LIORef l a -> LIO l s a-readLIORefP p (LIORefTCB l r) = do- taintP p l- val <- ioTCB $ readIORef r- return val+-- | Read the value of a labeled refernce. A read succeeds only if the+-- label of the reference is below the current clearance. Moreover,+-- the current label is raised to the join of the current label and+-- the reference label. To avoid failures use 'labelOfLIORef' to check+-- that a read will suceed.+readLIORef :: (LabelState l p s) => LIORef l a -> LIO l p s a+readLIORef x = getPrivileges >>= \p -> readLIORefP p x -readLIORef :: (Label l) => LIORef l a -> LIO l s a-readLIORef = readLIORefP NoPrivs+-- | Trusted function used to read the value of a reference without+-- raising the current label.+readLIORefTCB :: (LabelState l p s) => LIORef l a -> LIO l p s a+readLIORefTCB (LIORefTCB _ r) = rtioTCB $ readIORef r -readLIORefTCB :: (Label l) => LIORef l a -> LIO l s a-readLIORefTCB (LIORefTCB _ r) = ioTCB $ readIORef r+-- | Same as 'writeLIORef' except @writeLIORefP@ takes a set of+-- privileges which are accounted for in comparing the label of+-- the reference to the current label and clearance.+writeLIORefP :: (LabelState l p s)+ => p -> LIORef l a -> a -> LIO l p s ()+writeLIORefP p' (LIORefTCB l r) a = withCombinedPrivs p' $ \p -> do+ aguardP p l + rtioTCB $ writeIORef r a ---+-- | Write a new value into a labeled reference. A write succeeds if+-- the current label can-flow-to the label of the reference, and the+-- label of the reference can-flow-to the current clearance.+writeLIORef :: (LabelState l p s) => LIORef l a -> a -> LIO l p s ()+writeLIORef x a = getPrivileges >>= \p -> writeLIORefP p x a -writeLIORefP :: (Priv l p) => p -> LIORef l a -> a -> LIO l s ()-writeLIORefP p (LIORefTCB l r) a = do- aguardP p l- ioTCB $ writeIORef r a+-- | Trusted function used to write a new value into a labeled+-- reference, ignoring IFC.+writeLIORefTCB :: (LabelState l p s) => LIORef l a -> a -> LIO l p s ()+writeLIORefTCB (LIORefTCB _ r) a = rtioTCB $ writeIORef r a -writeLIORef :: (Label l) => LIORef l a -> a -> LIO l s ()-writeLIORef = writeLIORefP NoPrivs +-- | Same as 'modifyLIORef' except @modifyLIORefP@ takes a set of+-- privileges which are accounted for in comparing the label of+-- the reference to the current label and clearance.+modifyLIORefP :: (LabelState l p s)+ => p -> LIORef l a -> (a -> a) -> LIO l p s ()+modifyLIORefP p' (LIORefTCB l r) f = withCombinedPrivs p' $ \p -> do+ aguardP p l + rtioTCB $ modifyIORef r f -writeLIORefTCB :: (Label l) => LIORef l a -> a -> LIO l s ()-writeLIORefTCB (LIORefTCB _ r) a = ioTCB $ writeIORef r a+-- | Mutate the contents of a labeled reference. For the mutation to+-- succeed it must be that the current label can-flow-to the label of+-- the reference, and the label of the reference can-flow-to the+-- current clearance. Note that because a modifer is provided, the+-- reference contents are not observable by the outer computation and+-- so it is not required that the current label be raised.+modifyLIORef :: (LabelState l p s)+ => LIORef l a -- ^ Labeled reference+ -> (a -> a) -- ^ Modifier+ -> LIO l p s ()+modifyLIORef x f = getPrivileges >>= \p -> modifyLIORefP p x f ---+-- | Trusted function that mutates the contents on an 'LIORef',+-- ignoring IFC.+modifyLIORefTCB :: (LabelState l p s)+ => LIORef l a -> (a -> a) -> LIO l p s ()+modifyLIORefTCB (LIORefTCB _ r) f = rtioTCB $ modifyIORef r f -atomicModifyLIORefP :: (Priv l p) =>- p -> LIORef l a -> (a -> (a, b)) -> LIO l s b-atomicModifyLIORefP p (LIORefTCB l r) f = do++-- | Same as 'atomicModifyLIORef' except @atomicModifyLIORefP@ takes+-- a set of privileges which are accounted for in label comparisons.+atomicModifyLIORefP :: (LabelState l p s) =>+ p -> LIORef l a -> (a -> (a, b)) -> LIO l p s b+atomicModifyLIORefP p' (LIORefTCB l r) f = withCombinedPrivs p' $ \p -> do aguardP p l- ioTCB $ atomicModifyIORef r f+ rtioTCB $ atomicModifyIORef r f -atomicModifyLIORef :: (Label l) =>- LIORef l a -> (a -> (a, b)) -> LIO l s b-atomicModifyLIORef = atomicModifyLIORefP NoPrivs+-- | Atomically modifies the contents of an 'LIORef'. It is required+-- that the label of the reference be above the current label, but+-- below the current clearance. +atomicModifyLIORef :: (LabelState l p s) =>+ LIORef l a -> (a -> (a, b)) -> LIO l p s b+atomicModifyLIORef x f = getPrivileges >>= \p -> atomicModifyLIORefP p x f -atomicModifyLIORefTCB :: (Label l) =>- LIORef l a -> (a -> (a, b)) -> LIO l s b-atomicModifyLIORefTCB (LIORefTCB _ r) f = ioTCB $ atomicModifyIORef r f+-- | Trusted function used to atomically modify the contents of a+-- labeled reference, ignoring IFC.+atomicModifyLIORefTCB :: (LabelState l p s)+ => LIORef l a -> (a -> (a, b)) -> LIO l p s b+atomicModifyLIORefTCB (LIORefTCB _ r) f = rtioTCB $ atomicModifyIORef r f
LIO/MonadCatch.hs view
@@ -1,59 +1,88 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) {-# LANGUAGE Safe #-}-#else-#warning "This module is not using SafeHaskell" #endif-{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE RankNTypes #-} --- | This module generalizes 'throw' and 'catch' (from--- "Control.Exception") to methods that can be defined on multiple--- Monads.+-- | This module generalizes 'throw' and 'catch' (from "Control.Exception")+-- to methods that can be defined on multiple monads. module LIO.MonadCatch (MonadCatch(..), genericBracket) where -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-import safe Prelude hiding (catch)-import safe Control.Exception (Exception, SomeException)-import safe qualified Control.Exception as E-#else import Prelude hiding (catch) import Control.Exception (Exception, SomeException) import qualified Control.Exception as E-#endif -- | @MonadCatch@ is the class used to generalize the standard IO -- @catch@ and @throwIO@ functions to methods that can be defined in -- multiple monads.+-- Minimal definition requires: @mask@, @throwIO@, @catch@, and+-- @onException@. class (Monad m) => MonadCatch m where- block :: m a -> m a- unblock :: m a -> m a+ -- | Executes a computation with asynchronous exceptions masked.+ -- See "Control.Exception" for more details.+ mask :: ((forall a. m a -> m a) -> m b) -- ^ Function+ -- that takes a mask-restoring function as argument and returns an+ -- action to execute.+ -> m b+ -- | Like 'mask', but does not pass a restore action to the argument.+ mask_ :: m a -> m a+ mask_ io = mask $ \_ -> io+ -- | A variant of @throwIO@ that can be used within the monad. throwIO :: (Exception e) => e -> m a- catch :: (Exception e) => m a -> (e -> m a) -> m a+ -- | Simplest exception-catching function.+ catch :: (Exception e) => m a -- ^ Computation to run + -> (e -> m a) -- ^ Handler+ -> m a+ -- | Version of 'catch' with the arguments swapped around. handle :: (Exception e) => (e -> m a) -> m a -> m a handle = flip catch- onException :: m a -> m b -> m a+ -- | Performs an action and a subsequent action if an exceptino is raised.+ onException :: m a -- ^ Computation to run first+ -> m b -- ^ Computation to run after, if+ -- an exception was raised.+ -> m a onException io h = io `catch` \e -> h >> throwIO (e :: SomeException)- bracket :: m b -> (b -> m c) -> (b -> m a) -> m a+ -- | This function allows you to execute an action with an initial+ -- \"acquire resource\" and final \"release resource\" as @bracket@+ -- of "Control.Exception".+ bracket :: m b -- ^ Computation to run first+ -> (b -> m c) -- ^ Computation to run last+ -> (b -> m a) -- ^ Computation to run in-between+ -> m a bracket = genericBracket onException+ -- | Variant of 'bracket' where the return value from the first+ -- computation is not required. + bracket_ :: m a -> m b -> m c -> m c+ bracket_ a b c = bracket a (const b) (const c)+ -- | Performs an action and a subsequent action.+ finally :: m a -- ^ Computation to run first+ -> m b -- ^ Computation to run after+ -> m a+ finally a b = mask $ \restore -> do+ r <- restore a `onException` b+ _ <- b+ return r instance MonadCatch IO where- block = E.block- unblock = E.unblock+ mask = E.mask throwIO = E.throwIO catch = E.catch onException = E.onException bracket = E.bracket +-- | Given some general @onException@ function, @genericBracket@+-- allows you to execute an action with an initial \"acquire resource\"+-- and final \"release resource\" as @bracket@ of "Control.Exception". genericBracket :: (MonadCatch m) => (m b -> m c -> m b) -- ^ On exception function- -> m a -- ^ Action to perform before- -> (a -> m c) -- ^ Action for afterwards- -> (a -> m b) -- ^ Main (in between) action- -> m b -- ^ Result of main action-genericBracket myOnException before after between =- block $ do- a <- before- b <- unblock (between a) `myOnException` after a- after a >> return b+ -> m a -- ^ Action to perform first+ -> (a -> m c) -- ^ Action to perform last+ -> (a -> m b) -- ^ Action to perform in-between+ -> m b -- ^ Result of in-between action+genericBracket myOnException m1 m3 m2 =+ mask $ \restore -> do+ a <- m1+ b <- restore (m2 a) `myOnException` (m3 a)+ _ <- m3 a+ return b
LIO/MonadLIO.hs view
@@ -1,8 +1,6 @@ {-# LANGUAGE CPP #-} #if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702) {-# LANGUAGE Trustworthy #-}-#else-#warning "This module is not using SafeHaskell" #endif {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FunctionalDependencies #-}@@ -11,27 +9,23 @@ {-# LANGUAGE OverlappingInstances #-} -- | This module provides a function 'liftLIO' for executing 'LIO'--- computations from transformed versions of the 'LIO' monad. There--- is also a method @liftIO@, which is a synonym for 'liftLIO', to--- help with porting code that expects to run in the 'IO' monad.-module LIO.MonadLIO where--import LIO.TCB+-- computations from transformed versions of the 'LIO' monad.+-- There is also a method 'liftIO', which is a synonym for 'liftLIO',+-- to help with porting code that expects to run in the @IO@ monad.+module LIO.MonadLIO (MonadLIO(..)) where -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-#warning "Did not safely import Control.Monad.Trans"-import Control.Monad.Trans (MonadTrans(..))-#else+import LIO.TCB (LIO, LabelState) import Control.Monad.Trans (MonadTrans(..))-#endif -class (Monad m, Label l) => MonadLIO m l s | m -> l s where- liftLIO :: LIO l s a -> m a- liftIO :: LIO l s a -> m a -- Might want to hide this one+-- | MonadIO-like class.+class (Monad m, LabelState l p s) => MonadLIO m l p s | m -> l p s where+ liftLIO :: LIO l p s a -> m a+ liftIO :: LIO l p s a -> m a liftIO = liftLIO -instance (Label l) => MonadLIO (LIO l s) l s where+instance (LabelState l p s) => MonadLIO (LIO l p s) l p s where liftLIO = id -instance (MonadLIO m l s, MonadTrans t, Monad (t m)) => MonadLIO (t m) l s where+instance (MonadLIO m l p s, MonadTrans t, Monad (t m))+ => MonadLIO (t m) l p s where liftLIO = lift . liftLIO
+ LIO/Safe.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Trustworthy #-}+#endif++-- | This module exports the subset of symbols in the "LIO.TCB" module+-- that are safe for untrusted code to access. See the "LIO.TCB"+-- module for documentation.++module LIO.Safe ( Label(..)+ , Priv(..), NoPrivs(..)+ , LIO, LabelState+ , evalLIO+ , getLabel, setLabelP+ , getClearance, lowerClr, lowerClrP, withClearance+ , labelOf+ , label, labelP+ , unlabel, unlabelP+ , taintLabeled+ , toLabeled, toLabeledP, discard, discardP+ , taint, taintP+ , wguard, wguardP, aguard, aguardP+ , Labeled+ , LabelFault(..)+ , catchP, handleP, onExceptionP, bracketP+ , evaluate+ ) where++import LIO.TCB ( Label(..)+ , Priv(..), NoPrivs(..)+ , LIO, LabelState+ , evalLIO+ , getLabel, setLabelP+ , getClearance, lowerClr, lowerClrP, withClearance+ , labelOf+ , label, labelP+ , unlabel, unlabelP+ , taintLabeled+ , toLabeled, toLabeledP, discard, discardP+ , taint, taintP+ , wguard, wguardP, aguard, aguardP+ , Labeled+ , LabelFault(..)+ , catchP, handleP, onExceptionP, bracketP+ , evaluate+ )
LIO/TCB.hs view
@@ -1,923 +1,1026 @@ {-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-{-# LANGUAGE SafeImports #-}-#else-#warning "This module is not using SafeHaskell"-#endif-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}-{-# LANGUAGE ExistentialQuantification #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}---- | This module implements the core of the Labeled IO library for--- information flow control in Haskell. It provides a monad, 'LIO',--- that is intended to be used as a replacement for the IO monad in--- untrusted code. The idea is for untrusted code to provide a--- computation in the 'LIO' monad, which trusted code can then safely--- execute through the 'evalLIO' function. (Though usually a wrapper--- function is employed depending on the type of labels used by an--- application. For example, with "LIO.DCLabel", you would use--- 'evalDC' to execute an untrusted computation, and with "LIO.HiStar"--- labels, the function is 'evalHS'. There are also abbreviations for--- the 'LIO' monad type of a particular label--for instance 'DC' or--- 'HS'.)------ A data structure 'Labeled' (labeled value) protects access to pure--- values. Without the appropriate privileges, one cannot produce a--- pure value that depends on a secret 'Labeled', or conversely produce a--- high-integrity 'Labeled' based on pure data. The function 'toLabeled'--- allows one to seal off the results of an LIO computation inside an--- 'Labeled' without tainting the current flow of execution. 'unlabel'--- conversely allows one to use the value stored within a 'Labeled'.--- --- Any code that imports this module is part of the--- /Trusted Computing Base/ (TCB) of the system. Hence, untrusted--- code must be prevented from importing this module. The exported--- symbols ending ...@TCB@ can be used to violate label protections--- even from within pure code or the LIO Monad. A safe subset of--- these symbols is exported by the "LIO.Base" module, which is how--- untrusted code should access the core label functionality.--- ("LIO.Base" is also re-exported by "LIO.LIO", the main gateway to--- this library.)----module LIO.TCB (- -- * Basic label functions- -- $labels- POrdering(..), POrd(..), o2po, Label(..)- , Priv(..), NoPrivs(..)- -- * Labeled IO Monad (LIO)- -- $LIO- , LIO- , getLabel, setLabelP- , getClearance, lowerClr, lowerClrP, withClearance- -- ** LIO guards- -- $guards- , taint, taintP- , wguard, wguardP, aguard, aguardP- -- * Labeled values- , Labeled- --- , label, labelP- , unlabel, unlabelP- , toLabeled, toLabeledP, discard- , labelOf- , taintLabeled- -- * Exceptions- -- ** Exception type thrown by LIO library- , LabelFault(..)- -- ** Throwing and catching labeled exceptions- -- $lexception- , MonadCatch(..), catchP, handleP, onExceptionP, bracketP- -- * Executing computations- , evaluate- , evalLIO- -- Start TCB exports- -- * Privileged operations- , LIOstate(..)- , runLIO- , ShowTCB(..)- , ReadTCB(..)- , labelTCB- , PrivTCB, MintTCB(..)- , unlabelTCB- , setLabelTCB, lowerClrTCB- , getTCB, putTCB- , ioTCB, rtioTCB- , rethrowTCB, OnExceptionTCB(..)- , newstate- -- End TCB exports- ) where--#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)-import safe Prelude hiding (catch)-import Control.Monad.Error-#warning "Did not safely import Control.Monad.Error"-import Control.Monad.State.Lazy hiding (put, get)-#warning "Did not safely import Control.Monad.State.Lazy"-import safe Control.Exception hiding (catch, handle, throw, throwIO,- onException, block, unblock, evaluate)-import safe qualified Control.Exception as E-import safe Data.Monoid-import safe Data.Typeable-import safe Data.Functor-import safe Text.Read (minPrec)--import safe LIO.MonadCatch--#else-import Prelude hiding (catch)-import Control.Monad.Error-import Control.Monad.State.Lazy hiding (put, get)-import Control.Exception hiding (catch, handle, throw, throwIO,- onException, block, unblock, evaluate)-import qualified Control.Exception as E-import Data.Monoid-import Data.Typeable-import Data.Functor-import Text.Read (minPrec)--import LIO.MonadCatch--#endif------- We need a partial order and a Label-----{- $labels--Labels are a way of describing who can observe and modify data. There-is a partial order, generally pronounced \"can flow to\" on labels.-In Haskell we write this partial order ``leq`` (in the literature it-is usually written as a square less than or equal sign--@\\sqsubseteq@-in TeX).--The idea is that data labeled @l1@ should affect data labeled @l2@ only if-@l1@ ``leq`` @l2@, (i.e., @l1@ /can flow to/ @l2@). The 'LIO' monad keeps-track of the current label of the executing code (accessible via the-'getLabel' function). Code may attempt to perform various IO or-memory operations on labeled data. Touching data may change the-current label or throw an exception if an operation would violate-can-flow-to restrictions.--If the current label is @lcurrent@, then it is only permissible to-read data labeled @lr@ if @lr ``leq`` lcurrent@. This is sometimes-termed \"no read up\" in the literature; however, because the partial-order allows for incomparable labels (i.e., two labels @l1@ and @l2@-such that @not (l1 ``leq`` l2) && not (l2 ``leq`` l1)@), a more-appropriate phrasing would be \"read only what can flow to your-label\". Note that, rather than throw an exception, reading data will-often just increase the current label to ensure that @lr ``leq``-lcurrent@. The LIO monad keeps a second label, called the /clearance/-(see 'getClearance'), that represents the highest value the-current thread can raise its label to.--Conversely, it is only permissible to modify data labeled @lw@ when-@lcurrent ``leq`` lw@, a property often cited as \"no write down\",-but more accurately characterized as \"write only what you can flow-to\". In practice, there are very few IO abstractions in which it is-possible to do a pure write that doesn't also involve observing some-state. For instance, writing to a file handle and not getting an-exception tells you that the handle is not closed. Thus, in practice,-the requirement for modifying data labeled @lw@ is almost always that-@lcurrent == lw@.--Note that higher labels are neither more nor less privileged than-lower ones. Simply, the higher one's label is, the more things one-can read. Conversely, the lower one's label, the more things one can-write. But, because labels are a partial and not a total order, -some data may be completely inaccessible to a particular omputatoin; for-instance, if the current label is @lcurrent@, the current clearance is-@ccurrent@, and some data is labeled @ld@, such that @not (lcurrent-``leq`` ld || ld ``leq`` ccurrent)@, then the current thread can-neither read nor write the data, at least without invoking some-privilege.--Privilege comes from a separate class called 'Priv', representing the-ability to bypass the protection of certain labels. Essentially,-privilege allows you to behave as if @l1 ``leq`` l2@ even when that is-not the case. The process of making data labeled @l1@ affect data-labeled @l2@ when @not (l1 ``leq`` l2)@ is called /downgrading/.--The basic method of the 'Priv' object is 'leqp', which performs the-more permissive can-flow-to check in the presence of particular-privileges. Many 'LIO' operations have variants ending @...P@ that-take a privilege argument to act in a more permissive way. All 'Priv'-types are monoids, and so can be combined with 'mappend'.--How to create 'Priv' objects is specific to the particular label type-in use. The method used is 'mintTCB', but the arguments depend on the-particular label type. (Obviously, the symbol 'mintTCB' must not be-available to untrusted code.)---}--data POrdering = PEQ -- ^Equal- | PLT -- ^Less than- | PGT -- ^Greater than- | PNE- -- ^Incomparable (neither less than nor greater than)- deriving (Eq, Ord, Show)--instance Monoid POrdering where- mempty = PEQ- mappend PLT PGT = PNE- mappend PGT PLT = PNE- mappend x y = max x y--class (Eq a) => POrd a where- pcompare :: a -> a -> POrdering- leq :: a -> a -> Bool-- pcompare a b | a == b = PEQ- | a `leq` b = PLT- | b `leq` a = PGT- | otherwise = PNE- leq a b = case pcompare a b of- PEQ -> True- PLT -> True- _ -> False--o2po :: Ordering -> POrdering-o2po EQ = PEQ; o2po LT = PLT; o2po GT = PGT--class (POrd a, Show a, Read a, Typeable a) => Label a where- -- | bottom- lbot :: a- -- | top- ltop :: a- -- | least upper bound (join) of two labels- lub :: a -> a -> a- -- | greatest lower bound (meet) of two labels- glb :: a -> a -> a-------- Labeled value - Labeled--- Downgrading privileges - Priv------- | @Labeled@ is a type representing labeled data. -data (Label l) => Labeled l t = LabeledTCB l t---- | To make programming easier with labeled values, we provide a functor--- instance definition.-instance Label l => Functor (Labeled l) where- fmap f (LabeledTCB l a) = LabeledTCB l (f a)---- | It would be a security issue to make certain objects a member of--- the 'Show' class, but nonetheless it is useful to be able to--- examine such objects from within the debugger. The 'showTCB'--- method can be used to examine such objects.-class ShowTCB a where- showTCB :: a -> String--instance (Label l, Show a) => ShowTCB (Labeled l a) where- showTCB (LabeledTCB l t) = shows t $ " {" ++ shows l "}"--class MintTCB t i where- -- |A function that mints new objects (such as instances of- -- 'Priv') in a way that only privileged code should be allowed to- -- do. Because the MintTCB method is only available to- -- priviledged code, other modules imported by unpriviledged code- -- can define instances of mintTCB.- mintTCB :: i -> t---- | It is useful to have the dual of 'ShowTCB', @ReadTCB@, that allows--- for the reading of 'Labeled's that were written using 'showTCB'. Only--- @readTCB@ (corresponding to 'read') and @readsPrecTCB@ (corresponding--- to 'readsPrec') are implemented.-class ReadTCB a where- readsPrecTCB :: Int -> ReadS a- readTCB :: String -> a- readTCB str = check $ readsPrecTCB minPrec str- where check [] = error "readTCB: no parse"- check [(x,rst)] | all (==' ') rst = x- | otherwise = error "readTCB: no parse"- check _ = error "readTCB: ambiguous parse"--instance (Label l, Read l, Read a) => ReadTCB (Labeled l a) where- readsPrecTCB _ str = do (val, str1) <- reads str- ("{", str2) <- lex str1- (lab, str3) <- reads str2- ("}", rest) <- lex str3- return (labelTCB lab val, rest)---- | @PrivTCB@ is a method-less class whose only purpose is to be--- unavailable to unprivileged code. Since @(PrivTCB t) =>@ is in the--- context of class 'Priv' and unprivileged code cannot create new--- instances of the @PrivTCB@ class, this ensures unprivileged code--- cannot create new instances of the 'Priv' class either, even though--- the symbol 'Priv' is exported by "LIO.Base" and visible to--- untrusted code.-class PrivTCB t where-class (Label l, Monoid p, PrivTCB p) => Priv l p where- -- |@leqp p l1 l2@ means that privileges @p@ are sufficient to- -- downgrade data from @l1@ to @l2@. Note that @'leq' l1 l2@- -- implies @'leq' p l1 l2@ for all @p@, but for some labels and- -- privileges, @leqp@ will hold even where @'leq'@ does not.- leqp :: p -> l -> l -> Bool- leqp p a b = lostar p a b `leq` b-- -- | Roughly speaking, the function- -- - -- > result = lostar p label goal- -- - -- computes how close one can come to downgrading data labeled- -- @label@ to @goal@ given privileges @p@. When @p == 'NoPrivs'@,- -- @result == 'lub' label goal@. If @p@ contains all possible- -- privileges, then @result == goal@.- --- -- More specifically, @result@ is the greatest lower bound of the- -- set of all labels @r@ satisfying:- --- -- 1. @'leq' goal r@, and- --- -- 2. @'leqp' p label r@- --- -- Operationally, @lostar@ captures the minimum change required to- -- the current label when viewing data labeled @label@. A common- -- pattern is to use the result of 'getLabel' as @goal@ (i.e.,- -- the goal is to use privileges @p@ to avoid changing the label- -- at all), and then compute @result@ based on the @label@ of data- -- the code is about to observe. For example, 'taintP' could be- -- implemented as:- --- -- @- -- taintP p l = do lcurrent <- 'getLabel'- -- 'taint' (lostar p l lcurrent)- -- @- lostar :: p -- ^ Privileges- -> l -- ^ Label from which data must flow- -> l -- ^ Goal label- -> l -- ^ Result---- |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---- Trusted constructor that creates labeled values.-labelTCB :: Label l => l -> a -> Labeled l a-labelTCB l a = LabeledTCB l a---- | Raises the label of a 'Labeled' to the 'lub' of it's current label--- and the value supplied. The label supplied must be less than the--- current clarance, though the resulting label may not be if the--- 'Labeled' is already above the current thread's clearance.-taintLabeled :: (Label l) => l -> Labeled l a -> LIO l s (Labeled l a)-taintLabeled l (LabeledTCB la a) = do- aguard l- return $ LabeledTCB (lub l la) a---- | Extracts the value from an 'Labeled', discarding the label and any--- protection.-unlabelTCB :: Label l => Labeled l a -> a-unlabelTCB (LabeledTCB _ a) = a---- | Returns label of a 'Label' type.-labelOf :: Label l => Labeled l a -> l-labelOf (LabeledTCB l _) = l-------- Labeled IO------- $LIO--- --- The 'LIO' monad is a wrapper around 'IO' that keeps track of the--- current label and clearance. It is possible to raise one's label--- or lower one's clearance without privilege, but moving in the other--- direction requires appropriate privilege.------ 'LIO' is parameterized by two types. The first is the particular--- label type. The second type is state specific to the label type.--- Trusted label implementation code can use 'getTCB' and 'putTCB' to--- get and set the label state.--data (Label l) => LIOstate l s =- LIOstate { labelState :: s- , lioL :: l -- current label- , lioC :: l -- current clearance- }--newtype (Label l) => LIO l s a = LIO (StateT (LIOstate l s) IO a)- deriving (Functor, Monad, MonadFix)--get :: (Label l) => LIO l s (LIOstate l s)-get = mkLIO $ \s -> return (s, s)--put :: (Label l) => LIOstate l s -> LIO l s ()-put s = mkLIO $ \_ -> return (() , s)---- | Function to construct an 'Labeled' from a label and pure value. If--- the current label is @lcurrent@ and the current clearance is--- @ccurrent@, then the label @l@ specified must satisfy--- @lcurrent ``leq`` l && l ``leq`` ccurrent@.-label :: (Label l) => l -> a -> LIO l s (Labeled l a)-label l a = get >>= doit- where doit s | not $ l `leq` lioC s = throwIO LerrClearance- | not $ lioL s `leq` l = throwIO LerrLow- | otherwise = return $ LabeledTCB l a---- | Constructs an 'Labeled' using privilege to allow the `Labeled`'s label--- to be below the current label. If the current label is @lcurrent@--- and the current clearance is @ccurrent@, then the privilege @p@ and--- label @l@ specified must satisfy--- @(leqp p lcurrent l) && l ``leq`` ccurrent@.--- Note that privilege is not used to bypass the clearance. You must--- use 'lowerClrP' to raise the clearance first if you wish to--- create an 'Labeled' at a higher label than the current clearance.-labelP :: (Priv l p) => p -> l -> a -> LIO l s (Labeled l a)-labelP p l a = get >>= doit- where doit s | not $ l `leq` lioC s = throwIO LerrClearance- | not $ leqp p (lioL s) l = throwIO LerrLow- | otherwise = return $ LabeledTCB l a---- | Returns the current value of the thread's label.-getLabel :: (Label l) => LIO l s l-getLabel = get >>= return . lioL---- | Returns the current value of the thread's clearance.-getClearance :: (Label l) => LIO l s l-getClearance = get >>= return . lioC--{- $guards-- Guards are used by privileged code to check that the invoking,- unprivileged code has access to particular data. If the current- label is @lcurrent@ and the current clearance is @ccurrent@, then- the following checks should be performed when accessing data- labeled @ldata@:-- * When /reading/ an object labeled @ldata@, it must be the case- that @ldata ``leq`` lcurrent@. This check is performed by the- 'taint' function, so named becuase it \"taints\" the current LIO- context by raising @lcurrent@ until @ldata ``leq`` lcurrent@.- (Specifically, it does this by computing the least upper bound of- the two labels with the 'lub' method of the 'Label' class.)- However, if after doing this it would be the case that- @not (lcurrent ``leq`` ccurrent)@, then 'taint' throws exception- 'LerrClearance' rather than raising the current label.-- * When /writing/ an object, it should be the case that @ldata- ``leq`` lcurrent && lcurrent ``leq`` ldata@. (As stated, this is- the same as saying @ldata == lcurrent@, but the two are different- when using 'leqp' instead of 'leq'.) This is ensured by the- 'wguard' (write guard) function, which does the equivalent of- 'taint' to ensure the target label @ldata@ can flow to the- current label, then throws an exception if @lcurrent@ cannot flow- back to the target label.-- * When /creating/ or /allocating/ objects, it is permissible for- them to be higher than the current label, so long as they are- bellow the current clearance. In other words, it must be the- case that @lcurrent ``leq`` ldata && ldata ``leq`` ccurrent@.- This is ensured by the 'aguard' (allocation guard) function.--The 'taintP', 'wguardP', and 'aguardP' functions are variants of the-above that take privilege to be more permissive and raise the current-label less. ---}---- | General (internal) taint function. Uses @mylub@ instead of--- 'lub', so that privileges can optionally be passed in. Throws--- 'LerrClearance' if raising the current label would exceed the--- current clearance.-gtaint :: (Label l) =>- (l -> l -> l) -- ^ @mylub@ function- -> l -- ^ @l@ - Label to taint with- -> LIO l s ()-gtaint mylub l = do- s <- get- let lnew = l `mylub` (lioL s)- if lnew `leq` lioC s- then put s { lioL = lnew }- else ioTCB $ E.throwIO $ LabeledExceptionTCB (lioL s)- (toException LerrClearance)---- |Use @taint l@ in trusted code before observing an object labeled--- @l@. This will raise the current label to a value @l'@ such that--- @l ``leq`` l'@, or throw @'LerrClearance'@ if @l'@ would have to be--- higher than the current clearance.-taint :: (Label l) => l -> LIO l s ()-taint = gtaint lub---- |Like 'taint', but use privileges to reduce the amount of taint--- required. Note that unlike 'setLabelP', @taintP@ will never lower--- the current label. It simply uses privileges to avoid raising the--- label as high as 'taint' would raise it.-taintP :: (Priv l p) =>- p -- ^Privileges to invoke- -> l -- ^Label to taint to if no privileges- -> LIO l s ()-taintP p = gtaint (lostar p)---- |Use @wguard l@ in trusted code before modifying an object labeled--- @l@. If @l'@ is the current label, then this function ensures that--- @l' ``leq`` l@ before doing the same thing as @'taint' l@. Throws--- @'LerrHigh'@ if the current label @l'@ is too high.-wguard :: (Label l) => l -> LIO l s ()-wguard l = do l' <- getLabel- if l' `leq` l- then taint l- else throwIO LerrHigh---- |Like 'wguard', but takes privilege argument to be more permissive.-wguardP :: (Priv l p) => p -> l -> LIO l s ()-wguardP p l = do l' <- getLabel- if leqp p l' l- then taintP p l- else throwIO LerrHigh---- |Ensures the label argument is between the current IO label and--- current IO clearance. Use this function in code that allocates--- objects--untrusted code shouldn't be able to create an object--- labeled @l@ unless @aguard l@ does not throw an exception.-aguard :: (Label l) => l -> LIO l s ()-aguard newl = do c <- getClearance- l <- getLabel- unless (leq newl c) $ throwIO LerrClearance- unless (leq l newl) $ throwIO LerrLow- return ()---- | Like 'aguardP', but takes privilege argument to be more permissive.-aguardP :: (Priv l p) => p -> l -> LIO l s ()-aguardP p newl = do c <- getClearance- l <- getLabel- unless (leqp p newl c) $ throwIO LerrClearance- unless (leqp p l newl) $ throwIO LerrLow- return ()----- | If the current label is @oldLabel@ and the current clearance is--- @clearance@, this function allows code to raise the label to any--- value @newLabel@ such that--- @oldLabel ``leq`` newLabel && newLabel ``leq`` clearance@.--- Note that there is no @setLabel@ variant without the @...P@ because--- the 'taint' function provides essentially the same functionality--- that @setLabel@ would.-setLabelP :: (Priv l p) => p -> l -> LIO l s ()-setLabelP p l = do s <- get- if leqp p (lioL s) l- then put s { lioL = l }- else throwIO LerrPriv---- | Set the current label to anything, with no security check.-setLabelTCB :: (Label l) => l -> LIO l s ()-setLabelTCB l = do s <- get- if l `leq` lioC s- then put 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 :: (Label l) => l -> LIO l s ()-lowerClr l = get >>= doit- where doit s | not $ l `leq` lioC s = throwIO LerrClearance- | not $ lioL s `leq` l = throwIO LerrLow- | otherwise = put s { lioC = l }---- |Raise the current clearance (undoing the effects of 'lowerClr').--- This requires privileges.-lowerClrP :: (Priv l p) => p -> l -> LIO l s ()-lowerClrP p l = get >>= doit- where doit s | not $ leqp p l $ lioC s = throwIO LerrPriv- | not $ lioL s `leq` l = throwIO LerrLow- | otherwise = put s { lioC = l }---- | Set the current clearance to anything, with no security check.-lowerClrTCB :: (Label l) => l -> LIO l s ()-lowerClrTCB l = get >>= doit- where doit s | not $ lioL s `leq` l = throwIO LerrInval- | otherwise = put s { lioC = l }---- | Lowers the clearance of a computation, then restores the--- clearance to its previous value. Useful to wrap around a--- computation if you want to be sure you can catch exceptions thrown--- by it. Also useful to wrap around 'toLabeled' to ensure that the--- computation does not access data exceeding a particular label. If--- @withClearance@ is given a label that can't flow to the current--- clearance, then the clearance is lowered to the greatest lower--- bound of the label supplied and the current clearance.------ Note that if the computation inside @withClearance@ acquires any--- 'Priv's, it may still be able to raise its clearance above the--- supplied argument using 'lowerClrP'.-withClearance :: (Label l) => l -> LIO l s a -> LIO l s a-withClearance l m = do- s <- get- put s { lioC = l `glb` lioC s }- a <- m- put s { lioC = lioC s }- return a---- | Within the 'LIO' monad, this function takes an 'Labeled' and returns--- the value. Thus, in the 'LIO' monad one can say:------ > x <- unlabel (xv :: Labeled SomeLabelType Int)------ And now it is possible to use the value of @x@, which is the pure--- value of what was stored in @xv@. Of course, @unlabel@ also raises--- the current label. If raising the label would exceed the current--- clearance, then @unlabel@ throws 'LerrClearance'.--- However, you can use 'labelOf' to check if 'unlabel' will suceed without--- throwing an exception.-unlabel :: (Label l) => Labeled l a -> LIO l s a-unlabel (LabeledTCB la a) = do- taint la- return a---- | Extracts the value of an 'Labeled' just like 'unlabel', but takes a--- privilege argument to minimize the amount the current label must be--- raised. Will still throw 'LerrClearance' under the same--- circumstances as 'unlabel'.-unlabelP :: (Priv l p) => p -> Labeled l a -> LIO l s a-unlabelP p (LabeledTCB la a) = do- taintP p la- return a---- |@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 suggestst 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 occured in the computation--- producing the value of the 'Labeled'. --- This higlights one main use of clearance: to ensure that a @Labeled@--- computed does not exceed a particular label.-toLabeled :: (Label l) => l -> LIO l s a -> LIO l s (Labeled l a)-toLabeled = toLabeledP NoPrivs--toLabeledP :: (Priv l p) => p -> l -> LIO l s a -> LIO l s (Labeled l a)-toLabeledP p l m = do- aguard l- save_s <- get- a <- m- 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---- | Executes a computation that would raise the current label, but--- discards the result so as to keep the label the same. Used when--- one only cares about the side effects of a computation. For--- instance, if @log_handle@ is an 'LHandle' with a high label, one--- can execute------ @--- discard ltop $ 'hputStrLn' log_handle \"Log message\"--- @------ to create a log message without affecting the current label. (Of--- course, if @log_handle@ is closed and this throws an exception, it--- may not be possible to catch the exception within the 'LIO' monad--- without sufficient privileges--see 'catchP'.)-discard :: (Label l) => l -> LIO l s a -> LIO l s ()-discard l m = toLabeled l m >> return ()---- | 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 :: (Label l) => LIO l s s-getTCB = get >>= return . labelState---- | Sets the label-specific state of the 'LIO' monad. See 'getTCB'.-putTCB :: (Label l) => s -> LIO l s ()-putTCB ls = get >>= put . update- where update s = s { labelState = ls }---- | Generate a fresh state to pass 'runLIO' when invoking it for the--- first time.-newstate :: (Label l) => s -> LIOstate l s-newstate s = LIOstate { labelState = s , lioL = lbot , lioC = ltop }--mkLIO :: (Label l) => (LIOstate l s -> IO (a, LIOstate l s)) -> LIO l s a-mkLIO = LIO . StateT--unLIO :: (Label l) => LIO l s a -> LIOstate l s- -> IO (a, LIOstate l s)-unLIO (LIO (StateT f)) = f---- | Execute an LIO action.-runLIO :: forall l s a. (Label l) => LIO l s a -> LIOstate l s- -> IO (a, LIOstate l s)-runLIO m s = unLIO m s `E.catch` (E.throwIO . delabel)- where delabel :: LabeledExceptionTCB l -> SomeException- delabel (LabeledExceptionTCB _ e) = e- -- trace ("unlabeling " ++ show e ++ " {" ++ show l ++ "}") e---- | Produces an 'IO' computation that will execute a particular 'LIO'--- computation. Because untrusted code cannot execute 'IO'--- computations, this function should only be useful within trusted--- code. No harm is done from exposing the @evalLIO@ symbol to--- untrusted code. (In general, untrusted code is free to produce--- 'IO' computations--it just can't execute them without access to--- 'ioTCB'.)-evalLIO :: (Label l) =>- LIO l s a -- ^ The LIO computation to execute- -> s -- ^ Initial value of label-specific state- -> IO (a, l) -- ^ IO computation that will execute first argument-evalLIO m s = do (a, ls) <- runLIO m (newstate s)- return (a, lioL ls)---- | Lifts an 'IO' computation into the 'LIO' monad. Note that--- exceptions thrown within the 'IO' computation cannot directly be--- caught within the 'LIO' computation. Thus, if you are not inside a--- 'rethrowTCB' block, you will generally want to use 'rtioTCB'--- instead of 'ioTCB'.-ioTCB :: (Label l) => IO a -> LIO l s a-ioTCB a = mkLIO $ \s -> do r <- a; return (r, s)---- | Lifts an 'IO' computation into the 'LIO' monad. If the 'IO'--- computation throws an exception, it labels the exception with the--- current label so that the exception can be caught with 'catch' or--- 'catchP'. This function's name stands for \"re-throw io\", because--- the functionality is a combination of 'rethrowTCB' and 'ioTCB'.--- Effectively------ @--- rtioTCB = 'rethrowTCB' . 'ioTCB'--- @-rtioTCB :: (Label l) => IO a -> LIO l s a-rtioTCB a = rethrowTCB $ mkLIO $ \s -> do r <- a; return (r, s)------- Exceptions-----data LabelFault- = LerrLow -- ^ Requested label too low- | LerrHigh -- ^ Current label too high- | LerrClearance -- ^ Label would exceed clearance- | LerrPriv -- ^ Insufficient privileges- | LerrInval -- ^ Invalid request- deriving (Show, Typeable)--instance Exception LabelFault---- | Map a function over the underlying IO computation within an LIO.--- Obviously this symbol should not be exported, as it is privileged.-iomaps :: (Label l) =>- (LIOstate l s -> IO (a, LIOstate l s) -> IO (a, LIOstate l s))- -> LIO l s a -> LIO l s a-iomaps f c = mkLIO $ \s -> (f s $ unLIO c s)---- | Like 'iomaps' if you don't need the state.-iomap :: (Label l) =>- (IO (a, LIOstate l s) -> IO (a, LIOstate l s))- -> LIO l s a -> LIO l s a-iomap f = iomaps $ \_ -> f---- |Privileged code that does IO operations may cause exceptions that--- should be caught by untrusted code in the 'LIO' monad. Such--- operations should be wrapped by @rethrowTCB@ (or 'rtioTCB', which--- uses @rethrowTCB@) to ensure the exception is labeled. Note that--- it is very important that the computation executed inside--- @rethrowTCB@ not in any way change the label, as otherwise--- @rethrowTCB@ would put the wrong label on the exception.-rethrowTCB :: (Label l) => LIO l s a -> LIO l s a-rethrowTCB = iomaps $ \s -> handle (E.throwIO . (LabeledExceptionTCB $ lioL s))- -- mapException (LabeledExceptionTCB $ lioL s) c--data LabeledExceptionTCB l =- LabeledExceptionTCB l SomeException deriving Typeable--{- $lexception-- We must re-define the 'throwIO' and 'catch' functions to work in- the 'LIO' monad. A complication is that exceptions could- potentially leak information. For instance, within a block of code- wrapped by 'discard', one might examine a secret bit, and throw an- exception when the bit is 1 but not 0. Allowing untrusted code to- catch the exception leaks the bit.-- The solution is to wrap exceptions up with a label. The exception- may be caught, but only if the label of the exception can flow to- the label at the point the catch statement began execution. For- compatibility, the 'throwIO', 'catch', and 'onException' functions- are now methods that work in both the 'IO' or 'LIO' monad.-- If an exception is uncaught in the 'LIO' monad, the 'evalLIO'- function will unlabel and re-throw the exception, so that it is- okay to throw exceptions from within the 'LIO' monad and catch them- within the 'IO' monad. (Of course, code in the 'IO' monad must be- careful not to let the 'LIO' code exploit it to exfiltrate- information.)-- Wherever possible, however, code should use the 'catchP' and- 'onExceptionP' variants that use whatever privilege is available to- downgrade the exception. Privileged code that must always run some- cleanup function can use the 'onExceptionTCB' and 'bracketTCB'- functions to run the cleanup code on all exceptions.-- Note: Do not use 'throw' (as opposed to 'throwIO') within the- 'LIO' monad. Because 'throw' can be invoked from pure code, it has- no notion of current label and so cannot assign an appropriate- label to the exception. As a result, the exception will not be- catchable within the 'LIO' monad and will propagate all the way out- of the 'evalLIO' function. Similarly, asynchronous exceptions- (such as divide by zero or undefined values in lazily evaluated- expressions) cannot be caught within the 'LIO' monad.---}--instance Label l => Show (LabeledExceptionTCB l) where- showsPrec _ (LabeledExceptionTCB l e) rest =- shows e $ (" {" ++) $ shows l $ "}" ++ rest--instance (Label l) => Exception (LabeledExceptionTCB l)--instance (Label l) => MonadCatch (LIO l s) where- block = iomap E.block- unblock = iomap E.unblock- -- |It is not possible to catch pure exceptions from within the 'LIO'- -- monad, but @throwIO@ wraps up an exception with the current label,- -- so that it can be caught with 'catch' or 'catchP'..- throwIO e = mkLIO $ \s -> E.throwIO $- LabeledExceptionTCB (lioL s) (toException e)- -- | Basic function for catching labeled exceptions. (The fact that- -- they are labeled is hidden from the handler.)- --- -- > catch m c = catchP m NoPrivs (\_ -> c)- --- catch m c = iomaps (\s m' -> m' `E.catch` doit s) m- where- doit s e@(LabeledExceptionTCB l se) =- case fromException se of- Just e' | l `leq` lioC s ->- unLIO (c e') s { lioL = (lioL s) `lub` l }- _ -> E.throwIO e------ | Catches an exception, so long as the label at the point where the--- exception was thrown can flow to the label at which catchP is--- invoked, modulo the privileges specified. Note that the handler--- receives an an extra first argument (before the exception), which--- is the label when the exception was thrown.-catchP :: (Label l, Exception e, Priv l p) =>- p -- ^ Privileges with which to downgrade exception- -> LIO l s a -- ^ Computation to run- -> (l -> e -> LIO l s a) -- ^ Exception handler- -> LIO l s a -- ^ Result of computation or handler-catchP p m c = iomaps (\s m' -> m' `E.catch` doit s) m- where- doit s e@(LabeledExceptionTCB l se) =- case fromException se of- Just e' -> let lnew = lostar p l (lioL s)- in if leq lnew $ lioC s- then unLIO (c l e') s { lioL = lnew }- else E.throw e- _ -> E.throw e---- | Version of 'catchP' with arguments swapped.-handleP :: (Label l, Exception e, Priv l p) =>- p -- ^ Privileges with which to downgrade exception- -> (l -> e -> LIO l s a) -- ^ Exception handler- -> LIO l s a -- ^ Computation to run- -> LIO l s a -- ^ Result of computation or handler-handleP p = flip (catchP p)---- | 'onException' cannot run its handler if the label was raised in--- the computation that threw the exception. This variant allows--- privileges to be supplied, so as to catch exceptions thrown with a--- raised label.-onExceptionP :: (Priv l p) =>- p -- ^ Privileges to downgrade exception- -> LIO l s a -- ^ The computation to run- -> LIO l s b -- ^ Handler to run on exception- -> LIO l s a -- ^ Result if no exception thrown-onExceptionP p io what = catchP p io- (\_ e -> what >> throwIO (e :: SomeException))---- | Like standard 'E.bracket', but with privileges to downgrade--- exception.-bracketP :: (Priv l p) =>- p- -> LIO l s a- -> (a -> LIO l s c)- -> (a -> LIO l s b)- -> LIO l s b-bracketP p = genericBracket (onExceptionP p)---- | For privileged code that needs to catch all exceptions in some--- cleanup function. Note that for the 'LIO' monad, these methods do--- /not/ call 'rethrowTCB' to label the exceptions. It is assumed--- that you will use 'rtioTCB' instead of 'ioTCB' for IO within the--- computation arguments of these methods.-class (MonadCatch m) => OnExceptionTCB m where- onExceptionTCB :: m a -> m b -> m a- bracketTCB :: m a -> (a -> m c) -> (a -> m b) -> m b- bracketTCB = genericBracket onExceptionTCB-instance OnExceptionTCB IO where- onExceptionTCB = E.onException- bracketTCB = E.bracket-instance (Label l) => OnExceptionTCB (LIO l s) where- onExceptionTCB m cleanup = - mkLIO $ \s -> unLIO m s `E.catch` \e ->- unLIO cleanup s >> E.throwIO (e :: SomeException)--instance (Label l) => MonadError IOException (LIO l s) where- throwError = throwIO- catchError = catch---- | Evaluate in LIO.-evaluate :: (Label l) => a -> LIO l s a-evaluate = rtioTCB . E.evaluate+#if __GLASGOW_HASKELL__ >= 702+{-# LANGUAGE SafeImports #-}+#endif+#if __GLASGOW_HASKELL__ >= 704+{-# LANGUAGE Unsafe #-}+#endif+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FunctionalDependencies #-}++-- | This module implements the core of the Labeled IO library for+-- information flow control in Haskell. It provides a monad, 'LIO',+-- that is intended to be used as a replacement for the IO monad in+-- untrusted code. The idea is for untrusted code to provide a+-- computation in the 'LIO' monad, which trusted code can then safely+-- execute through the 'evalLIO' function. (Though usually a wrapper+-- function is employed depending on the type of labels used by an+-- application. For example, with "LIO.DCLabel", you would use+-- 'evalDC' to execute an untrusted computation. There are also+-- abbreviations for the 'LIO' monad type of a particular+-- label--for instance 'DC'.)+--+-- A data structure 'Labeled' (labeled value) protects access to pure+-- values. Without the appropriate privileges, one cannot produce a+-- pure value that depends on a secret 'Labeled', or conversely produce a+-- high-integrity 'Labeled' based on pure data. The function 'toLabeled'+-- allows one to seal off the results of an LIO computation inside an+-- 'Labeled' without tainting the current flow of execution. 'unlabel'+-- conversely allows one to use the value stored within a 'Labeled'.+--+-- We note that using 'toLabeled' is /not/ safe with respect to+-- the termination covert channel. Specifically, LIO with 'toLabeled'+-- is only termination-insensitive non-interfering. For a+-- termination-sensitive 'toLabeled'-like function, see "LIO.Concurrent".+-- +-- Any code that imports this module is part of the+-- /Trusted Computing Base/ (TCB) of the system. Hence, untrusted+-- code must be prevented from importing this module. The exported+-- symbols ending @...TCB@ can be used to violate label protections+-- even from within pure code or the LIO Monad. A safe subset of+-- these symbols is exported by the "LIO.Safe" module, which is how+-- untrusted code should access the core label functionality.+-- ("LIO.Safe" is also re-exported by "LIO", the main gateway to+-- this library.)+--+module LIO.TCB (-- * Basic Label Functions+ -- $labels+ Label(..)+ -- * Basic Privilige Functions+ -- $privs+ , Priv(..), NoPrivs(..)+ , getPrivileges, withPrivileges+ , withCombinedPrivs + -- * Labeled IO Monad (LIO)+ -- $LIO+ , LIO, LabelState+ , evalLIO, runLIO+ , newState+ , getLabel, setLabelP+ , getClearance, lowerClr, lowerClrP+ , withClearance+ -- * Labeled Values+ , Labeled+ , labelOf+ , label, labelP+ , unlabel, unlabelP+ , taintLabeled+ , toLabeled, toLabeledP, discard, discardP+ -- ** LIO Guards+ -- $guards+ , taint, taintP+ , wguard, wguardP+ , aguard, aguardP+ -- * Labeled Exceptions+ -- $lexception+ -- ** Exception type thrown by LIO library+ , LabelFault(..)+ -- ** Throwing and Catching Labeled Exceptions+ -- $throw+ , LabeledException(..)+ , MonadCatch(..)+ , catchP, handleP+ , onExceptionP, bracketP+ , evaluate+ -- * Unsafe (TCB) Operations+ -- ** Basic Label Functions+ , PrivTCB, MintTCB(..)+ -- ** Labeled IO Monad (LIO)+ , LIOstate(..)+ , getTCB, putTCB+ , setLabelTCB, lowerClrTCB+ -- ** Labeled Values+ , ShowTCB(..), ReadTCB(..)+ , labelTCB, unlabelTCB+ -- ** Labeled Exceptions+ , catchTCB, OnExceptionTCB(..)+ , ioTCB, rtioTCB+ ) where++#if __GLASGOW_HASKELL__ >= 702+import safe Prelude hiding (catch)+import safe Control.Exception hiding (catch, handle, throw, throwIO,+ onException, block, unblock, evaluate)+import safe qualified Control.Exception as E+import safe Data.Monoid+import safe Data.Typeable+import safe Data.Functor+import safe Control.Applicative+import safe Text.Read (minPrec)+import safe LIO.MonadCatch+#else+import Prelude hiding (catch)+import qualified Control.Exception as E+import Data.Monoid+import Data.Typeable+import Data.Functor+import Control.Applicative+import Text.Read (minPrec)+import LIO.MonadCatch+#endif++import Control.Monad.Error+import Control.Monad.State.Lazy hiding (put, get)++---------------------------------------------------------------------+-- Basic label functions --------------------------------------------+---------------------------------------------------------------------++{- $labels++Labels are a way of describing who can observe and modify data. There+is a partial order, generally pronounced \"can flow to\" on labels.+In Haskell we write this partial order ``leq`` (in the literature it+is usually written as ⊑).++The idea is that data labeled @L_1@ should affect data labeled+@L_2@ only if @L_1@ ``leq`` @L_2@, (i.e., @L_1@ /can flow to/+@L_2@). The 'LIO' monad keeps track of the current label of the+executing code (accessible via the 'getLabel' function). Code may+attempt to perform various IO or memory operations on labeled data.+Touching data may change the current label (or throw an exception+if an operation would violate can-flow-to restrictions).++If the current label is @L_cur@, then it is only permissible to+read data labeled @L_r@ if @L_r ``leq`` L_cur@. This is sometimes+termed \"no read up\" in the literature; however, because the partial+order allows for incomparable labels (i.e., two labels @L_1@ and+@L_2@ such that @not (L_1 ``leq`` L_2) && not (L_2 ``leq`` L_1)@),+a more appropriate phrasing would be \"read only what can flow to+your label\". Note that, rather than throw an exception, reading+data will often just increase the current label to ensure that+@L_r ``leq`` L_cur@. The LIO monad keeps a second label, called+the /clearance/ (see 'getClearance'), that represents the highest+value the current thread can raise its label to. The purpose of+clearance is to enforce of discretionary access control: you can+set the clearance to a label @L_clear@ as to prevent a piece of+LIO code from reading anything above @L_clear@.++Conversely, it is only permissible to modify data labeled @L_w@+when @L_cur``leq`` L_w@, a property often cited as \"no write+down\", but more accurately characterized as \"write only what you+can flow to\". In practice, there are very few IO abstractions+(namely, mutable references) in which it is possible to do a pure+write that doesn't also involve observing some state. For instance,+writing to a file handle and not getting an exception tells you that+the handle is not closed. Thus, in practice, the requirement for+modifying data labeled @L_w@ is almost always that @L_cur == L_w@.++Note that higher labels are neither more nor less privileged than+lower ones. Simply, the higher one's label is, the more things one+can read. Conversely, the lower one's label, the more things one can+write. But, because labels are a partial and not a total order, +some data may be completely inaccessible to a particular computation;+for instance, if the current label is @L_cur@, the current clearance+ is @C_cur@, and some data is labeled @Ld_@, such that @not (L_cur+``leq`` L_d || L_d ``leq`` C_cur)@, then the current thread can+neither read nor write the data, at least without invoking some+privilege.+-}++{- | This class defines a label format, corresponding to a bounded+lattice. Specifically, it is necessary to define a bottom element+'lbot' (in literature, written as ⊥), a top element 'ltop'+(in literature, written as ⊤), a join, or least upper bound,+'lub' (in literature, written as ⊔), a meet, or greatest lower+bound, 'glb' (in literature, written as ⊓), and of course the+can-flow-to partial-order 'leq' (in literature, written as ⊑).+-}+class (Eq a, Show a, Read a, Typeable a) => Label a where+ -- | Bottom+ lbot :: a+ -- | Top+ ltop :: a+ -- | Least upper bound (join) of two labels+ lub :: a -> a -> a+ -- | Greatest lower bound (meet) of two labels+ glb :: a -> a -> a+ -- | Can-flow-to relation+ leq :: a -> a -> Bool++---------------------------------------------------------------------+-- Basic privilege functions ----------------------------------------+---------------------------------------------------------------------++{- $privs++Privilege comes from a separate class called 'Priv', representing the+ability to bypass the protection of certain labels. Essentially,+privilege allows you to behave as if @L_1 ``leq`` L_2@ even when+that is not the case. The process of making data labeled @L_1@+affect data labeled @L_2@ when @not (L_1 ``leq`` L_2)@ is called+/downgrading/.++The basic method of the 'Priv' object is 'leqp', which performs the+more permissive can-flow-to check in the presence of particular+privileges (in literature this relation is a pre-order, commonly+written as ⊑ₚ). Many 'LIO' operations have variants+ending @...P@ that take a privilege argument to act in a more+permissive way. It is also possible to execute an 'LIO' action with+a set of privileges (without explicitly using the @...P@ combinators)+using the 'withPrivileges' combinator. Practicing the /principle of+least privilege/, it is recommended that 'withPrivileges' only be+used in small blocks of code in which many operations require the+same privileges. It is safer to use @...P@ operators and privileges+explicitly.++All 'Priv' types are monoids, and so can be combined with 'mappend'.+How to create 'Priv' objects is specific to the particular label+type in use. The method used is 'mintTCB', but the arguments depend+on the particular label type. (Of course, the symbol 'mintTCB'+must not be available to untrusted code.)++-}+++-- | @PrivTCB@ is a method-less class whose only purpose is to be+-- unavailable to unprivileged code. Since @(PrivTCB t) =>@ is in the+-- context of class 'Priv' and unprivileged code cannot create new+-- instances of the @PrivTCB@ class, this ensures unprivileged code+-- cannot create new instances of the 'Priv' class either, even though+-- the symbol 'Priv' is exported by "LIO.Base" and visible to+-- untrusted code.+class PrivTCB t where++-- | This class defines privileges and the more-permissive relation+-- ('leqp') on labels using privileges. Additionally, it defines+-- 'lostar' which is used to compute the smallest difference between+-- two labels given a set of privilege.+class (Label l, Monoid p, PrivTCB p) => Priv l p where+ -- | The \"can-flow-to given privileges\" pre-order used to+ -- compare two labels in the presence of privileges.+ -- If @'leqp' p L_1 L_2@ holds, then privileges @p@ are sufficient to+ -- downgrade data from @L_1@ to @L_2@. Note that @'leq' L_1 L_2@+ -- implies @'leq' p L_1 L_2@ for all @p@, but for some labels and+ -- privileges, 'leqp' will hold even where 'leq' does not.+ leqp :: p -> l -> l -> Bool+ leqp p a b = lostar p a b `leq` b++ -- | 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+ -- label @L_r == L ``lub``L_g@. If @p@ contains all possible privileges,+ -- then @L_r == L_g@.+ --+ -- More specifically, @L_r@ is the greatest lower bound of the+ -- set of all labels @L_l@ satisfying:+ --+ -- 1. @ L_g ⊑ L_l@, and+ --+ -- 2. @ L ⊑ₚ L_l@.+ --+ -- Operationally, @lostar@ captures the minimum change required to+ -- the current label when viewing data labeled @L_l@. A common+ -- pattern is to use the result of 'getLabel' as @L_g@ (i.e.,+ -- the goal is to use privileges @p@ to avoid changing the label+ -- at all), and then compute @L_r@ based on the label of data+ -- the code is about to observe. For example, 'taintP' could be+ -- implemented as:+ --+ -- @+ -- taintP p l = do lcurrent <- 'getLabel'+ -- 'taint' (lostar p l lcurrent)+ -- @+ lostar :: p -- ^ Privileges+ -> l -- ^ Label from which data must flow+ -> l -- ^ Goal label+ -> l -- ^ Result++class MintTCB t i where+ -- |A function that mints new objects (such as instances of+ -- 'Priv') in a way that only privileged code should be allowed to+ -- do. Because the MintTCB method is only available to+ -- priviledged code, other modules imported by unpriviledged code+ -- 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++---------------------------------------------------------------------+-- Labeled IO -------------------------------------------------------+---------------------------------------------------------------------++-- $LIO+-- +-- The 'LIO' monad is a wrapper around 'IO' that keeps track of the+-- current label and clearance. It is possible to raise one's label+-- or lower one's clearance without privilege, but moving in the other+-- direction requires appropriate privilege. The 'LIO' monad also+-- keeps track of a set of privileges, used within a 'withPrivileges'+-- block.+--+-- 'LIO' is parameterized by three types. The first is the+-- particular label type. The second type is the type of underlying+-- privileges. The third type is state specific to and functionally+-- determined by the label type. Trusted label implementation code+-- can use 'getTCB' and 'putTCB' to get and set the label state.++-- | Empty class used to specify the functional dependency between a+-- label and it state.+class (Priv l p, Label l) => LabelState l p s | l -> s, l -> p where+++-- | Internal state of an 'LIO' computation.+data LIOstate l p s = LIOstate { labelState :: s -- ^ label-specific state+ , lioL :: l -- ^ current label+ , lioC :: l -- ^ current clearance+ , lioP :: p -- ^ current privileges+ }++-- | LIO monad is a State monad transformer with IO as the underlying+-- monad.+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)++-- | 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++-- | 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+ where update s = s { labelState = ls }++-- | Generate a fresh state to pass 'runLIO' when invoking it for the+-- first time. The current label is set to 'lbot', the current+-- clearance is set to 'ltop', and the current privileges are set to+-- none.+newState :: (LabelState l p s) => s -> LIOstate l p s+newState s = LIOstate { labelState = s+ , lioL = lbot+ , lioC = ltop+ , lioP = mempty }++-- | Lift an IO computation into @LIO@.+mkLIO :: (LabelState l p s)+ => (LIOstate l p s -> IO (a, LIOstate l p s)) -> LIO l p s a+mkLIO = LIO . StateT++-- | Given an LIO computation and state, run it.+unLIO :: (LabelState l p s)+ => LIO l p s a -> LIOstate l p s -> IO (a, LIOstate l p s)+unLIO (LIO m) = runStateT m++-- | Execute an LIO action. The label on exceptions are removed.+-- See 'evalLIO'.+runLIO :: forall l p s a. (LabelState l p s)+ => LIO l p s a -> LIOstate l p s -> IO (a, LIOstate l p s)+runLIO m s = unLIO m s `catch` (throwIO . delabel)+ where delabel :: LabeledException l -> SomeException+ delabel (LabeledExceptionTCB _ e) = e++-- | Produces an 'IO' computation that will execute a particular 'LIO'+-- computation. Because untrusted code cannot execute 'IO'+-- computations, this function should only be useful within trusted+-- code. No harm is done from exposing the @evalLIO@ symbol to+-- untrusted code. (In general, untrusted code is free to produce+-- 'IO' computations--it just can't execute them without access to+-- 'ioTCB'.)+evalLIO :: (LabelState l p s) =>+ LIO l p s a -- ^ The LIO computation to execute+ -> s -- ^ Initial value of label-specific state+ -> IO (a, l) -- ^ IO computation that will execute first argument+evalLIO m s = do (a, ls) <- runLIO m (newState s)+ return (a, lioL ls)++-- | Returns the current value of the thread's label.+getLabel :: (LabelState l p s) => LIO l p s l+getLabel = lioL <$> get++-- | Returns the current value of the thread's clearance.+getClearance :: (LabelState l p s) => LIO l p s l+getClearance = lioC <$> get+++-- | Returns the current privileges.+getPrivileges :: (LabelState l p s) => LIO l p s p+getPrivileges = lioP <$> get++-- | Execute an LIO action with a set of underlying privileges. Within+-- a @withPrivileges@ block, the supplied privileges are used in every +-- even (non @...P@) operation. For instance,+--+-- > unlabelP p x+--+-- can instead be written as:+--+-- > withPrivileges p $ unlabel x+--+-- The original privileges of the thread are restored after+-- the action is executed within the @withPrivileges@ block.+-- The @withPrivileges@ combinator provides a middle-ground between+-- a fully explicit, but safe, privilege use (@...P@ combinators),+-- and an implicit, but less safe, interface (provide getter/setter,+-- and always use underlying privileges). It allows for the use+-- of implicit privileges by explicitly enclosing the code with a+-- @withPrivileges@ block.+withPrivileges :: (LabelState l p s) => p -> LIO l p s a -> LIO l p s a+withPrivileges p m = do+ s <- get+ p0 <- getPrivileges+ put s { lioP = p `mappend` p0 }+ a <- m+ put s { lioP = p0 }+ return a++-- | If the current label is @oldLabel@ and the current clearance is+-- @clearance@, this function allows code to raise the label to+-- any value @newLabel@ such that+-- @oldLabel ``leq`` newLabel && newLabel ``leq`` clearance@. +-- Note that there is no @setLabel@ variant without the @...P@+-- because the 'taint' function provides essentially the same+-- functionality that @setLabel@ would.+setLabelP :: (LabelState l p s) => p -> l -> LIO l p s ()+setLabelP p' l = withCombinedPrivs p' $ \p -> do+ s <- get+ if leqp p (lioL s) l+ then put 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+ if l `leq` lioC s+ then put 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+ where doit s | not $ l `leq` lioC s = throwIO LerrClearance+ | not $ lioL s `leq` l = throwIO LerrLow+ | otherwise = put 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+ where doit p s | not $ leqp p l $ lioC s = throwIO LerrPriv+ | not $ lioL s `leq` l = throwIO LerrLow+ | otherwise = put 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+ where doit s | not $ lioL s `leq` l =+ throwIO $ LerrInval ("Cannot lower the current clearance"+ ++ " below current label.")+ | otherwise = put s { lioC = l }++-- | Lowers the clearance of a computation, then restores the+-- clearance to its previous value. Useful to wrap around a+-- computation if you want to be sure you can catch exceptions thrown+-- by it. Also useful to wrap around 'toLabeled' to ensure that the+-- computation does not access data exceeding a particular label. If+-- @withClearance@ is given a label that can't flow to the current+-- clearance, then the clearance is lowered to the greatest lower+-- bound of the label supplied and the current clearance.+--+-- Note that if the computation inside @withClearance@ acquires any+-- 'Priv's, it may still be able to raise its clearance above the+-- 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 }+ a <- m+ put s { lioC = lioC s }+ return a++-- | Lifts an 'IO' computation into the 'LIO' monad. Note that+-- exceptions thrown within the 'IO' computation cannot directly be+-- caught within the 'LIO' computation. Thus, you will generally+-- want to use 'rtioTCB' instead of 'ioTCB'.+ioTCB :: (LabelState l p s) => IO a -> LIO l p s a+ioTCB a = mkLIO $ \s -> do+ r <- a+ return (r, s)++-- | Lifts an 'IO' computation into the 'LIO' monad. If the 'IO'+-- computation throws an exception, it labels the exception with the+-- current label so that the exception can be caught with 'catch' or+-- 'catchP'. This function's name stands for \"re-throw io\".+rtioTCB :: (LabelState l p s) => IO a -> LIO l p s a+rtioTCB io = do+ l <- getLabel+ ioTCB $ io `catch` (throwIO . (LabeledExceptionTCB l))++---------------------------------------------------------------------+-- Labeled value ----------------------------------------------------+---------------------------------------------------------------------++-- | @Labeled@ is a type representing labeled data. +data Labeled l t = LabeledTCB l t++-- | Returns label of a 'Labeled' type.+labelOf :: Label l => Labeled l a -> l+labelOf (LabeledTCB l _) = l++-- | Function to construct a 'Labeled' from a label and pure value. If+-- the current label is @lcurrent@ and the current clearance is+-- @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++-- | Constructs a 'Labeled' using privilege to allow the `Labeled`'s label+-- to be below the current label. If the current label is @lcurrent@+-- and the current clearance is @ccurrent@, then the privilege @p@ and+-- label @l@ specified must satisfy+-- @(leqp p lcurrent l) && l ``leq`` ccurrent@.+-- Note that privilege is not used to bypass the clearance. You must+-- 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+ where doit p s | not $ l `leq` lioC s = throwIO LerrClearance+ | not $ leqp p (lioL s) l = throwIO LerrLow+ | otherwise = return $ LabeledTCB l a++-- | Trusted constructor that creates labeled values.+labelTCB :: Label l => l -> a -> Labeled l a+labelTCB l a = LabeledTCB l a++-- | Within the 'LIO' monad, this function takes a 'Labeled' and returns+-- the value. Thus, in the 'LIO' monad one can say:+--+-- > x <- unlabel (xv :: Labeled SomeLabelType Int)+--+-- And now it is possible to use the value of @x@, which is the pure+-- value of what was stored in @xv@. Of course, @unlabel@ also raises+-- the current label. If raising the label would exceed the current+-- clearance, then @unlabel@ throws 'LerrClearance'.+-- 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++-- | Extracts the value of an 'Labeled' just like 'unlabel', but takes a+-- privilege argument to minimize the amount the current label must be+-- raised. Will still throw 'LerrClearance' under the same+-- circumstances as 'unlabel'.+unlabelP :: (LabelState l p s) => p -> Labeled l a -> LIO l p s a+unlabelP p' (LabeledTCB la a) = withCombinedPrivs p' $ \p ->+ taintP p la >> return a++-- | Extracts the value from an 'Labeled', discarding the label and any+-- protection.+unlabelTCB :: Label l => Labeled l a -> a+unlabelTCB (LabeledTCB _ a) = a++-- | Raises the label of a 'Labeled' to the 'lub' of it's current label+-- and the value supplied. The label supplied must be less than the+-- current clearance, though the resulting label may not be if the+-- 'Labeled' is already above the current thread's clearance.+taintLabeled :: (LabelState l p s)+ => l -> Labeled l a -> LIO l p s (Labeled l a)+taintLabeled l (LabeledTCB la a) = do+ aguard l+ return $ LabeledTCB (lub l la) a+++-- | @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.+--+-- 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.+--+-- 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+{-# WARNING toLabeled "toLabeled is susceptible to termination attacks" #-}++-- | Same as 'toLabeled' but allows one to supply a privilege object+-- when comparing the initial and final label of the computation.+--+-- WARNING: @toLabeledP@ is susceptible to termination attacks.+--+toLabeledP :: (LabelState l p s)+ => 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+{-# WARNING toLabeledP "toLabeledP is susceptible to termination attacks" #-}++-- | Executes a computation that would raise the current label, but+-- discards the result so as to keep the label the same. Used when+-- one only cares about the side effects of a computation. For+-- instance, if @log_handle@ is an 'LHandle' with a high label, one+-- can execute+--+-- @+-- discard ltop $ 'hputStrLn' log_handle \"Log message\"+-- @+--+-- to create a log message without affecting the current label. (Of+-- course, if @log_handle@ is closed and this throws an exception, it+-- may not be possible to catch the exception within the 'LIO' monad+-- without sufficient privileges--see 'catchP'.)+--+-- 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+{-# WARNING discard "discard is susceptible to termination attacks" #-}++-- | Same as 'discard', but uses privileges when comparing initial and+-- final label of the computation.+discardP :: (LabelState l p s) => p -> l -> LIO l p s a -> LIO l p s ()+discardP p l m = toLabeledP p l m >> return ()+{-# WARNING discardP "discardP is susceptible to termination attacks" #-}++++-- | It would be a security issue to make certain objects a member of+-- the 'Show' class, but nonetheless it is useful to be able to+-- examine such objects when debugging. The 'showTCB' method can be used+-- to examine such objects.+class ShowTCB a where+ showTCB :: a -> String++instance (Label l, Show a) => ShowTCB (Labeled l a) where+ showTCB (LabeledTCB l t) = show t ++ " {" ++ show l ++ "}"++-- | It is useful to have the dual of 'ShowTCB', @ReadTCB@, that allows+-- for the reading of 'Labeled's that were written using 'showTCB'. Only+-- @readTCB@ (corresponding to 'read') and @readsPrecTCB@ (corresponding+-- to 'readsPrec') are implemented.+class ReadTCB a where+ readsPrecTCB :: Int -> ReadS a+ readTCB :: String -> a+ readTCB str = check $ readsPrecTCB minPrec str+ where check [] = error "readTCB: no parse"+ check [(x,rst)] | all (==' ') rst = x+ | otherwise = error "readTCB: no parse"+ check _ = error "readTCB: ambiguous parse"++instance (Label l, Read l, Read a) => ReadTCB (Labeled l a) where+ readsPrecTCB _ str = do (val, str1) <- reads str+ ("{", str2) <- lex str1+ (lab, str3) <- reads str2+ ("}", rest) <- lex str3+ return (labelTCB lab val, rest)++---------------------------------------------------------------------+-- LIO guards -------------------------------------------------------+---------------------------------------------------------------------++{- $guards++ Guards are used by privileged code to check that the invoking,+ unprivileged code has access to particular data. If the current+ label is @lcurrent@ and the current clearance is @ccurrent@, then+ the following checks should be performed when accessing data+ labeled @ldata@:++ * When /reading/ an object labeled @ldata@, it must be the case+ that @ldata ``leq`` lcurrent@. This check is performed by the+ 'taint' function, so named becuase it \"taints\" the current LIO+ context by raising @lcurrent@ until @ldata ``leq`` lcurrent@.+ (Specifically, it does this by computing the least upper bound of+ the two labels with the 'lub' method of the 'Label' class.)+ However, if after doing this it would be the case that+ @not (lcurrent ``leq`` ccurrent)@, then 'taint' throws exception+ 'LerrClearance' rather than raising the current label.++ * When /writing/ an object, it should be the case that @ldata+ ``leq`` lcurrent && lcurrent ``leq`` ldata@. (As stated, this is+ the same as saying @ldata == lcurrent@, but the two are different+ when using 'leqp' instead of 'leq'.) This is ensured by the+ 'wguard' (write guard) function, which does the equivalent of+ 'taint' to ensure the target label @ldata@ can flow to the+ current label, then throws an exception if @lcurrent@ cannot flow+ back to the target label.++ * When /creating/ or /allocating/ objects, it is permissible for+ them to be higher than the current label, so long as they are+ bellow the current clearance. In other words, it must be the+ case that @lcurrent ``leq`` ldata && ldata ``leq`` ccurrent@.+ This is ensured by the 'aguard' (allocation guard) function.++The 'taintP', 'wguardP', and 'aguardP' functions are variants of the+above that take privilege to be more permissive and raise the current+label less. ++-}++-- | General (internal) taint function. Uses @mylub@ instead of+-- 'lub', so that privileges can optionally be passed in. Throws+-- 'LerrClearance' if raising the current label would exceed the+-- current clearance.+gtaint :: (LabelState l p s) =>+ (l -> l -> l) -- ^ @mylub@ function+ -> l -- ^ @l@ - Label to taint with+ -> LIO l p s ()+gtaint mylub l = do+ s <- get+ let lnew = l `mylub` (lioL s)+ if lnew `leq` lioC s+ then put s { lioL = lnew }+ else ioTCB $ E.throwIO $ LabeledExceptionTCB (lioL s)+ (toException LerrClearance)++-- |Use @taint l@ in trusted code before observing an object labeled+-- @l@. This will raise the current label to a value @l'@ such that+-- @l ``leq`` l'@, or throw @'LerrClearance'@ if @l'@ would have to be+-- higher than the current clearance.+taint :: (LabelState l p s) => l -> LIO l p s ()+taint = gtaint lub++-- |Like 'taint', but use privileges to reduce the amount of taint+-- required. Note that unlike 'setLabelP', @taintP@ will never lower+-- the current label. It simply uses privileges to avoid raising the+-- label as high as 'taint' would raise it.+taintP :: (LabelState l p s)+ => p -- ^Privileges to invoke+ -> l -- ^Label to taint to if no privileges+ -> LIO l p s ()+taintP p' l = withCombinedPrivs p' $ \p -> gtaint (lostar p) l++-- |Use @wguard l@ in trusted code before modifying an object labeled+-- @l@. If @l'@ is the current label, then this function ensures that+-- @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++-- |Like 'wguard', but takes privilege argument to be more permissive.+wguardP :: (LabelState l p s) => p -> l -> LIO l p s ()+wguardP p' l = withCombinedPrivs p' $ \p -> do+ l' <- getLabel+ if leqp p l' l+ then taintP p l+ else throwIO LerrHigh++-- |Ensures the label argument is between the current IO label and+-- current IO clearance. Use this function in code that allocates+-- 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++-- | 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 (leqp p l newl) $ throwIO LerrLow+++---------------------------------------------------------------------+-- Labeled Exceptions -----------------------------------------------+---------------------------------------------------------------------++{- $lexception++LIO throws 'LabelFault' exceptions when an information flow violation+is to occur. In general, such exceptions are handled in the outer,+trusted IO code block that executes untrusted LIO code. However, it is+sometimes desirable for untrusted code to throw exceptions. To this+end we provide an implementation of labeled exceptions, as \"normal\"+exceptions are unsafe and can be used to leak information. We+describe the interface below.++-}++-- | Violation of information flow conditions, or label checks should+-- throw exceptions of type @LabelFault@. The @LerrInval@ constructor+-- takes a string parameter -- it is important that trusted code use+-- this carefully and aovid leaking information through it.+data LabelFault = LerrLow -- ^ Requested label too low+ | LerrHigh -- ^ Current label too high+ | LerrClearance -- ^ Label would exceed clearance+ | LerrPriv -- ^ Insufficient privileges+ | LerrInval String -- ^ Invalid request+ deriving Typeable++instance Show LabelFault where+ show LerrLow = "LerrLow: Requested label is too low"+ show LerrHigh = "LerrHigh: Requested label is too high"+ show LerrClearance = "LerrClearance: Label would exceed clearance"+ show LerrPriv = "LerrPriv: Insufficient privileges"+ show (LerrInval s) = "LerrInval: " ++ s++instance Exception LabelFault+++{- $throw++ We must re-define the 'throwIO' and 'catch' functions to work in+ the 'LIO' monad. A complication is that exceptions could+ potentially leak information. For instance, within a block of code+ wrapped by 'discard', one might examine a secret bit, and throw an+ exception when the bit is 1 but not 0. Allowing untrusted code to+ catch the exception leaks the bit.++ The solution is to wrap exceptions up with a label. The exception+ may be caught, but only if the label of the exception can flow to+ the label at the point the catch statement began execution. For+ compatibility, the 'throwIO', 'catch', and 'onException' functions+ are now methods that work in both the 'IO' or 'LIO' monad.++ If an exception is uncaught in the 'LIO' monad, the 'evalLIO'+ function will unlabel and re-throw the exception, so that it is+ okay to throw exceptions from within the 'LIO' monad and catch them+ within the 'IO' monad. (Of course, code in the 'IO' monad must be+ careful not to let the 'LIO' code exploit it to exfiltrate+ information.)++ Wherever possible, however, code should use the 'catchP' and+ 'onExceptionP' variants that use whatever privilege is available to+ downgrade the exception. Privileged code that must always run some+ cleanup function can use the 'onExceptionTCB' and 'bracketTCB'+ functions to run the cleanup code on all exceptions.++ /Note/: Do not use 'throw' (as opposed to 'throwIO') within the+ 'LIO' monad. Because 'throw' can be invoked from pure code, it has+ no notion of current label and so cannot assign an appropriate+ label to the exception. As a result, the exception will not be+ catchable within the 'LIO' monad and will propagate all the way out+ of the 'evalLIO' function. Similarly, asynchronous exceptions+ (such as divide by zero or undefined values in lazily evaluated+ expressions) cannot be caught within the 'LIO' monad.++-}++-- | A labeled exception is simply an exception associated with a label.+data LabeledException l = LabeledExceptionTCB l SomeException+ deriving (Typeable)++instance Label l => Show (LabeledException l) where+ show (LabeledExceptionTCB l e) = show e ++ " {" ++ show l ++ "}"++instance (Label l) => Exception (LabeledException l)++instance (LabelState l p s) => MonadCatch (LIO l p s) where+ mask k = mkLIO $ \s -> E.mask (fun k s)+ where fun :: (LabelState l p s)+ => ((forall a. LIO l p s a -> LIO l p s a) -> LIO l p s b)+ -> LIOstate l p s+ -> (forall a. IO a -> IO a) -> IO (b, LIOstate l p s)+ -- this is a little bit like magic to make types work:+ fun f s = \g -> unLIO (f (\x -> rtioTCB $ g (fst <$> unLIO x s))) s+ -- | It is not possible to catch pure exceptions from within the 'LIO'+ -- monad, but @throwIO@ wraps up an exception with the current label,+ -- so that it can be caught with 'catch' or 'catchP'..+ throwIO e = do+ l <- getLabel+ ioTCB $ E.throwIO $ LabeledExceptionTCB l (toException e)++ -- | Basic function for catching labeled exceptions. (The fact that+ -- they are labeled is hidden from the handler.)+ --+ -- > catch = catchP NoPrivs+ --+ catch x h = getPrivileges >>= \p -> catchP p x h+++-- | Catches an exception, so long as the label at the point where the+-- exception was thrown can flow to the label at which @catchP@ is+-- invoked, modulo the privileges specified. Note that the handler+-- receives an extra first argument (before the exception), which+-- is the label when the exception was thrown.+catchP :: (Exception e, LabelState l p s)+ => p -- ^ Privileges with which to downgrade exception+ -> LIO l p s a -- ^ Computation to run+ -> (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+ 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+ then unLIO (taintP p le >> handler e') s+ else throwIO e)+ put s'+ return a++-- | Trusted catch functin.+catchTCB :: (LabelState l p s)+ => LIO l p s a -- ^ Computation to run+ -> (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+ (a, s') <- ioTCB $ do+ (unLIO io s) `E.catch` (\e -> unLIO (handler e) s)+ put s'+ return a++-- | Version of 'catchP' with arguments swapped.+handleP :: (Exception e, LabelState l p s)+ => p -- ^ Privileges with which to downgrade exception+ -> (e -> LIO l p s a) -- ^ Exception handler+ -> LIO l p s a -- ^ Computation to run+ -> LIO l p s a -- ^ Result of computation or handler+handleP p = flip (catchP p)++-- | 'onException' cannot run its handler if the label was raised in+-- the computation that threw the exception. This variant allows+-- privileges to be supplied, so as to catch exceptions thrown with a+-- raised label.+onExceptionP :: (LabelState l p s)+ => p -- ^ Privileges to downgrade exception+ -> LIO l p s a -- ^ The computation to run+ -> LIO l p s b -- ^ Handler to run on exception+ -> LIO l p s a -- ^ Result if no exception thrown+onExceptionP p io what = catchP p io+ (\e -> what >> throwIO (e :: SomeException))++-- | Like standard 'E.bracket', but with privileges to downgrade+-- exception.+bracketP :: (LabelState l p s)+ => p -- ^ Priviliges used to downgrade+ -> LIO l p s a -- ^ Computation to run first+ -> (a -> LIO l p s c) -- ^ Computation to run last+ -> (a -> LIO l p s b) -- ^ Computation to run in-between+ -> LIO l p s b+bracketP p' f l i = withCombinedPrivs p' $ \p ->+ genericBracket (onExceptionP p) f l i++-- | Forces its argument to be evaluated to weak head normal form when the+-- resultant LIO action is executed. This is simply a wrapper for +-- "Control.Exception"'s @evaluate@.+evaluate :: (LabelState l p s) => a -> LIO l p s a+evaluate = rtioTCB . E.evaluate++-- | For privileged code that needs to catch all exceptions in some+-- cleanup function. Note that for the 'LIO' monad, these methods do+-- /not/ label the exceptions. It is assumed that you will use+-- 'rtioTCB' instead of 'ioTCB' for IO within the computation arguments+-- of these methods.+class (MonadCatch m) => OnExceptionTCB m where+ onExceptionTCB :: m a -> m b -> m a+ bracketTCB :: m a -> (a -> m c) -> (a -> m b) -> m b+ bracketTCB = genericBracket onExceptionTCB++instance OnExceptionTCB IO where+ onExceptionTCB = E.onException+ bracketTCB = E.bracket++instance (LabelState l p s) => OnExceptionTCB (LIO l p s) where+ onExceptionTCB m cleanup = mkLIO $ \s ->+ unLIO m s `catch` (\e -> unLIO cleanup s >> throwIO (e :: SomeException))++instance (LabelState l p s) => MonadError IOException (LIO l p s) where+ throwError = throwIO+ catchError = catch+++--+-- Misc helper+--++-- | Execute an 'LIO' action with the combination of the supplied+-- privileges (usually passed to @...P@ functions) and current+-- privileges.+withCombinedPrivs :: LabelState l p s => p -> (p -> LIO l p s a) -> LIO l p s a+withCombinedPrivs p0 io = do+ p1 <- getPrivileges+ io (p0 `mappend` p1)
− LIO/TmpFile.hs
@@ -1,146 +0,0 @@-{-# LANGUAGE ForeignFunctionInterface #-}---- | This module creates new files and directories with unique names.--- Its functionality is similary to C's mkstemp() and mkdtemp()--- functions.-module LIO.TmpFile (-- * The high level interface- mkTmpFile- , mkTmpDir- , mkTmpDir'- -- * Some lower-level helper functions- , mkTmp, openFileExclusive- -- * Functions for generating unique names- , tmpName, nextTmpName, serializele, unserializele- -- * For flushing temp files before rename- , hSync- )where--import LIO.Armor--import Prelude hiding (catch)-import Control.Exception (throwIO, catch)--- import qualified Control.Exception as IO-import Data.Bits (shiftL, shiftR, (.|.))-import qualified Data.ByteString.Lazy as L-import Data.Word (Word8)-import Foreign.C.Error-import Foreign.C.Types-import System.Directory (createDirectory)-import System.FilePath ((</>))-import System.Posix.IO (OpenMode(..), OpenFileFlags(..)- , defaultFileFlags , openFd, fdToHandle)-import qualified System.IO as IO-import qualified System.IO.Error as IO-import System.Time (ClockTime(..), getClockTime)--import Data.Typeable-import GHC.IO.FD (FD(..))-import GHC.IO.Handle.Types (Handle__(..))-import GHC.IO.Handle.Internals (wantWritableHandle)--foreign import ccall "unistd.h fsync" c_fsync :: CInt -> IO CInt------- Temporary file name based on time in 1/16 of a microsecond, then--- step until unused file name found.------- | Serialize an Integer into an array of bytes, in little-endian--- order.-serializele :: Int -- ^ Minimum number of bytes to return- -> Integer -- ^ The Integer to serialize- -> [Word8]-serializele n i | n <= 0 && i <= 0 = []-serializele n i = (fromInteger i):serializele (n - 1) (i `shiftR` 8)---- | Take an array of bytes containing an Integer serialized in--- little-endian order, and return the Integer.-unserializele :: [Word8] -> Integer-unserializele [] = 0-unserializele (c:s) = (fromIntegral c) .|. (unserializele s `shiftL` 8)---- | Return a temorary file name, based on the value of the current--- time of day clock.-tmpName :: IO String-tmpName = do- (TOD sec psec) <- getClockTime- return $ armor32 $ L.pack $- serializele 3 (psec `shiftR` 16) ++ serializele 4 sec---- | When the file name returned by 'tmpName' already exists,--- @nextTmpName@ modifies the file name to generate a new one.-nextTmpName :: String -> String-nextTmpName s =- let val = unserializele $ L.unpack $ dearmor32 s- in armor32 $ L.pack $ serializele 7 (1 + val)---- | Opens a file in exclusive mode, throwing AlreadyExistsError if--- the file name is already in use.-openFileExclusive :: IO.IOMode -> FilePath -> IO IO.Handle-openFileExclusive m p = do- let dom = defaultFileFlags { exclusive = True }- (om, fm) = case m of- IO.WriteMode -> (WriteOnly, dom)- IO.AppendMode -> (WriteOnly, dom { append = True })- IO.ReadWriteMode -> (ReadWrite, dom)- IO.ReadMode ->- error "openFileExclusive: ReadMode is illegal"- fd <- openFd p om (Just $ toEnum 0o666) fm- fdToHandle fd---- | Executes a function on temporary file names until the function--- does not throw AlreadyExistsError. For example, 'mkTmpFile' is--- defined as:------ > mkTmpFile m d s = mkTmp (openFileExclusive m) d s----mkTmp :: (FilePath -> IO a) -- ^The function to execute (@f@)- -> FilePath -- ^Directory to prepend to temp file names- -> String -- ^Suffix for new file name- -> IO (a, FilePath) -- ^The result of @f@ and the- -- FilePath on which it finally- -- succeeded.-mkTmp f dir suffix = tmpName >>= loop- where- ff n = case dir </> n of path -> do a <- f path; return (a, path)- loop name = ff (name ++ suffix) `catch` reloop name- reloop name e = if IO.isAlreadyExistsError e- then loop $ nextTmpName name- else throwIO e----- | Creates a new file with a unique name in a particular directory-mkTmpFile :: IO.IOMode -- ^@WriteMode@, @AppendMode@, or- -- @ReadWriteMode@ (It is an error to- -- use @ReadMode@.)- -> FilePath -- ^Directory in which to create file- -> String -- ^Suffix for new file name- -> IO (IO.Handle, FilePath) -- ^Returns open handle to new- -- file, along with pathname of- -- new file-mkTmpFile m d s = mkTmp (openFileExclusive m) d s---- | Creates a new subdirectory with uniqe file name. Returns the--- pathname of the new directory as the second element of a pair, just--- for consistency with the interface to 'mkTmpFile'. See--- `mkTmpDir'` if you don't want this behavior.-mkTmpDir :: FilePath -- ^Directory in which to create subdirectory- -> String -- ^Suffix to append to new directory name- -> IO ((), FilePath) -- ^Returns full path to new directory-mkTmpDir d s = mkTmp createDirectory d s---- | Like 'mkTmpDir', but just returns the pathname of the new directory.-mkTmpDir' :: FilePath -- ^Directory in which to create subdirectory- -> String -- ^Suffix to append to new directory name- -> IO FilePath -- ^Returns full path to new directory-mkTmpDir' d s = fmap snd $ mkTmpDir d s---- | Flushes a Handle to disk with fsync()-hSync :: IO.Handle -> IO ()-hSync h = do- IO.hFlush h- wantWritableHandle "hSync" h $ fsyncH- where- fsyncH Handle__ {haDevice = dev} = maybe (return ()) fsyncD $ cast dev- fsyncD FD {fdFD = fd} = throwErrnoPathIfMinus1_ "fsync" (show h)- (c_fsync fd)
+ System/Posix/Tmp.hsc view
@@ -0,0 +1,112 @@+{-# LANGUAGE ForeignFunctionInterface #-}+#if __GLASGOW_HASKELL__ >= 701+{-# LANGUAGE Trustworthy #-}+#endif+-----------------------------------------------------------------------------+-- |+-- Module : System.Posix.Tmp+-- Copyright : (c) Volker Stolz <vs@foldr.org>+-- Deian Stefan <deian@cs.stanford.edu>+-- This is a copy of the /latest/ @System.Posix.Temp@ module. Because+-- @Temp@ will not be made available until GHC 7.6, we are including+-- the core functions here.+--+-----------------------------------------------------------------------------++module System.Posix.Tmp (+ mkstemp, mkstemps, mkdtemp+ ) where++#include "HsTmp.h"++import Foreign.C+import System.IO+import System.Posix.IO+import System.Posix.Types++#if __GLASGOW_HASKELL__ > 700+import System.Posix.Internals (withFilePath, peekFilePath)++#elif __GLASGOW_HASKELL__ > 611+import System.Posix.Internals (withFilePath)++peekFilePath :: CString -> IO FilePath+peekFilePath = peekCString++#else+withFilePath :: FilePath -> (CString -> IO a) -> IO a+withFilePath = withCString++peekFilePath :: CString -> IO FilePath+peekFilePath = peekCString+#endif++#if HAVE_MKSTEMP+foreign import ccall unsafe "HsUnix.h __hscore_mkstemp"+ c_mkstemp :: CString -> IO CInt+#endif++-- | Make a unique filename and open it for reading\/writing. The returned+-- 'FilePath' is the (possibly relative) path of the created file, which is+-- padded with 6 random characters. The argument is the desired prefix of the+-- filepath of the temporary file to be created.+mkstemp :: String -> IO (FilePath, Handle)+#if HAVE_MKSTEMP+mkstemp template' = do+ let template = template' ++ "XXXXXX"+ withFilePath template $ \ ptr -> do+ fd <- throwErrnoIfMinus1 "mkstemp" (c_mkstemp ptr)+ name <- peekFilePath ptr+ h <- fdToHandle (Fd fd)+ return (name, h)+#else+mkstemp = error "System.Posix.Temp.mkstemp: not supported"+#endif++#if HAVE_MKSTEMPS+foreign import ccall unsafe "HsUnix.h __hscore_mkstemps"+ c_mkstemps :: CString -> CInt -> IO CInt+#endif++-- | Make a unique filename with a given prefix and suffix and open it for+-- reading\/writing. The returned 'FilePath' is the (possibly relative) path of+-- the created file, which contains 6 random characters in between the prefix+-- and suffix. The first argument is the desired prefix of the filepath of the+-- temporary file to be created. The second argument is the suffix of the+-- temporary file to be created.+--+-- If you are using as system that doesn't support the mkstemps glibc function+-- (supported in glibc > 2.11) then this function simply throws an error.+mkstemps :: String -> String -> IO (FilePath, Handle)+#if HAVE_MKSTEMPS+mkstemps prefix suffix = do+ let template = prefix ++ "XXXXXX" ++ suffix+ lenOfsuf = (fromIntegral $ length suffix) :: CInt+ withFilePath template $ \ ptr -> do+ fd <- throwErrnoIfMinus1 "mkstemps" (c_mkstemps ptr lenOfsuf)+ name <- peekFilePath ptr+ h <- fdToHandle (Fd fd)+ return (name, h)+#else+mkstemps = error "System.Posix.Temp.mkstemps: not supported"+#endif++#if HAVE_MKDTEMP+foreign import ccall unsafe "HsUnix.h __hscore_mkdtemp"+ c_mkdtemp :: CString -> IO CString+#endif++-- | Make a unique directory. The returned 'FilePath' is the path of the+-- created directory, which is padded with 6 random characters. The argument is+-- the desired prefix of the filepath of the temporary directory to be created.+mkdtemp :: String -> IO FilePath+mkdtemp template' = do+#if HAVE_MKDTEMP+ let template = template' ++ "XXXXXX"+ withFilePath template $ \ ptr -> do+ _ <- throwErrnoIfNull "mkdtemp" (c_mkdtemp ptr)+ name <- peekFilePath ptr+ return name+#else+mkdtemp = error "System.Posix.Temp.mkdtemp: not supported"+#endif
+ cbits/HsTmp.c view
@@ -0,0 +1,19 @@+#include "HsTmp.h"++#if HAVE_MKSTEMP+int __hscore_mkstemp(char *filetemplate) {+ return (mkstemp(filetemplate));+}+#endif++#if HAVE_MKSTEMPS+int __hscore_mkstemps(char *filetemplate, int suffixlen) {+ return (mkstemps(filetemplate, suffixlen));+}+#endif++#if HAVE_MKDTEMP+char *__hscore_mkdtemp(char *filetemplate) {+ return (mkdtemp(filetemplate));+}+#endif
+ configure view
@@ -0,0 +1,3666 @@+#! /bin/sh+# Guess values for system-dependent variables and create Makefiles.+# Generated by GNU Autoconf 2.68 for Labeled IO library 0.1.0.+#+# Report bugs to <deian@cs.stanford.edu>.+#+#+# Copyright (C) 1992, 1993, 1994, 1995, 1996, 1998, 1999, 2000, 2001,+# 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010 Free Software+# Foundation, Inc.+#+#+# This configure script is free software; the Free Software Foundation+# gives unlimited permission to copy, distribute and modify it.+## -------------------- ##+## M4sh Initialization. ##+## -------------------- ##++# Be more Bourne compatible+DUALCASE=1; export DUALCASE # for MKS sh+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then :+ emulate sh+ NULLCMD=:+ # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which+ # is contrary to our usage. Disable this feature.+ alias -g '${1+"$@"}'='"$@"'+ setopt NO_GLOB_SUBST+else+ case `(set -o) 2>/dev/null` in #(+ *posix*) :+ set -o posix ;; #(+ *) :+ ;;+esac+fi+++as_nl='+'+export as_nl+# Printing a long string crashes Solaris 7 /usr/bin/printf.+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo+# Prefer a ksh shell builtin over an external printf program on Solaris,+# but without wasting forks for bash or zsh.+if test -z "$BASH_VERSION$ZSH_VERSION" \+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then+ as_echo='print -r --'+ as_echo_n='print -rn --'+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then+ as_echo='printf %s\n'+ as_echo_n='printf %s'+else+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'+ as_echo_n='/usr/ucb/echo -n'+ else+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'+ as_echo_n_body='eval+ arg=$1;+ case $arg in #(+ *"$as_nl"*)+ expr "X$arg" : "X\\(.*\\)$as_nl";+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;+ esac;+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"+ '+ export as_echo_n_body+ as_echo_n='sh -c $as_echo_n_body as_echo'+ fi+ export as_echo_body+ as_echo='sh -c $as_echo_body as_echo'+fi++# The user is always right.+if test "${PATH_SEPARATOR+set}" != set; then+ PATH_SEPARATOR=:+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||+ PATH_SEPARATOR=';'+ }+fi+++# IFS+# We need space, tab and new line, in precisely that order. Quoting is+# there to prevent editors from complaining about space-tab.+# (If _AS_PATH_WALK were called with IFS unset, it would disable word+# splitting by setting IFS to empty value.)+IFS=" "" $as_nl"++# Find who we are. Look in the path if we contain no directory separator.+as_myself=+case $0 in #((+ *[\\/]* ) as_myself=$0 ;;+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break+ done+IFS=$as_save_IFS++ ;;+esac+# We did not find ourselves, most probably we were run as `sh COMMAND'+# in which case we are not to be found in the path.+if test "x$as_myself" = x; then+ as_myself=$0+fi+if test ! -f "$as_myself"; then+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2+ exit 1+fi++# Unset variables that we do not need and which cause bugs (e.g. in+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"+# suppresses any "Segmentation fault" message there. '((' could+# trigger a bug in pdksh 5.2.14.+for as_var in BASH_ENV ENV MAIL MAILPATH+do eval test x\${$as_var+set} = xset \+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :+done+PS1='$ '+PS2='> '+PS4='+ '++# NLS nuisances.+LC_ALL=C+export LC_ALL+LANGUAGE=C+export LANGUAGE++# CDPATH.+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH++if test "x$CONFIG_SHELL" = x; then+ as_bourne_compatible="if test -n \"\${ZSH_VERSION+set}\" && (emulate sh) >/dev/null 2>&1; then :+ emulate sh+ NULLCMD=:+ # Pre-4.2 versions of Zsh do word splitting on \${1+\"\$@\"}, which+ # is contrary to our usage. Disable this feature.+ alias -g '\${1+\"\$@\"}'='\"\$@\"'+ setopt NO_GLOB_SUBST+else+ case \`(set -o) 2>/dev/null\` in #(+ *posix*) :+ set -o posix ;; #(+ *) :+ ;;+esac+fi+"+ as_required="as_fn_return () { (exit \$1); }+as_fn_success () { as_fn_return 0; }+as_fn_failure () { as_fn_return 1; }+as_fn_ret_success () { return 0; }+as_fn_ret_failure () { return 1; }++exitcode=0+as_fn_success || { exitcode=1; echo as_fn_success failed.; }+as_fn_failure && { exitcode=1; echo as_fn_failure succeeded.; }+as_fn_ret_success || { exitcode=1; echo as_fn_ret_success failed.; }+as_fn_ret_failure && { exitcode=1; echo as_fn_ret_failure succeeded.; }+if ( set x; as_fn_ret_success y && test x = \"\$1\" ); then :++else+ exitcode=1; echo positional parameters were not saved.+fi+test x\$exitcode = x0 || exit 1"+ as_suggested=" as_lineno_1=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_1a=\$LINENO+ as_lineno_2=";as_suggested=$as_suggested$LINENO;as_suggested=$as_suggested" as_lineno_2a=\$LINENO+ eval 'test \"x\$as_lineno_1'\$as_run'\" != \"x\$as_lineno_2'\$as_run'\" &&+ test \"x\`expr \$as_lineno_1'\$as_run' + 1\`\" = \"x\$as_lineno_2'\$as_run'\"' || exit 1"+ if (eval "$as_required") 2>/dev/null; then :+ as_have_required=yes+else+ as_have_required=no+fi+ if test x$as_have_required = xyes && (eval "$as_suggested") 2>/dev/null; then :++else+ as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+as_found=false+for as_dir in /bin$PATH_SEPARATOR/usr/bin$PATH_SEPARATOR$PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ as_found=:+ case $as_dir in #(+ /*)+ for as_base in sh bash ksh sh5; do+ # Try only shells that exist, to save several forks.+ as_shell=$as_dir/$as_base+ if { test -f "$as_shell" || test -f "$as_shell.exe"; } &&+ { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$as_shell"; } 2>/dev/null; then :+ CONFIG_SHELL=$as_shell as_have_required=yes+ if { $as_echo "$as_bourne_compatible""$as_suggested" | as_run=a "$as_shell"; } 2>/dev/null; then :+ break 2+fi+fi+ done;;+ esac+ as_found=false+done+$as_found || { if { test -f "$SHELL" || test -f "$SHELL.exe"; } &&+ { $as_echo "$as_bourne_compatible""$as_required" | as_run=a "$SHELL"; } 2>/dev/null; then :+ CONFIG_SHELL=$SHELL as_have_required=yes+fi; }+IFS=$as_save_IFS+++ if test "x$CONFIG_SHELL" != x; then :+ # We cannot yet assume a decent shell, so we have to provide a+ # neutralization value for shells without unset; and this also+ # works around shells that cannot unset nonexistent variables.+ # Preserve -v and -x to the replacement shell.+ BASH_ENV=/dev/null+ ENV=/dev/null+ (unset BASH_ENV) >/dev/null 2>&1 && unset BASH_ENV ENV+ export CONFIG_SHELL+ case $- in # ((((+ *v*x* | *x*v* ) as_opts=-vx ;;+ *v* ) as_opts=-v ;;+ *x* ) as_opts=-x ;;+ * ) as_opts= ;;+ esac+ exec "$CONFIG_SHELL" $as_opts "$as_myself" ${1+"$@"}+fi++ if test x$as_have_required = xno; then :+ $as_echo "$0: This script requires a shell more modern than all"+ $as_echo "$0: the shells that I found on your system."+ if test x${ZSH_VERSION+set} = xset ; then+ $as_echo "$0: In particular, zsh $ZSH_VERSION has bugs and should"+ $as_echo "$0: be upgraded to zsh 4.3.4 or later."+ else+ $as_echo "$0: Please tell bug-autoconf@gnu.org and+$0: deian@cs.stanford.edu about your system, including any+$0: error possibly output before this message. Then install+$0: a modern shell, or manually run the script under such a+$0: shell if you do have one."+ fi+ exit 1+fi+fi+fi+SHELL=${CONFIG_SHELL-/bin/sh}+export SHELL+# Unset more variables known to interfere with behavior of common tools.+CLICOLOR_FORCE= GREP_OPTIONS=+unset CLICOLOR_FORCE GREP_OPTIONS++## --------------------- ##+## M4sh Shell Functions. ##+## --------------------- ##+# as_fn_unset VAR+# ---------------+# Portably unset VAR.+as_fn_unset ()+{+ { eval $1=; unset $1;}+}+as_unset=as_fn_unset++# as_fn_set_status STATUS+# -----------------------+# Set $? to STATUS, without forking.+as_fn_set_status ()+{+ return $1+} # as_fn_set_status++# as_fn_exit STATUS+# -----------------+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.+as_fn_exit ()+{+ set +e+ as_fn_set_status $1+ exit $1+} # as_fn_exit++# as_fn_mkdir_p+# -------------+# Create "$as_dir" as a directory, including parents if necessary.+as_fn_mkdir_p ()+{++ case $as_dir in #(+ -*) as_dir=./$as_dir;;+ esac+ test -d "$as_dir" || eval $as_mkdir_p || {+ as_dirs=+ while :; do+ case $as_dir in #(+ *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(+ *) as_qdir=$as_dir;;+ esac+ as_dirs="'$as_qdir' $as_dirs"+ as_dir=`$as_dirname -- "$as_dir" ||+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+ X"$as_dir" : 'X\(//\)[^/]' \| \+ X"$as_dir" : 'X\(//\)$' \| \+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||+$as_echo X"$as_dir" |+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{+ s//\1/+ q+ }+ /^X\(\/\/\)[^/].*/{+ s//\1/+ q+ }+ /^X\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`+ test -d "$as_dir" && break+ done+ test -z "$as_dirs" || eval "mkdir $as_dirs"+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"+++} # as_fn_mkdir_p+# as_fn_append VAR VALUE+# ----------------------+# Append the text in VALUE to the end of the definition contained in VAR. Take+# advantage of any shell optimizations that allow amortized linear growth over+# repeated appends, instead of the typical quadratic growth present in naive+# implementations.+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then :+ eval 'as_fn_append ()+ {+ eval $1+=\$2+ }'+else+ as_fn_append ()+ {+ eval $1=\$$1\$2+ }+fi # as_fn_append++# as_fn_arith ARG...+# ------------------+# Perform arithmetic evaluation on the ARGs, and store the result in the+# global $as_val. Take advantage of shells that can avoid forks. The arguments+# must be portable across $(()) and expr.+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then :+ eval 'as_fn_arith ()+ {+ as_val=$(( $* ))+ }'+else+ as_fn_arith ()+ {+ as_val=`expr "$@" || test $? -eq 1`+ }+fi # as_fn_arith+++# as_fn_error STATUS ERROR [LINENO LOG_FD]+# ----------------------------------------+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the+# script with STATUS, using 1 if that was 0.+as_fn_error ()+{+ as_status=$1; test $as_status -eq 0 && as_status=1+ if test "$4"; then+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4+ fi+ $as_echo "$as_me: error: $2" >&2+ as_fn_exit $as_status+} # as_fn_error++if expr a : '\(a\)' >/dev/null 2>&1 &&+ test "X`expr 00001 : '.*\(...\)'`" = X001; then+ as_expr=expr+else+ as_expr=false+fi++if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then+ as_basename=basename+else+ as_basename=false+fi++if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then+ as_dirname=dirname+else+ as_dirname=false+fi++as_me=`$as_basename -- "$0" ||+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \+ X"$0" : 'X\(//\)$' \| \+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||+$as_echo X/"$0" |+ sed '/^.*\/\([^/][^/]*\)\/*$/{+ s//\1/+ q+ }+ /^X\/\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\/\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`++# Avoid depending upon Character Ranges.+as_cr_letters='abcdefghijklmnopqrstuvwxyz'+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'+as_cr_Letters=$as_cr_letters$as_cr_LETTERS+as_cr_digits='0123456789'+as_cr_alnum=$as_cr_Letters$as_cr_digits+++ as_lineno_1=$LINENO as_lineno_1a=$LINENO+ as_lineno_2=$LINENO as_lineno_2a=$LINENO+ eval 'test "x$as_lineno_1'$as_run'" != "x$as_lineno_2'$as_run'" &&+ test "x`expr $as_lineno_1'$as_run' + 1`" = "x$as_lineno_2'$as_run'"' || {+ # Blame Lee E. McMahon (1931-1989) for sed's syntax. :-)+ sed -n '+ p+ /[$]LINENO/=+ ' <$as_myself |+ sed '+ s/[$]LINENO.*/&-/+ t lineno+ b+ :lineno+ N+ :loop+ s/[$]LINENO\([^'$as_cr_alnum'_].*\n\)\(.*\)/\2\1\2/+ t loop+ s/-\n.*//+ ' >$as_me.lineno &&+ chmod +x "$as_me.lineno" ||+ { $as_echo "$as_me: error: cannot create $as_me.lineno; rerun with a POSIX shell" >&2; as_fn_exit 1; }++ # Don't try to exec as it changes $[0], causing all sort of problems+ # (the dirname of $[0] is not the place where we might find the+ # original and so on. Autoconf is especially sensitive to this).+ . "./$as_me.lineno"+ # Exit status is that of the last command.+ exit+}++ECHO_C= ECHO_N= ECHO_T=+case `echo -n x` in #(((((+-n*)+ case `echo 'xy\c'` in+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.+ xy) ECHO_C='\c';;+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null+ ECHO_T=' ';;+ esac;;+*)+ ECHO_N='-n';;+esac++rm -f conf$$ conf$$.exe conf$$.file+if test -d conf$$.dir; then+ rm -f conf$$.dir/conf$$.file+else+ rm -f conf$$.dir+ mkdir conf$$.dir 2>/dev/null+fi+if (echo >conf$$.file) 2>/dev/null; then+ if ln -s conf$$.file conf$$ 2>/dev/null; then+ as_ln_s='ln -s'+ # ... but there are two gotchas:+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.+ # In both cases, we have to default to `cp -p'.+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||+ as_ln_s='cp -p'+ elif ln conf$$.file conf$$ 2>/dev/null; then+ as_ln_s=ln+ else+ as_ln_s='cp -p'+ fi+else+ as_ln_s='cp -p'+fi+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file+rmdir conf$$.dir 2>/dev/null++if mkdir -p . 2>/dev/null; then+ as_mkdir_p='mkdir -p "$as_dir"'+else+ test -d ./-p && rmdir ./-p+ as_mkdir_p=false+fi++if test -x / >/dev/null 2>&1; then+ as_test_x='test -x'+else+ if ls -dL / >/dev/null 2>&1; then+ as_ls_L_option=L+ else+ as_ls_L_option=+ fi+ as_test_x='+ eval sh -c '\''+ if test -d "$1"; then+ test -d "$1/.";+ else+ case $1 in #(+ -*)set "./$1";;+ esac;+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((+ ???[sx]*):;;*)false;;esac;fi+ '\'' sh+ '+fi+as_executable_p=$as_test_x++# Sed expression to map a string onto a valid CPP name.+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"++# Sed expression to map a string onto a valid variable name.+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"+++test -n "$DJDIR" || exec 7<&0 </dev/null+exec 6>&1++# Name of the host.+# hostname on some systems (SVR3.2, old GNU/Linux) returns a bogus exit status,+# so uname gets run too.+ac_hostname=`(hostname || uname -n) 2>/dev/null | sed 1q`++#+# Initializations.+#+ac_default_prefix=/usr/local+ac_clean_files=+ac_config_libobj_dir=.+LIBOBJS=+cross_compiling=no+subdirs=+MFLAGS=+MAKEFLAGS=++# Identity of this package.+PACKAGE_NAME='Labeled IO library'+PACKAGE_TARNAME='lio'+PACKAGE_VERSION='0.1.0'+PACKAGE_STRING='Labeled IO library 0.1.0'+PACKAGE_BUGREPORT='deian@cs.stanford.edu'+PACKAGE_URL=''++ac_unique_file="include/HsTmp.h"+ac_subst_vars='LTLIBOBJS+LIBOBJS+OBJEXT+EXEEXT+ac_ct_CC+CPPFLAGS+LDFLAGS+CFLAGS+CC+target_alias+host_alias+build_alias+LIBS+ECHO_T+ECHO_N+ECHO_C+DEFS+mandir+localedir+libdir+psdir+pdfdir+dvidir+htmldir+infodir+docdir+oldincludedir+includedir+localstatedir+sharedstatedir+sysconfdir+datadir+datarootdir+libexecdir+sbindir+bindir+program_transform_name+prefix+exec_prefix+PACKAGE_URL+PACKAGE_BUGREPORT+PACKAGE_STRING+PACKAGE_VERSION+PACKAGE_TARNAME+PACKAGE_NAME+PATH_SEPARATOR+SHELL'+ac_subst_files=''+ac_user_opts='+enable_option_checking+'+ ac_precious_vars='build_alias+host_alias+target_alias+CC+CFLAGS+LDFLAGS+LIBS+CPPFLAGS'+++# Initialize some variables set by options.+ac_init_help=+ac_init_version=false+ac_unrecognized_opts=+ac_unrecognized_sep=+# The variables have the same names as the options, with+# dashes changed to underlines.+cache_file=/dev/null+exec_prefix=NONE+no_create=+no_recursion=+prefix=NONE+program_prefix=NONE+program_suffix=NONE+program_transform_name=s,x,x,+silent=+site=+srcdir=+verbose=+x_includes=NONE+x_libraries=NONE++# Installation directory options.+# These are left unexpanded so users can "make install exec_prefix=/foo"+# and all the variables that are supposed to be based on exec_prefix+# by default will actually change.+# Use braces instead of parens because sh, perl, etc. also accept them.+# (The list follows the same order as the GNU Coding Standards.)+bindir='${exec_prefix}/bin'+sbindir='${exec_prefix}/sbin'+libexecdir='${exec_prefix}/libexec'+datarootdir='${prefix}/share'+datadir='${datarootdir}'+sysconfdir='${prefix}/etc'+sharedstatedir='${prefix}/com'+localstatedir='${prefix}/var'+includedir='${prefix}/include'+oldincludedir='/usr/include'+docdir='${datarootdir}/doc/${PACKAGE_TARNAME}'+infodir='${datarootdir}/info'+htmldir='${docdir}'+dvidir='${docdir}'+pdfdir='${docdir}'+psdir='${docdir}'+libdir='${exec_prefix}/lib'+localedir='${datarootdir}/locale'+mandir='${datarootdir}/man'++ac_prev=+ac_dashdash=+for ac_option+do+ # If the previous option needs an argument, assign it.+ if test -n "$ac_prev"; then+ eval $ac_prev=\$ac_option+ ac_prev=+ continue+ fi++ case $ac_option in+ *=?*) ac_optarg=`expr "X$ac_option" : '[^=]*=\(.*\)'` ;;+ *=) ac_optarg= ;;+ *) ac_optarg=yes ;;+ esac++ # Accept the important Cygnus configure options, so we can diagnose typos.++ case $ac_dashdash$ac_option in+ --)+ ac_dashdash=yes ;;++ -bindir | --bindir | --bindi | --bind | --bin | --bi)+ ac_prev=bindir ;;+ -bindir=* | --bindir=* | --bindi=* | --bind=* | --bin=* | --bi=*)+ bindir=$ac_optarg ;;++ -build | --build | --buil | --bui | --bu)+ ac_prev=build_alias ;;+ -build=* | --build=* | --buil=* | --bui=* | --bu=*)+ build_alias=$ac_optarg ;;++ -cache-file | --cache-file | --cache-fil | --cache-fi \+ | --cache-f | --cache- | --cache | --cach | --cac | --ca | --c)+ ac_prev=cache_file ;;+ -cache-file=* | --cache-file=* | --cache-fil=* | --cache-fi=* \+ | --cache-f=* | --cache-=* | --cache=* | --cach=* | --cac=* | --ca=* | --c=*)+ cache_file=$ac_optarg ;;++ --config-cache | -C)+ cache_file=config.cache ;;++ -datadir | --datadir | --datadi | --datad)+ ac_prev=datadir ;;+ -datadir=* | --datadir=* | --datadi=* | --datad=*)+ datadir=$ac_optarg ;;++ -datarootdir | --datarootdir | --datarootdi | --datarootd | --dataroot \+ | --dataroo | --dataro | --datar)+ ac_prev=datarootdir ;;+ -datarootdir=* | --datarootdir=* | --datarootdi=* | --datarootd=* \+ | --dataroot=* | --dataroo=* | --dataro=* | --datar=*)+ datarootdir=$ac_optarg ;;++ -disable-* | --disable-*)+ ac_useropt=`expr "x$ac_option" : 'x-*disable-\(.*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&+ as_fn_error $? "invalid feature name: $ac_useropt"+ ac_useropt_orig=$ac_useropt+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`+ case $ac_user_opts in+ *"+"enable_$ac_useropt"+"*) ;;+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--disable-$ac_useropt_orig"+ ac_unrecognized_sep=', ';;+ esac+ eval enable_$ac_useropt=no ;;++ -docdir | --docdir | --docdi | --doc | --do)+ ac_prev=docdir ;;+ -docdir=* | --docdir=* | --docdi=* | --doc=* | --do=*)+ docdir=$ac_optarg ;;++ -dvidir | --dvidir | --dvidi | --dvid | --dvi | --dv)+ ac_prev=dvidir ;;+ -dvidir=* | --dvidir=* | --dvidi=* | --dvid=* | --dvi=* | --dv=*)+ dvidir=$ac_optarg ;;++ -enable-* | --enable-*)+ ac_useropt=`expr "x$ac_option" : 'x-*enable-\([^=]*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&+ as_fn_error $? "invalid feature name: $ac_useropt"+ ac_useropt_orig=$ac_useropt+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`+ case $ac_user_opts in+ *"+"enable_$ac_useropt"+"*) ;;+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--enable-$ac_useropt_orig"+ ac_unrecognized_sep=', ';;+ esac+ eval enable_$ac_useropt=\$ac_optarg ;;++ -exec-prefix | --exec_prefix | --exec-prefix | --exec-prefi \+ | --exec-pref | --exec-pre | --exec-pr | --exec-p | --exec- \+ | --exec | --exe | --ex)+ ac_prev=exec_prefix ;;+ -exec-prefix=* | --exec_prefix=* | --exec-prefix=* | --exec-prefi=* \+ | --exec-pref=* | --exec-pre=* | --exec-pr=* | --exec-p=* | --exec-=* \+ | --exec=* | --exe=* | --ex=*)+ exec_prefix=$ac_optarg ;;++ -gas | --gas | --ga | --g)+ # Obsolete; use --with-gas.+ with_gas=yes ;;++ -help | --help | --hel | --he | -h)+ ac_init_help=long ;;+ -help=r* | --help=r* | --hel=r* | --he=r* | -hr*)+ ac_init_help=recursive ;;+ -help=s* | --help=s* | --hel=s* | --he=s* | -hs*)+ ac_init_help=short ;;++ -host | --host | --hos | --ho)+ ac_prev=host_alias ;;+ -host=* | --host=* | --hos=* | --ho=*)+ host_alias=$ac_optarg ;;++ -htmldir | --htmldir | --htmldi | --htmld | --html | --htm | --ht)+ ac_prev=htmldir ;;+ -htmldir=* | --htmldir=* | --htmldi=* | --htmld=* | --html=* | --htm=* \+ | --ht=*)+ htmldir=$ac_optarg ;;++ -includedir | --includedir | --includedi | --included | --include \+ | --includ | --inclu | --incl | --inc)+ ac_prev=includedir ;;+ -includedir=* | --includedir=* | --includedi=* | --included=* | --include=* \+ | --includ=* | --inclu=* | --incl=* | --inc=*)+ includedir=$ac_optarg ;;++ -infodir | --infodir | --infodi | --infod | --info | --inf)+ ac_prev=infodir ;;+ -infodir=* | --infodir=* | --infodi=* | --infod=* | --info=* | --inf=*)+ infodir=$ac_optarg ;;++ -libdir | --libdir | --libdi | --libd)+ ac_prev=libdir ;;+ -libdir=* | --libdir=* | --libdi=* | --libd=*)+ libdir=$ac_optarg ;;++ -libexecdir | --libexecdir | --libexecdi | --libexecd | --libexec \+ | --libexe | --libex | --libe)+ ac_prev=libexecdir ;;+ -libexecdir=* | --libexecdir=* | --libexecdi=* | --libexecd=* | --libexec=* \+ | --libexe=* | --libex=* | --libe=*)+ libexecdir=$ac_optarg ;;++ -localedir | --localedir | --localedi | --localed | --locale)+ ac_prev=localedir ;;+ -localedir=* | --localedir=* | --localedi=* | --localed=* | --locale=*)+ localedir=$ac_optarg ;;++ -localstatedir | --localstatedir | --localstatedi | --localstated \+ | --localstate | --localstat | --localsta | --localst | --locals)+ ac_prev=localstatedir ;;+ -localstatedir=* | --localstatedir=* | --localstatedi=* | --localstated=* \+ | --localstate=* | --localstat=* | --localsta=* | --localst=* | --locals=*)+ localstatedir=$ac_optarg ;;++ -mandir | --mandir | --mandi | --mand | --man | --ma | --m)+ ac_prev=mandir ;;+ -mandir=* | --mandir=* | --mandi=* | --mand=* | --man=* | --ma=* | --m=*)+ mandir=$ac_optarg ;;++ -nfp | --nfp | --nf)+ # Obsolete; use --without-fp.+ with_fp=no ;;++ -no-create | --no-create | --no-creat | --no-crea | --no-cre \+ | --no-cr | --no-c | -n)+ no_create=yes ;;++ -no-recursion | --no-recursion | --no-recursio | --no-recursi \+ | --no-recurs | --no-recur | --no-recu | --no-rec | --no-re | --no-r)+ no_recursion=yes ;;++ -oldincludedir | --oldincludedir | --oldincludedi | --oldincluded \+ | --oldinclude | --oldinclud | --oldinclu | --oldincl | --oldinc \+ | --oldin | --oldi | --old | --ol | --o)+ ac_prev=oldincludedir ;;+ -oldincludedir=* | --oldincludedir=* | --oldincludedi=* | --oldincluded=* \+ | --oldinclude=* | --oldinclud=* | --oldinclu=* | --oldincl=* | --oldinc=* \+ | --oldin=* | --oldi=* | --old=* | --ol=* | --o=*)+ oldincludedir=$ac_optarg ;;++ -prefix | --prefix | --prefi | --pref | --pre | --pr | --p)+ ac_prev=prefix ;;+ -prefix=* | --prefix=* | --prefi=* | --pref=* | --pre=* | --pr=* | --p=*)+ prefix=$ac_optarg ;;++ -program-prefix | --program-prefix | --program-prefi | --program-pref \+ | --program-pre | --program-pr | --program-p)+ ac_prev=program_prefix ;;+ -program-prefix=* | --program-prefix=* | --program-prefi=* \+ | --program-pref=* | --program-pre=* | --program-pr=* | --program-p=*)+ program_prefix=$ac_optarg ;;++ -program-suffix | --program-suffix | --program-suffi | --program-suff \+ | --program-suf | --program-su | --program-s)+ ac_prev=program_suffix ;;+ -program-suffix=* | --program-suffix=* | --program-suffi=* \+ | --program-suff=* | --program-suf=* | --program-su=* | --program-s=*)+ program_suffix=$ac_optarg ;;++ -program-transform-name | --program-transform-name \+ | --program-transform-nam | --program-transform-na \+ | --program-transform-n | --program-transform- \+ | --program-transform | --program-transfor \+ | --program-transfo | --program-transf \+ | --program-trans | --program-tran \+ | --progr-tra | --program-tr | --program-t)+ ac_prev=program_transform_name ;;+ -program-transform-name=* | --program-transform-name=* \+ | --program-transform-nam=* | --program-transform-na=* \+ | --program-transform-n=* | --program-transform-=* \+ | --program-transform=* | --program-transfor=* \+ | --program-transfo=* | --program-transf=* \+ | --program-trans=* | --program-tran=* \+ | --progr-tra=* | --program-tr=* | --program-t=*)+ program_transform_name=$ac_optarg ;;++ -pdfdir | --pdfdir | --pdfdi | --pdfd | --pdf | --pd)+ ac_prev=pdfdir ;;+ -pdfdir=* | --pdfdir=* | --pdfdi=* | --pdfd=* | --pdf=* | --pd=*)+ pdfdir=$ac_optarg ;;++ -psdir | --psdir | --psdi | --psd | --ps)+ ac_prev=psdir ;;+ -psdir=* | --psdir=* | --psdi=* | --psd=* | --ps=*)+ psdir=$ac_optarg ;;++ -q | -quiet | --quiet | --quie | --qui | --qu | --q \+ | -silent | --silent | --silen | --sile | --sil)+ silent=yes ;;++ -sbindir | --sbindir | --sbindi | --sbind | --sbin | --sbi | --sb)+ ac_prev=sbindir ;;+ -sbindir=* | --sbindir=* | --sbindi=* | --sbind=* | --sbin=* \+ | --sbi=* | --sb=*)+ sbindir=$ac_optarg ;;++ -sharedstatedir | --sharedstatedir | --sharedstatedi \+ | --sharedstated | --sharedstate | --sharedstat | --sharedsta \+ | --sharedst | --shareds | --shared | --share | --shar \+ | --sha | --sh)+ ac_prev=sharedstatedir ;;+ -sharedstatedir=* | --sharedstatedir=* | --sharedstatedi=* \+ | --sharedstated=* | --sharedstate=* | --sharedstat=* | --sharedsta=* \+ | --sharedst=* | --shareds=* | --shared=* | --share=* | --shar=* \+ | --sha=* | --sh=*)+ sharedstatedir=$ac_optarg ;;++ -site | --site | --sit)+ ac_prev=site ;;+ -site=* | --site=* | --sit=*)+ site=$ac_optarg ;;++ -srcdir | --srcdir | --srcdi | --srcd | --src | --sr)+ ac_prev=srcdir ;;+ -srcdir=* | --srcdir=* | --srcdi=* | --srcd=* | --src=* | --sr=*)+ srcdir=$ac_optarg ;;++ -sysconfdir | --sysconfdir | --sysconfdi | --sysconfd | --sysconf \+ | --syscon | --sysco | --sysc | --sys | --sy)+ ac_prev=sysconfdir ;;+ -sysconfdir=* | --sysconfdir=* | --sysconfdi=* | --sysconfd=* | --sysconf=* \+ | --syscon=* | --sysco=* | --sysc=* | --sys=* | --sy=*)+ sysconfdir=$ac_optarg ;;++ -target | --target | --targe | --targ | --tar | --ta | --t)+ ac_prev=target_alias ;;+ -target=* | --target=* | --targe=* | --targ=* | --tar=* | --ta=* | --t=*)+ target_alias=$ac_optarg ;;++ -v | -verbose | --verbose | --verbos | --verbo | --verb)+ verbose=yes ;;++ -version | --version | --versio | --versi | --vers | -V)+ ac_init_version=: ;;++ -with-* | --with-*)+ ac_useropt=`expr "x$ac_option" : 'x-*with-\([^=]*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&+ as_fn_error $? "invalid package name: $ac_useropt"+ ac_useropt_orig=$ac_useropt+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`+ case $ac_user_opts in+ *"+"with_$ac_useropt"+"*) ;;+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--with-$ac_useropt_orig"+ ac_unrecognized_sep=', ';;+ esac+ eval with_$ac_useropt=\$ac_optarg ;;++ -without-* | --without-*)+ ac_useropt=`expr "x$ac_option" : 'x-*without-\(.*\)'`+ # Reject names that are not valid shell variable names.+ expr "x$ac_useropt" : ".*[^-+._$as_cr_alnum]" >/dev/null &&+ as_fn_error $? "invalid package name: $ac_useropt"+ ac_useropt_orig=$ac_useropt+ ac_useropt=`$as_echo "$ac_useropt" | sed 's/[-+.]/_/g'`+ case $ac_user_opts in+ *"+"with_$ac_useropt"+"*) ;;+ *) ac_unrecognized_opts="$ac_unrecognized_opts$ac_unrecognized_sep--without-$ac_useropt_orig"+ ac_unrecognized_sep=', ';;+ esac+ eval with_$ac_useropt=no ;;++ --x)+ # Obsolete; use --with-x.+ with_x=yes ;;++ -x-includes | --x-includes | --x-include | --x-includ | --x-inclu \+ | --x-incl | --x-inc | --x-in | --x-i)+ ac_prev=x_includes ;;+ -x-includes=* | --x-includes=* | --x-include=* | --x-includ=* | --x-inclu=* \+ | --x-incl=* | --x-inc=* | --x-in=* | --x-i=*)+ x_includes=$ac_optarg ;;++ -x-libraries | --x-libraries | --x-librarie | --x-librari \+ | --x-librar | --x-libra | --x-libr | --x-lib | --x-li | --x-l)+ ac_prev=x_libraries ;;+ -x-libraries=* | --x-libraries=* | --x-librarie=* | --x-librari=* \+ | --x-librar=* | --x-libra=* | --x-libr=* | --x-lib=* | --x-li=* | --x-l=*)+ x_libraries=$ac_optarg ;;++ -*) as_fn_error $? "unrecognized option: \`$ac_option'+Try \`$0 --help' for more information"+ ;;++ *=*)+ ac_envvar=`expr "x$ac_option" : 'x\([^=]*\)='`+ # Reject names that are not valid shell variable names.+ case $ac_envvar in #(+ '' | [0-9]* | *[!_$as_cr_alnum]* )+ as_fn_error $? "invalid variable name: \`$ac_envvar'" ;;+ esac+ eval $ac_envvar=\$ac_optarg+ export $ac_envvar ;;++ *)+ # FIXME: should be removed in autoconf 3.0.+ $as_echo "$as_me: WARNING: you should use --build, --host, --target" >&2+ expr "x$ac_option" : ".*[^-._$as_cr_alnum]" >/dev/null &&+ $as_echo "$as_me: WARNING: invalid host type: $ac_option" >&2+ : "${build_alias=$ac_option} ${host_alias=$ac_option} ${target_alias=$ac_option}"+ ;;++ esac+done++if test -n "$ac_prev"; then+ ac_option=--`echo $ac_prev | sed 's/_/-/g'`+ as_fn_error $? "missing argument to $ac_option"+fi++if test -n "$ac_unrecognized_opts"; then+ case $enable_option_checking in+ no) ;;+ fatal) as_fn_error $? "unrecognized options: $ac_unrecognized_opts" ;;+ *) $as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2 ;;+ esac+fi++# Check all directory arguments for consistency.+for ac_var in exec_prefix prefix bindir sbindir libexecdir datarootdir \+ datadir sysconfdir sharedstatedir localstatedir includedir \+ oldincludedir docdir infodir htmldir dvidir pdfdir psdir \+ libdir localedir mandir+do+ eval ac_val=\$$ac_var+ # Remove trailing slashes.+ case $ac_val in+ */ )+ ac_val=`expr "X$ac_val" : 'X\(.*[^/]\)' \| "X$ac_val" : 'X\(.*\)'`+ eval $ac_var=\$ac_val;;+ esac+ # Be sure to have absolute directory names.+ case $ac_val in+ [\\/$]* | ?:[\\/]* ) continue;;+ NONE | '' ) case $ac_var in *prefix ) continue;; esac;;+ esac+ as_fn_error $? "expected an absolute directory name for --$ac_var: $ac_val"+done++# There might be people who depend on the old broken behavior: `$host'+# used to hold the argument of --host etc.+# FIXME: To remove some day.+build=$build_alias+host=$host_alias+target=$target_alias++# FIXME: To remove some day.+if test "x$host_alias" != x; then+ if test "x$build_alias" = x; then+ cross_compiling=maybe+ $as_echo "$as_me: WARNING: if you wanted to set the --build type, don't use --host.+ If a cross compiler is detected then cross compile mode will be used" >&2+ elif test "x$build_alias" != "x$host_alias"; then+ cross_compiling=yes+ fi+fi++ac_tool_prefix=+test -n "$host_alias" && ac_tool_prefix=$host_alias-++test "$silent" = yes && exec 6>/dev/null+++ac_pwd=`pwd` && test -n "$ac_pwd" &&+ac_ls_di=`ls -di .` &&+ac_pwd_ls_di=`cd "$ac_pwd" && ls -di .` ||+ as_fn_error $? "working directory cannot be determined"+test "X$ac_ls_di" = "X$ac_pwd_ls_di" ||+ as_fn_error $? "pwd does not report name of working directory"+++# Find the source files, if location was not specified.+if test -z "$srcdir"; then+ ac_srcdir_defaulted=yes+ # Try the directory containing this script, then the parent directory.+ ac_confdir=`$as_dirname -- "$as_myself" ||+$as_expr X"$as_myself" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+ X"$as_myself" : 'X\(//\)[^/]' \| \+ X"$as_myself" : 'X\(//\)$' \| \+ X"$as_myself" : 'X\(/\)' \| . 2>/dev/null ||+$as_echo X"$as_myself" |+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{+ s//\1/+ q+ }+ /^X\(\/\/\)[^/].*/{+ s//\1/+ q+ }+ /^X\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`+ srcdir=$ac_confdir+ if test ! -r "$srcdir/$ac_unique_file"; then+ srcdir=..+ fi+else+ ac_srcdir_defaulted=no+fi+if test ! -r "$srcdir/$ac_unique_file"; then+ test "$ac_srcdir_defaulted" = yes && srcdir="$ac_confdir or .."+ as_fn_error $? "cannot find sources ($ac_unique_file) in $srcdir"+fi+ac_msg="sources are in $srcdir, but \`cd $srcdir' does not work"+ac_abs_confdir=`(+ cd "$srcdir" && test -r "./$ac_unique_file" || as_fn_error $? "$ac_msg"+ pwd)`+# When building in place, set srcdir=.+if test "$ac_abs_confdir" = "$ac_pwd"; then+ srcdir=.+fi+# Remove unnecessary trailing slashes from srcdir.+# Double slashes in file names in object file debugging info+# mess up M-x gdb in Emacs.+case $srcdir in+*/) srcdir=`expr "X$srcdir" : 'X\(.*[^/]\)' \| "X$srcdir" : 'X\(.*\)'`;;+esac+for ac_var in $ac_precious_vars; do+ eval ac_env_${ac_var}_set=\${${ac_var}+set}+ eval ac_env_${ac_var}_value=\$${ac_var}+ eval ac_cv_env_${ac_var}_set=\${${ac_var}+set}+ eval ac_cv_env_${ac_var}_value=\$${ac_var}+done++#+# Report the --help message.+#+if test "$ac_init_help" = "long"; then+ # Omit some internal or obsolete options to make the list less imposing.+ # This message is too long to be a string in the A/UX 3.1 sh.+ cat <<_ACEOF+\`configure' configures Labeled IO library 0.1.0 to adapt to many kinds of systems.++Usage: $0 [OPTION]... [VAR=VALUE]...++To assign environment variables (e.g., CC, CFLAGS...), specify them as+VAR=VALUE. See below for descriptions of some of the useful variables.++Defaults for the options are specified in brackets.++Configuration:+ -h, --help display this help and exit+ --help=short display options specific to this package+ --help=recursive display the short help of all the included packages+ -V, --version display version information and exit+ -q, --quiet, --silent do not print \`checking ...' messages+ --cache-file=FILE cache test results in FILE [disabled]+ -C, --config-cache alias for \`--cache-file=config.cache'+ -n, --no-create do not create output files+ --srcdir=DIR find the sources in DIR [configure dir or \`..']++Installation directories:+ --prefix=PREFIX install architecture-independent files in PREFIX+ [$ac_default_prefix]+ --exec-prefix=EPREFIX install architecture-dependent files in EPREFIX+ [PREFIX]++By default, \`make install' will install all the files in+\`$ac_default_prefix/bin', \`$ac_default_prefix/lib' etc. You can specify+an installation prefix other than \`$ac_default_prefix' using \`--prefix',+for instance \`--prefix=\$HOME'.++For better control, use the options below.++Fine tuning of the installation directories:+ --bindir=DIR user executables [EPREFIX/bin]+ --sbindir=DIR system admin executables [EPREFIX/sbin]+ --libexecdir=DIR program executables [EPREFIX/libexec]+ --sysconfdir=DIR read-only single-machine data [PREFIX/etc]+ --sharedstatedir=DIR modifiable architecture-independent data [PREFIX/com]+ --localstatedir=DIR modifiable single-machine data [PREFIX/var]+ --libdir=DIR object code libraries [EPREFIX/lib]+ --includedir=DIR C header files [PREFIX/include]+ --oldincludedir=DIR C header files for non-gcc [/usr/include]+ --datarootdir=DIR read-only arch.-independent data root [PREFIX/share]+ --datadir=DIR read-only architecture-independent data [DATAROOTDIR]+ --infodir=DIR info documentation [DATAROOTDIR/info]+ --localedir=DIR locale-dependent data [DATAROOTDIR/locale]+ --mandir=DIR man documentation [DATAROOTDIR/man]+ --docdir=DIR documentation root [DATAROOTDIR/doc/lio]+ --htmldir=DIR html documentation [DOCDIR]+ --dvidir=DIR dvi documentation [DOCDIR]+ --pdfdir=DIR pdf documentation [DOCDIR]+ --psdir=DIR ps documentation [DOCDIR]+_ACEOF++ cat <<\_ACEOF+_ACEOF+fi++if test -n "$ac_init_help"; then+ case $ac_init_help in+ short | recursive ) echo "Configuration of Labeled IO library 0.1.0:";;+ esac+ cat <<\_ACEOF++Some influential environment variables:+ CC C compiler command+ CFLAGS C compiler flags+ LDFLAGS linker flags, e.g. -L<lib dir> if you have libraries in a+ nonstandard directory <lib dir>+ LIBS libraries to pass to the linker, e.g. -l<library>+ CPPFLAGS (Objective) C/C++ preprocessor flags, e.g. -I<include dir> if+ you have headers in a nonstandard directory <include dir>++Use these variables to override the choices made by `configure' or to help+it to find libraries and programs with nonstandard names/locations.++Report bugs to <deian@cs.stanford.edu>.+_ACEOF+ac_status=$?+fi++if test "$ac_init_help" = "recursive"; then+ # If there are subdirs, report their specific --help.+ for ac_dir in : $ac_subdirs_all; do test "x$ac_dir" = x: && continue+ test -d "$ac_dir" ||+ { cd "$srcdir" && ac_pwd=`pwd` && srcdir=. && test -d "$ac_dir"; } ||+ continue+ ac_builddir=.++case "$ac_dir" in+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;+*)+ ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`+ # A ".." for each directory in $ac_dir_suffix.+ ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`+ case $ac_top_builddir_sub in+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;+ esac ;;+esac+ac_abs_top_builddir=$ac_pwd+ac_abs_builddir=$ac_pwd$ac_dir_suffix+# for backward compatibility:+ac_top_builddir=$ac_top_build_prefix++case $srcdir in+ .) # We are building in place.+ ac_srcdir=.+ ac_top_srcdir=$ac_top_builddir_sub+ ac_abs_top_srcdir=$ac_pwd ;;+ [\\/]* | ?:[\\/]* ) # Absolute name.+ ac_srcdir=$srcdir$ac_dir_suffix;+ ac_top_srcdir=$srcdir+ ac_abs_top_srcdir=$srcdir ;;+ *) # Relative name.+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix+ ac_top_srcdir=$ac_top_build_prefix$srcdir+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;+esac+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix++ cd "$ac_dir" || { ac_status=$?; continue; }+ # Check for guested configure.+ if test -f "$ac_srcdir/configure.gnu"; then+ echo &&+ $SHELL "$ac_srcdir/configure.gnu" --help=recursive+ elif test -f "$ac_srcdir/configure"; then+ echo &&+ $SHELL "$ac_srcdir/configure" --help=recursive+ else+ $as_echo "$as_me: WARNING: no configuration information is in $ac_dir" >&2+ fi || ac_status=$?+ cd "$ac_pwd" || { ac_status=$?; break; }+ done+fi++test -n "$ac_init_help" && exit $ac_status+if $ac_init_version; then+ cat <<\_ACEOF+Labeled IO library configure 0.1.0+generated by GNU Autoconf 2.68++Copyright (C) 2010 Free Software Foundation, Inc.+This configure script is free software; the Free Software Foundation+gives unlimited permission to copy, distribute and modify it.+_ACEOF+ exit+fi++## ------------------------ ##+## Autoconf initialization. ##+## ------------------------ ##++# ac_fn_c_try_compile LINENO+# --------------------------+# Try to compile conftest.$ac_ext, and return whether this succeeded.+ac_fn_c_try_compile ()+{+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+ rm -f conftest.$ac_objext+ if { { ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_compile") 2>conftest.err+ ac_status=$?+ if test -s conftest.err; then+ grep -v '^ *+' conftest.err >conftest.er1+ cat conftest.er1 >&5+ mv -f conftest.er1 conftest.err+ fi+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest.$ac_objext; then :+ ac_retval=0+else+ $as_echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_retval=1+fi+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+ as_fn_set_status $ac_retval++} # ac_fn_c_try_compile++# ac_fn_c_try_link LINENO+# -----------------------+# Try to link conftest.$ac_ext, and return whether this succeeded.+ac_fn_c_try_link ()+{+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+ rm -f conftest.$ac_objext conftest$ac_exeext+ if { { ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_link") 2>conftest.err+ ac_status=$?+ if test -s conftest.err; then+ grep -v '^ *+' conftest.err >conftest.er1+ cat conftest.er1 >&5+ mv -f conftest.er1 conftest.err+ fi+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; } && {+ test -z "$ac_c_werror_flag" ||+ test ! -s conftest.err+ } && test -s conftest$ac_exeext && {+ test "$cross_compiling" = yes ||+ $as_test_x conftest$ac_exeext+ }; then :+ ac_retval=0+else+ $as_echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++ ac_retval=1+fi+ # Delete the IPA/IPO (Inter Procedural Analysis/Optimization) information+ # created by the PGI compiler (conftest_ipa8_conftest.oo), as it would+ # interfere with the next link command; also delete a directory that is+ # left behind by Apple's compiler. We do this before executing the actions.+ rm -rf conftest.dSYM conftest_ipa8_conftest.oo+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno+ as_fn_set_status $ac_retval++} # ac_fn_c_try_link++# ac_fn_c_check_func LINENO FUNC VAR+# ----------------------------------+# Tests whether FUNC exists, setting the cache variable VAR accordingly+ac_fn_c_check_func ()+{+ as_lineno=${as_lineno-"$1"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+ { $as_echo "$as_me:${as_lineno-$LINENO}: checking for $2" >&5+$as_echo_n "checking for $2... " >&6; }+if eval \${$3+:} false; then :+ $as_echo_n "(cached) " >&6+else+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */+/* Define $2 to an innocuous variant, in case <limits.h> declares $2.+ For example, HP-UX 11i <limits.h> declares gettimeofday. */+#define $2 innocuous_$2++/* System header to define __stub macros and hopefully few prototypes,+ which can conflict with char $2 (); below.+ Prefer <limits.h> to <assert.h> if __STDC__ is defined, since+ <limits.h> exists even on freestanding compilers. */++#ifdef __STDC__+# include <limits.h>+#else+# include <assert.h>+#endif++#undef $2++/* Override any GCC internal prototype to avoid an error.+ Use char because int might match the return type of a GCC+ builtin and then its argument prototype would still apply. */+#ifdef __cplusplus+extern "C"+#endif+char $2 ();+/* The GNU C library defines this for functions which it implements+ to always fail with ENOSYS. Some functions are actually named+ something starting with __ and the normal name is an alias. */+#if defined __stub_$2 || defined __stub___$2+choke me+#endif++int+main ()+{+return $2 ();+ ;+ return 0;+}+_ACEOF+if ac_fn_c_try_link "$LINENO"; then :+ eval "$3=yes"+else+ eval "$3=no"+fi+rm -f core conftest.err conftest.$ac_objext \+ conftest$ac_exeext conftest.$ac_ext+fi+eval ac_res=\$$3+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_res" >&5+$as_echo "$ac_res" >&6; }+ eval $as_lineno_stack; ${as_lineno_stack:+:} unset as_lineno++} # ac_fn_c_check_func+cat >config.log <<_ACEOF+This file contains any messages produced by compilers while+running configure, to aid debugging if configure makes a mistake.++It was created by Labeled IO library $as_me 0.1.0, which was+generated by GNU Autoconf 2.68. Invocation command line was++ $ $0 $@++_ACEOF+exec 5>>config.log+{+cat <<_ASUNAME+## --------- ##+## Platform. ##+## --------- ##++hostname = `(hostname || uname -n) 2>/dev/null | sed 1q`+uname -m = `(uname -m) 2>/dev/null || echo unknown`+uname -r = `(uname -r) 2>/dev/null || echo unknown`+uname -s = `(uname -s) 2>/dev/null || echo unknown`+uname -v = `(uname -v) 2>/dev/null || echo unknown`++/usr/bin/uname -p = `(/usr/bin/uname -p) 2>/dev/null || echo unknown`+/bin/uname -X = `(/bin/uname -X) 2>/dev/null || echo unknown`++/bin/arch = `(/bin/arch) 2>/dev/null || echo unknown`+/usr/bin/arch -k = `(/usr/bin/arch -k) 2>/dev/null || echo unknown`+/usr/convex/getsysinfo = `(/usr/convex/getsysinfo) 2>/dev/null || echo unknown`+/usr/bin/hostinfo = `(/usr/bin/hostinfo) 2>/dev/null || echo unknown`+/bin/machine = `(/bin/machine) 2>/dev/null || echo unknown`+/usr/bin/oslevel = `(/usr/bin/oslevel) 2>/dev/null || echo unknown`+/bin/universe = `(/bin/universe) 2>/dev/null || echo unknown`++_ASUNAME++as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ $as_echo "PATH: $as_dir"+ done+IFS=$as_save_IFS++} >&5++cat >&5 <<_ACEOF+++## ----------- ##+## Core tests. ##+## ----------- ##++_ACEOF+++# Keep a trace of the command line.+# Strip out --no-create and --no-recursion so they do not pile up.+# Strip out --silent because we don't want to record it for future runs.+# Also quote any args containing shell meta-characters.+# Make two passes to allow for proper duplicate-argument suppression.+ac_configure_args=+ac_configure_args0=+ac_configure_args1=+ac_must_keep_next=false+for ac_pass in 1 2+do+ for ac_arg+ do+ case $ac_arg in+ -no-create | --no-c* | -n | -no-recursion | --no-r*) continue ;;+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \+ | -silent | --silent | --silen | --sile | --sil)+ continue ;;+ *\'*)+ ac_arg=`$as_echo "$ac_arg" | sed "s/'/'\\\\\\\\''/g"` ;;+ esac+ case $ac_pass in+ 1) as_fn_append ac_configure_args0 " '$ac_arg'" ;;+ 2)+ as_fn_append ac_configure_args1 " '$ac_arg'"+ if test $ac_must_keep_next = true; then+ ac_must_keep_next=false # Got value, back to normal.+ else+ case $ac_arg in+ *=* | --config-cache | -C | -disable-* | --disable-* \+ | -enable-* | --enable-* | -gas | --g* | -nfp | --nf* \+ | -q | -quiet | --q* | -silent | --sil* | -v | -verb* \+ | -with-* | --with-* | -without-* | --without-* | --x)+ case "$ac_configure_args0 " in+ "$ac_configure_args1"*" '$ac_arg' "* ) continue ;;+ esac+ ;;+ -* ) ac_must_keep_next=true ;;+ esac+ fi+ as_fn_append ac_configure_args " '$ac_arg'"+ ;;+ esac+ done+done+{ ac_configure_args0=; unset ac_configure_args0;}+{ ac_configure_args1=; unset ac_configure_args1;}++# When interrupted or exit'd, cleanup temporary files, and complete+# config.log. We remove comments because anyway the quotes in there+# would cause problems or look ugly.+# WARNING: Use '\'' to represent an apostrophe within the trap.+# WARNING: Do not start the trap code with a newline, due to a FreeBSD 4.0 bug.+trap 'exit_status=$?+ # Save into config.log some information that might help in debugging.+ {+ echo++ $as_echo "## ---------------- ##+## Cache variables. ##+## ---------------- ##"+ echo+ # The following way of writing the cache mishandles newlines in values,+(+ for ac_var in `(set) 2>&1 | sed -n '\''s/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'\''`; do+ eval ac_val=\$$ac_var+ case $ac_val in #(+ *${as_nl}*)+ case $ac_var in #(+ *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5+$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;+ esac+ case $ac_var in #(+ _ | IFS | as_nl) ;; #(+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(+ *) { eval $ac_var=; unset $ac_var;} ;;+ esac ;;+ esac+ done+ (set) 2>&1 |+ case $as_nl`(ac_space='\'' '\''; set) 2>&1` in #(+ *${as_nl}ac_space=\ *)+ sed -n \+ "s/'\''/'\''\\\\'\'''\''/g;+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\''\\2'\''/p"+ ;; #(+ *)+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"+ ;;+ esac |+ sort+)+ echo++ $as_echo "## ----------------- ##+## Output variables. ##+## ----------------- ##"+ echo+ for ac_var in $ac_subst_vars+ do+ eval ac_val=\$$ac_var+ case $ac_val in+ *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;+ esac+ $as_echo "$ac_var='\''$ac_val'\''"+ done | sort+ echo++ if test -n "$ac_subst_files"; then+ $as_echo "## ------------------- ##+## File substitutions. ##+## ------------------- ##"+ echo+ for ac_var in $ac_subst_files+ do+ eval ac_val=\$$ac_var+ case $ac_val in+ *\'\''*) ac_val=`$as_echo "$ac_val" | sed "s/'\''/'\''\\\\\\\\'\'''\''/g"`;;+ esac+ $as_echo "$ac_var='\''$ac_val'\''"+ done | sort+ echo+ fi++ if test -s confdefs.h; then+ $as_echo "## ----------- ##+## confdefs.h. ##+## ----------- ##"+ echo+ cat confdefs.h+ echo+ fi+ test "$ac_signal" != 0 &&+ $as_echo "$as_me: caught signal $ac_signal"+ $as_echo "$as_me: exit $exit_status"+ } >&5+ rm -f core *.core core.conftest.* &&+ rm -f -r conftest* confdefs* conf$$* $ac_clean_files &&+ exit $exit_status+' 0+for ac_signal in 1 2 13 15; do+ trap 'ac_signal='$ac_signal'; as_fn_exit 1' $ac_signal+done+ac_signal=0++# confdefs.h avoids OS command line length limits that DEFS can exceed.+rm -f -r conftest* confdefs.h++$as_echo "/* confdefs.h */" > confdefs.h++# Predefined preprocessor variables.++cat >>confdefs.h <<_ACEOF+#define PACKAGE_NAME "$PACKAGE_NAME"+_ACEOF++cat >>confdefs.h <<_ACEOF+#define PACKAGE_TARNAME "$PACKAGE_TARNAME"+_ACEOF++cat >>confdefs.h <<_ACEOF+#define PACKAGE_VERSION "$PACKAGE_VERSION"+_ACEOF++cat >>confdefs.h <<_ACEOF+#define PACKAGE_STRING "$PACKAGE_STRING"+_ACEOF++cat >>confdefs.h <<_ACEOF+#define PACKAGE_BUGREPORT "$PACKAGE_BUGREPORT"+_ACEOF++cat >>confdefs.h <<_ACEOF+#define PACKAGE_URL "$PACKAGE_URL"+_ACEOF+++# Let the site file select an alternate cache file if it wants to.+# Prefer an explicitly selected file to automatically selected ones.+ac_site_file1=NONE+ac_site_file2=NONE+if test -n "$CONFIG_SITE"; then+ # We do not want a PATH search for config.site.+ case $CONFIG_SITE in #((+ -*) ac_site_file1=./$CONFIG_SITE;;+ */*) ac_site_file1=$CONFIG_SITE;;+ *) ac_site_file1=./$CONFIG_SITE;;+ esac+elif test "x$prefix" != xNONE; then+ ac_site_file1=$prefix/share/config.site+ ac_site_file2=$prefix/etc/config.site+else+ ac_site_file1=$ac_default_prefix/share/config.site+ ac_site_file2=$ac_default_prefix/etc/config.site+fi+for ac_site_file in "$ac_site_file1" "$ac_site_file2"+do+ test "x$ac_site_file" = xNONE && continue+ if test /dev/null != "$ac_site_file" && test -r "$ac_site_file"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading site script $ac_site_file" >&5+$as_echo "$as_me: loading site script $ac_site_file" >&6;}+ sed 's/^/| /' "$ac_site_file" >&5+ . "$ac_site_file" \+ || { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error $? "failed to load site script $ac_site_file+See \`config.log' for more details" "$LINENO" 5; }+ fi+done++if test -r "$cache_file"; then+ # Some versions of bash will fail to source /dev/null (special files+ # actually), so we avoid doing that. DJGPP emulates it as a regular file.+ if test /dev/null != "$cache_file" && test -f "$cache_file"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: loading cache $cache_file" >&5+$as_echo "$as_me: loading cache $cache_file" >&6;}+ case $cache_file in+ [\\/]* | ?:[\\/]* ) . "$cache_file";;+ *) . "./$cache_file";;+ esac+ fi+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating cache $cache_file" >&5+$as_echo "$as_me: creating cache $cache_file" >&6;}+ >$cache_file+fi++# Check that the precious variables saved in the cache have kept the same+# value.+ac_cache_corrupted=false+for ac_var in $ac_precious_vars; do+ eval ac_old_set=\$ac_cv_env_${ac_var}_set+ eval ac_new_set=\$ac_env_${ac_var}_set+ eval ac_old_val=\$ac_cv_env_${ac_var}_value+ eval ac_new_val=\$ac_env_${ac_var}_value+ case $ac_old_set,$ac_new_set in+ set,)+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&5+$as_echo "$as_me: error: \`$ac_var' was set to \`$ac_old_val' in the previous run" >&2;}+ ac_cache_corrupted=: ;;+ ,set)+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' was not set in the previous run" >&5+$as_echo "$as_me: error: \`$ac_var' was not set in the previous run" >&2;}+ ac_cache_corrupted=: ;;+ ,);;+ *)+ if test "x$ac_old_val" != "x$ac_new_val"; then+ # differences in whitespace do not lead to failure.+ ac_old_val_w=`echo x $ac_old_val`+ ac_new_val_w=`echo x $ac_new_val`+ if test "$ac_old_val_w" != "$ac_new_val_w"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: \`$ac_var' has changed since the previous run:" >&5+$as_echo "$as_me: error: \`$ac_var' has changed since the previous run:" >&2;}+ ac_cache_corrupted=:+ else+ { $as_echo "$as_me:${as_lineno-$LINENO}: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&5+$as_echo "$as_me: warning: ignoring whitespace changes in \`$ac_var' since the previous run:" >&2;}+ eval $ac_var=\$ac_old_val+ fi+ { $as_echo "$as_me:${as_lineno-$LINENO}: former value: \`$ac_old_val'" >&5+$as_echo "$as_me: former value: \`$ac_old_val'" >&2;}+ { $as_echo "$as_me:${as_lineno-$LINENO}: current value: \`$ac_new_val'" >&5+$as_echo "$as_me: current value: \`$ac_new_val'" >&2;}+ fi;;+ esac+ # Pass precious variables to config.status.+ if test "$ac_new_set" = set; then+ case $ac_new_val in+ *\'*) ac_arg=$ac_var=`$as_echo "$ac_new_val" | sed "s/'/'\\\\\\\\''/g"` ;;+ *) ac_arg=$ac_var=$ac_new_val ;;+ esac+ case " $ac_configure_args " in+ *" '$ac_arg' "*) ;; # Avoid dups. Use of quotes ensures accuracy.+ *) as_fn_append ac_configure_args " '$ac_arg'" ;;+ esac+ fi+done+if $ac_cache_corrupted; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+ { $as_echo "$as_me:${as_lineno-$LINENO}: error: changes in the environment can compromise the build" >&5+$as_echo "$as_me: error: changes in the environment can compromise the build" >&2;}+ as_fn_error $? "run \`make distclean' and/or \`rm $cache_file' and start over" "$LINENO" 5+fi+## -------------------- ##+## Main body of script. ##+## -------------------- ##++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu++++# Safety check: Ensure that we are in the correct source directory.+++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu+if test -n "$ac_tool_prefix"; then+ # Extract the first word of "${ac_tool_prefix}gcc", so it can be a program name with args.+set dummy ${ac_tool_prefix}gcc; ac_word=$2+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5+$as_echo_n "checking for $ac_word... " >&6; }+if ${ac_cv_prog_CC+:} false; then :+ $as_echo_n "(cached) " >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_CC="${ac_tool_prefix}gcc"+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+ done+IFS=$as_save_IFS++fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5+$as_echo "$CC" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+fi+++fi+if test -z "$ac_cv_prog_CC"; then+ ac_ct_CC=$CC+ # Extract the first word of "gcc", so it can be a program name with args.+set dummy gcc; ac_word=$2+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5+$as_echo_n "checking for $ac_word... " >&6; }+if ${ac_cv_prog_ac_ct_CC+:} false; then :+ $as_echo_n "(cached) " >&6+else+ if test -n "$ac_ct_CC"; then+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_ac_ct_CC="gcc"+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+ done+IFS=$as_save_IFS++fi+fi+ac_ct_CC=$ac_cv_prog_ac_ct_CC+if test -n "$ac_ct_CC"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5+$as_echo "$ac_ct_CC" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+fi++ if test "x$ac_ct_CC" = x; then+ CC=""+ else+ case $cross_compiling:$ac_tool_warned in+yes:)+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}+ac_tool_warned=yes ;;+esac+ CC=$ac_ct_CC+ fi+else+ CC="$ac_cv_prog_CC"+fi++if test -z "$CC"; then+ if test -n "$ac_tool_prefix"; then+ # Extract the first word of "${ac_tool_prefix}cc", so it can be a program name with args.+set dummy ${ac_tool_prefix}cc; ac_word=$2+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5+$as_echo_n "checking for $ac_word... " >&6; }+if ${ac_cv_prog_CC+:} false; then :+ $as_echo_n "(cached) " >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_CC="${ac_tool_prefix}cc"+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+ done+IFS=$as_save_IFS++fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5+$as_echo "$CC" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+fi+++ fi+fi+if test -z "$CC"; then+ # Extract the first word of "cc", so it can be a program name with args.+set dummy cc; ac_word=$2+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5+$as_echo_n "checking for $ac_word... " >&6; }+if ${ac_cv_prog_CC+:} false; then :+ $as_echo_n "(cached) " >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+ ac_prog_rejected=no+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ if test "$as_dir/$ac_word$ac_exec_ext" = "/usr/ucb/cc"; then+ ac_prog_rejected=yes+ continue+ fi+ ac_cv_prog_CC="cc"+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+ done+IFS=$as_save_IFS++if test $ac_prog_rejected = yes; then+ # We found a bogon in the path, so make sure we never use it.+ set dummy $ac_cv_prog_CC+ shift+ if test $# != 0; then+ # We chose a different compiler from the bogus one.+ # However, it has the same basename, so the bogon will be chosen+ # first if we set CC to just the basename; use the full file name.+ shift+ ac_cv_prog_CC="$as_dir/$ac_word${1+' '}$@"+ fi+fi+fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5+$as_echo "$CC" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+fi+++fi+if test -z "$CC"; then+ if test -n "$ac_tool_prefix"; then+ for ac_prog in cl.exe+ do+ # Extract the first word of "$ac_tool_prefix$ac_prog", so it can be a program name with args.+set dummy $ac_tool_prefix$ac_prog; ac_word=$2+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5+$as_echo_n "checking for $ac_word... " >&6; }+if ${ac_cv_prog_CC+:} false; then :+ $as_echo_n "(cached) " >&6+else+ if test -n "$CC"; then+ ac_cv_prog_CC="$CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_CC="$ac_tool_prefix$ac_prog"+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+ done+IFS=$as_save_IFS++fi+fi+CC=$ac_cv_prog_CC+if test -n "$CC"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $CC" >&5+$as_echo "$CC" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+fi+++ test -n "$CC" && break+ done+fi+if test -z "$CC"; then+ ac_ct_CC=$CC+ for ac_prog in cl.exe+do+ # Extract the first word of "$ac_prog", so it can be a program name with args.+set dummy $ac_prog; ac_word=$2+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $ac_word" >&5+$as_echo_n "checking for $ac_word... " >&6; }+if ${ac_cv_prog_ac_ct_CC+:} false; then :+ $as_echo_n "(cached) " >&6+else+ if test -n "$ac_ct_CC"; then+ ac_cv_prog_ac_ct_CC="$ac_ct_CC" # Let the user override the test.+else+as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ for ac_exec_ext in '' $ac_executable_extensions; do+ if { test -f "$as_dir/$ac_word$ac_exec_ext" && $as_test_x "$as_dir/$ac_word$ac_exec_ext"; }; then+ ac_cv_prog_ac_ct_CC="$ac_prog"+ $as_echo "$as_me:${as_lineno-$LINENO}: found $as_dir/$ac_word$ac_exec_ext" >&5+ break 2+ fi+done+ done+IFS=$as_save_IFS++fi+fi+ac_ct_CC=$ac_cv_prog_ac_ct_CC+if test -n "$ac_ct_CC"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_ct_CC" >&5+$as_echo "$ac_ct_CC" >&6; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+fi+++ test -n "$ac_ct_CC" && break+done++ if test "x$ac_ct_CC" = x; then+ CC=""+ else+ case $cross_compiling:$ac_tool_warned in+yes:)+{ $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: using cross tools not prefixed with host triplet" >&5+$as_echo "$as_me: WARNING: using cross tools not prefixed with host triplet" >&2;}+ac_tool_warned=yes ;;+esac+ CC=$ac_ct_CC+ fi+fi++fi+++test -z "$CC" && { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error $? "no acceptable C compiler found in \$PATH+See \`config.log' for more details" "$LINENO" 5; }++# Provide some information about the compiler.+$as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler version" >&5+set X $ac_compile+ac_compiler=$2+for ac_option in --version -v -V -qversion; do+ { { ac_try="$ac_compiler $ac_option >&5"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_compiler $ac_option >&5") 2>conftest.err+ ac_status=$?+ if test -s conftest.err; then+ sed '10a\+... rest of stderr output deleted ...+ 10q' conftest.err >conftest.er1+ cat conftest.er1 >&5+ fi+ rm -f conftest.er1 conftest.err+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; }+done++cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+ac_clean_files_save=$ac_clean_files+ac_clean_files="$ac_clean_files a.out a.out.dSYM a.exe b.out"+# Try to create an executable without -o first, disregard a.out.+# It will help us diagnose broken compilers, and finding out an intuition+# of exeext.+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether the C compiler works" >&5+$as_echo_n "checking whether the C compiler works... " >&6; }+ac_link_default=`$as_echo "$ac_link" | sed 's/ -o *conftest[^ ]*//'`++# The possible output files:+ac_files="a.out conftest.exe conftest a.exe a_out.exe b.out conftest.*"++ac_rmfiles=+for ac_file in $ac_files+do+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;+ * ) ac_rmfiles="$ac_rmfiles $ac_file";;+ esac+done+rm -f $ac_rmfiles++if { { ac_try="$ac_link_default"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_link_default") 2>&5+ ac_status=$?+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; }; then :+ # Autoconf-2.13 could set the ac_cv_exeext variable to `no'.+# So ignore a value of `no', otherwise this would lead to `EXEEXT = no'+# in a Makefile. We should not override ac_cv_exeext if it was cached,+# so that the user can short-circuit this test for compilers unknown to+# Autoconf.+for ac_file in $ac_files ''+do+ test -f "$ac_file" || continue+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj )+ ;;+ [ab].out )+ # We found the default executable, but exeext='' is most+ # certainly right.+ break;;+ *.* )+ if test "${ac_cv_exeext+set}" = set && test "$ac_cv_exeext" != no;+ then :; else+ ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`+ fi+ # We set ac_cv_exeext here because the later test for it is not+ # safe: cross compilers may not add the suffix if given an `-o'+ # argument, so we may need to know it at that point already.+ # Even if this section looks crufty: it has the advantage of+ # actually working.+ break;;+ * )+ break;;+ esac+done+test "$ac_cv_exeext" = no && ac_cv_exeext=++else+ ac_file=''+fi+if test -z "$ac_file"; then :+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: no" >&5+$as_echo "no" >&6; }+$as_echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error 77 "C compiler cannot create executables+See \`config.log' for more details" "$LINENO" 5; }+else+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: yes" >&5+$as_echo "yes" >&6; }+fi+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for C compiler default output file name" >&5+$as_echo_n "checking for C compiler default output file name... " >&6; }+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_file" >&5+$as_echo "$ac_file" >&6; }+ac_exeext=$ac_cv_exeext++rm -f -r a.out a.out.dSYM a.exe conftest$ac_cv_exeext b.out+ac_clean_files=$ac_clean_files_save+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of executables" >&5+$as_echo_n "checking for suffix of executables... " >&6; }+if { { ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_link") 2>&5+ ac_status=$?+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; }; then :+ # If both `conftest.exe' and `conftest' are `present' (well, observable)+# catch `conftest.exe'. For instance with Cygwin, `ls conftest' will+# work properly (i.e., refer to `conftest.exe'), while it won't with+# `rm'.+for ac_file in conftest.exe conftest conftest.*; do+ test -f "$ac_file" || continue+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM | *.o | *.obj ) ;;+ *.* ) ac_cv_exeext=`expr "$ac_file" : '[^.]*\(\..*\)'`+ break;;+ * ) break;;+ esac+done+else+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error $? "cannot compute suffix of executables: cannot compile and link+See \`config.log' for more details" "$LINENO" 5; }+fi+rm -f conftest conftest$ac_cv_exeext+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_exeext" >&5+$as_echo "$ac_cv_exeext" >&6; }++rm -f conftest.$ac_ext+EXEEXT=$ac_cv_exeext+ac_exeext=$EXEEXT+cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */+#include <stdio.h>+int+main ()+{+FILE *f = fopen ("conftest.out", "w");+ return ferror (f) || fclose (f) != 0;++ ;+ return 0;+}+_ACEOF+ac_clean_files="$ac_clean_files conftest.out"+# Check that the compiler produces executables we can run. If not, either+# the compiler is broken, or we cross compile.+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are cross compiling" >&5+$as_echo_n "checking whether we are cross compiling... " >&6; }+if test "$cross_compiling" != yes; then+ { { ac_try="$ac_link"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_link") 2>&5+ ac_status=$?+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; }+ if { ac_try='./conftest$ac_cv_exeext'+ { { case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_try") 2>&5+ ac_status=$?+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; }; }; then+ cross_compiling=no+ else+ if test "$cross_compiling" = maybe; then+ cross_compiling=yes+ else+ { { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error $? "cannot run C compiled programs.+If you meant to cross compile, use \`--host'.+See \`config.log' for more details" "$LINENO" 5; }+ fi+ fi+fi+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $cross_compiling" >&5+$as_echo "$cross_compiling" >&6; }++rm -f conftest.$ac_ext conftest$ac_cv_exeext conftest.out+ac_clean_files=$ac_clean_files_save+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for suffix of object files" >&5+$as_echo_n "checking for suffix of object files... " >&6; }+if ${ac_cv_objext+:} false; then :+ $as_echo_n "(cached) " >&6+else+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+rm -f conftest.o conftest.obj+if { { ac_try="$ac_compile"+case "(($ac_try" in+ *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;;+ *) ac_try_echo=$ac_try;;+esac+eval ac_try_echo="\"\$as_me:${as_lineno-$LINENO}: $ac_try_echo\""+$as_echo "$ac_try_echo"; } >&5+ (eval "$ac_compile") 2>&5+ ac_status=$?+ $as_echo "$as_me:${as_lineno-$LINENO}: \$? = $ac_status" >&5+ test $ac_status = 0; }; then :+ for ac_file in conftest.o conftest.obj conftest.*; do+ test -f "$ac_file" || continue;+ case $ac_file in+ *.$ac_ext | *.xcoff | *.tds | *.d | *.pdb | *.xSYM | *.bb | *.bbg | *.map | *.inf | *.dSYM ) ;;+ *) ac_cv_objext=`expr "$ac_file" : '.*\.\(.*\)'`+ break;;+ esac+done+else+ $as_echo "$as_me: failed program was:" >&5+sed 's/^/| /' conftest.$ac_ext >&5++{ { $as_echo "$as_me:${as_lineno-$LINENO}: error: in \`$ac_pwd':" >&5+$as_echo "$as_me: error: in \`$ac_pwd':" >&2;}+as_fn_error $? "cannot compute suffix of object files: cannot compile+See \`config.log' for more details" "$LINENO" 5; }+fi+rm -f conftest.$ac_cv_objext conftest.$ac_ext+fi+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_objext" >&5+$as_echo "$ac_cv_objext" >&6; }+OBJEXT=$ac_cv_objext+ac_objext=$OBJEXT+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether we are using the GNU C compiler" >&5+$as_echo_n "checking whether we are using the GNU C compiler... " >&6; }+if ${ac_cv_c_compiler_gnu+:} false; then :+ $as_echo_n "(cached) " >&6+else+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */++int+main ()+{+#ifndef __GNUC__+ choke me+#endif++ ;+ return 0;+}+_ACEOF+if ac_fn_c_try_compile "$LINENO"; then :+ ac_compiler_gnu=yes+else+ ac_compiler_gnu=no+fi+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+ac_cv_c_compiler_gnu=$ac_compiler_gnu++fi+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_c_compiler_gnu" >&5+$as_echo "$ac_cv_c_compiler_gnu" >&6; }+if test $ac_compiler_gnu = yes; then+ GCC=yes+else+ GCC=+fi+ac_test_CFLAGS=${CFLAGS+set}+ac_save_CFLAGS=$CFLAGS+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking whether $CC accepts -g" >&5+$as_echo_n "checking whether $CC accepts -g... " >&6; }+if ${ac_cv_prog_cc_g+:} false; then :+ $as_echo_n "(cached) " >&6+else+ ac_save_c_werror_flag=$ac_c_werror_flag+ ac_c_werror_flag=yes+ ac_cv_prog_cc_g=no+ CFLAGS="-g"+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+if ac_fn_c_try_compile "$LINENO"; then :+ ac_cv_prog_cc_g=yes+else+ CFLAGS=""+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+if ac_fn_c_try_compile "$LINENO"; then :++else+ ac_c_werror_flag=$ac_save_c_werror_flag+ CFLAGS="-g"+ cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */++int+main ()+{++ ;+ return 0;+}+_ACEOF+if ac_fn_c_try_compile "$LINENO"; then :+ ac_cv_prog_cc_g=yes+fi+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+fi+rm -f core conftest.err conftest.$ac_objext conftest.$ac_ext+ ac_c_werror_flag=$ac_save_c_werror_flag+fi+{ $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_g" >&5+$as_echo "$ac_cv_prog_cc_g" >&6; }+if test "$ac_test_CFLAGS" = set; then+ CFLAGS=$ac_save_CFLAGS+elif test $ac_cv_prog_cc_g = yes; then+ if test "$GCC" = yes; then+ CFLAGS="-g -O2"+ else+ CFLAGS="-g"+ fi+else+ if test "$GCC" = yes; then+ CFLAGS="-O2"+ else+ CFLAGS=+ fi+fi+{ $as_echo "$as_me:${as_lineno-$LINENO}: checking for $CC option to accept ISO C89" >&5+$as_echo_n "checking for $CC option to accept ISO C89... " >&6; }+if ${ac_cv_prog_cc_c89+:} false; then :+ $as_echo_n "(cached) " >&6+else+ ac_cv_prog_cc_c89=no+ac_save_CC=$CC+cat confdefs.h - <<_ACEOF >conftest.$ac_ext+/* end confdefs.h. */+#include <stdarg.h>+#include <stdio.h>+#include <sys/types.h>+#include <sys/stat.h>+/* Most of the following tests are stolen from RCS 5.7's src/conf.sh. */+struct buf { int x; };+FILE * (*rcsopen) (struct buf *, struct stat *, int);+static char *e (p, i)+ char **p;+ int i;+{+ return p[i];+}+static char *f (char * (*g) (char **, int), char **p, ...)+{+ char *s;+ va_list v;+ va_start (v,p);+ s = g (p, va_arg (v,int));+ va_end (v);+ return s;+}++/* OSF 4.0 Compaq cc is some sort of almost-ANSI by default. It has+ function prototypes and stuff, but not '\xHH' hex character constants.+ These don't provoke an error unfortunately, instead are silently treated+ as 'x'. The following induces an error, until -std is added to get+ proper ANSI mode. Curiously '\x00'!='x' always comes out true, for an+ array size at least. It's necessary to write '\x00'==0 to get something+ that's true only with -std. */+int osf4_cc_array ['\x00' == 0 ? 1 : -1];++/* IBM C 6 for AIX is almost-ANSI by default, but it replaces macro parameters+ inside strings and character constants. */+#define FOO(x) 'x'+int xlc6_cc_array[FOO(a) == 'x' ? 1 : -1];++int test (int i, double x);+struct s1 {int (*f) (int a);};+struct s2 {int (*f) (double a);};+int pairnames (int, char **, FILE *(*)(struct buf *, struct stat *, int), int, int);+int argc;+char **argv;+int+main ()+{+return f (e, argv, 0) != argv[0] || f (e, argv, 1) != argv[1];+ ;+ return 0;+}+_ACEOF+for ac_arg in '' -qlanglvl=extc89 -qlanglvl=ansi -std \+ -Ae "-Aa -D_HPUX_SOURCE" "-Xc -D__EXTENSIONS__"+do+ CC="$ac_save_CC $ac_arg"+ if ac_fn_c_try_compile "$LINENO"; then :+ ac_cv_prog_cc_c89=$ac_arg+fi+rm -f core conftest.err conftest.$ac_objext+ test "x$ac_cv_prog_cc_c89" != "xno" && break+done+rm -f conftest.$ac_ext+CC=$ac_save_CC++fi+# AC_CACHE_VAL+case "x$ac_cv_prog_cc_c89" in+ x)+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: none needed" >&5+$as_echo "none needed" >&6; } ;;+ xno)+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: unsupported" >&5+$as_echo "unsupported" >&6; } ;;+ *)+ CC="$CC $ac_cv_prog_cc_c89"+ { $as_echo "$as_me:${as_lineno-$LINENO}: result: $ac_cv_prog_cc_c89" >&5+$as_echo "$ac_cv_prog_cc_c89" >&6; } ;;+esac+if test "x$ac_cv_prog_cc_c89" != xno; then :++fi++ac_ext=c+ac_cpp='$CPP $CPPFLAGS'+ac_compile='$CC -c $CFLAGS $CPPFLAGS conftest.$ac_ext >&5'+ac_link='$CC -o conftest$ac_exeext $CFLAGS $CPPFLAGS $LDFLAGS conftest.$ac_ext $LIBS >&5'+ac_compiler_gnu=$ac_cv_c_compiler_gnu+++ac_config_headers="$ac_config_headers include/HsTmpConfig.h"+++# Temp functions++for ac_func in mkstemp mkstemps mkdtemp+do :+ as_ac_var=`$as_echo "ac_cv_func_$ac_func" | $as_tr_sh`+ac_fn_c_check_func "$LINENO" "$ac_func" "$as_ac_var"+if eval test \"x\$"$as_ac_var"\" = x"yes"; then :+ cat >>confdefs.h <<_ACEOF+#define `$as_echo "HAVE_$ac_func" | $as_tr_cpp` 1+_ACEOF++fi+done+++cat >confcache <<\_ACEOF+# This file is a shell script that caches the results of configure+# tests run on this system so they can be shared between configure+# scripts and configure runs, see configure's option --config-cache.+# It is not useful on other systems. If it contains results you don't+# want to keep, you may remove or edit it.+#+# config.status only pays attention to the cache file if you give it+# the --recheck option to rerun configure.+#+# `ac_cv_env_foo' variables (set or unset) will be overridden when+# loading this file, other *unset* `ac_cv_foo' will be assigned the+# following values.++_ACEOF++# The following way of writing the cache mishandles newlines in values,+# but we know of no workaround that is simple, portable, and efficient.+# So, we kill variables containing newlines.+# Ultrix sh set writes to stderr and can't be redirected directly,+# and sets the high bit in the cache file unless we assign to the vars.+(+ for ac_var in `(set) 2>&1 | sed -n 's/^\([a-zA-Z_][a-zA-Z0-9_]*\)=.*/\1/p'`; do+ eval ac_val=\$$ac_var+ case $ac_val in #(+ *${as_nl}*)+ case $ac_var in #(+ *_cv_*) { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: cache variable $ac_var contains a newline" >&5+$as_echo "$as_me: WARNING: cache variable $ac_var contains a newline" >&2;} ;;+ esac+ case $ac_var in #(+ _ | IFS | as_nl) ;; #(+ BASH_ARGV | BASH_SOURCE) eval $ac_var= ;; #(+ *) { eval $ac_var=; unset $ac_var;} ;;+ esac ;;+ esac+ done++ (set) 2>&1 |+ case $as_nl`(ac_space=' '; set) 2>&1` in #(+ *${as_nl}ac_space=\ *)+ # `set' does not quote correctly, so add quotes: double-quote+ # substitution turns \\\\ into \\, and sed turns \\ into \.+ sed -n \+ "s/'/'\\\\''/g;+ s/^\\([_$as_cr_alnum]*_cv_[_$as_cr_alnum]*\\)=\\(.*\\)/\\1='\\2'/p"+ ;; #(+ *)+ # `set' quotes correctly as required by POSIX, so do not add quotes.+ sed -n "/^[_$as_cr_alnum]*_cv_[_$as_cr_alnum]*=/p"+ ;;+ esac |+ sort+) |+ sed '+ /^ac_cv_env_/b end+ t clear+ :clear+ s/^\([^=]*\)=\(.*[{}].*\)$/test "${\1+set}" = set || &/+ t end+ s/^\([^=]*\)=\(.*\)$/\1=${\1=\2}/+ :end' >>confcache+if diff "$cache_file" confcache >/dev/null 2>&1; then :; else+ if test -w "$cache_file"; then+ if test "x$cache_file" != "x/dev/null"; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: updating cache $cache_file" >&5+$as_echo "$as_me: updating cache $cache_file" >&6;}+ if test ! -f "$cache_file" || test -h "$cache_file"; then+ cat confcache >"$cache_file"+ else+ case $cache_file in #(+ */* | ?:*)+ mv -f confcache "$cache_file"$$ &&+ mv -f "$cache_file"$$ "$cache_file" ;; #(+ *)+ mv -f confcache "$cache_file" ;;+ esac+ fi+ fi+ else+ { $as_echo "$as_me:${as_lineno-$LINENO}: not updating unwritable cache $cache_file" >&5+$as_echo "$as_me: not updating unwritable cache $cache_file" >&6;}+ fi+fi+rm -f confcache++test "x$prefix" = xNONE && prefix=$ac_default_prefix+# Let make expand exec_prefix.+test "x$exec_prefix" = xNONE && exec_prefix='${prefix}'++DEFS=-DHAVE_CONFIG_H++ac_libobjs=+ac_ltlibobjs=+U=+for ac_i in : $LIBOBJS; do test "x$ac_i" = x: && continue+ # 1. Remove the extension, and $U if already installed.+ ac_script='s/\$U\././;s/\.o$//;s/\.obj$//'+ ac_i=`$as_echo "$ac_i" | sed "$ac_script"`+ # 2. Prepend LIBOBJDIR. When used with automake>=1.10 LIBOBJDIR+ # will be set to the directory where LIBOBJS objects are built.+ as_fn_append ac_libobjs " \${LIBOBJDIR}$ac_i\$U.$ac_objext"+ as_fn_append ac_ltlibobjs " \${LIBOBJDIR}$ac_i"'$U.lo'+done+LIBOBJS=$ac_libobjs++LTLIBOBJS=$ac_ltlibobjs++++: "${CONFIG_STATUS=./config.status}"+ac_write_fail=0+ac_clean_files_save=$ac_clean_files+ac_clean_files="$ac_clean_files $CONFIG_STATUS"+{ $as_echo "$as_me:${as_lineno-$LINENO}: creating $CONFIG_STATUS" >&5+$as_echo "$as_me: creating $CONFIG_STATUS" >&6;}+as_write_fail=0+cat >$CONFIG_STATUS <<_ASEOF || as_write_fail=1+#! $SHELL+# Generated by $as_me.+# Run this file to recreate the current configuration.+# Compiler output produced by configure, useful for debugging+# configure, is in config.log if it exists.++debug=false+ac_cs_recheck=false+ac_cs_silent=false++SHELL=\${CONFIG_SHELL-$SHELL}+export SHELL+_ASEOF+cat >>$CONFIG_STATUS <<\_ASEOF || as_write_fail=1+## -------------------- ##+## M4sh Initialization. ##+## -------------------- ##++# Be more Bourne compatible+DUALCASE=1; export DUALCASE # for MKS sh+if test -n "${ZSH_VERSION+set}" && (emulate sh) >/dev/null 2>&1; then :+ emulate sh+ NULLCMD=:+ # Pre-4.2 versions of Zsh do word splitting on ${1+"$@"}, which+ # is contrary to our usage. Disable this feature.+ alias -g '${1+"$@"}'='"$@"'+ setopt NO_GLOB_SUBST+else+ case `(set -o) 2>/dev/null` in #(+ *posix*) :+ set -o posix ;; #(+ *) :+ ;;+esac+fi+++as_nl='+'+export as_nl+# Printing a long string crashes Solaris 7 /usr/bin/printf.+as_echo='\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\'+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo+as_echo=$as_echo$as_echo$as_echo$as_echo$as_echo$as_echo+# Prefer a ksh shell builtin over an external printf program on Solaris,+# but without wasting forks for bash or zsh.+if test -z "$BASH_VERSION$ZSH_VERSION" \+ && (test "X`print -r -- $as_echo`" = "X$as_echo") 2>/dev/null; then+ as_echo='print -r --'+ as_echo_n='print -rn --'+elif (test "X`printf %s $as_echo`" = "X$as_echo") 2>/dev/null; then+ as_echo='printf %s\n'+ as_echo_n='printf %s'+else+ if test "X`(/usr/ucb/echo -n -n $as_echo) 2>/dev/null`" = "X-n $as_echo"; then+ as_echo_body='eval /usr/ucb/echo -n "$1$as_nl"'+ as_echo_n='/usr/ucb/echo -n'+ else+ as_echo_body='eval expr "X$1" : "X\\(.*\\)"'+ as_echo_n_body='eval+ arg=$1;+ case $arg in #(+ *"$as_nl"*)+ expr "X$arg" : "X\\(.*\\)$as_nl";+ arg=`expr "X$arg" : ".*$as_nl\\(.*\\)"`;;+ esac;+ expr "X$arg" : "X\\(.*\\)" | tr -d "$as_nl"+ '+ export as_echo_n_body+ as_echo_n='sh -c $as_echo_n_body as_echo'+ fi+ export as_echo_body+ as_echo='sh -c $as_echo_body as_echo'+fi++# The user is always right.+if test "${PATH_SEPARATOR+set}" != set; then+ PATH_SEPARATOR=:+ (PATH='/bin;/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 && {+ (PATH='/bin:/bin'; FPATH=$PATH; sh -c :) >/dev/null 2>&1 ||+ PATH_SEPARATOR=';'+ }+fi+++# IFS+# We need space, tab and new line, in precisely that order. Quoting is+# there to prevent editors from complaining about space-tab.+# (If _AS_PATH_WALK were called with IFS unset, it would disable word+# splitting by setting IFS to empty value.)+IFS=" "" $as_nl"++# Find who we are. Look in the path if we contain no directory separator.+as_myself=+case $0 in #((+ *[\\/]* ) as_myself=$0 ;;+ *) as_save_IFS=$IFS; IFS=$PATH_SEPARATOR+for as_dir in $PATH+do+ IFS=$as_save_IFS+ test -z "$as_dir" && as_dir=.+ test -r "$as_dir/$0" && as_myself=$as_dir/$0 && break+ done+IFS=$as_save_IFS++ ;;+esac+# We did not find ourselves, most probably we were run as `sh COMMAND'+# in which case we are not to be found in the path.+if test "x$as_myself" = x; then+ as_myself=$0+fi+if test ! -f "$as_myself"; then+ $as_echo "$as_myself: error: cannot find myself; rerun with an absolute file name" >&2+ exit 1+fi++# Unset variables that we do not need and which cause bugs (e.g. in+# pre-3.0 UWIN ksh). But do not cause bugs in bash 2.01; the "|| exit 1"+# suppresses any "Segmentation fault" message there. '((' could+# trigger a bug in pdksh 5.2.14.+for as_var in BASH_ENV ENV MAIL MAILPATH+do eval test x\${$as_var+set} = xset \+ && ( (unset $as_var) || exit 1) >/dev/null 2>&1 && unset $as_var || :+done+PS1='$ '+PS2='> '+PS4='+ '++# NLS nuisances.+LC_ALL=C+export LC_ALL+LANGUAGE=C+export LANGUAGE++# CDPATH.+(unset CDPATH) >/dev/null 2>&1 && unset CDPATH+++# as_fn_error STATUS ERROR [LINENO LOG_FD]+# ----------------------------------------+# Output "`basename $0`: error: ERROR" to stderr. If LINENO and LOG_FD are+# provided, also output the error to LOG_FD, referencing LINENO. Then exit the+# script with STATUS, using 1 if that was 0.+as_fn_error ()+{+ as_status=$1; test $as_status -eq 0 && as_status=1+ if test "$4"; then+ as_lineno=${as_lineno-"$3"} as_lineno_stack=as_lineno_stack=$as_lineno_stack+ $as_echo "$as_me:${as_lineno-$LINENO}: error: $2" >&$4+ fi+ $as_echo "$as_me: error: $2" >&2+ as_fn_exit $as_status+} # as_fn_error+++# as_fn_set_status STATUS+# -----------------------+# Set $? to STATUS, without forking.+as_fn_set_status ()+{+ return $1+} # as_fn_set_status++# as_fn_exit STATUS+# -----------------+# Exit the shell with STATUS, even in a "trap 0" or "set -e" context.+as_fn_exit ()+{+ set +e+ as_fn_set_status $1+ exit $1+} # as_fn_exit++# as_fn_unset VAR+# ---------------+# Portably unset VAR.+as_fn_unset ()+{+ { eval $1=; unset $1;}+}+as_unset=as_fn_unset+# as_fn_append VAR VALUE+# ----------------------+# Append the text in VALUE to the end of the definition contained in VAR. Take+# advantage of any shell optimizations that allow amortized linear growth over+# repeated appends, instead of the typical quadratic growth present in naive+# implementations.+if (eval "as_var=1; as_var+=2; test x\$as_var = x12") 2>/dev/null; then :+ eval 'as_fn_append ()+ {+ eval $1+=\$2+ }'+else+ as_fn_append ()+ {+ eval $1=\$$1\$2+ }+fi # as_fn_append++# as_fn_arith ARG...+# ------------------+# Perform arithmetic evaluation on the ARGs, and store the result in the+# global $as_val. Take advantage of shells that can avoid forks. The arguments+# must be portable across $(()) and expr.+if (eval "test \$(( 1 + 1 )) = 2") 2>/dev/null; then :+ eval 'as_fn_arith ()+ {+ as_val=$(( $* ))+ }'+else+ as_fn_arith ()+ {+ as_val=`expr "$@" || test $? -eq 1`+ }+fi # as_fn_arith+++if expr a : '\(a\)' >/dev/null 2>&1 &&+ test "X`expr 00001 : '.*\(...\)'`" = X001; then+ as_expr=expr+else+ as_expr=false+fi++if (basename -- /) >/dev/null 2>&1 && test "X`basename -- / 2>&1`" = "X/"; then+ as_basename=basename+else+ as_basename=false+fi++if (as_dir=`dirname -- /` && test "X$as_dir" = X/) >/dev/null 2>&1; then+ as_dirname=dirname+else+ as_dirname=false+fi++as_me=`$as_basename -- "$0" ||+$as_expr X/"$0" : '.*/\([^/][^/]*\)/*$' \| \+ X"$0" : 'X\(//\)$' \| \+ X"$0" : 'X\(/\)' \| . 2>/dev/null ||+$as_echo X/"$0" |+ sed '/^.*\/\([^/][^/]*\)\/*$/{+ s//\1/+ q+ }+ /^X\/\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\/\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`++# Avoid depending upon Character Ranges.+as_cr_letters='abcdefghijklmnopqrstuvwxyz'+as_cr_LETTERS='ABCDEFGHIJKLMNOPQRSTUVWXYZ'+as_cr_Letters=$as_cr_letters$as_cr_LETTERS+as_cr_digits='0123456789'+as_cr_alnum=$as_cr_Letters$as_cr_digits++ECHO_C= ECHO_N= ECHO_T=+case `echo -n x` in #(((((+-n*)+ case `echo 'xy\c'` in+ *c*) ECHO_T=' ';; # ECHO_T is single tab character.+ xy) ECHO_C='\c';;+ *) echo `echo ksh88 bug on AIX 6.1` > /dev/null+ ECHO_T=' ';;+ esac;;+*)+ ECHO_N='-n';;+esac++rm -f conf$$ conf$$.exe conf$$.file+if test -d conf$$.dir; then+ rm -f conf$$.dir/conf$$.file+else+ rm -f conf$$.dir+ mkdir conf$$.dir 2>/dev/null+fi+if (echo >conf$$.file) 2>/dev/null; then+ if ln -s conf$$.file conf$$ 2>/dev/null; then+ as_ln_s='ln -s'+ # ... but there are two gotchas:+ # 1) On MSYS, both `ln -s file dir' and `ln file dir' fail.+ # 2) DJGPP < 2.04 has no symlinks; `ln -s' creates a wrapper executable.+ # In both cases, we have to default to `cp -p'.+ ln -s conf$$.file conf$$.dir 2>/dev/null && test ! -f conf$$.exe ||+ as_ln_s='cp -p'+ elif ln conf$$.file conf$$ 2>/dev/null; then+ as_ln_s=ln+ else+ as_ln_s='cp -p'+ fi+else+ as_ln_s='cp -p'+fi+rm -f conf$$ conf$$.exe conf$$.dir/conf$$.file conf$$.file+rmdir conf$$.dir 2>/dev/null+++# as_fn_mkdir_p+# -------------+# Create "$as_dir" as a directory, including parents if necessary.+as_fn_mkdir_p ()+{++ case $as_dir in #(+ -*) as_dir=./$as_dir;;+ esac+ test -d "$as_dir" || eval $as_mkdir_p || {+ as_dirs=+ while :; do+ case $as_dir in #(+ *\'*) as_qdir=`$as_echo "$as_dir" | sed "s/'/'\\\\\\\\''/g"`;; #'(+ *) as_qdir=$as_dir;;+ esac+ as_dirs="'$as_qdir' $as_dirs"+ as_dir=`$as_dirname -- "$as_dir" ||+$as_expr X"$as_dir" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+ X"$as_dir" : 'X\(//\)[^/]' \| \+ X"$as_dir" : 'X\(//\)$' \| \+ X"$as_dir" : 'X\(/\)' \| . 2>/dev/null ||+$as_echo X"$as_dir" |+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{+ s//\1/+ q+ }+ /^X\(\/\/\)[^/].*/{+ s//\1/+ q+ }+ /^X\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`+ test -d "$as_dir" && break+ done+ test -z "$as_dirs" || eval "mkdir $as_dirs"+ } || test -d "$as_dir" || as_fn_error $? "cannot create directory $as_dir"+++} # as_fn_mkdir_p+if mkdir -p . 2>/dev/null; then+ as_mkdir_p='mkdir -p "$as_dir"'+else+ test -d ./-p && rmdir ./-p+ as_mkdir_p=false+fi++if test -x / >/dev/null 2>&1; then+ as_test_x='test -x'+else+ if ls -dL / >/dev/null 2>&1; then+ as_ls_L_option=L+ else+ as_ls_L_option=+ fi+ as_test_x='+ eval sh -c '\''+ if test -d "$1"; then+ test -d "$1/.";+ else+ case $1 in #(+ -*)set "./$1";;+ esac;+ case `ls -ld'$as_ls_L_option' "$1" 2>/dev/null` in #((+ ???[sx]*):;;*)false;;esac;fi+ '\'' sh+ '+fi+as_executable_p=$as_test_x++# Sed expression to map a string onto a valid CPP name.+as_tr_cpp="eval sed 'y%*$as_cr_letters%P$as_cr_LETTERS%;s%[^_$as_cr_alnum]%_%g'"++# Sed expression to map a string onto a valid variable name.+as_tr_sh="eval sed 'y%*+%pp%;s%[^_$as_cr_alnum]%_%g'"+++exec 6>&1+## ----------------------------------- ##+## Main body of $CONFIG_STATUS script. ##+## ----------------------------------- ##+_ASEOF+test $as_write_fail = 0 && chmod +x $CONFIG_STATUS || ac_write_fail=1++cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1+# Save the log message, to keep $0 and so on meaningful, and to+# report actual input values of CONFIG_FILES etc. instead of their+# values after options handling.+ac_log="+This file was extended by Labeled IO library $as_me 0.1.0, which was+generated by GNU Autoconf 2.68. Invocation command line was++ CONFIG_FILES = $CONFIG_FILES+ CONFIG_HEADERS = $CONFIG_HEADERS+ CONFIG_LINKS = $CONFIG_LINKS+ CONFIG_COMMANDS = $CONFIG_COMMANDS+ $ $0 $@++on `(hostname || uname -n) 2>/dev/null | sed 1q`+"++_ACEOF+++case $ac_config_headers in *"+"*) set x $ac_config_headers; shift; ac_config_headers=$*;;+esac+++cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1+# Files that config.status was made for.+config_headers="$ac_config_headers"++_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1+ac_cs_usage="\+\`$as_me' instantiates files and other configuration actions+from templates according to the current configuration. Unless the files+and actions are specified as TAGs, all are instantiated by default.++Usage: $0 [OPTION]... [TAG]...++ -h, --help print this help, then exit+ -V, --version print version number and configuration settings, then exit+ --config print configuration, then exit+ -q, --quiet, --silent+ do not print progress messages+ -d, --debug don't remove temporary files+ --recheck update $as_me by reconfiguring in the same conditions+ --header=FILE[:TEMPLATE]+ instantiate the configuration header FILE++Configuration headers:+$config_headers++Report bugs to <deian@cs.stanford.edu>."++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1+ac_cs_config="`$as_echo "$ac_configure_args" | sed 's/^ //; s/[\\""\`\$]/\\\\&/g'`"+ac_cs_version="\\+Labeled IO library config.status 0.1.0+configured by $0, generated by GNU Autoconf 2.68,+ with options \\"\$ac_cs_config\\"++Copyright (C) 2010 Free Software Foundation, Inc.+This config.status script is free software; the Free Software Foundation+gives unlimited permission to copy, distribute and modify it."++ac_pwd='$ac_pwd'+srcdir='$srcdir'+test -n "\$AWK" || AWK=awk+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1+# The default lists apply if the user does not specify any file.+ac_need_defaults=:+while test $# != 0+do+ case $1 in+ --*=?*)+ ac_option=`expr "X$1" : 'X\([^=]*\)='`+ ac_optarg=`expr "X$1" : 'X[^=]*=\(.*\)'`+ ac_shift=:+ ;;+ --*=)+ ac_option=`expr "X$1" : 'X\([^=]*\)='`+ ac_optarg=+ ac_shift=:+ ;;+ *)+ ac_option=$1+ ac_optarg=$2+ ac_shift=shift+ ;;+ esac++ case $ac_option in+ # Handling of the options.+ -recheck | --recheck | --rechec | --reche | --rech | --rec | --re | --r)+ ac_cs_recheck=: ;;+ --version | --versio | --versi | --vers | --ver | --ve | --v | -V )+ $as_echo "$ac_cs_version"; exit ;;+ --config | --confi | --conf | --con | --co | --c )+ $as_echo "$ac_cs_config"; exit ;;+ --debug | --debu | --deb | --de | --d | -d )+ debug=: ;;+ --header | --heade | --head | --hea )+ $ac_shift+ case $ac_optarg in+ *\'*) ac_optarg=`$as_echo "$ac_optarg" | sed "s/'/'\\\\\\\\''/g"` ;;+ esac+ as_fn_append CONFIG_HEADERS " '$ac_optarg'"+ ac_need_defaults=false;;+ --he | --h)+ # Conflict between --help and --header+ as_fn_error $? "ambiguous option: \`$1'+Try \`$0 --help' for more information.";;+ --help | --hel | -h )+ $as_echo "$ac_cs_usage"; exit ;;+ -q | -quiet | --quiet | --quie | --qui | --qu | --q \+ | -silent | --silent | --silen | --sile | --sil | --si | --s)+ ac_cs_silent=: ;;++ # This is an error.+ -*) as_fn_error $? "unrecognized option: \`$1'+Try \`$0 --help' for more information." ;;++ *) as_fn_append ac_config_targets " $1"+ ac_need_defaults=false ;;++ esac+ shift+done++ac_configure_extra_args=++if $ac_cs_silent; then+ exec 6>/dev/null+ ac_configure_extra_args="$ac_configure_extra_args --silent"+fi++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1+if \$ac_cs_recheck; then+ set X '$SHELL' '$0' $ac_configure_args \$ac_configure_extra_args --no-create --no-recursion+ shift+ \$as_echo "running CONFIG_SHELL=$SHELL \$*" >&6+ CONFIG_SHELL='$SHELL'+ export CONFIG_SHELL+ exec "\$@"+fi++_ACEOF+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1+exec 5>>config.log+{+ echo+ sed 'h;s/./-/g;s/^.../## /;s/...$/ ##/;p;x;p;x' <<_ASBOX+## Running $as_me. ##+_ASBOX+ $as_echo "$ac_log"+} >&5++_ACEOF+cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1+_ACEOF++cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1++# Handling of arguments.+for ac_config_target in $ac_config_targets+do+ case $ac_config_target in+ "include/HsTmpConfig.h") CONFIG_HEADERS="$CONFIG_HEADERS include/HsTmpConfig.h" ;;++ *) as_fn_error $? "invalid argument: \`$ac_config_target'" "$LINENO" 5;;+ esac+done+++# If the user did not use the arguments to specify the items to instantiate,+# then the envvar interface is used. Set only those that are not.+# We use the long form for the default assignment because of an extremely+# bizarre bug on SunOS 4.1.3.+if $ac_need_defaults; then+ test "${CONFIG_HEADERS+set}" = set || CONFIG_HEADERS=$config_headers+fi++# Have a temporary directory for convenience. Make it in the build tree+# simply because there is no reason against having it here, and in addition,+# creating and moving files from /tmp can sometimes cause problems.+# Hook for its removal unless debugging.+# Note that there is a small window in which the directory will not be cleaned:+# after its creation but before its name has been assigned to `$tmp'.+$debug ||+{+ tmp= ac_tmp=+ trap 'exit_status=$?+ : "${ac_tmp:=$tmp}"+ { test ! -d "$ac_tmp" || rm -fr "$ac_tmp"; } && exit $exit_status+' 0+ trap 'as_fn_exit 1' 1 2 13 15+}+# Create a (secure) tmp directory for tmp files.++{+ tmp=`(umask 077 && mktemp -d "./confXXXXXX") 2>/dev/null` &&+ test -d "$tmp"+} ||+{+ tmp=./conf$$-$RANDOM+ (umask 077 && mkdir "$tmp")+} || as_fn_error $? "cannot create a temporary directory in ." "$LINENO" 5+ac_tmp=$tmp++# Set up the scripts for CONFIG_HEADERS section.+# No need to generate them if there are no CONFIG_HEADERS.+# This happens for instance with `./config.status Makefile'.+if test -n "$CONFIG_HEADERS"; then+cat >"$ac_tmp/defines.awk" <<\_ACAWK ||+BEGIN {+_ACEOF++# Transform confdefs.h into an awk script `defines.awk', embedded as+# here-document in config.status, that substitutes the proper values into+# config.h.in to produce config.h.++# Create a delimiter string that does not exist in confdefs.h, to ease+# handling of long lines.+ac_delim='%!_!# '+for ac_last_try in false false :; do+ ac_tt=`sed -n "/$ac_delim/p" confdefs.h`+ if test -z "$ac_tt"; then+ break+ elif $ac_last_try; then+ as_fn_error $? "could not make $CONFIG_HEADERS" "$LINENO" 5+ else+ ac_delim="$ac_delim!$ac_delim _$ac_delim!! "+ fi+done++# For the awk script, D is an array of macro values keyed by name,+# likewise P contains macro parameters if any. Preserve backslash+# newline sequences.++ac_word_re=[_$as_cr_Letters][_$as_cr_alnum]*+sed -n '+s/.\{148\}/&'"$ac_delim"'/g+t rset+:rset+s/^[ ]*#[ ]*define[ ][ ]*/ /+t def+d+:def+s/\\$//+t bsnl+s/["\\]/\\&/g+s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\+D["\1"]=" \3"/p+s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2"/p+d+:bsnl+s/["\\]/\\&/g+s/^ \('"$ac_word_re"'\)\(([^()]*)\)[ ]*\(.*\)/P["\1"]="\2"\+D["\1"]=" \3\\\\\\n"\\/p+t cont+s/^ \('"$ac_word_re"'\)[ ]*\(.*\)/D["\1"]=" \2\\\\\\n"\\/p+t cont+d+:cont+n+s/.\{148\}/&'"$ac_delim"'/g+t clear+:clear+s/\\$//+t bsnlc+s/["\\]/\\&/g; s/^/"/; s/$/"/p+d+:bsnlc+s/["\\]/\\&/g; s/^/"/; s/$/\\\\\\n"\\/p+b cont+' <confdefs.h | sed '+s/'"$ac_delim"'/"\\\+"/g' >>$CONFIG_STATUS || ac_write_fail=1++cat >>$CONFIG_STATUS <<_ACEOF || ac_write_fail=1+ for (key in D) D_is_set[key] = 1+ FS = ""+}+/^[\t ]*#[\t ]*(define|undef)[\t ]+$ac_word_re([\t (]|\$)/ {+ line = \$ 0+ split(line, arg, " ")+ if (arg[1] == "#") {+ defundef = arg[2]+ mac1 = arg[3]+ } else {+ defundef = substr(arg[1], 2)+ mac1 = arg[2]+ }+ split(mac1, mac2, "(") #)+ macro = mac2[1]+ prefix = substr(line, 1, index(line, defundef) - 1)+ if (D_is_set[macro]) {+ # Preserve the white space surrounding the "#".+ print prefix "define", macro P[macro] D[macro]+ next+ } else {+ # Replace #undef with comments. This is necessary, for example,+ # in the case of _POSIX_SOURCE, which is predefined and required+ # on some systems where configure will not decide to define it.+ if (defundef == "undef") {+ print "/*", prefix defundef, macro, "*/"+ next+ }+ }+}+{ print }+_ACAWK+_ACEOF+cat >>$CONFIG_STATUS <<\_ACEOF || ac_write_fail=1+ as_fn_error $? "could not setup config headers machinery" "$LINENO" 5+fi # test -n "$CONFIG_HEADERS"+++eval set X " :H $CONFIG_HEADERS "+shift+for ac_tag+do+ case $ac_tag in+ :[FHLC]) ac_mode=$ac_tag; continue;;+ esac+ case $ac_mode$ac_tag in+ :[FHL]*:*);;+ :L* | :C*:*) as_fn_error $? "invalid tag \`$ac_tag'" "$LINENO" 5;;+ :[FH]-) ac_tag=-:-;;+ :[FH]*) ac_tag=$ac_tag:$ac_tag.in;;+ esac+ ac_save_IFS=$IFS+ IFS=:+ set x $ac_tag+ IFS=$ac_save_IFS+ shift+ ac_file=$1+ shift++ case $ac_mode in+ :L) ac_source=$1;;+ :[FH])+ ac_file_inputs=+ for ac_f+ do+ case $ac_f in+ -) ac_f="$ac_tmp/stdin";;+ *) # Look for the file first in the build tree, then in the source tree+ # (if the path is not absolute). The absolute path cannot be DOS-style,+ # because $ac_f cannot contain `:'.+ test -f "$ac_f" ||+ case $ac_f in+ [\\/$]*) false;;+ *) test -f "$srcdir/$ac_f" && ac_f="$srcdir/$ac_f";;+ esac ||+ as_fn_error 1 "cannot find input file: \`$ac_f'" "$LINENO" 5;;+ esac+ case $ac_f in *\'*) ac_f=`$as_echo "$ac_f" | sed "s/'/'\\\\\\\\''/g"`;; esac+ as_fn_append ac_file_inputs " '$ac_f'"+ done++ # Let's still pretend it is `configure' which instantiates (i.e., don't+ # use $as_me), people would be surprised to read:+ # /* config.h. Generated by config.status. */+ configure_input='Generated from '`+ $as_echo "$*" | sed 's|^[^:]*/||;s|:[^:]*/|, |g'+ `' by configure.'+ if test x"$ac_file" != x-; then+ configure_input="$ac_file. $configure_input"+ { $as_echo "$as_me:${as_lineno-$LINENO}: creating $ac_file" >&5+$as_echo "$as_me: creating $ac_file" >&6;}+ fi+ # Neutralize special characters interpreted by sed in replacement strings.+ case $configure_input in #(+ *\&* | *\|* | *\\* )+ ac_sed_conf_input=`$as_echo "$configure_input" |+ sed 's/[\\\\&|]/\\\\&/g'`;; #(+ *) ac_sed_conf_input=$configure_input;;+ esac++ case $ac_tag in+ *:-:* | *:-) cat >"$ac_tmp/stdin" \+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5 ;;+ esac+ ;;+ esac++ ac_dir=`$as_dirname -- "$ac_file" ||+$as_expr X"$ac_file" : 'X\(.*[^/]\)//*[^/][^/]*/*$' \| \+ X"$ac_file" : 'X\(//\)[^/]' \| \+ X"$ac_file" : 'X\(//\)$' \| \+ X"$ac_file" : 'X\(/\)' \| . 2>/dev/null ||+$as_echo X"$ac_file" |+ sed '/^X\(.*[^/]\)\/\/*[^/][^/]*\/*$/{+ s//\1/+ q+ }+ /^X\(\/\/\)[^/].*/{+ s//\1/+ q+ }+ /^X\(\/\/\)$/{+ s//\1/+ q+ }+ /^X\(\/\).*/{+ s//\1/+ q+ }+ s/.*/./; q'`+ as_dir="$ac_dir"; as_fn_mkdir_p+ ac_builddir=.++case "$ac_dir" in+.) ac_dir_suffix= ac_top_builddir_sub=. ac_top_build_prefix= ;;+*)+ ac_dir_suffix=/`$as_echo "$ac_dir" | sed 's|^\.[\\/]||'`+ # A ".." for each directory in $ac_dir_suffix.+ ac_top_builddir_sub=`$as_echo "$ac_dir_suffix" | sed 's|/[^\\/]*|/..|g;s|/||'`+ case $ac_top_builddir_sub in+ "") ac_top_builddir_sub=. ac_top_build_prefix= ;;+ *) ac_top_build_prefix=$ac_top_builddir_sub/ ;;+ esac ;;+esac+ac_abs_top_builddir=$ac_pwd+ac_abs_builddir=$ac_pwd$ac_dir_suffix+# for backward compatibility:+ac_top_builddir=$ac_top_build_prefix++case $srcdir in+ .) # We are building in place.+ ac_srcdir=.+ ac_top_srcdir=$ac_top_builddir_sub+ ac_abs_top_srcdir=$ac_pwd ;;+ [\\/]* | ?:[\\/]* ) # Absolute name.+ ac_srcdir=$srcdir$ac_dir_suffix;+ ac_top_srcdir=$srcdir+ ac_abs_top_srcdir=$srcdir ;;+ *) # Relative name.+ ac_srcdir=$ac_top_build_prefix$srcdir$ac_dir_suffix+ ac_top_srcdir=$ac_top_build_prefix$srcdir+ ac_abs_top_srcdir=$ac_pwd/$srcdir ;;+esac+ac_abs_srcdir=$ac_abs_top_srcdir$ac_dir_suffix+++ case $ac_mode in++ :H)+ #+ # CONFIG_HEADER+ #+ if test x"$ac_file" != x-; then+ {+ $as_echo "/* $configure_input */" \+ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs"+ } >"$ac_tmp/config.h" \+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5+ if diff "$ac_file" "$ac_tmp/config.h" >/dev/null 2>&1; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: $ac_file is unchanged" >&5+$as_echo "$as_me: $ac_file is unchanged" >&6;}+ else+ rm -f "$ac_file"+ mv "$ac_tmp/config.h" "$ac_file" \+ || as_fn_error $? "could not create $ac_file" "$LINENO" 5+ fi+ else+ $as_echo "/* $configure_input */" \+ && eval '$AWK -f "$ac_tmp/defines.awk"' "$ac_file_inputs" \+ || as_fn_error $? "could not create -" "$LINENO" 5+ fi+ ;;+++ esac++done # for ac_tag+++as_fn_exit 0+_ACEOF+ac_clean_files=$ac_clean_files_save++test $ac_write_fail = 0 ||+ as_fn_error $? "write failure creating $CONFIG_STATUS" "$LINENO" 5+++# configure is writing to config.log, and then calls config.status.+# config.status does its own redirection, appending to config.log.+# Unfortunately, on DOS this fails, as config.log is still kept open+# by configure, so config.status won't be able to write to it; its+# output is simply discarded. So we exec the FD to /dev/null,+# effectively closing config.log, so it can be properly (re)opened and+# appended to by config.status. When coming back to configure, we+# need to make the FD available again.+if test "$no_create" != yes; then+ ac_cs_success=:+ ac_config_status_args=+ test "$silent" = yes &&+ ac_config_status_args="$ac_config_status_args --quiet"+ exec 5>/dev/null+ $SHELL $CONFIG_STATUS $ac_config_status_args || ac_cs_success=false+ exec 5>>config.log+ # Use ||, not &&, to avoid exiting from the if with $? = 1, which+ # would make configure fail if this is the last instruction.+ $ac_cs_success || as_fn_exit 1+fi+if test -n "$ac_unrecognized_opts" && test "$enable_option_checking" != no; then+ { $as_echo "$as_me:${as_lineno-$LINENO}: WARNING: unrecognized options: $ac_unrecognized_opts" >&5+$as_echo "$as_me: WARNING: unrecognized options: $ac_unrecognized_opts" >&2;}+fi+
+ configure.ac view
@@ -0,0 +1,13 @@+AC_INIT([Labeled IO library], [0.1.0], [deian@cs.stanford.edu], [lio])++# Safety check: Ensure that we are in the correct source directory.+AC_CONFIG_SRCDIR([include/HsTmp.h])++AC_PROG_CC++AC_CONFIG_HEADERS([include/HsTmpConfig.h])++# Temp functions+AC_CHECK_FUNCS([mkstemp mkstemps mkdtemp])++AC_OUTPUT
+ examples/LambdaChair/AliceCode.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif+module AliceCode ( mainReview ) where++import Safe++findPaper' s = do+ ep <- findPaper s+ case ep of+ Left e -> error $ "Failed with" ++ e+ Right p -> return p++mainReview = do+ p1 <- findPaper' "Flexible Dynamic"+ p2 <- findPaper' "A Static"++ readPaper p1++ appendToReview p1 "Interesting work!"++ readPaper p2+ readReview p2+ appendToReview p2 "What about adding new users?"
+ examples/LambdaChair/BobCode.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Safe #-}+#endif+module BobCode ( mainReview ) where++import Safe++findPaper' s = do+ ep <- findPaper s+ case ep of+ Left e -> error $ "Failed with" ++ e+ Right p -> return p++mainReview = do+ p1 <- findPaper' "Flexible Dynamic..."+ p2 <- findPaper' "A Static..."+ appendToReview p2 "Hmm, IFC.."+ readReview p2+ readReview p1
+ examples/LambdaChair/LambdaChair.hs view
@@ -0,0 +1,420 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ScopedTypeVariables #-}+module LambdaChair ( evalReviewDC+ , addUser+ , addPaper+ , addConflict+ , addAssignment+ , asUser+ ---+ , findPaper+ , retrievePaper, readPaper+ , retrieveReview, readReview+ , appendToReview+ , reviewDCPutStrLn + -- TCB+ , printUsersTCB+ , printReviewsTCB+ , reviewDCPutStrLnTCB + , dcPutStrLnTCB + ) where++import Prelude hiding (catch)+import Control.Monad+import Control.Exception (SomeException, ErrorCall(..))+import Control.Monad.State+import Data.Maybe+import Data.List+import Data.Monoid++import LIO.TCB+import LIO.LIORef+import LIO.LIORef.TCB (readLIORefTCB)+import LIO.MonadLIO+import LIO.MonadCatch (throwIO)+import LIO.DCLabel hiding (name)+import DCLabel.Safe hiding (name)+import DCLabel.TCB (Disj(..), Conj(..), Component(..))+import DCLabel.PrettyShow++import qualified Data.ByteString.Char8 as C+++type ErrorStr = String+type DCLabeled = Labeled DCLabel+type DCRef = LIORef DCLabel++-- ^ Clss to with sideffectful show+class DCShowTCB s where+ dcShowTCB :: s -> DC String++dcPutStrLnTCB :: String -> DC ()+dcPutStrLnTCB = ioTCB . putStrLn++dcGetLineTCB :: DC String+dcGetLineTCB = ioTCB getLine++type Name = String+type Password = String+type Content = String+type Reviews = String++type Id = Int+data Paper = Paper Content+data Review = Review Content++data User = User { name :: Name+ , password :: Password+ , conflicts :: [Id]+ , assignments :: [Id] }++instance Eq User where+ u1 == u2 = name u1 == name u2++instance DCShowTCB User where+ dcShowTCB u = do+ return $ "Name: " ++ (name u) ++ "\n"+ ++ "Password: " ++ (password u) ++ "\n"+ ++ "Conflicts: " ++ (show . conflicts $ u) ++ "\n"+ ++ "Assignments: " ++ (show . assignments $ u)++data ReviewEnt = ReviewEnt { paperId :: Id+ , paper :: DCRef Paper+ , review :: DCRef Review }++instance Eq ReviewEnt where+ r1 == r2 = paperId r1 == paperId r2++instance DCShowTCB ReviewEnt where+ dcShowTCB r = do+ (Paper pap) <- readLIORefTCB (paper r)+ (Review rev) <- readLIORefTCB (review r)+ return $ "ID:" ++ (show . paperId $ r)+ ++ "\nPaper:" ++ pap+ ++ "\nReviews:" ++ rev+++-- State related+data ReviewState = ReviewState { users :: [User]+ , reviewEntries :: [ReviewEnt]+ , curUser :: Maybe Name }++emptyReviewState :: ReviewState+emptyReviewState = ReviewState [] [] Nothing++newtype ReviewDC a = ReviewDC (StateT ReviewState DC a)+ deriving (Monad)++liftReviewDC :: DC a -> ReviewDC a+liftReviewDC = ReviewDC . liftLIO++get' :: ReviewDC ReviewState+get' = ReviewDC . StateT $ \s -> return (s,s)++put' :: ReviewState -> ReviewDC ()+put' s = ReviewDC . StateT $ \_ -> return ((),s)++runReviewDC :: ReviewDC a -> ReviewState -> DC (a, ReviewState)+runReviewDC (ReviewDC m) s = runStateT m s++evalReviewDC :: ReviewDC a -> IO (a, DCLabel)+evalReviewDC m = evalDC $ do+ (a, s') <- runReviewDC m emptyReviewState+ return a+--++-- ^ Get all users+getUsers :: ReviewDC [User]+getUsers = get' >>= return . users++-- ^ Get all review entries+getReviews :: ReviewDC [ReviewEnt]+getReviews = get' >>= return . reviewEntries++-- ^ Get priviliges+getCurUserName :: ReviewDC (Maybe Name)+getCurUserName = get' >>= return . curUser++-- ^ Get curren tuser name+getCurUser :: ReviewDC (Maybe User)+getCurUser = do+ n <- getCurUserName+ maybe (return Nothing) findUser n++-- ^ Get priviliges+getPrivs :: ReviewDC DCPrivTCB+getPrivs = do + u <- getCurUser+ return $ maybe mempty (genPrivTCB . name) u++-- ^ Write new users+putUsers :: [User] -> ReviewDC ()+putUsers us = do+ rs <- getReviews+ u <- getCurUserName+ put' $ ReviewState us rs u++-- ^ Write new reviews+putReviews :: [ReviewEnt] -> ReviewDC ()+putReviews rs = do+ us <- getUsers+ u <- getCurUserName+ put' $ ReviewState us rs u++-- ^ Write new privs+putCurUserName :: Name -> ReviewDC ()+putCurUserName u = do+ us <- getUsers+ rs <- getReviews+ put' $ ReviewState us rs (Just u)++-- ^ Clear user naem+clearCurUserName :: ReviewDC ()+clearCurUserName = do+ us <- getUsers+ rs <- getReviews+ put' $ ReviewState us rs Nothing++-- ^ Find review entry by id+findReview :: Id -> ReviewDC (Maybe ReviewEnt)+findReview pId = do+ reviews <- getReviews+ return $ find (\e -> paperId e == pId) reviews++-- ^ Find user by name+findUser :: Name -> ReviewDC (Maybe User)+findUser n = do+ users <- getUsers+ return $ find (\u -> name u == n) users ++-- ^ Add new (fresh) user+addUser :: Name -> Password -> ReviewDC ()+addUser n p = do+ u <- findUser n+ unless (isJust u) $ do+ let newUser = User { name = n+ , password = p+ , conflicts = []+ , assignments = [] }+ us <- getUsers+ putUsers (newUser:us)++-- ^ Add conflicting paper to user+addConflict :: Name -> Id -> ReviewDC ()+addConflict n i = do+ usr <- findUser n+ pap <- findReview i+ case (usr, pap) of+ (Just u, Just _) -> + if i `elem` (assignments u)+ then return ()+ else do let u' = u { conflicts = i : (conflicts u)}+ usrs <- getUsers+ putUsers $ u' : (filter (/= u) usrs)+ _ -> return ()++-- ^ Assign a paper for the user to review+addAssignment :: Name -> Id -> ReviewDC ()+addAssignment n i = do+ usr <- findUser n+ pap <- findReview i+ case (usr, pap) of+ (Just u, Just _) -> + if i `elem` (conflicts u)+ then return ()+ else do let u' = u { assignments = i : (assignments u)}+ usrs <- getUsers+ putUsers $ u' : (filter (/= u) usrs)+ _ -> return ()++-- ^ Print users+printUsersTCB :: ReviewDC ()+printUsersTCB = do+ users <- getUsers+ mapM (liftReviewDC . dcShowTCB) users >>=+ reviewDCPutStrLnTCB . (intercalate "\n--\n")++-- ^ Print papers and reviews+printReviewsTCB :: ReviewDC ()+printReviewsTCB = do+ reviews <- getReviews+ mapM (liftReviewDC . dcShowTCB) reviews >>=+ reviewDCPutStrLnTCB . (intercalate "\n--\n")++-- | Generate privilege from a string+genPrivTCB :: NewPriv a => a -> DCPrivTCB+genPrivTCB = mintTCB . newPriv ++-- ^ Create new paper given id and content+newReviewEnt :: Id -> Content -> ReviewDC ReviewEnt+newReviewEnt pId content = do+ let p1 = "Paper" ++ (show pId)+ r1 = "Review" ++ (show pId)+ pLabel = newDC (<>) p1 + rLabel = newDC r1 r1 + privs = genPrivTCB (p1 ./\. r1)+ liftReviewDC $ do+ rPaper <- newLIORefP privs pLabel (Paper content)+ rReview <- newLIORefP privs rLabel (Review "")+ return $ ReviewEnt pId rPaper rReview++-- ^ Adda new paper to be reviewed+addPaper :: Content -> ReviewDC Id+addPaper content = do+ reviews <- getReviews+ let pId = 1 + (length reviews)+ ent <- newReviewEnt pId content+ putReviews (ent:reviews)+ return pId+++-- ^ Given a paper number return the paper+retrievePaper :: Id -> ReviewDC (Either ErrorStr Content)+retrievePaper pId = do+ mu <- getCurUser+ case mu of+ Nothing -> return $ Left "Need to be logged in"+ Just u -> do+ mRev <- findReview pId + case mRev of + Nothing -> return $ Left "Invalid Id"+ Just rev -> let as = assignments u+ priv = genPrivTCB (listToComponent $ map id2cat as)+ in doReadPaper priv rev+ where doReadPaper priv rev = liftReviewDC $ do+ (Paper lPaper) <- readLIORefP priv (paper rev)+ return (Right lPaper)+ id2cat i = MkDisj [principal . C.pack $ "Review"++(show i)]++-- ^ Given a paper number print the paper+-- NOTE: in the paper, the functionality of @readPaper@ corresponds to+-- that of @retrievePaper@; here, we print out the content.+readPaper :: Id -> ReviewDC ()+readPaper i = retrievePaper i >>= \r -> reviewDCPutStrLn $ show r+++-- ^ Given a paper/review number return the review, if the entry exists+retrieveReview :: Id -> ReviewDC (Either ErrorStr Content)+retrieveReview pId = do+ mRev <- findReview pId + case mRev of + Nothing -> return $ Left "Invalid Id"+ Just rev -> do mu <- getCurUser+ case mu of+ Nothing -> return $ Left "Must login first"+ Just u -> doReadReview rev+ where doReadReview rev = liftReviewDC $ do+ (Review r) <- readLIORef (review rev)+ return (Right r)++-- ^ Given a paper/review number print the review, if the entry exists+readReview :: Id -> ReviewDC ()+readReview i = retrieveReview i >>= \r -> reviewDCPutStrLn $ show r++-- ^ Computer the label of the output' channel+getOutputChLbl :: ReviewDC (DCLabel) +getOutputChLbl = do+ mu <- getCurUser+ case mu of+ Nothing -> liftReviewDC $ throwIO (ErrorCall "No user is logged in.")+ Just u -> do+ as <- getReviews >>= return . map paperId -- all reviews+ let cs = conflicts u -- conflicting reviews+ c_cat = map id2conf_cat (cs) -- conflicting categories+ nc_cat = map id2cat (as \\ cs) -- noconflicting categories+ return $ newDC (listToComponent $ c_cat ++ nc_cat) (<>)+ where id2cat i = MkDisj [ principal . C.pack $ "Review"++(show i)]+ id2conf_cat i = MkDisj [ principal . C.pack $ "Review" ++ (show i)+ , principal $ "CONFLICT" ]+ +-- ^ Print if the current label flows to the output channel label, i.e.,+-- there is no conflict of interest.+dcPutStrLn :: DCLabel -> Content -> DC ()+dcPutStrLn lo cont = do+ l <- getLabel+ if l `leq` lo+ then dcPutStrLnTCB cont+ else throwIO . ErrorCall $ "Trying to print conflicting review:\n" +++ (prettyShow l) ++ " [/= " ++ (prettyShow lo)++-- ^ Main printing function. Print to a labeled output channel.+reviewDCPutStrLn :: String -> ReviewDC ()+reviewDCPutStrLn s = do + l <- getOutputChLbl+ liftReviewDC $ dcPutStrLn l $ "-> "++ s++reviewDCPutStrLnTCB :: String -> ReviewDC ()+reviewDCPutStrLnTCB = liftReviewDC . dcPutStrLnTCB++-- ^ Given a paper number and review content append to the current review.+appendToReview :: Id -> Content -> ReviewDC (Either ErrorStr ())+appendToReview pId content = do+ mRev <- findReview pId + case mRev of + Nothing -> return $ Left "Invalid Id"+ Just rev -> do privs <- getPrivs+ doWriteReview privs rev content+ return $ Right ()+ where doWriteReview privs rev content = liftReviewDC $ do+ toLabeledP privs ltop $ do+ (Review rs) <- readLIORef (review rev)+ -- restrict writes: + writeLIORef (review rev) (Review (rs++content))++-- ^ Set the current label to the assignments+assign2curLabel :: [Id] -> ReviewDC() +assign2curLabel as = liftReviewDC $ do+ let l = newDC (<>) (listToComponent $ map id2cat as)+ setLabelTCB l+ where id2cat i = MkDisj [principal . C.pack $ "Review"++(show i)]+ +-- ^ Safely execute untrusted code+safeExecTCB :: ReviewDC () -> ReviewDC ()+safeExecTCB m = do+ s <- get'+ s' <- liftReviewDC $ do+ cc <- getClearance+ cl <- getLabel+ (_, s') <- (runReviewDC m s) `catch` + (\(e::SomeException) -> do+ dcPutStrLnTCB "-> ERROR: IFC violated\n"+ return ((), s))+ lowerClrTCB cc+ setLabelTCB cl+ return s'+ put' s'++-- ^ Execute on behalf of user+asUser :: Name -> ReviewDC a -> ReviewDC ()+asUser n m = do+ putCurUserName n+ mu <- getCurUser+ case mu of+ Nothing -> return ()+ Just u -> do+ reviewDCPutStrLnTCB $ "| Hi, "++ (name u)++".\n| Password>"+ p <- liftReviewDC dcGetLineTCB+ if p /= (password u)+ then reviewDCPutStrLnTCB "| Failed, try again" >> asUser n m+ else do+ reviewDCPutStrLnTCB $ "| Executing on behalf of "++(name u)++"...\n"+ safeExecTCB $ assign2curLabel (assignments u) >> m >> return ()+ clearCurUserName++-- | Given a paper prefix return either an error string, if the paper cannot be+-- found or the paper id.+findPaper :: String -> ReviewDC (Either ErrorStr Id)+findPaper s = do+ revs <- getReviews+ res <- mapM (simpleMatch s) revs >>= return . find isJust+ case res of+ Nothing -> return . Left $ "Could not find paper"+ Just i -> return . Right $ fromJust i+ -- ^ Fing paper by checking for prefix+ where simpleMatch :: String -> ReviewEnt -> ReviewDC (Maybe Id)+ simpleMatch s ent = do+ (Paper pap) <- liftReviewDC $ readLIORefTCB (paper ent)+ if s `isPrefixOf` pap+ then return . Just $ paperId ent+ else return Nothing
+ examples/LambdaChair/Main.hs view
@@ -0,0 +1,35 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE SafeImports #-}+#endif+import LambdaChair+import DCLabel.PrettyShow++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+import safe AliceCode as Alice+import safe BobCode as Bob+#else+import AliceCode as Alice+import BobCode as Bob+#endif+++main :: IO ()+main = printL . evalReviewDC $ do+ addUser "Alice" "password"+ + p1 <- addPaper "Flexible Dynamic..."+ p2 <- addPaper "A Static..."+ + addAssignment "Alice" p1+ addAssignment "Alice" p2+ + asUser "Alice" $ Alice.mainReview+ + addUser "Bob" "password"+ + addAssignment "Bob" p2+ addConflict "Bob" p1++ asUser "Bob" $ Bob.mainReview+ where printL m = m >>= (putStrLn . prettyShow . snd)
+ examples/LambdaChair/Safe.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE CPP #-}+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 702)+{-# LANGUAGE Trustworthy #-}+#endif+module Safe ( module LambdaChair ) where+import LambdaChair ( findPaper+ , retrievePaper, readPaper+ , retrieveReview, readReview+ , appendToReview+ , reviewDCPutStrLn )
+ examples/fsExample.hs view
@@ -0,0 +1,129 @@+{-# LANGUAGE ScopedTypeVariables #-}++import Prelude hiding (catch)+import System.FilePath+import Data.Functor ((<$>))+import Data.Serialize+++import Control.Exception (SomeException)+import LIO+import LIO.MonadCatch+import LIO.TCB (ioTCB, setLabelTCB, lowerClrTCB)+import LIO.DCLabel+import LIO.Handle+import DCLabel.PrettyShow+import DCLabel.Core (createPrivTCB)++import Control.Monad+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as LC++lpub :: DCLabel+lpub = newDC (<>) (<>)++dcEvalWithRoot :: FilePath -> DC a -> IO (a, DCLabel)+dcEvalWithRoot path act = evalWithRoot path (Just lpub) act ()+++-- Enable malicious code:+malicious :: Bool+malicious = False++--+-- Labels and privileges+--++lalice, lbob, lbobOralice :: DCLabel+lalice = newDC "alice" "alice"+lbob = newDC "bob" "bob"+lclarice = newDC "clarice" "clarice"+lbobOralice = newDC ("bob" .\/. "alice") ("bob" .\/. "alice")++palice, pbob, pclarice :: DCPrivTCB+pbob = createPrivTCB $ newPriv "bob"+palice = createPrivTCB $ newPriv "alice"+pclarice = createPrivTCB $ newPriv "clarice"+++main = ignore $ dcEvalWithRoot "/tmp/rootFS" $ do+ exec bobsCode pbob (newDC "bob" (<>)) "bob"+ exec alicesCode palice (newDC "alice" (<>)) "alice"+ exec claricesCode pclarice (newDC "clairce" (<>)) "clarice"+ where exec act p l s = do setLabelTCB lbot+ lowerClrTCB ltop+ putStrLnTCB $ ">Executing for " ++ s ++ ":"+ catch (withClearance l $ setLabelTCB lpub >>+ act p)+ (\(e::SomeException) ->+ putStrLnTCB "IFC violation attempt!")+ printCurLabel $ ">" ++ s+ ignore act = act >> return ()+++printCurLabel s = do l <- getLabel + c <- getClearance+ ioTCB . putStrLn $ s ++ " : " ++ (prettyShow l)+ ++ " : " ++ (prettyShow c)++--+-- Bob's code:+--++bobsCode :: DCPrivTCB -> DC ()+bobsCode p = do+ discard_ $ createDirectoryP p lbobOralice "bobOralice"+ discard_ $ createDirectoryP p lbob ("bobOralice" </> "bob")+ -- Write alice a message:+ h <- openFileP p (Just lbobOralice) ("bobOralice" </> "messages") AppendMode+ hPutStrLnP p h (LC.pack "Hi Alice!")+ hCloseP p h+ -- Write secret:+ taint lbob -- writeFileP uses current label to label file+ writeFileP p ("bobOralice" </> "bob" </> "secret")+ (LC.pack "I am Chuck Norris!")++--+-- Alice's code:+-- +alicesCode :: DCPrivTCB -> DC ()+alicesCode p = do+ when malicious malCode + discard_ $ createDirectoryP p lbobOralice "bobOralice"+ discard_ $ createDirectoryP p lalice ("bobOralice" </> "alice")+ files <- getDirectoryContentsP p "bobOralice"+ if "messages" `elem` files+ then do msg <- readFileP p ("bobOralice" </> "messages")+ putStrLnTCB $ "Message log:\n" ++ (LC.unpack msg)+ else writeFileLP p lbobOralice ("bobOralice" </> "messages")+ (LC.pack "Hello Bob!")+ where malCode = do+ msg <- readFileP p ("bobOralice" </> "bob" </> "secret")+ putStrLnTCB $ "Bob's secret:\n" ++ (LC.unpack msg)+ +++--+-- Clarice's malicious code:+--++claricesCode :: DCPrivTCB -> DC ()+claricesCode p = do+ discard_ $ createDirectoryP p lclarice "clarice"+ when malicious $ do+ files <- getDirectoryContentsP p "bobOralice"+ forM_ files $ \f -> putStrLnTCB f+++--+-- Misc helper functions+-- ++discard_ :: DC a -> DC ()+discard_ act = do+ c <- getClearance+ catch (discard c act) (\(e::SomeException) -> return ())+++putStrLnTCB :: String -> DC ()+putStrLnTCB s = ioTCB $ putStrLn s
+ examples/maskExample.hs view
@@ -0,0 +1,19 @@+import LIO.TCB+import LIO.DCLabel+import DCLabel.Safe+import Control.Concurrent+import Control.Monad+++main = do+ tid <- forkIO $ do+ _ <- evalDC $ + mask $ \restore -> do+ forM_ [1..10000] (ioTCB . print)+ ioTCB . putStrLn $ "bye!"+ restore (return ())+ ioTCB . putStrLn $ "DONE!"+ return ()+ threadDelay 100000+ throwTo tid (userError "WOO")+
+ examples/waitAndCatch.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE ScopedTypeVariables #-}+import Prelude hiding (catch)+import LIO+import LIO.TCB (ioTCB)+import LIO.MonadCatch+import LIO.DCLabel+import LIO.Concurrent+import DCLabel.PrettyShow+++l,m,h :: DCLabel+l = lbot+m = newDC "M" (<>)+h = ltop++main = do+ (_,l) <- evalDC $ do+ lb <- label m 6+ f <- lFork l $ do+ v <- unlabel lb+ return (3+v)+ catch (do r <- lWait f+ ioTCB . print $ r + ) (\(e::LabelFault) -> ioTCB . putStrLn $ "exception")+ print . pShow $ l
+ include/HsTmp.h view
@@ -0,0 +1,22 @@+#ifndef HSTMP_H+#define HSTMP_H++#include "HsTmpConfig.h"++#include <stdlib.h>+#include <stdio.h>+++#if HAVE_MKSTEMP+int __hscore_mkstemp(char *filetemplate);+#endif++#if HAVE_MKSTEMPS+int __hscore_mkstemps(char *filetemplate, int suffixlen);+#endif++#if HAVE_MKDTEMP+char *__hscore_mkdtemp(char *filetemplate);+#endif++#endif
+ include/HsTmpConfig.h view
@@ -0,0 +1,29 @@+/* include/HsTmpConfig.h. Generated from HsTmpConfig.h.in by configure. */+/* include/HsTmpConfig.h.in. Generated from configure.ac by autoheader. */++/* Define to 1 if you have the `mkdtemp' function. */+#define HAVE_MKDTEMP 1++/* Define to 1 if you have the `mkstemp' function. */+#define HAVE_MKSTEMP 1++/* Define to 1 if you have the `mkstemps' function. */+#define HAVE_MKSTEMPS 1++/* Define to the address where bug reports for this package should be sent. */+#define PACKAGE_BUGREPORT "deian@cs.stanford.edu"++/* Define to the full name of this package. */+#define PACKAGE_NAME "Labeled IO library"++/* Define to the full name and version of this package. */+#define PACKAGE_STRING "Labeled IO library 0.1.0"++/* Define to the one symbol short name of this package. */+#define PACKAGE_TARNAME "lio"++/* Define to the home page for this package. */+#define PACKAGE_URL ""++/* Define to the version of this package. */+#define PACKAGE_VERSION "0.1.0"
+ include/HsTmpConfig.h.in view
@@ -0,0 +1,28 @@+/* include/HsTmpConfig.h.in. Generated from configure.ac by autoheader. */++/* Define to 1 if you have the `mkdtemp' function. */+#undef HAVE_MKDTEMP++/* Define to 1 if you have the `mkstemp' function. */+#undef HAVE_MKSTEMP++/* Define to 1 if you have the `mkstemps' function. */+#undef HAVE_MKSTEMPS++/* Define to the address where bug reports for this package should be sent. */+#undef PACKAGE_BUGREPORT++/* Define to the full name of this package. */+#undef PACKAGE_NAME++/* Define to the full name and version of this package. */+#undef PACKAGE_STRING++/* Define to the one symbol short name of this package. */+#undef PACKAGE_TARNAME++/* Define to the home page for this package. */+#undef PACKAGE_URL++/* Define to the version of this package. */+#undef PACKAGE_VERSION
lio.cabal view
@@ -1,5 +1,5 @@ Name: lio-Version: 0.0.2+Version: 0.1.0 build-type: Simple License: GPL License-File: LICENSE@@ -8,19 +8,10 @@ Stability: experimental Synopsis: Labeled IO Information Flow Control Library Category: Security-Cabal-Version: >= 1.6--Extra-source-files:- Examples/LambdaChair/AliceCode.hs- Examples/LambdaChair/BobCode.hs- Examples/LambdaChair/LambdaChair.hs- Examples/LambdaChair/Main.hs- Examples/LambdaChair/Safe.hs- Description: The /Labeled IO/ (LIO) library provides information flow control for incorporating untrusted code within Haskell- applications. Most code should import module "LIO.LIO" and+ applications. Most code should import module "LIO" and whichever label type the application is using (e.g., "LIO.DCLabel"). The core functionality of the library is documented in "LIO.TCB". LIO was implemented by David@@ -36,11 +27,29 @@ The library depends on the @DCLabel@ module. You can read more on DC Labels here: <http://www.scs.stanford.edu/~deian/dclabels/>.+Cabal-Version: >= 1.6 +Build-Type: Configure+Extra-source-files:+ examples/LambdaChair/AliceCode.hs+ examples/LambdaChair/BobCode.hs+ examples/LambdaChair/LambdaChair.hs+ examples/LambdaChair/Main.hs+ examples/LambdaChair/Safe.hs+ examples/fsExample.hs+ examples/maskExample.hs+ examples/waitAndCatch.hs+ configure.ac+ configure+ include/HsTmpConfig.h.in+Extra-Tmp-Files:+ include/HsTmpConfig.h+ Source-repository head Type: git Location: http://www.scs.stanford.edu/~deian/lio.git + Library Build-Depends: base >= 4 && < 5, array >= 0.2 && < 1,@@ -50,24 +59,40 @@ filepath >= 1.1 && < 2, mtl >= 1.1.0.2 && < 3, old-time >= 1 && < 2,- unix >= 2.3 && < 3,+ unix >= 2.5.0.0 && < 3, SHA >= 1.4.1.1 && < 2, time >= 1.1.4 && < 2,- dclabel >= 0.0.1 && < 2+ dclabel >= 0.0.4 && < 2,+ cereal >= 0.3.3 && < 0.4,+ base64-bytestring >= 0.1.0.4 - ghc-options: -Wall+ ghc-options: -Wall -fno-warn-orphans+ Exposed-modules:- LIO.Armor,- LIO.Base,+ -- Core:+ LIO,+ LIO.Safe,+ LIO.TCB,+ LIO.MonadCatch,+ LIO.MonadLIO,+ -- Label formats: LIO.DCLabel,- LIO.FS,- LIO.Handle,- LIO.HiStar,- LIO.LIO,+ -- References: LIO.LIORef, LIO.LIORef.TCB, LIO.LIORef.Safe,- LIO.MonadCatch,- LIO.MonadLIO,- LIO.TCB,- LIO.TmpFile+ -- Concurrency:+ LIO.Concurrent,+ LIO.Concurrent.LMVar,+ LIO.Concurrent.LMVar.Safe,+ LIO.Concurrent.LMVar.TCB,+ -- Filesystem:+ LIO.FS,+ LIO.Handle+ if impl(ghc < 7.6)+ Other-Modules:+ System.Posix.Tmp+ Include-Dirs: include+ Includes: HsTmp.h+ Install-Includes: HsTmp.h HsTmpConfig.h+ C-Sources: cbits/HsTmp.c