diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,165 @@ + GNU LESSER GENERAL PUBLIC LICENSE + Version 3, 29 June 2007 + + Copyright (C) 2007 Free Software Foundation, Inc. + Everyone is permitted to copy and distribute verbatim copies + of this license document, but changing it is not allowed. + + + This version of the GNU Lesser General Public License incorporates +the terms and conditions of version 3 of the GNU General Public +License, supplemented by the additional permissions listed below. + + 0. Additional Definitions. + + As used herein, "this License" refers to version 3 of the GNU Lesser +General Public License, and the "GNU GPL" refers to version 3 of the GNU +General Public License. + + "The Library" refers to a covered work governed by this License, +other than an Application or a Combined Work as defined below. + + An "Application" is any work that makes use of an interface provided +by the Library, but which is not otherwise based on the Library. +Defining a subclass of a class defined by the Library is deemed a mode +of using an interface provided by the Library. + + A "Combined Work" is a work produced by combining or linking an +Application with the Library. The particular version of the Library +with which the Combined Work was made is also called the "Linked +Version". + + The "Minimal Corresponding Source" for a Combined Work means the +Corresponding Source for the Combined Work, excluding any source code +for portions of the Combined Work that, considered in isolation, are +based on the Application, and not on the Linked Version. + + The "Corresponding Application Code" for a Combined Work means the +object code and/or source code for the Application, including any data +and utility programs needed for reproducing the Combined Work from the +Application, but excluding the System Libraries of the Combined Work. + + 1. Exception to Section 3 of the GNU GPL. + + You may convey a covered work under sections 3 and 4 of this License +without being bound by section 3 of the GNU GPL. + + 2. Conveying Modified Versions. + + If you modify a copy of the Library, and, in your modifications, a +facility refers to a function or data to be supplied by an Application +that uses the facility (other than as an argument passed when the +facility is invoked), then you may convey a copy of the modified +version: + + a) under this License, provided that you make a good faith effort to + ensure that, in the event an Application does not supply the + function or data, the facility still operates, and performs + whatever part of its purpose remains meaningful, or + + b) under the GNU GPL, with none of the additional permissions of + this License applicable to that copy. + + 3. Object Code Incorporating Material from Library Header Files. + + The object code form of an Application may incorporate material from +a header file that is part of the Library. You may convey such object +code under terms of your choice, provided that, if the incorporated +material is not limited to numerical parameters, data structure +layouts and accessors, or small macros, inline functions and templates +(ten or fewer lines in length), you do both of the following: + + a) Give prominent notice with each copy of the object code that the + Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the object code with a copy of the GNU GPL and this license + document. + + 4. Combined Works. + + You may convey a Combined Work under terms of your choice that, +taken together, effectively do not restrict modification of the +portions of the Library contained in the Combined Work and reverse +engineering for debugging such modifications, if you also do each of +the following: + + a) Give prominent notice with each copy of the Combined Work that + the Library is used in it and that the Library and its use are + covered by this License. + + b) Accompany the Combined Work with a copy of the GNU GPL and this license + document. + + c) For a Combined Work that displays copyright notices during + execution, include the copyright notice for the Library among + these notices, as well as a reference directing the user to the + copies of the GNU GPL and this license document. + + d) Do one of the following: + + 0) Convey the Minimal Corresponding Source under the terms of this + License, and the Corresponding Application Code in a form + suitable for, and under terms that permit, the user to + recombine or relink the Application with a modified version of + the Linked Version to produce a modified Combined Work, in the + manner specified by section 6 of the GNU GPL for conveying + Corresponding Source. + + 1) Use a suitable shared library mechanism for linking with the + Library. A suitable mechanism is one that (a) uses at run time + a copy of the Library already present on the user's computer + system, and (b) will operate properly with a modified version + of the Library that is interface-compatible with the Linked + Version. + + e) Provide Installation Information, but only if you would otherwise + be required to provide such information under section 6 of the + GNU GPL, and only to the extent that such information is + necessary to install and execute a modified version of the + Combined Work produced by recombining or relinking the + Application with a modified version of the Linked Version. (If + you use option 4d0, the Installation Information must accompany + the Minimal Corresponding Source and Corresponding Application + Code. If you use option 4d1, you must provide the Installation + Information in the manner specified by section 6 of the GNU GPL + for conveying Corresponding Source.) + + 5. Combined Libraries. + + You may place library facilities that are a work based on the +Library side by side in a single library together with other library +facilities that are not Applications and are not covered by this +License, and convey such a combined library under terms of your +choice, if you do both of the following: + + a) Accompany the combined library with a copy of the same work based + on the Library, uncombined with any other library facilities, + conveyed under the terms of this License. + + b) Give prominent notice with the combined library that part of it + is a work based on the Library, and explaining where to find the + accompanying uncombined form of the same work. + + 6. Revised Versions of the GNU Lesser General Public License. + + The Free Software Foundation may publish revised and/or new versions +of the GNU Lesser General Public License from time to time. Such new +versions will be similar in spirit to the present version, but may +differ in detail to address new problems or concerns. + + Each version is given a distinguishing version number. If the +Library as you received it specifies that a certain numbered version +of the GNU Lesser General Public License "or any later version" +applies to it, you have the option of following the terms and +conditions either of that published version or of any later version +published by the Free Software Foundation. If the Library as you +received it does not specify a version number of the GNU Lesser +General Public License, you may choose any version of the GNU Lesser +General Public License ever published by the Free Software Foundation. + + If the Library as you received it specifies that a proxy can decide +whether future versions of the GNU Lesser General Public License shall +apply, that proxy's public statement of acceptance of any version is +permanent authorization for you to choose that version for the +Library. diff --git a/LIO/Web/Simple.hs b/LIO/Web/Simple.hs new file mode 100644 --- /dev/null +++ b/LIO/Web/Simple.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +{-| + + This module defines several instances needed to use 'LIO' as the + underlying monad with "Web.Simple", the simple web framework. + Additionally, we provide some middleware for executing apps in a safe + manner. + + "LIO.Web.Simple.TCB" defines several functions that can be used to + execute 'LIO' web applications with the Warp server. + +-} +module LIO.Web.Simple ( + -- * Utilities for parsing request + body, parseForm + -- * Middleware + , browserLabelGuard + , removeRequestHeaders + , removeResponseHeaders + -- * LIO applications + , SimpleLIOApplication, SimpleLIOMiddleware + , LIOController + -- * Relevant modules + , module Web.Simple.Responses + , module Web.Simple.Templates + , module Web.Simple.Controller.Trans + ) where + +import safe LIO +import LIO.TCB (ioTCB) +import LIO.Web.Simple.TCB + +import safe Web.Simple hiding (request, body, parseForm) +import safe Web.Simple.Responses +import safe Web.Simple.Controller.Trans +import safe Web.Simple.Templates + +import Network.Wai.Parse + +import Data.Conduit +import qualified Data.Conduit.List as CL + +import qualified Data.ByteString as S +import qualified Data.ByteString.Lazy as L +import safe qualified Data.ByteString.Lazy.Char8 as L8 + + +-- | Controller with 'LIO' as the underlying monad. +type LIOController l = ControllerT (LIO l) + +-- | Parses a HTML form from the request body. It returns a list of 'Param's as +-- well as a list of 'File's, which are pairs mapping the name of a /file/ form +-- field to a 'FileInfo' pointing to a temporary file with the contents of the +-- upload. +-- +-- Currently only tursted code can read the file. +parseForm :: Label l + => LIOController l r ([Param], [(S.ByteString, FileInfo L.ByteString)]) +parseForm = do + req <- request + liftLIO . ioTCB $ parseRequestBody lbsBackEnd req + +-- | Parses a HTML form from the request body. It returns a list of 'Param's as +-- well as a list of 'File's, which are pairs mapping the name of a /file/ form +-- field to a 'FileInfo' pointing to a temporary file with the contents of the + +-- | Reads and returns the body of the HTTP request. +-- +-- Note: @body@ function consumes the body from a Source IO +-- Bytestring. Since the 'Request' constructor is exposed by +-- "Network.Wai.Internal", it's important to disallow construction of +-- such values when considering untrusted code. +body :: Label l => LIOController l r L8.ByteString +body = do + req <- request + liftLIO . ioTCB $ L8.fromChunks `fmap` (requestBody req $$ CL.consume) + +instance Label l => MonadLIO l (ControllerT (LIO l) r) where + liftLIO act = ControllerT $ \st -> + liftLIO act >>= \r -> return (Right r, st) diff --git a/LIO/Web/Simple/Auth.hs b/LIO/Web/Simple/Auth.hs new file mode 100644 --- /dev/null +++ b/LIO/Web/Simple/Auth.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | Provides HTTP Basic Authentication. +module LIO.Web.Simple.Auth ( basicAuth) where + +import Control.Monad +import qualified Data.ByteString.Char8 as S8 +import Data.ByteString.Base64 +import Network.HTTP.Types +import Network.Wai +import Web.Simple.Responses +import Web.Simple.Controller.Trans + + +-- | A 'Route' that uses HTTP basic authentication to authenticate a +-- request for a realm with the given username ans password. The +-- request is rewritten with an 'X-User' header containing the +-- authenticated username before being passed to the next 'Route'. +basicAuth :: Monad m + => String -- ^ Realm + -> (S8.ByteString -> S8.ByteString -> m Bool) + -> SimpleMiddleware m +basicAuth realm auth app req = + case getBasicAuthLogin req of + Nothing -> return authResp + Just (usr, pwd) -> do + success <- auth usr pwd + let req' = req { requestHeaders = ("X-User", usr) : requestHeaders req } + if success + then app req' + else return authResp + where authResp = requireBasicAuth realm + + +-- | Helper method for implementing basic authentication. Given a +-- 'Request' returns the (username, password) pair from the basic +-- authentication header if present. +getBasicAuthLogin :: Request -> Maybe (S8.ByteString, S8.ByteString) +getBasicAuthLogin req = do + authStr <- lookup hAuthorization $ requestHeaders req + unless ("Basic" `S8.isPrefixOf` authStr) $ fail "Not basic auth." + let up = fmap (S8.split ':') $ decode $ S8.drop 6 authStr + case up of + Right (user:pwd:[]) -> return (user, pwd) + _ -> fail "Malformed basic auth header." diff --git a/LIO/Web/Simple/DCLabel.hs b/LIO/Web/Simple/DCLabel.hs new file mode 100644 --- /dev/null +++ b/LIO/Web/Simple/DCLabel.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE Safe #-} + +{- | + +This module exports several types that makes it easier to write LIO +web apps with DCLabels. + +-} + +module LIO.Web.Simple.DCLabel ( + DCController + , SimpleDCApplication + , SimpleDCMiddleware + ) where + +import safe LIO.DCLabel +import safe LIO.Web.Simple + +type DCController = LIOController DCLabel +type SimpleDCApplication = SimpleLIOApplication CNF DCLabel +type SimpleDCMiddleware = SimpleLIOMiddleware CNF DCLabel diff --git a/LIO/Web/Simple/TCB.hs b/LIO/Web/Simple/TCB.hs new file mode 100644 --- /dev/null +++ b/LIO/Web/Simple/TCB.hs @@ -0,0 +1,166 @@ +{-# LANGUAGE Unsafe #-} +{-# LANGUAGE FlexibleContexts #-} + +{- | + + This module exports a function 'run' for creating a runner that is + used to run a "Web.Simple" 'SimpleApplication' in the 'LIO' monad. + + The runner is only available to trusted code since we do not impose + any policy on how requests and responses should be handled. + Middleware should be used on both ends to ensure safety. This module + provides several such Middleware. + +-} + +module LIO.Web.Simple.TCB ( + -- * LIO applications + SimpleLIOApplication, SimpleLIOMiddleware + -- * Runners + , run, runP + -- * Middleware + , browserLabelGuard + , removeRequestHeaders + , removeResponseHeaders + -- * Templates + , lioGetTemplateTCB + ) where + +import safe Control.Monad + +import Data.Text.Encoding + +import safe Control.Applicative + +import safe LIO +import safe LIO.Error +import LIO.TCB (ioTCB, getLIOStateTCB) + +import safe qualified Data.List as List +import safe qualified Data.ByteString.Char8 as S8 +import safe qualified Data.ByteString.Lazy.Char8 as L8 + +import safe Web.Simple +import safe Web.Simple.Controller.Trans +import safe Web.Simple.Templates.Language + +import Network.HTTP.Types +import Network.Wai.Internal +import Network.Wai.Handler.Warp hiding (run) +import qualified Network.Wai.Handler.Warp as Warp + +import safe System.FilePath + +-- | An LIO simple aplpication is an 'LIO' computation mapping a set +-- of privileges and request to a response. While privileges can be +-- provided in terms of a e.g., 'Reader' monad, in certain cases not +-- having the privilege as part of the sate is cleaner. +type SimpleLIOApplication p l = Priv p -> SimpleApplication (LIO l) + +-- | Simple LIO middleware. +type SimpleLIOMiddleware p l = SimpleLIOApplication p l -> SimpleLIOApplication p l + +-- | Run an LIO web app wrapped by some middleware. Since web servers +-- can be quite messy it is important that you provide middleware to +-- sanitize responses to prevent data leakage. +-- +-- Since security properties vary across applications, we do not +-- impose any conditions on the requests and reponses. The latter can +-- be sanitized by supplying a middleware, while the former can simply +-- be baked-into the app (as 'SimpleMiddleware'. +run :: Label l => Port -> Middleware -> SimpleApplication (LIO l) -> LIO l () +run port middleware app = runP port middleware noPrivs (const app) + +-- | Same as 'run', but run 'SimpleLIOApplication's, i.e., +-- applications that take privileges. +runP :: (PrivDesc l p, Label l) + => Port -> Middleware -> Priv p -> SimpleLIOApplication p l -> LIO l () +runP port middleware priv app = do + state <- getLIOStateTCB + ioTCB $ Warp.run port $ middleware . filterFileResponses $ + \req -> evalLIO (app priv req) state + +-- | Remove any responses that were built with 'responseFile' or +-- 'responseSource'. +filterFileResponses :: Middleware +filterFileResponses app req = do + resp <- app req + return $ case resp of + ResponseBuilder _ _ _ -> resp + _ -> serverError $ L8.pack "App should not read directly from files." + +-- | Middleware that ensures the 'Response' from the +-- application is readable by the client's browser (as determined by the +-- result label of the app computation and the label of the browser). If +-- the response is not readable by the browser, the middleware sends a +-- 403 (unauthorized) response instead. +browserLabelGuard :: MonadLIO l m => l -> SimpleMiddleware m +browserLabelGuard browserLabel app req = do + resp <- app req + resultLabel <- liftLIO $ getLabel + return $ if resultLabel `canFlowTo` browserLabel + then resp + else forbidden + +-- | Remove certain headers from the request. +removeRequestHeaders :: Monad m => [HeaderName] -> SimpleMiddleware m +removeRequestHeaders headers app req = do + app $ foldr (\h r -> rmRequestHeader r h) req headers + where rmRequestHeader r h = r { requestHeaders = rm h (requestHeaders r) } + +-- | Remove certain headers from the response, e.g., Set-Cookie. +removeResponseHeaders :: Monad m => [HeaderName] -> SimpleMiddleware m +removeResponseHeaders headers app req = do + resp <- app req + return $ foldr (\h r -> rmResponseHeader r h) resp headers + +rmResponseHeader :: Response -> HeaderName -> Response +rmResponseHeader (ResponseFile x hs y z) h = ResponseFile x hs' y z where hs' = rm h hs +rmResponseHeader (ResponseBuilder x hs y ) h = ResponseBuilder x hs' y where hs' = rm h hs +rmResponseHeader (ResponseSource x hs y ) h = ResponseSource x hs' y where hs' = rm h hs + +rm :: HeaderName -> [Header] -> [Header] +rm h = List.filter ((/= h) . fst) + +-- | Function to use to get a template. When the underlying monad is +-- 'LIO', it looks in the 'viewDirectory' for the given file name and +-- compiles the file into a template. +-- +-- This function should be used only when the everything reachable +-- from the 'viewDirectory' is public. +-- +-- To ensure that the function cannot be abused the function first +-- cleans up the 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. +-- +-- Since this funciton does not use the 'lio-fs' filesystem @readFile@, +-- but rather the 'IO' @readFile@, it should not be exposed to +-- untrusted code. +lioGetTemplateTCB :: Label l => FilePath -> LIO l Template +lioGetTemplateTCB fp = do + fp' <- cleanUpPath fp + eres <- compileTemplate . decodeUtf8 <$> (ioTCB $ S8.readFile fp') + case eres of + Left str -> fail str + Right tmpl -> return tmpl + +-- | 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 :: Label l => FilePath -> LIO l FilePath +cleanUpPath path = withContext "cleanUpPath" $ + doit . splitDirectories . normalise . stripSlash $ path + where doit [] = return [] + doit ("..":_) = throwLIO $ userError "Path cannot contain .." + doit (_:"..":xs) = doit xs + doit (".":xs) = doit xs + doit (x:xs) = (x ) `liftM` doit xs + +-- | 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 + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/lio-simple.cabal b/lio-simple.cabal new file mode 100644 --- /dev/null +++ b/lio-simple.cabal @@ -0,0 +1,47 @@ +name: lio-simple +version: 0.0.0.1 +synopsis: LIO support for the Simple web framework +description: + + LIO support for the Simple web framework. + See the 'lio' and 'simple' packages for more information. + +homepage: http://simple.cx +license: LGPL-3 +license-file: LICENSE +author: Hails team +maintainer: hails@scs.stanford.edu +category: Web +build-type: Simple +cabal-version: >=1.10 + +library + build-depends: + base < 6 + , bytestring + , conduit + , directory + , filepath + , wai >= 2.0 + , wai-extra + , warp + , http-types + , base64-bytestring + , simple + , simple-templates + , lio + , text + , unix + + ghc-options: -Wall -fno-warn-unused-do-bind -fno-warn-orphans + + exposed-modules: + LIO.Web.Simple + LIO.Web.Simple.Auth + LIO.Web.Simple.DCLabel + LIO.Web.Simple.TCB + default-language: Haskell2010 + +source-repository head + type: git + location: git://github.com/scslab/lio.git