Capabilities (empty) → 0.1.0.0

raw patch · 7 files changed

+489/−0 lines, 7 filesdep +basedep +compdatadep +directorysetup-changed

Dependencies added: base, compdata, directory, free, unix

Files

Capabilities.cabal +47/−0
LICENSE +30/−0
Setup.hs +2/−0
src/Capabilities.hs +75/−0
src/Capabilities/IO.hs +216/−0
src/Capabilities/Internals.hs +46/−0
src/System/Environment/Capabilities.hs +73/−0

+ Capabilities.cabal view

@@ -0,0 +1,47 @@+-- Initial Capabilities.cabal generated by cabal init.  For further +-- documentation, see http://haskell.org/cabal/users-guide/++name:                Capabilities+version:             0.1.0.0+synopsis:            Separate and contain effects of IO monad.+category:            Security, Generics+description:         +  The /capabilities/ library is an effort to make effects in Haskell+  more explicit by breaking the monolithic IO monad into smaller+  composable parts called /capabilities/: a use case might be an+  action that needs logging with current time but which should not be+  allowed any other IO. This exists as a pleasant middle ground+  between pure functions, the ST monad and the kitchen-sink IO+  providing a more fine-grained approach to effectful+  computations. Another benefit to this approach is security where a+  computation should only have access to resources requires to+  complete its job (/principle of least privilege/).++  .+  The implementation of the idea is based on Wouter Swierstra's+  Functional Pearl /Data types a la carte/ (Journal of Functional+  Programming, 18(4):423-436, 2008,+  <http://dx.doi.org/10.1017/S0956796808006758>) and uses the+  'compdata' package for compositional data types.+  +homepage:            https://github.com/Icelandjack/Capabilities+license:             BSD3+license-file:        LICENSE+author:              Baldur Blöndal, Daniel Schoepe+maintainer:          baldur@student.chalmers.se, daniel@schoepe.org+tested-with:         GHC ==7.4.1+-- copyright:           +-- category:            +build-type:          Simple+cabal-version:       >=1.8++source-repository head+  type:     git+  location: git://github.com/IcelandJack/Capabilties.git++library+  exposed-modules:     Capabilities, Capabilities.IO, Capabilities.Internals, System.Environment.Capabilities+  -- other-modules:       +  build-depends:       base ==4.5.*, unix ==2.5.*, directory ==1.1.*, free ==3.4.*, compdata ==0.6.*+  hs-source-dirs:      src+  ghc-options:         -Wall

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2013, Baldur Blöndal, Daniel Schoepe++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Baldur Blöndal, Daniel Schoepe nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS 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 COPYRIGHT+OWNER 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ src/Capabilities.hs view

@@ -0,0 +1,75 @@+-- | This is a top-level module.+-- The purpose of the module is to make effectful computations more explicit.+-- +--   A simple example of the library in use:+-- +-- > {-# LANGUAGE FlexibleContexts    #-}+-- > +-- > import Prelude hiding    (putStrLn, getLine)+-- > import Capabilities      (run, Restr, (:+:))+-- > import Capabilities.IO   (TTY, W, putStrLn, getLine)+-- > +-- > printMyName :: Restr (W :+: TTY) ()+-- > printMyName = do+-- >   name <- getLine+-- >   putStrLn ("Hey my name is " ++ name ++ "!")+-- > +-- > main :: IO ()+-- > main = run printMyName+-- +-- where @printMyName@ can /only/ write to files and read and write to+-- handles (note that @TTY@ is a type synonym for @Stdin :+: Stdout@).+-- +-- Defining your own restricted actions works as follows: you want to+-- outsource summing numbers from a file to an untrusted party but don't+-- want them accessing your secret files. This is accomplished by creating+-- a new data type @SecureRead a@ which checks the filepath against the+-- string \"secret\". The function @secureRead@ cannot open such a file:+-- +-- > {-# LANGUAGE FlexibleContexts    #-}+-- > {-# LANGUAGE DeriveFunctor       #-}+-- > {-# LANGUAGE TypeOperators       #-}+-- > +-- > import qualified Prelude as P+-- > import Data.List+-- > import Prelude hiding (readFile, putStrLn)+-- > +-- > import Capabilities+-- > +-- > data SecureRead a = SecureRead FilePath (Maybe String -> a) deriving Functor+-- > +-- > instance Run SecureRead where+-- >   runAlgebra (SecureRead filepath io) +-- >     | "secret" `isInfixOf` filepath = io Nothing+-- >     | otherwise                     = do content <- P.readFile filepath+-- >                                          io (Just content)+-- > +-- > secureRead :: (SecureRead :<: f) => FilePath -> Restr f (Maybe String)+-- > secureRead filepath = liftRaw (SecureRead filepath Pure)+-- > +-- > untrusted :: FilePath -> Restr (Stdout :+: SecureRead) (Maybe Int)+-- > untrusted filepath = do+-- >   outcome <- secureRead filepath+-- >   let numbers = fmap (map read . lines) outcome+-- >   case numbers of+-- >     Just ns -> putStrLn ("Contents: " ++ show ns)+-- >     Nothing -> putStrLn "Invalid filepath!"+-- >   return (fmap sum numbers)+-- +-- with+-- +-- >>> run (untrusted "/tmp/file.txt")+-- Contents: [10,20,30,40]+-- Just 100+-- >>> run (untrusted "/tmp/secret.txt")+-- Invalid filepath!+-- Nothing++module Capabilities (+  module Capabilities.IO,+  module Capabilities.Internals +  )+  where++import Capabilities.IO+import Capabilities.Internals

+ src/Capabilities/IO.hs view

@@ -0,0 +1,216 @@+{-# LANGUAGE Trustworthy         #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE TypeOperators       #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE DeriveDataTypeable  #-}++module Capabilities.IO (+  -- * Teletype terminal+  TTY,+  +  -- ** Reading from handle+  Stdin, hGetChar, getChar, getLine, hGetContents, getContents,+  +  -- ** Write to handle+  Stdout, hPutChar, putChar, putStr, putStrLn, print,+  +  -- ** Reading and writing+  interact,++  -- * Opening and closing files+  RW,+  +  -- ** Writing to files+  W, writeFile, appendFile,+  +  -- ** Reading from files+  R, readFile,++  -- * Information from files+  Stat, stat+     +  ) where+++import Capabilities.Internals++import qualified Prelude as P            (getChar, putChar, readFile,+                                          writeFile, appendFile)+import Prelude hiding                    (putChar, getChar, putStrLn, putStr,+                                          getLine, readFile, print, writeFile,+                                          appendFile, catch, getContents,+                                          interact)++import Control.Exception                 (catch, SomeException)++import System.Posix.Files                (FileStatus, getFileStatus)+import qualified System.IO as IO         (hGetChar, hPutChar, hGetContents,+                                          stdin, stdout)+import qualified System.Directory as Dir (getDirectoryContents,+                                          removeFile, removeDirectory,+                                          removeDirectoryRecursive)++import GHC.IO.Handle.Types               (Handle)++-- | Reading characters from a handle.+data Stdin a+  = HGetChar Handle (Char -> a)+  | HGetContents Handle (String -> a)+  deriving Functor++-- | Writing characters to a handle.+data Stdout a+  = HPutChar Handle Char a+  deriving Functor++-- | Allows reading and writing to handle.+type TTY = Stdin :+: Stdout++instance Run Stdin where+  runAlgebra (HGetChar     handle io) = IO.hGetChar     handle >>= io+  runAlgebra (HGetContents handle io) = IO.hGetContents handle >>= io++instance Run Stdout where+  runAlgebra (HPutChar handle c io) = IO.hPutChar handle c >>  io++-- | Writes a character to a handle.+hPutChar :: (Stdout :<: f) => Handle -> Char -> Restr f ()+hPutChar handle c = liftRaw (HPutChar handle c (Pure ()))++-- | Write a character to the standard output device+-- (same as 'hPutChar' 'stdout').+putChar :: (Stdout :<: f) => Char -> Restr f ()+putChar = hPutChar IO.stdout++-- | Write a string to the standard output device+-- (same as 'hPutStr' 'stdout').+putStr :: (Functor f, Stdout :<: f) => String -> Restr f ()+putStr = mapM_ putChar++-- | The same as 'putStr', but adds a newline character.+putStrLn :: (Functor f, Stdout :<: f) => String -> Restr f ()+putStrLn string = putStr string >> putChar '\n'++-- | The 'print' function outputs a value of any printable type to the+-- standard output device.+print :: (Show s, Functor f, Stdout :<: f) => s -> Restr f ()+print string = putStrLn (show string)++-- | Read a character from a handle.+hGetChar :: (Stdin :<: f) => Handle -> Restr f Char+hGetChar handle = liftRaw (HGetChar handle Pure)++-- | Read a character from the standard input device+-- (same as 'hGetChar' 'stdin').+getChar :: (Stdin :<: f) => Restr f Char+getChar = hGetChar IO.stdin++-- | Read a line from the standard input device+-- (same as 'hGetLine' 'stdin').+getLine :: (Functor f, Stdin :<: f) => Restr f String+getLine = do+  c <- getChar+  if c == '\n'+     then return ""+     else do+       cs <- getLine+       return (c:cs)++-- | Read a character from a handle.+hGetContents :: (Stdin :<: f) => Handle -> Restr f String+hGetContents handle = liftRaw (HGetContents handle Pure)++-- | Read a character from the standard input device+-- (same as 'hGetChar' 'stdin').+getContents :: (Stdin :<: f) => Restr f String+getContents = hGetContents IO.stdin++-- | The 'interact' function takes a function of type @String->String@+-- as its argument.  The entire input from the standard input device is+-- passed to this function as its argument, and the resulting string is+-- output on the standard output device.+interact :: (Stdin :<: f, Stdout :<: f, Functor f)+         => (String -> String) -> Restr f ()+interact f = do+  s <- getContents+  putStr (f s)++-- | Reading from file+data R a = Read FilePath (String -> a) deriving Functor++instance Run R where+  runAlgebra (Read file io) = P.readFile file >>= io++readFile :: (Functor f, R :<: f) => FilePath -> Restr f String+readFile skrá = liftRaw (Read skrá Pure)++-- | Writing to file+data W a+  = Write FilePath String a+  | Append FilePath String a+  deriving Functor++instance Run W where+  runAlgebra (Write file cont io) = P.writeFile file cont >> io+  runAlgebra (Append file cont io) = P.appendFile file cont >> io++-- | The computation 'writeFile' @file str@ function writes the string @str@,+-- to the file @file@.+writeFile :: (Functor f, W :<: f) => FilePath -> String -> Restr f ()+writeFile skrá cont = liftRaw (Write skrá cont (Pure ()))++-- | The computation 'appendFile' @file str@ function appends the string @str@,+-- to the file @file@.+appendFile :: (Functor f, W :<: f) => FilePath -> String -> Restr f ()+appendFile skrá cont = liftRaw (Append skrá cont (Pure ()))++-- | Capability to read and write to a file.+type RW = R :+: W++-- | File status+data Stat a = Stat FilePath (Maybe FileStatus -> a) deriving Functor++instance Run Stat where+  runAlgebra (Stat file io) = do+    status <- catch+              (Just `fmap` getFileStatus file)+              (\(_ :: SomeException) -> return Nothing)+    io status++stat :: (Functor f, Stat :<: f) => FilePath -> Restr f (Maybe FileStatus)+stat skrá = liftRaw (Stat skrá Pure)++-- | Gets directory listing+data Dir a = Dir FilePath (Maybe [FilePath] -> a) deriving Functor++instance Run Dir where+  runAlgebra (Dir file io) = do+    cont <- catch+            (Just `fmap` Dir.getDirectoryContents file)+            (\(_ :: SomeException) -> return Nothing)+    io cont++getDirectoryContents :: (Dir :<: f) => FilePath -> Restr f (Maybe [FilePath])+getDirectoryContents dir = liftRaw (Dir dir Pure)++-- | Remove files.+data Rm a+  = Rm FilePath a+  | RmDir FilePath a+  | RmRecursive FilePath a+  deriving Functor++instance Run Rm where+  runAlgebra (Rm file io)         = Dir.removeFile file              >> io+  runAlgebra (RmDir dir io)       = Dir.removeDirectory dir          >> io+  runAlgebra (RmRecursive dir io) = Dir.removeDirectoryRecursive dir >> io++rm :: (Rm :<: f) => FilePath -> Restr f ()+rm file = liftRaw $ Rm file $ Pure ()++rmDir :: (Rm :<: f) => FilePath -> Restr f ()+rmDir dir = liftRaw $ RmDir dir $ Pure ()++rmRec :: (Rm :<: f) => FilePath -> Restr f ()+rmRec dir = liftRaw $ RmRecursive dir $ Pure ()

+ src/Capabilities/Internals.hs view

@@ -0,0 +1,46 @@+{-# LANGUAGE TemplateHaskell            #-}+{-# LANGUAGE DeriveFunctor              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE TypeOperators              #-}++-- | Internal plumbing for capabilities.+module Capabilities.Internals (+  +  Restr(..), Run(..), run, inj, (:<:), (:+:)(Inl, Inr), liftRaw,+  Free(..)+  ) where++import Control.Monad.Free (Free(..))+import Data.Comp.Algebra  (Alg)+import Data.Comp.Derive   (derive, liftSum)+import Data.Comp.Ops      (inj, (:<:), (:+:)(Inl, Inr))++-- | Core datatype of the Capabilities package. Represents a+-- restricted IO action where @f@ indicates the restriction type+-- returning a value of type @a@. The type @Repr (Stdout :+: Env)+-- String@ refers to an action returning a value of type @String@+-- restricted to writing to terminal and looking up values in the+-- environment. Use 'run' to run action.+newtype Restr f a = Restr (Free f a)+  deriving (Monad, Functor)++-- | Type class to define the semantics of a capability+class Functor f => Run f where+  runAlgebra :: Alg f (IO a)++-- | Lifts @Run@ so that it works with @(Run f, Run g) => Run (f :+: g)@.+$(derive [liftSum] [''Run])++-- | A fold on restriction.+foldRestr :: Functor f => (a -> b) -> (f b -> b) -> Free f a -> b+foldRestr pure _   (Pure x) = pure x+foldRestr pure imp (Free t) = imp (fmap (foldRestr pure imp) t)++-- | Runs a restricted computation with return type @a@ turning it+-- into an IO operation with return type @a@.+run :: Run f => Restr f a -> IO a+run (Restr restr) = foldRestr return runAlgebra restr++-- | Lift an action in a specific capability to Restr.+liftRaw :: (sub :<: f) => sub (Free f a) -> Restr f a+liftRaw = Restr . Free . inj

+ src/System/Environment/Capabilities.hs view

@@ -0,0 +1,73 @@+{-# LANGUAGE Trustworthy         #-}+{-# LANGUAGE DeriveFunctor       #-}+{-# LANGUAGE CPP                 #-}+{-# LANGUAGE FlexibleContexts    #-}+{-# LANGUAGE TypeOperators       #-}++module System.Environment.Capabilities (+  -- * The environment type+  Env,+  getEnv,+  getArgs,+  getEnvironment,+  getProgName+#if MIN_VERSION_base(4,6,0)+  getExecutablePath,+  lookupEnv+#endif+  ) where++import qualified System.Environment as Env++import Capabilities.Internals+import qualified Capabilities.IO as IO++data Env a+  = GetEnv String (String -> a)+  | GetEnvironment ([(String, String)] -> a)+  | GetArgs ([String] -> a)+  | GetProgName (String -> a)+  deriving Functor+           +instance Run Env where+  runAlgebra (GetArgs        io) = Env.getArgs        >>= io+  runAlgebra (GetProgName    io) = Env.getProgName    >>= io+  runAlgebra (GetEnv key     io) = Env.getEnv key     >>= io+  runAlgebra (GetEnvironment io) = Env.getEnvironment >>= io++-- | Computation 'getArgs' returns a list of the program's command+-- line arguments (not including the program name).+getArgs :: (Env :<: f) => Restr f [String]+getArgs = liftRaw (GetArgs Pure)++{-|+Computation 'getProgName' returns the name of the program as it was+invoked.++However, this is hard-to-impossible to implement on some non-Unix+OSes, so instead, for maximum portability, we just return the leafname+of the program as invoked. Even then there are some differences+between platforms: on Windows, for example, a program invoked as foo+is probably really @FOO.EXE@, and that is what 'getProgName' will return.+-}+getProgName :: (Env :<: f) => Restr f String+getProgName = liftRaw (GetProgName Pure)++-- | Computation 'getEnv' @var@ returns the value+-- of the environment variable @var@.+--+-- This computation may fail with:+--+--  * 'System.IO.Error.isDoesNotExistError' if the environment variable+--    does not exist.+getEnv :: (Env :<: f) => String -> Restr f String+getEnv key = liftRaw (GetEnv key Pure)++-- |'getEnvironment' retrieves the entire environment as a+-- list of @(key,value)@ pairs.+--+-- If an environment entry does not contain an @\'=\'@ character,+-- the @key@ is the whole entry and the @value@ is the empty string.+getEnvironment :: (Env :<: f) => Restr f [(String, String)]+getEnvironment = liftRaw (GetEnvironment Pure)+