diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,28 @@ +Copyright (c) Sebastiaan Visser 2009 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: +1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. +2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. +3. Neither the name of the author nor the names of his contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND +ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE +IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE +FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS +OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) +HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY +OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF +SUCH DAMAGE. + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#! /usr/bin/env runhaskell + +>import Distribution.Simple + +>main = defaultMain + diff --git a/jail.cabal b/jail.cabal new file mode 100644 --- /dev/null +++ b/jail.cabal @@ -0,0 +1,75 @@ +Name: jail +Version: 0.0.1 +Description: + + Like all of us know, the IO monad from the System.IO module + is a wild beast allowing all forms of insecure computations + that can read, or even worse, alter /the real world/. Writing + to sockets, deleting files or even launching missiles, its + possibilities are endless. This library provides a special + IO module that wraps all file and handle based IO operations + from the System.IO module, but provides a possibility to run + them in an restricted environment. When running a jailed IO + computation a file path can be specified all IO operations + will be checked against. Accessing files outside this + directory is not allowed and results in a runtime error. + Additionally, when running a jailed IO computation a + whitelist of file handles can be specified that are + accessible as well. + . + + For example, running some code with the permission to access + all files within (and only within) my home directory and + allowing to access the standard output and standard error can + be enforced like this: + . + + > Jail.run (Just "/home/sebas") [stdout, stderr] yourUntrustworthyComputation + . + + Only allowing the code to access the standard input and + nothing else can be enforced like this: + . + + > Jail.run Nothing [stdin] yourEvenMoreUntrustworthyComputation + . + + Because the jailed IO environment keeps track of all file + handles and checks that are opened by its own operations, + smuggling in evil file handles from the fierce and dangerous + outside world will be punished by border patrol. Only handles + from the whitelist or handles securely opened by functions + like `openFile' will be accepted. Because of the opaque IO + constructor and the restricted set of exported operations + this module is not easily fooled. + . + + I would almost dare to say this module is conceptually safe + and code with the jailed IO type can blindly be trusted. + Except, yes unfortunately except, @unsafePerformIO@ ruins it + all. I would almost suggest adding a flag to the compiler to + enforce the absence of @unsafeRuinMyTypeSafety@-alike + functions in order to be able to create systems in which code + can be trusted by its type alone. + . + Nonetheless, this module is one step forward in trusting your + own programs. Some real + prefer writing there software in one of the most insecure + programming languages and perform security audits by hand, + I'd rather have my compiler do the job. (Anyone who wants to + audit this library is more than welcome!) + +Synopsis: Jailed IO monad. +Category: System, Security +Cabal-Version: >= 1.6 +License: BSD3 +License-file: LICENSE +Author: Sebastiaan Visser +Maintainer: sfvisser@cs.uu.nl +Build-Type: Simple +Build-Depends: base >= 3 && <= 5, containers ==0.2.*, directory ==1.0.*, monads-fd ==0.0.*, transformers ==0.1.* + +GHC-Options: -Wall +HS-Source-Dirs: src +Exposed-modules: System.IO.Jail + diff --git a/src/System/IO/Jail.hs b/src/System/IO/Jail.hs new file mode 100644 --- /dev/null +++ b/src/System/IO/Jail.hs @@ -0,0 +1,495 @@ +{-# LANGUAGE CPP, GeneralizedNewtypeDeriving, DeriveDataTypeable #-} +module System.IO.Jail + ( -- * The IO monad + + IO, -- instance MonadFix + run, + JailIO (..), + + -- * Files and handles + + FilePath, -- :: String + + Handle, -- abstract, instance of: Eq, Show. + + -- | Three handles are allocated during program initialisation, + -- and are initially open. + + stdin, stdout, stderr, -- :: Handle + + -- * Opening and closing files + + -- ** Opening files + + withFile, + openFile, -- :: FilePath -> IOMode -> IO Handle + IOMode(ReadMode,WriteMode,AppendMode,ReadWriteMode), + + -- ** Closing files + + hClose, -- :: Handle -> IO () + + -- ** Special cases + + readFile, -- :: FilePath -> IO String + writeFile, -- :: FilePath -> String -> IO () + appendFile, -- :: FilePath -> String -> IO () + + -- ** File locking + + -- $locking + + -- * Operations on handles + + -- ** Determining and changing the size of a file + + hFileSize, -- :: Handle -> IO Integer + +#ifdef __GLASGOW_HASKELL__ + hSetFileSize, -- :: Handle -> Integer -> IO () +#endif + + -- ** Detecting the end of input + + hIsEOF, -- :: Handle -> IO Bool + isEOF, -- :: IO Bool + + -- ** Buffering operations + + BufferMode(NoBuffering,LineBuffering,BlockBuffering), + hSetBuffering, -- :: Handle -> BufferMode -> IO () + hGetBuffering, -- :: Handle -> IO BufferMode + hFlush, -- :: Handle -> IO () + + -- ** Repositioning handles + + hGetPosn, -- :: Handle -> IO HandlePosn + hSetPosn, -- :: HandlePosn -> IO () + HandlePosn, -- abstract, instance of: Eq, Show. + + hSeek, -- :: Handle -> SeekMode -> Integer -> IO () + SeekMode(AbsoluteSeek,RelativeSeek,SeekFromEnd), + +#if !defined(__NHC__) + hTell, -- :: Handle -> IO Integer +#endif + + -- ** Handle properties + + hIsOpen, hIsClosed, -- :: Handle -> IO Bool + hIsReadable, hIsWritable, -- :: Handle -> IO Bool + hIsSeekable, -- :: Handle -> IO Bool + + -- ** Terminal operations (not portable: GHC\/Hugs only) + +#if !defined(__NHC__) + hIsTerminalDevice, -- :: Handle -> IO Bool + + hSetEcho, -- :: Handle -> Bool -> IO () + hGetEcho, -- :: Handle -> IO Bool +#endif + + -- ** Showing handle state (not portable: GHC only) + +#ifdef __GLASGOW_HASKELL__ + hShow, -- :: Handle -> IO String +#endif + + -- * Text input and output + + -- ** Text input + + hWaitForInput, -- :: Handle -> Int -> IO Bool + hReady, -- :: Handle -> IO Bool + hGetChar, -- :: Handle -> IO Char + hGetLine, -- :: Handle -> IO [Char] + hLookAhead, -- :: Handle -> IO Char + hGetContents, -- :: Handle -> IO [Char] + + -- ** Text output + + hPutChar, -- :: Handle -> Char -> IO () + hPutStr, -- :: Handle -> [Char] -> IO () + hPutStrLn, -- :: Handle -> [Char] -> IO () + hPrint, -- :: Show a => Handle -> a -> IO () + + -- ** Special cases for standard input and output + + interact, -- :: (String -> String) -> IO () + putChar, -- :: Char -> IO () + putStr, -- :: String -> IO () + putStrLn, -- :: String -> IO () + print, -- :: Show a => a -> IO () + getChar, -- :: IO Char + getLine, -- :: IO String + getContents, -- :: IO String + readIO, -- :: Read a => String -> IO a + readLn, -- :: Read a => IO a + + -- * Binary input and output + + withBinaryFile, + openBinaryFile, -- :: FilePath -> IOMode -> IO Handle + hSetBinaryMode, -- :: Handle -> Bool -> IO () + hPutBuf, -- :: Handle -> Ptr a -> Int -> IO () + hGetBuf, -- :: Handle -> Ptr a -> Int -> IO Int + +#if !defined(__NHC__) && !defined(__HUGS__) + hPutBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int + hGetBufNonBlocking, -- :: Handle -> Ptr a -> Int -> IO Int +#endif + + -- * Temporary files + + openTempFile, + openBinaryTempFile, + ) +where + +import Control.Applicative +import Control.Monad.Cont +import Control.Monad.Error +import Control.Monad.Trans.Identity +import Control.Monad.List +import Control.Monad.RWS +import Control.Monad.Reader +import Control.Monad.State +import Control.Monad.Writer +import Data.List +import Data.Set (Set) +import Data.Typeable +import Foreign.Ptr +import Prelude hiding (readFile, writeFile, print, appendFile, IO, getChar, getLine, getContents, readIO, readLn, interact, putChar, putStr, putStrLn) +import System.Directory +import System.IO (IOMode, Handle, BufferMode, HandlePosn, SeekMode, stdin, stdout, stderr) +import qualified Data.Set as Set +import qualified System.IO as U + +-- Make `Handle's orderable. + +data HandleS = HandleS String Handle + +mkHWrap :: Handle -> HandleS +mkHWrap h = HandleS (show h) h + +instance Eq HandleS where + (HandleS _ s) == (HandleS _ t) = s == t + +instance Ord HandleS where + (HandleS s _) `compare` (HandleS t _) = s `compare` t + +-- | The jailed IO monad. + +newtype IO a = IO { unJail :: ReaderT (Maybe FilePath) (StateT (Set HandleS) U.IO) a} + deriving (Functor, Applicative, Monad, Typeable, MonadFix) + +-- | Like `MonadIO`, but for jailed computations. + +class Monad m => JailIO m where + jailIO :: IO a -> m a + +instance JailIO IO where + jailIO = id + +instance JailIO m => JailIO (ContT r m) where jailIO = lift . jailIO +instance (Error e, JailIO m) => JailIO (ErrorT e m) where jailIO = lift . jailIO +instance JailIO m => JailIO (IdentityT m) where jailIO = lift . jailIO +instance JailIO m => JailIO (ListT m) where jailIO = lift . jailIO +instance (Monoid w, JailIO m) => JailIO (RWST r w s m) where jailIO = lift . jailIO +instance JailIO m => JailIO (ReaderT r m) where jailIO = lift . jailIO +instance JailIO m => JailIO (StateT r m) where jailIO = lift . jailIO +instance (Monoid r, JailIO m) => JailIO (WriterT r m) where jailIO = lift . jailIO + +{- | +Run a jailed IO computation. The IO computation will be able to access all +files that are within the specified jail directory. All file accesses outside +the jail directory will be refused. Only file handles opened from within the +jailed computation and the handles from the white list will be accessible to +the operations requiring a file handle. No smuggling in of foreign handles, +border patrol is very strict. When the jail path is specified as `Nothing' no +file access will be possible at all, this means the computation can only rely +on the white listed handles. +-} + +run + :: Maybe FilePath -- ^ The jail directory or `Nothing' for not allowing file access. + -> [Handle] -- ^ A white list of handles that are always accessible. + -> IO a -- ^ The jailed IO computation to run. + -> U.IO a -- ^ Run the computation from within the insecure real world. +run jail = runRaw jail . Set.fromList . map mkHWrap + +runRaw :: Maybe FilePath -> Set HandleS -> IO a -> U.IO a +runRaw p h = + flip evalStateT h + . flip runReaderT p + . unJail + +isSubPathOf :: FilePath -> FilePath -> U.IO Bool +isSubPathOf path jail = isPrefixOf <$> canonicalizePath jail <*> canonicalizePath path + +-- Unconditionally, embed an IO action into the Jail monad. Not to be exported! + +io :: U.IO a -> IO a +io = IO . liftIO + +-- Allow a new Handle. + +allow :: Handle -> IO () +allow h = (IO . lift) (modify (Set.insert (mkHWrap h))) + +{- +Embed an IO action that takes a FilePath as input. The IO action will only +executed when the path is within the jail directory. Not to be exported! +-} + +embedPath :: String -> (FilePath -> U.IO a) -> FilePath -> IO a +embedPath name action path = + do jail <- IO ask + safe <- io (maybe (return False) (path `isSubPathOf`) jail) + if safe + then io (action path) + else error (name ++ ": Permission denied, filepath outside jailed environment. " + ++ show path) + +{- +Embed an IO action that takes a `Handle' as input. The IO action will only +executed when the handle is opened from within the jailed IO monad. Not to be +exported! +-} + +embedHandles :: String -> ([Handle] -> U.IO a) -> [Handle] -> IO a +embedHandles name action handles = + do set <- IO (lift get) + if all (\h -> mkHWrap h `Set.member` set) handles + then io (action handles) + else error (name ++ ": Permission denied, handle from outside jailed environment. " + ++ show handles) + +embedHandle :: String -> (Handle -> U.IO a) -> Handle -> IO a +embedHandle name action handle = embedHandles name (action . head) [handle] + +-- Embedded IO actions. + +withFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a +withFile f m w = + do r <- runRaw <$> IO ask <*> IO (lift get) + embedPath "withFile" (\f' -> U.withFile f' m (\h -> r (allow h >> w h))) f + +openFile :: FilePath -> IOMode -> IO Handle +openFile f m = + do h <- embedPath "openFile" (flip U.openFile m) f + allow h + return h + +hClose :: Handle -> IO () +hClose = io . U.hClose + +-- + +readFile :: FilePath -> IO String +readFile = embedPath "readFile" U.readFile + +writeFile :: FilePath -> String -> IO () +writeFile f s = embedPath "writeFile" (flip U.writeFile s) f + +appendFile :: FilePath -> String -> IO () +appendFile f s = embedPath "appendFile" (flip U.appendFile s) f + +-- + +hFileSize :: Handle -> IO Integer +hFileSize = embedHandle "hFileSize" U.hFileSize + +#ifdef __GLASGOW_HASKELL__ + +hSetFileSize :: Handle -> Integer -> IO () +hSetFileSize h i = embedHandle "setFileSize" (flip U.hSetFileSize i) h + +#endif + +-- + +hIsEOF :: Handle -> IO Bool +hIsEOF = io . U.hIsEOF + +isEOF :: IO Bool +isEOF = io U.isEOF + +-- + +hSetBuffering :: Handle -> BufferMode -> IO () +hSetBuffering h m = embedHandle "hSetBuffering" (flip U.hSetBuffering m) h + +hGetBuffering :: Handle -> IO BufferMode +hGetBuffering = embedHandle "hGetBuffering" U.hGetBuffering + +hFlush :: Handle -> IO () +hFlush = embedHandle "hFlush" U.hFlush + +-- + +hGetPosn :: Handle -> IO HandlePosn +hGetPosn = embedHandle "hGetPosn" U.hGetPosn + +hSetPosn :: HandlePosn -> IO () +hSetPosn = io . U.hSetPosn + +hSeek :: Handle -> SeekMode -> Integer -> IO () +hSeek h m i = embedHandle "hSeek" (\h' -> U.hSeek h' m i) h + +#if !defined(__NHC__) + +hTell :: Handle -> IO Integer +hTell = embedHandle "hTell" U.hTell + +#endif + +-- + +hIsOpen :: Handle -> IO Bool +hIsOpen = embedHandle "hIsOpen" U.hIsOpen + +hIsClosed :: Handle -> IO Bool +hIsClosed = embedHandle "hIsClosed" U.hIsClosed + +hIsReadable :: Handle -> IO Bool +hIsReadable = embedHandle "hIsReadable" U.hIsReadable + +hIsWritable :: Handle -> IO Bool +hIsWritable = embedHandle "hIsWritable" U.hIsWritable + +hIsSeekable :: Handle -> IO Bool +hIsSeekable = embedHandle "hIsSeekable" U.hIsSeekable + +-- + +#if !defined(__NHC__) + +hIsTerminalDevice :: Handle -> IO Bool +hIsTerminalDevice = embedHandle "hIsTerminalDevice" U.hIsTerminalDevice + +hSetEcho :: Handle -> Bool -> IO () +hSetEcho h e = embedHandle "hSetEcho" (flip U.hSetEcho e) h + +hGetEcho :: Handle -> IO Bool +hGetEcho = embedHandle "hGetEcho" U.hGetEcho + +#endif + +-- + +#ifdef __GLASGOW_HASKELL__ + +hShow :: Handle -> IO String +hShow = embedHandle "hShow" U.hShow + +#endif + +-- + +hWaitForInput :: Handle -> Int -> IO Bool +hWaitForInput h i = embedHandle "hWaitForInput" (flip U.hWaitForInput i) h + +hReady :: Handle -> IO Bool +hReady = embedHandle "hReady" U.hReady + +hGetChar :: Handle -> IO Char +hGetChar = embedHandle "hGetChar" U.hGetChar + +hGetLine :: Handle -> IO String +hGetLine = embedHandle "hGetLine" U.hGetLine + +hLookAhead :: Handle -> IO Char +hLookAhead = embedHandle "hLookAhead" U.hLookAhead + +hGetContents :: Handle -> IO String +hGetContents = embedHandle "hGetContents" U.hGetContents + +-- + +hPutChar :: Handle -> Char -> IO () +hPutChar h c = embedHandle "hPutChar" (flip U.hPutChar c) h + +hPutStr :: Handle -> String -> IO () +hPutStr h s = embedHandle "hPutStr" (flip U.hPutStr s) h + +hPutStrLn :: Handle -> String -> IO () +hPutStrLn h s = embedHandle "hPutStrLn" (flip U.hPutStrLn s) h + +hPrint :: Show a => Handle -> a -> IO () +hPrint h s = embedHandle "hPrint" (flip U.hPrint s) h + +-- + +interact :: (String -> String) -> IO () +interact a = embedHandles "interact" (const (U.interact a)) [stdout, stdin] + +putChar :: Char -> IO () +putChar a = embedHandle "putChar" (const (U.putChar a)) stdout + +putStr :: String -> IO () +putStr a = embedHandle "putStr" (const (U.putStr a)) stdout + +putStrLn :: String -> IO () +putStrLn a = embedHandle "putStrLn" (const (U.putStrLn a)) stdout + +print :: Show a => a -> IO () +print a = embedHandle "print" (const (U.print a)) stdout + +-- + +getChar :: IO Char +getChar = embedHandle "getChar" (const U.getChar) stdin + +getLine :: IO String +getLine = embedHandle "getLine" (const U.getLine) stdin + +getContents :: IO String +getContents = embedHandle "getContents" (const U.getContents) stdin + +readIO :: Read a => String -> IO a +readIO s = embedHandle "readIO" (const (U.readIO s)) stdin + +readLn :: Read a => IO a +readLn = embedHandle "readLn" (const U.readLn) stdin + +-- + +withBinaryFile :: FilePath -> IOMode -> (Handle -> IO a) -> IO a +withBinaryFile f m w = + do r <- runRaw <$> IO ask <*> IO (lift get) + embedPath "withBinaryFile" (\f' -> U.withBinaryFile f' m (\h -> r (allow h >> w h))) f + +openBinaryFile :: FilePath -> IOMode -> IO Handle +openBinaryFile f m = + do h <- embedPath "openBinaryFile" (flip U.openBinaryFile m) f + allow h + return h + +hSetBinaryMode :: Handle -> Bool -> IO () +hSetBinaryMode h b = embedHandle "hSetBinaryMode" (flip U.hSetBinaryMode b) h + +hPutBuf :: Handle -> Ptr a -> Int -> IO () +hPutBuf h p i = embedHandle "hPutBuf" (\h' -> U.hPutBuf h' p i) h + +hGetBuf :: Handle -> Ptr a -> Int -> IO Int +hGetBuf h p i = embedHandle "hGetBuf" (\h' -> U.hGetBuf h' p i) h + +#if !defined(__NHC__) && !defined(__HUGS__) + +hPutBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int +hPutBufNonBlocking h p i = embedHandle "hPutBufNonBlocking" (\h' -> U.hPutBufNonBlocking h' p i) h + +hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int +hGetBufNonBlocking h p i = embedHandle "hGetBufNonBlocking" (\h' -> U.hGetBufNonBlocking h' p i) h + +#endif + +-- + +openTempFile :: FilePath -> String -> IO (FilePath, Handle) +openTempFile f s = embedPath "openTempFile" (flip U.openTempFile s) f + +openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle) +openBinaryTempFile f s = embedPath "openBinaryTempFile" (flip U.openBinaryTempFile s) f +