hails 0.1.1 → 0.9.0.1
raw patch · 43 files changed
+5009/−2974 lines, 43 filesdep +HUnitdep +QuickCheckdep +authenticatedep −HsOpenSSLdep −MissingHdep −RSAdep ~basedep ~base64-bytestringdep ~binarynew-component:exe:hailsnew-uploader
Dependencies added: HUnit, QuickCheck, authenticate, blaze-builder, conduit, cookie, directory, failure, filepath, ghc-paths, hails, http-conduit, http-types, quickcheck-instances, quickcheck-lio-instances, resourcet, test-framework, test-framework-hunit, test-framework-quickcheck2, text, wai, wai-app-static, wai-extra, wai-test, warp
Dependencies removed: HsOpenSSL, MissingH, RSA, SHA, SimpleAES, cereal, compact-string-fix, dclabel, iterIO, iterio-server, monad-control, pureMD5, transformers-base
Dependency ranges changed: base, base64-bytestring, binary, bson, bytestring, containers, lio, mongoDB, mtl, network, parsec, time, transformers, unix
Files
- Hails/App.hs +0/−30
- Hails/Crypto.hs +0/−17
- Hails/Data/Hson.hs +625/−0
- Hails/Data/Hson/TCB.hs +298/−0
- Hails/Data/LBson.hs +0/−7
- Hails/Data/LBson/Rexports.hs +0/−28
- Hails/Data/LBson/Rexports/Bson.hs +0/−9
- Hails/Data/LBson/Safe.hs +0/−51
- Hails/Data/LBson/TCB.hs +0/−493
- Hails/Database.hs +91/−65
- Hails/Database/Core.hs +84/−0
- Hails/Database/MongoDB.hs +0/−52
- Hails/Database/MongoDB/Structured.hs +0/−193
- Hails/Database/MongoDB/TCB/Access.hs +0/−127
- Hails/Database/MongoDB/TCB/Convert.hs +0/−69
- Hails/Database/MongoDB/TCB/DCAccess.hs +0/−249
- Hails/Database/MongoDB/TCB/Query.hs +0/−417
- Hails/Database/MongoDB/TCB/Types.hs +0/−374
- Hails/Database/Query.hs +631/−0
- Hails/Database/Query/TCB.hs +32/−0
- Hails/Database/Structured.hs +210/−0
- Hails/Database/TCB.hs +295/−0
- Hails/HttpClient.hs +219/−0
- Hails/HttpServer.hs +241/−95
- Hails/HttpServer/Auth.hs +136/−89
- Hails/HttpServer/Types.hs +106/−0
- Hails/IterIO/Conversions.hs +0/−79
- Hails/IterIO/HailsRoute.hs +0/−47
- Hails/IterIO/HttpClient.hs +0/−302
- Hails/IterIO/Mime.hs +0/−25
- Hails/Policy.hs +0/−19
- Hails/PolicyModule.hs +518/−0
- Hails/PolicyModule/DSL.hs +753/−0
- Hails/PolicyModule/TCB.hs +41/−0
- Hails/TCB/Types.hs +0/−44
- Hails/Version.hs +9/−0
- LIO/Data/Time.hs +0/−33
- examples/SimpleApp.hs +10/−0
- examples/httpClientExample.hs +41/−0
- examples/simpleDBExample.hs +108/−0
- hails.cabal +183/−60
- hails.hs +363/−0
- tests/Tests.hs +15/−0
− Hails/App.hs
@@ -1,30 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-module Hails.App ( module Hails.IterIO.HailsRoute- , module LIO- , module LIO.DCLabel- , AppReqHandler, AppRoute- -- * Info about app and user- , getHailsUser, getHailsApp- ) where--import Hails.IterIO.HailsRoute-import LIO-import LIO.DCLabel-import Hails.TCB.Types ( AppReqHandler, AppRoute )-import Data.IterIO.Http.Support.Action (Action, requestHeader)-import qualified Data.ByteString.Char8 as S8---- | Get the user the app is running on behalf of-getHailsUser :: Action t b DC String-getHailsUser = do- hdr <- requestHeader (S8.pack "x-hails-user")- maybe (fail "No x-hails-user header") (return . S8.unpack) hdr---- | Get the app the app is running on behalf of-getHailsApp :: Action t b DC String-getHailsApp = do- hdr <- requestHeader (S8.pack "x-hails-app")- maybe (fail "No x-hails-app header") (return . S8.unpack) hdr
− Hails/Crypto.hs
@@ -1,17 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--- | This module exports various cryptographic primitives.-module Hails.Crypto ( -- * Hash functions- module Data.Digest.Pure.SHA- , module Data.Digest.Pure.MD5- -- * Symmetric ciphers- , module Codec.Crypto.SimpleAES- -- * Asymmetric ciphers- , module Codec.Crypto.RSA- ) where-import Data.Digest.Pure.SHA-import Data.Digest.Pure.MD5-import Codec.Crypto.SimpleAES-import Codec.Crypto.RSA
+ Hails/Data/Hson.hs view
@@ -0,0 +1,625 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ConstraintKinds,+ FlexibleContexts,+ DeriveDataTypeable,+ MultiParamTypeClasses,+ FlexibleInstances,+ TypeSynonymInstances,+ ScopedTypeVariables,+ OverlappingInstances,+ FunctionalDependencies+ #-}++{- |++This module exports the type for a Hails BSON document, 'HsonDoc' and+related classes for creating such documents. A Hails document is+similar to "Data.Bson"\'s documents, but differs in two ways. First,+Hails restricts the number of types to a subset of BSON's (see+'BsonVal'). This restriction is primarily due to the fact that many of+the BSON types are redundant and not used (at least within Hails).+Second, Hails allows for documents to contain policy-labeled values.++Policy labeled values ('PolicyLabeled') are permitted only at the+\"top-level\" of a document. (This is primarily done to keep+policy-specification simple and may change in the future.)+Consequently to allow for nested documents and documents containing an+array of values we separate top-level fields ('HsonField'), that may+contain policy labeled values, from potentially-nested fields+('BsonField'). A top-level field 'HsonField' is thus either a+'BsonField' or a 'PolicyLabled' value.++Example:++> module Main (x, y) where+> +> import Data.Text (Text)+> +> import LIO.DCLabel+> import LIO.Labeled.TCB (labelTCB)+> import Hails.Data.Hson+> +> -- | Create document, verbose approach+> x :: HsonDocument+> x = [ "myInt" =: BsonInt32 42+> , "nested" =: BsonDoc [ "flag" =: BsonBool True]+> , "secret" =: (HsonLabeled $ hasPolicy (labelTCB dcPub (BsonString "hi")))+> ]+> +> -- | Create same document, clean approach+> y :: HsonDocument+> y = [ "myInt" -: (42 :: Int)+> , "nested" -: ([ "flag" -: True] :: BsonDocument)+> , "secret" -: labelTCB dcPub (toBsonValue ("hi" :: Text))+> ]++Both @x@ and @y@ with @-XOverloadedStrings@:++> [myInt -: 42,nested -: [flag -: True],secret -: HsonLabeled]+++-}++module Hails.Data.Hson (+ -- * Documents+ HsonDocument, Document, BsonDocument+ -- ** Operations on documents+ , DocOps(..)+ , DocValOps(..)+ , include, exclude+ , merge+ -- ** Converting to/from Hson/Bson+ , bsonDocToHsonDoc, bsonFieldToHsonField+ , isBsonDoc+ , hsonDocToBsonDoc+ , hsonDocToBsonDocStrict+ , labeledRequestToHson+ -- * Fields+ , FieldName, HsonField(..), BsonField(..)+ , IsField(..), Field(..), GenField(..)+ -- * Values+ , HsonValue(..), HsonVal(..)+ , BsonValue(..), BsonVal(..)+ , PolicyLabeled, needPolicy, hasPolicy, getPolicyLabeled + , Binary(..)+ , ObjectId(..), genObjectId+ ) where++import Prelude hiding (lookup)+import Control.Monad (liftM)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Data.Binary.Put+import Data.Bson.Binary+import Data.Maybe (mapMaybe)+import Data.Monoid (mconcat)+import qualified Data.List as List+import Data.Text (Text)+import qualified Data.Text as T+import Data.Int (Int32, Int64)+import Data.Time.Clock (UTCTime)+import Data.Typeable+import Data.Functor.Identity (runIdentity)+import qualified Data.Bson as Bson++import LIO+import LIO.DCLabel+import LIO.Labeled.TCB+import LIO.TCB (ioTCB, ShowTCB(..))++import Network.HTTP.Types++import Hails.Data.Hson.TCB+import Hails.HttpServer.Types++infix 0 =:, -:+++-- | Synonym for 'HsonDocument'+type Document = HsonDocument+++--+-- Fields+--++instance Show BsonField where+ show (BsonField n v) = T.unpack n ++ " -: " ++ show v++instance Show HsonField where+ show (HsonField n v) = T.unpack n ++ " -: " ++ show v++-- | Class for retrieving the name of a field.+class IsField f where+ -- | Get the name of a field.+ fieldName :: f -> FieldName++instance IsField BsonField where fieldName (BsonField n _) = n+instance IsField HsonField where fieldName (HsonField n _) = n++-- | Class used to define fields.+class (IsField f, Show v, Show f) => Field v f where+ -- | Given a name and value construct either a 'HsonField' or+ -- 'BsonField'+ (=:) :: FieldName -> v -> f+ -- | Get the field value.+ fieldValue :: Monad m => f -> m v++instance Field BsonValue BsonField where+ (=:) = BsonField+ fieldValue (BsonField _ v) = return v+instance Field BsonValue HsonField where+ n =: v = n =: HsonValue v+ fieldValue (HsonField _ (HsonValue v)) = return v+ fieldValue _ = fail "fieldValue: cannot extract PolicyLabled"+instance Field HsonValue HsonField where+ (=:) = HsonField+ fieldValue (HsonField _ v) = return v+++--+-- Values+--+++instance Show BsonValue where+ show (BsonFloat v) = show v+ show (BsonString v) = show v+ show (BsonDoc v) = show v+ show (BsonArray v) = show v+ show (BsonBlob v) = show v+ show (BsonObjId v) = show v+ show (BsonBool v) = show v+ show (BsonUTC v) = show v+ show BsonNull = "NULL"+ show (BsonInt32 v) = show v+ show (BsonInt64 v) = show v++instance Show HsonValue where+ show (HsonValue h) = show h+ show (HsonLabeled _) = "{- Hidden -} HsonLabeled"++instance ShowTCB HsonValue where+ showTCB (HsonValue h) = show h+ showTCB (HsonLabeled h) = showTCB h++++--+-- Policy labeled values+--++instance ShowTCB PolicyLabeled where+ showTCB (NeedPolicyTCB bv) = "NeedPolicyTCB " ++ show bv+ showTCB (HasPolicyTCB lbv) = "HasPolicyTCB " ++ showTCB lbv++-- | Create a policy labeled value given an unlabeled 'HsonValue'.+needPolicy :: BsonValue-> PolicyLabeled+needPolicy = NeedPolicyTCB++-- | Create a policy labeled value a labeled 'HsonValue'.+hasPolicy :: DCLabeled BsonValue -> PolicyLabeled+hasPolicy = HasPolicyTCB++-- | Get the policy labeled value, only if the policy has been+-- applied.+getPolicyLabeled :: Monad m => PolicyLabeled -> m (DCLabeled BsonValue)+getPolicyLabeled (NeedPolicyTCB _) =+ fail "Can only retrieve already labeldv policy values"+getPolicyLabeled (HasPolicyTCB lv) = return lv++--+-- Document operations+--++-- | Class used to implement operatoins on documents that return+-- 'HsonValue's or 'BsonValue's. The main role of this function is to+-- impose the functional dependency between values and fields. As a+-- consequence 'look'ing up and getting 'valueAt' in a 'HsonDocument'+-- (resp. 'BsonDocument') will return a 'HsonValue' (resp. 'BsonValue').+-- This eliminates the need to specify the end type of very query, but+-- forces the programmer to cast between Hson and Bson values.+class Field v f => DocOps v f | v -> f, f -> v where+ -- | Find value of field in document, or fail not found.+ look :: (Field v f, Monad m) => FieldName -> [f] -> m v+ look n doc = case List.find ((==n) . fieldName) doc of+ Just v -> fieldValue v+ _ -> fail $ "look: Not found " ++ show n++ -- | Same as 'look', but 'fail's if the value is not found.+ valueAt :: Field v f => FieldName -> [f] -> v+ valueAt n = runIdentity . look n++ -- Serializes a document to binary BSON representation+ serialize :: [f] -> L8.ByteString++instance DocOps HsonValue HsonField where+ serialize = serialize . hsonDocToBsonDoc ++instance DocOps BsonValue BsonField where+ serialize = runPut . putDocument . bsonDocToDataBsonDocTCB++-- | Only include fields specified.+include :: IsField f => [FieldName] -> [f] -> [f]+include ns doc = mapMaybe (\n -> List.find ((==n) . fieldName) doc) ns++-- | Exclude fields specified.+exclude :: IsField f => [FieldName] -> [f] -> [f]+exclude ns doc = filter ((\n -> notElem n ns) . fieldName) doc++-- | Merge documents with preference given to first one when both have+-- the same field name.+merge :: IsField f => [f] -> [f] -> [f]+merge doc1 doc2 = + let ns1 = map fieldName doc1+ doc2' = List.filter ((\n -> n `notElem` ns1) . fieldName) doc2+ in doc1 ++ doc2'++-- | Class used to implement operations on documents that return+-- Haskell values (as opposed to 'HsonValue' or 'BsonValue').+class DocValOps d v where+ -- | Same as 'look', but returns \"unwrapped\" value.+ lookup :: (Monad m) => FieldName -> d -> m v+ -- | Same as 'valueAt', but returns \"unwrapped\" value.+ at :: FieldName -> d -> v+ at n = runIdentity . lookup n++instance HsonVal v => DocValOps HsonDocument v where+ lookup n doc = look n doc >>= fromHsonValue++instance BsonVal v => DocValOps BsonDocument v where+ lookup n doc = look n doc >>= fromBsonValue+++--+-- Converters+--++-- | Returns true if the document is composed solely of 'BsonValue's.+-- This function is useful when converting from 'HsonDocument' to+-- 'BsonDocument'.+isBsonDoc :: HsonDocument -> Bool+isBsonDoc doc = all f doc+ where f (HsonField _ (HsonLabeled _)) = False+ f _ = True++-- | Convert 'BsonDocument' to 'HsonDocument'+bsonDocToHsonDoc :: BsonDocument -> HsonDocument+bsonDocToHsonDoc = map bsonFieldToHsonField ++-- | Convert 'BsonField' to 'HsonField'+bsonFieldToHsonField :: BsonField -> HsonField+bsonFieldToHsonField (BsonField n v) = n =: v++-- | This is a relaxed version of 'hsonDocToBsonDocStrict' that only+-- converts fields containing 'BsonValue's. In other words, the+-- 'PolicyLabeled' values are dropped.+hsonDocToBsonDoc :: HsonDocument -> BsonDocument+hsonDocToBsonDoc doc = mapMaybe hsonFieldToBsonField doc++-- | Convert an 'HsonDocument' to a 'BsonDocument'. If any of the+-- fields contain 'PolicyLabeled' values (i.e., are 'HsonLabeled'+-- values) this function 'fail's, otherwise it returns the converted+-- document. To check for failure use 'isBsonDoc'.+hsonDocToBsonDocStrict :: Monad m => HsonDocument -> m BsonDocument+hsonDocToBsonDocStrict doc = mapM hsonFieldToBsonField doc++-- | Convert 'HsonField' to 'BsonField'+hsonFieldToBsonField :: Monad m => HsonField -> m BsonField+hsonFieldToBsonField (HsonField n (HsonValue v)) = return (n =: v)+hsonFieldToBsonField (HsonField n _) = + fail $ "hsonFieldToBsonField: field " ++ show n ++ " is PolicyLabeled"+++labeledRequestToHson :: Label l => Labeled l Request -> LIO l (Labeled l HsonDocument)+labeledRequestToHson lreq = do+ let origLabel = labelOf lreq+ let req = unlabelTCB lreq+ let body = mconcat . L8.toChunks $ requestBody req+ let q = map convert $ parseSimpleQuery body+ return $ labelTCB origLabel q+ where convert (k,v) = HsonField+ (T.pack . S8.unpack $ k)+ (toHsonValue . S8.unpack $ v)++--+-- Friendly interface for creating documents+--++-- | Class used to define fields.+class (Show v, Show f) => GenField v f where+ -- | Given a name and Haskell value construct either a 'HsonField'+ -- or a 'BsonField'+ (-:) :: FieldName -> v -> f++instance BsonVal v => GenField v BsonField where+ n -: v = n =: toBsonValue v+instance HsonVal v => GenField v HsonField where+ n -: v = n =: toHsonValue v+++--+-- To/From BsonValue+--++-- | Class used to (de)construct 'BsonValue's+class (Typeable a, Show a) => BsonVal a where+ -- | Convert to 'BsonValue'+ toBsonValue :: a -> BsonValue+ -- | Convert from 'BsonValue'+ fromBsonValue :: Monad m => BsonValue -> m a++instance BsonVal Double where+ toBsonValue = BsonFloat+ fromBsonValue (BsonFloat x) = return x+ fromBsonValue (BsonInt32 x) = return (fromIntegral x)+ fromBsonValue (BsonInt64 x) = return (fromIntegral x)+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Double of " ++ (show v)++instance BsonVal Float where+ toBsonValue = BsonFloat . realToFrac+ fromBsonValue (BsonFloat x) = return (realToFrac x)+ fromBsonValue (BsonInt32 x) = return (fromIntegral x)+ fromBsonValue (BsonInt64 x) = return (fromIntegral x)+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Float of " ++ (show v)++instance BsonVal Text where+ toBsonValue = BsonString+ fromBsonValue (BsonString x) = return x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Text of " ++ (show v)++instance BsonVal String where+ toBsonValue = BsonString . T.pack+ fromBsonValue (BsonString x) = return $ T.unpack x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to String of " ++ (show v)++instance BsonVal S8.ByteString where+ toBsonValue = BsonString . T.pack . S8.unpack+ fromBsonValue (BsonString x) = return $ S8.pack $ T.unpack x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to ByteString (Strict) of " ++ (show v)++instance BsonVal L8.ByteString where+ toBsonValue = BsonString . T.pack . L8.unpack+ fromBsonValue (BsonString x) = return $ L8.pack $ T.unpack x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to ByteString (Lazy) of " ++ (show v)++instance BsonVal BsonDocument where+ toBsonValue = BsonDoc+ fromBsonValue (BsonDoc x) = return x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to BsonDocument of " ++ (show v)++instance BsonVal [BsonValue] where+ toBsonValue = BsonArray+ fromBsonValue (BsonArray x) = return x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to [BsonValue] of " ++ (show v)++instance (BsonVal a) => BsonVal [a] where+ toBsonValue = BsonArray . map toBsonValue+ fromBsonValue (BsonArray x) = mapM fromBsonValue x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to [a] of " ++ (show v)++instance BsonVal Binary where+ toBsonValue = BsonBlob+ fromBsonValue (BsonBlob x) = return x+ fromBsonValue (BsonString x) = return $ Binary $ S8.pack $ T.unpack x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Binary of " ++ (show v)+++instance BsonVal ObjectId where+ toBsonValue = BsonObjId+ fromBsonValue (BsonObjId x) = return x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to ObjectId of " ++ (show v)++instance BsonVal Bool where+ toBsonValue = BsonBool+ fromBsonValue (BsonBool x) = return x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Bool of " ++ (show v)++instance BsonVal UTCTime where+ toBsonValue = BsonUTC+ fromBsonValue (BsonUTC x) = return x+ fromBsonValue v = fail $ "fromBsonValue: no conversion to UTCTime of " ++ (show v)++instance BsonVal (Maybe BsonValue) where+ toBsonValue Nothing = BsonNull+ toBsonValue (Just v) = v+ fromBsonValue BsonNull = return Nothing+ fromBsonValue v = return (Just v)++instance (BsonVal a) => BsonVal (Maybe a) where+ toBsonValue Nothing = BsonNull+ toBsonValue (Just a) = toBsonValue a+ fromBsonValue BsonNull = return Nothing+ fromBsonValue v = Just `liftM` fromBsonValue v++instance BsonVal Int32 where+ toBsonValue = BsonInt32+ fromBsonValue (BsonInt32 x) = return x+ fromBsonValue (BsonInt64 x) = fitInt x+ fromBsonValue (BsonFloat x) = return (round x)+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Int32 of " ++ (show v)++instance BsonVal Int64 where+ toBsonValue = BsonInt64+ fromBsonValue (BsonInt64 x) = return x+ fromBsonValue (BsonInt32 x) = return (fromIntegral x)+ fromBsonValue (BsonFloat x) = return (round x)+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Int64 of " ++ (show v)++instance BsonVal Int where+ toBsonValue n = maybe (BsonInt64 $ fromIntegral n) BsonInt32 (fitInt n)+ fromBsonValue (BsonInt32 x) = return (fromIntegral x)+ fromBsonValue (BsonInt64 x) = return (fromEnum x)+ fromBsonValue (BsonFloat x) = return (round x)+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Int of " ++ (show v)++instance BsonVal Integer where+ toBsonValue n = maybe (maybe err BsonInt64 $ fitInt n)+ BsonInt32 (fitInt n) + where err = error $ show n ++ " is too large for BsonInt{32,64}"+ fromBsonValue (BsonInt32 x) = return (fromIntegral x)+ fromBsonValue (BsonInt64 x) = return (fromIntegral x)+ fromBsonValue (BsonFloat x) = return (round x)+ fromBsonValue v = fail $ "fromBsonValue: no conversion to Integer of " ++ (show v)++--+-- To/From HsonValue+--+-- Lot of redundant instances to avoid use of gnarly GHC extensions+--++-- | Class used to (de)construct 'HsonValue's+class (Typeable a, Show a) => HsonVal a where+ -- | Convert to 'HsonValue'+ toHsonValue :: a -> HsonValue+ -- | Convert from 'HsonValue'+ fromHsonValue :: Monad m => HsonValue -> m a++instance HsonVal HsonValue where+ toHsonValue = id+ fromHsonValue = return++instance HsonVal Double where+ toHsonValue = HsonValue . BsonFloat+ fromHsonValue (HsonValue (BsonFloat x)) = return x+ fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)+ fromHsonValue (HsonValue (BsonInt64 x)) = return (fromIntegral x)+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Float where+ toHsonValue = HsonValue . BsonFloat . realToFrac+ fromHsonValue (HsonValue (BsonFloat x)) = return (realToFrac x)+ fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)+ fromHsonValue (HsonValue (BsonInt64 x)) = return (fromIntegral x)+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Text where+ toHsonValue = HsonValue . BsonString+ fromHsonValue (HsonValue (BsonString x)) = return x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal String where+ toHsonValue = HsonValue . BsonString . T.pack+ fromHsonValue (HsonValue (BsonString x)) = return $ T.unpack x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal BsonDocument where+ toHsonValue = HsonValue . BsonDoc+ fromHsonValue (HsonValue (BsonDoc x)) = return x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal [BsonValue] where+ toHsonValue = HsonValue . BsonArray+ fromHsonValue (HsonValue (BsonArray x)) = return x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance (HsonVal a, BsonVal a) => HsonVal [a] where+ toHsonValue = HsonValue . BsonArray . map toBsonValue+ fromHsonValue (HsonValue (BsonArray x)) = mapM fromBsonValue x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Binary where+ toHsonValue = HsonValue . BsonBlob+ fromHsonValue (HsonValue (BsonBlob x)) = return x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal ObjectId where+ toHsonValue = HsonValue . BsonObjId+ fromHsonValue (HsonValue (BsonObjId x)) = return x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Bool where+ toHsonValue = HsonValue . BsonBool+ fromHsonValue (HsonValue (BsonBool x)) = return x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal UTCTime where+ toHsonValue = HsonValue . BsonUTC+ fromHsonValue (HsonValue (BsonUTC x)) = return x+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal (Maybe BsonValue) where+ toHsonValue Nothing = HsonValue BsonNull+ toHsonValue (Just v) = HsonValue v+ fromHsonValue (HsonValue BsonNull) = return Nothing+ fromHsonValue (HsonValue v) = return (Just v)+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance (HsonVal a, BsonVal a) => HsonVal (Maybe a) where+ toHsonValue Nothing = HsonValue BsonNull+ toHsonValue (Just a) = HsonValue $ toBsonValue a+ fromHsonValue (HsonValue BsonNull) = return Nothing+ fromHsonValue (HsonValue v) = fromBsonValue v+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Int32 where+ toHsonValue = HsonValue . BsonInt32+ fromHsonValue (HsonValue (BsonInt32 x)) = return x+ fromHsonValue (HsonValue (BsonInt64 x)) = fitInt x+ fromHsonValue (HsonValue (BsonFloat x)) = return (round x)+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Int64 where+ toHsonValue = HsonValue . BsonInt64+ fromHsonValue (HsonValue (BsonInt64 x)) = return x+ fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)+ fromHsonValue (HsonValue (BsonFloat x)) = return (round x)+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Int where+ toHsonValue n = HsonValue $ maybe (BsonInt64 $ fromIntegral n)+ BsonInt32 (fitInt n)+ fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)+ fromHsonValue (HsonValue (BsonInt64 x)) = return (fromEnum x)+ fromHsonValue (HsonValue (BsonFloat x)) = return (round x)+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal Integer where+ toHsonValue n = HsonValue $ maybe (maybe err BsonInt64 $ fitInt n)+ BsonInt32 (fitInt n) + where err = error $ show n ++ " is too large for HsonInt{32,64}"+ fromHsonValue (HsonValue (BsonInt32 x)) = return (fromIntegral x)+ fromHsonValue (HsonValue (BsonInt64 x)) = return (fromIntegral x)+ fromHsonValue (HsonValue (BsonFloat x)) = return (round x)+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal BsonValue where+ toHsonValue = HsonValue+ fromHsonValue (HsonValue v) = return v+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance HsonVal PolicyLabeled where+ toHsonValue = HsonLabeled+ fromHsonValue (HsonLabeled v) = return v+ fromHsonValue _ = fail "fromHsonValue: no conversion"++instance Show (DCLabeled BsonValue) where+ show lv = " -UNKNOWN VALUE- {" ++ show (labelOf lv) ++ "}"+ +instance HsonVal (DCLabeled BsonValue) where+ toHsonValue = HsonLabeled . hasPolicy+ fromHsonValue (HsonLabeled v) = getPolicyLabeled v+ fromHsonValue _ = fail "fromHsonValue: no conversion"+++--+-- ObjectId+--++-- | Create a fresh ObjectId.+genObjectId :: MonadDC m => m ObjectId+genObjectId = liftLIO $ ioTCB Bson.genObjectId++--+-- Helpers+--+ ++-- | From "Data.Bson": Cast number to end type, if it \"fits\".+fitInt :: forall a b m. (Integral a, Integral b, Bounded b, Monad m)+ => a -> m b+fitInt n = if fromIntegral (minBound :: b) <= n+ && n <= fromIntegral (maxBound :: b)+ then return $ fromIntegral n+ else fail "fitInt: number is too big"+
+ Hails/Data/Hson/TCB.hs view
@@ -0,0 +1,298 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE DeriveDataTypeable #-}++{- |+++This module exports the type for a Hails BSON document, 'HsonDoc'. A+Hails document is akin to "Data.Bson"\'s documents, but differs in two+ways. First, Hails restricts the number of types to a subset of BSON's+(see 'BsonVal'). This restriction is primarily due to the fact that+many of the BSON types are redundant and not used (at least within+Hails). Second, Hails allows for documents to contain policy-labeled+values.++Policy labeled values ('PolicyLabeled') are permitted only at the+\"top-level\" of a document. (This is primarily done to keep+policy-specification simple and may change in the future.)+Consequently to allow for nested documents and documents containing an+array of values we separate top-level fields ('HsonField'), that may+contain policy labeled values, from potentially-nested fields+('BsonField'). A top-level field 'HsonField' is thus either a+'BsonField' or a 'PolicyLabled' value.++To keep the TCB compact, this module does not export the combinators+used to create documents in a friendly fashion. See "Hails.Data.Hson"+for the safe external API.+++/Credit:/ Much of this code is based on/reuses "Data.Bson".+-}++module Hails.Data.Hson.TCB (+ -- * Documents+ HsonDocument, BsonDocument+ -- * Fields+ , FieldName, HsonField(..), BsonField(..)+ -- * Values+ , HsonValue(..), BsonValue(..)+ , PolicyLabeled(..), ObjectId(..), Binary(..), S8+ -- * Marshall to/from "Data.Bson"+ , hsonDocToDataBsonDocTCB + , dataBsonDocToHsonDocTCB + , bsonDocToDataBsonDocTCB + , dataBsonValueToHsonValueTCB + -- * Internal+ , add__hails_prefix + ) where++import Data.Text (Text)+import qualified Data.Text as T+import Data.Int (Int32, Int64)+import Data.Time.Clock (UTCTime)+import Data.Typeable+import qualified Data.Bson as Bson+import qualified Data.Bson.Binary as Bson+import Data.Bson ( ObjectId(..) )+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import qualified Data.Binary.Put as Binary+import qualified Data.Binary.Get as Binary++import LIO.Labeled.TCB (unlabelTCB)+import LIO.DCLabel++-- | Strict ByeString+type S8 = S8.ByteString+++++--+-- Document+--++-- | A top-level document containing 'HsonField's.+type HsonDocument = [HsonField]++-- | A (possibly top-)level document containing 'BsonField's.+type BsonDocument = [BsonField]++--+-- Fields+--++-- | The name of a field.+type FieldName = Text++-- | A field containing a named 'BsonValue'+data BsonField = BsonField !FieldName BsonValue+ deriving (Typeable, Eq, Ord)++-- | A field containing a named 'HsonValue'+data HsonField = HsonField !FieldName HsonValue+ deriving (Typeable, Eq, Ord)++--+-- Values+--++-- | A @BsonValue@ is a subset of BSON ("Data.Bson") values. Note that a+-- @BsonValue@ cannot contain any labeled values; all labeled values+-- occur in a document as 'HsonValue's. Correspondingly, @BsonValue@s+-- may be arbitrarily nested.+data BsonValue = BsonFloat Double+ -- ^ Float value+ | BsonString Text+ -- ^ String value+ | BsonDoc BsonDocument+ -- ^ Inner document+ | BsonArray [BsonValue]+ -- ^ List of values+ | BsonBlob Binary+ -- ^ Binary blob value+ | BsonObjId ObjectId+ -- ^ Object Id value+ | BsonBool Bool+ -- ^ Boolean value+ | BsonUTC UTCTime+ -- ^ Time stamp value+ | BsonNull+ -- ^ The @NULL@ value+ | BsonInt32 Int32+ -- ^ 32-bit integer+ | BsonInt64 Int64+ -- ^ 64-bit integer+ deriving (Typeable, Eq, Ord)++-- | An @HsonValue@ is a top-level value that may either be a+-- 'BsonValue' or a policy labeled value. The separation of values+-- into 'BsonValue' and 'HsonValue' is solely due to the restriction+-- that policy-labeled values may only occur at the top level and+-- 'BsonValue's may be nested (e.g. using 'BsonArray' and 'BsonDoc').+data HsonValue = HsonValue BsonValue+ -- ^ Bson value+ | HsonLabeled PolicyLabeled+ -- ^ Policy labeled value+ deriving (Typeable, Eq, Ord)++-- | A @PolicyLabeled@ value can be either an unlabeled value for which+-- the policy needs to be applied (@NeedPolicyTCB@), or an already+-- labeled value (@HasPolicyTCB@). @PolicyLabeled@ is a partially-opaque+-- type; code should not be able to inspect the value of an unlabeleda+-- value, but may inspect an already labeled value.+data PolicyLabeled = NeedPolicyTCB BsonValue+ -- ^ Policy was not applied + | HasPolicyTCB (DCLabeled BsonValue)+ -- ^ Policy applied+ deriving (Typeable)++instance Eq PolicyLabeled where (==) _ _ = True+instance Ord PolicyLabeled where (<=) _ _ = False+instance Show PolicyLabeled where show _ = "PolicyLabeled"+++-- | Arbitrary binary blob+newtype Binary = Binary { unBinary :: S8 }+ deriving (Typeable, Show, Read, Eq, Ord)+++--+-- Convert to "Data.Bson"+--++-- | Convert 'HsonValue' to a "Data.Bson" @Value@. Note that+-- 'PolicyLabeled' values are marshalled out as "Data.Bson" @UserDefined@+-- values. This means that the @UserDefined@ type is reserved and+-- exposing it as a type in 'BsonValue' would potentially lead to leaks.+-- Note that the label is /NOT/ serialized, only the value. Hence,+-- after marshalling such that back it is important that a policy is +-- applied to label the field.+hsonToDataBsonTCB :: HsonValue -> Bson.Value+hsonToDataBsonTCB (HsonValue b) = bsonToDataBsonTCB b+hsonToDataBsonTCB (HsonLabeled (HasPolicyTCB lv)) =+ toUserDef . hsonDocToDataBsonDocTCB $ + [ HsonField __hails_HsonLabeled_value $ HsonValue (unlabelTCB lv) ]+ where toUserDef = Bson.UserDef+ . Bson.UserDefined+ . strictify+ . Binary.runPut+ . Bson.putDocument+ strictify = S8.concat . L.toChunks+hsonToDataBsonTCB _ =+ error $ "hsonToDataBsonTCB: all policy labeled values" +++ " must have labeled values"++-- | Convert 'BsonValue' to a "Data.Bson" @Value@.+bsonToDataBsonTCB :: BsonValue -> Bson.Value+bsonToDataBsonTCB bv = case bv of+ (BsonFloat d) -> Bson.Float d+ (BsonString t) -> Bson.String t+ (BsonDoc d) -> Bson.Doc $ bsonDocToDataBsonDocTCB d+ (BsonArray hs) -> Bson.Array $ bsonToDataBsonTCB `map` hs+ (BsonBlob b) -> Bson.Bin . Bson.Binary . unBinary $ b+ (BsonObjId oid) -> Bson.ObjId oid+ (BsonBool b) -> Bson.Bool b+ (BsonUTC t) -> Bson.UTC t+ BsonNull -> Bson.Null + (BsonInt32 i) -> Bson.Int32 i+ (BsonInt64 i) -> Bson.Int64 i+++-- | Convert an 'HsonField' to a "Data.Bson" @Field@.+hsonFieldToDataBsonFieldTCB :: HsonField -> Bson.Field+hsonFieldToDataBsonFieldTCB (HsonField n v) =+ (Bson.:=) n (hsonToDataBsonTCB v)++-- | Convert a top-level document (i.e., 'HsonDocument') to a "Data.Bson"+-- @Document@. This is the primary marshall-out function. All+-- 'PolicyLabeled' values are marshalled out as "Data.Bson" @UserDefined@+-- values. This means that the @UserDefined@ type is reserved and+-- exposing it as a type in 'BsonValue' would potentially lead to+-- vulnerabilities in which labeled values can be marshalled in from+-- well-crafted ByteStrings. Moreover, untrusted code should not have+-- access to this function; having such access would allow it to+-- inspect the serialized labeled values and thus violate IFC.+hsonDocToDataBsonDocTCB :: HsonDocument -> Bson.Document+hsonDocToDataBsonDocTCB = map hsonFieldToDataBsonFieldTCB++-- | Convert a 'BsonField' to a "Data.Bson" @Field@.+bsonFieldToDataBsonFieldTCB :: BsonField -> Bson.Field+bsonFieldToDataBsonFieldTCB (BsonField n v) =+ (Bson.:=) n (bsonToDataBsonTCB v)++-- | Convert a 'BsonDocument' to a "Data.Bson" @Document@.+bsonDocToDataBsonDocTCB :: BsonDocument -> Bson.Document+bsonDocToDataBsonDocTCB = map bsonFieldToDataBsonFieldTCB+++--+-- Convert from "Data.Bson"+--++-- | Convert a "Data.Bson" @Field@ to 'BsonField'.+dataBsonFieldToBsonFieldTCB :: Bson.Field -> BsonField+dataBsonFieldToBsonFieldTCB ((Bson.:=) n v) = BsonField n (dataBsonToBsonTCB v)++-- | Convert a "Data.Bson" @Document@ to a 'BsonDocument'.+dataBsonDocToBsonDocTCB :: Bson.Document -> BsonDocument+dataBsonDocToBsonDocTCB = map dataBsonFieldToBsonFieldTCB++-- | Convert "Data.Bson" @Value@ to a 'BsonValue'.+dataBsonToBsonTCB :: Bson.Value -> BsonValue+dataBsonToBsonTCB bv = case bv of+ (Bson.Float d) -> BsonFloat d+ (Bson.String t) -> BsonString t+ (Bson.Doc d) -> BsonDoc $ dataBsonDocToBsonDocTCB d+ (Bson.Array hs) -> BsonArray $ dataBsonToBsonTCB `map` hs+ (Bson.Bin (Bson.Binary b)) -> BsonBlob . Binary $ b+ (Bson.ObjId oid) -> BsonObjId oid+ (Bson.Bool b) -> BsonBool b+ (Bson.UTC t) -> BsonUTC t+ Bson.Null -> BsonNull + (Bson.Int32 i) -> BsonInt32 i+ (Bson.Int64 i) -> BsonInt64 i+ _ -> error "dataBsonToBsonTCB: only support subset of BSON"+++-- | Convert "Data.Bson" @Document@ to a 'HsonDocument'. This is the+-- top-level function that marshalls BSON documents to Hails+-- documents. This function assumes that all documents have been+-- marshalled out using 'hsonDocToDataBsonDocTCB'. Otherwise, the+-- 'PolicyLabled' values that are created from the document may be+-- forged.+dataBsonDocToHsonDocTCB :: Bson.Document -> HsonDocument+dataBsonDocToHsonDocTCB =+ map (\((Bson.:=) n bv) -> HsonField n $ dataBsonValueToHsonValueTCB bv)++-- |Convert a "Data.Bson" @Value@ to a 'HsonValue'. See+-- 'dataBsonDocToHsonDocTCB'.+dataBsonValueToHsonValueTCB :: Bson.Value -> HsonValue+dataBsonValueToHsonValueTCB bv = case bv of+ (Bson.UserDef (Bson.UserDefined b)) ->+ let bdoc = Binary.runGet Bson.getDocument (lazyfy b)+ in case maybePolicyLabeledTCB bdoc of+ Nothing -> error $ "dataBsonValueToHsonValueTCB: "+ ++ "Expected PolicyLabeled"+ Just lv -> HsonLabeled lv+ v -> HsonValue $ dataBsonToBsonTCB v+ where lazyfy x = L8.fromChunks [x]++++-- | Hails internal field name for a policy labeled value (label part)+-- (name part).+__hails_HsonLabeled_value :: FieldName+__hails_HsonLabeled_value = add__hails_prefix $ T.pack "HsonLabeled_value"++-- | Hails internal prefix that is used to serialized labeled values.+add__hails_prefix :: FieldName -> FieldName+add__hails_prefix t = T.pack "__hails_" `T.append` t+++-- | Convert a "Data.Bson" @Document@ to a policy labeled value.+maybePolicyLabeledTCB :: Bson.Document -> Maybe PolicyLabeled+maybePolicyLabeledTCB doc = do+ v <- Bson.look __hails_HsonLabeled_value doc+ return . NeedPolicyTCB $ dataBsonToBsonTCB v
− Hails/Data/LBson.hs
@@ -1,7 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe #-}-#endif--module Hails.Data.LBson ( module Hails.Data.LBson.Safe ) where-import Hails.Data.LBson.Safe
− Hails/Data/LBson/Rexports.hs
@@ -1,28 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif---- | Moduule rexport Bson Value value-constructors-module Hails.Data.LBson.Rexports( Value ( Float- , String- , Doc- , Array- , Bin- , Fun- , Uuid- , Md5- , UserDef- , ObjId- , Bool- , UTC- , Null- , RegEx- , JavaScr- , Sym- , Int32- , Int64- , Stamp- , MinMax )- ) where-import Data.Bson
− Hails/Data/LBson/Rexports/Bson.hs
@@ -1,9 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Trustworthy #-}-#endif---- | Rexports "Data.Bson"-module Hails.Data.LBson.Rexports.Bson ( module Data.Bson ) where--import Data.Bson
− Hails/Data/LBson/Safe.hs
@@ -1,51 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--{- | This module exports a safe subset of the labeled BSON (LBSON)- module. See "Hails.Data.LBson.TCB" for documentation.--}--module Hails.Data.LBson.Safe ( -- * UTF-8 String- module Data.UString- -- * Document- , Document, LabeledDocument- , look, lookup- , valueAt, at, include, exclude, merge- -- * Field- , Field(..), (=:), (=?)- , Key- , hailsInternalKeyPrefix - -- * Value- , Value, Val, val, cast', cast, typed- -- * Policy labeled values- , pu, pl- -- * Special Bson value types- , Binary(..)- , Function(..)- , UUID(..)- , MD5(..)- , UserDefined(..)- , Regex(..)- , Javascript(..)- , Symbol(..)- , MongoStamp(..)- , MinMaxKey(..)- -- ** ObjectId- , ObjectId(..)- , timestamp- , genObjectId-- -- * Convert to/from "Data.Bson"- , BsonValue- , module Hails.Data.LBson.Rexports- , safeToBsonValue, safeFromBsonValue- , BsonDocument, safeToBsonDoc, safeFromBsonDoc- -- * Convert to/from Bytestring- , encodeDoc, decodeDoc- ) where-import Prelude hiding (lookup)-import Hails.Data.LBson.TCB-import Data.UString-import Hails.Data.LBson.Rexports hiding (Value)
− Hails/Data/LBson/TCB.hs
@@ -1,493 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif-{- | This module exports an interface for LBSON (Labeled BSON) object.- An LBSON object is either a BSON object (see 'Data.Bson') with the- added support for labeled 'Value's. More specifically, a LBSON- document is a list of 'Field's (which are 'Key'-'Value' pairs),- where the 'Value' of a 'Field' can either be a standard- 'Data.Bson.Value' type or a 'Labeled' 'Value' type.--}-{-# LANGUAGE Rank2Types #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE OverlappingInstances #-}--module Hails.Data.LBson.TCB ( -- * UTF-8 String- module Data.UString- -- * Document- , Document, LabeledDocument- , look, lookup, valueAt, at, include, exclude, merge- -- * Field- , Field(..), (=:), (=?)- , Key- , hailsInternalKeyPrefix - , isUnsafeKey- -- * Value- , Value(..), Val(..), cast, typed- -- * Policy labeled values- , PolicyLabeled(..), pu, pl- -- * Special Bson value types- , Binary(..)- , Function(..)- , UUID(..)- , MD5(..)- , UserDefined(..)- , Regex(..)- , Javascript(..)- , Symbol(..)- , MongoStamp(..)- , MinMaxKey(..)- -- ** ObjectId- , ObjectId(..)- , timestamp- , genObjectId- -- * Serializing Value, converting to Bson documents- , BsonValue- , safeToBsonValue, safeFromBsonValue- , BsonDocument, safeToBsonDoc, safeFromBsonDoc- , encodeDoc, decodeDoc- -- Unsafe converters- , toBsonDoc- , fromBsonDoc, fromBsonDocStrict- , sanitizeBsonValue- ) where---import Prelude hiding (lookup,)-import Data.UString (UString, u, unpack)-import qualified Data.Bson as Bson-import Data.Bson ( Binary(..)- , Function(..)- , UUID(..)- , MD5(..)- , UserDefined(..)- , Regex(..)- , Javascript(..)- , Symbol(..)- , MongoStamp(..)- , MinMaxKey(..)- , ObjectId(..)- , timestamp- )-import Data.Bson.Binary (putDocument, getDocument)-import Data.Binary.Get (runGet)-import Data.Binary.Put (runPut)-import qualified Data.ByteString.Lazy as L--import Data.Maybe-import Data.List (find, findIndex)-import Data.Typeable hiding (cast)-import Data.CompactString.UTF8 (append, isPrefixOf)-import Data.Serialize (Serialize, encode, decode)--import Control.Monad-import Control.Monad.Identity (runIdentity)--import LIO-import LIO.TCB (labelTCB, unlabelTCB, rtioTCB)-#if DEBUG-import LIO.TCB (showTCB)-#endif------- Document related-------- | A 'Key', or attribute is a BSON label.-type Key = Bson.Label---- | A LBSON document is a list of 'Field's-type Document l = [Field l]---- | A labeled 'Document'-type LabeledDocument l = Labeled l (Document l)---- | Value of field in document, or fail (Nothing) if field not found-look :: (Monad m, Label l) => Key -> Document l -> m (Value l)-look k doc = maybe notFound (return . value) (find ((k ==) . key) doc)- where notFound = fail $ "expected " ++ show k---- | Lookup value of field in document and cast to expected--- type. Fail (Nothing) if field not found or value not of expected--- type.-lookup :: (Val l v, Monad m, Label l) => Key -> Document l -> m v-lookup k doc = cast =<< look k doc----- | Value of field in document. Error if missing.-valueAt :: Label l => Key -> [Field l] -> Value l-valueAt k = runIdentity . look k---- | Typed value of field in document. Error if missing or wrong type.-at :: forall v l. (Val l v, Label l) => Key -> Document l -> v-at k doc = fromMaybe err (lookup k doc)- where err = error $ "expected (" ++ show k ++ " :: "- ++ show (typeOf (undefined :: v)) ++ ") in " ++ show doc---- | Only include fields of document in key list-include :: Label l => [Key] -> Document l -> Document l-include keys doc = mapMaybe (\k -> find ((k ==) . key) doc) keys---- | Exclude fields from document in key list-exclude :: Label l => [Key] -> Document l -> Document l-exclude keys = filter (\(k := _) -> notElem k keys)---- | Merge documents with preference given to first one when both--- have the same key. I.e. for every (k := v) in first argument,--- if k exists in second argument then replace its value with v,--- otherwise add (k := v) to second argument.-merge :: Label l => Document l -> Document l -> Document l-merge es doc' = foldl f doc' es where- f doc (k := v) = case findIndex ((k ==) . key) doc of- Nothing -> doc ++ [k := v]- Just i -> let (x, _ : y) = splitAt i doc in x ++ [k := v] ++ y------- Field related-----infix 0 :=, =:, =?---- | A @Field@ is a 'Key'-'Value' pair.-data Field l = (:=) { key :: !Key- , value :: Value l }- deriving (Eq, Typeable)--instance Label l => Show (Field l) where- showsPrec d (k := v) = showParen (d > 0) $- showString (' ' : unpack k) . showString ": " . showsPrec 1 v------ | Field with given label and typed value-(=:) :: (Val l v, Label l) => Key -> v -> Field l-k =: v = k := val v---- | If @Just@ value then return one field document, otherwise--- return empty document-(=?) :: (Val l a, Label l) => Key -> Maybe a -> Document l-k =? ma = maybeToList (fmap (k =:) ma)------- Value related------- | A @Value@ is either a standard BSON value, a labeled value, or--- a policy-labeled value.-data Value l = BsonVal Bson.Value- -- ^ Unlabeled BSON value- | LabeledVal (Labeled l Bson.Value)- -- ^ Labeled (LBSON) value- | PolicyLabeledVal (PolicyLabeled l Bson.Value)- -- ^ Policy labeled (LBSON) value- deriving (Typeable)---- | Instance for @Show@, only showing unlabeled BSON values.-instance Label l => Show (Value l) where- show (BsonVal v) = show v-#if DEBUG- show (LabeledVal lv) = showTCB lv- show (PolicyLabeledVal lv) = show lv-#else- show _ = "{- HIDING DATA -} "-#endif---- | Instance for @Eq@, only comparing unlabeled BSON values.-instance Label l => Eq (Value l) where- (==) (BsonVal v1) (BsonVal v2) = v1 == v2- (==) _ _ = False----- | Haskell types of this class correspond to LBSON value types.-class (Typeable a, Show a, Eq a, Label l) => Val l a where- val :: a -> Value l- cast' :: Value l -> Maybe a---- | Every type that is an instance of BSON Val is an instance of--- LBSON Val. This requires the use of @OverlappingInstances@--- extension.-instance (Bson.Val a, Label l) => Val l a where- val = BsonVal . Bson.val- cast' (BsonVal v) = Bson.cast' v- cast' _ = Nothing- --- | Every 'Value' is a 'Val'.-instance (Label l) => Val l (Value l) where- val = id- cast' = Just---- | Convert between a labeled value and a labeled BSON value.-instance (Bson.Val a, Label l) => Val l (Labeled l a) where- val lv = let l = labelOf lv- v = unlabelTCB lv- in LabeledVal $ labelTCB l (Bson.val v)- cast' (LabeledVal lv) = let l = labelOf lv- v = unlabelTCB lv- in Bson.cast' v >>= return . labelTCB l- cast' _ = Nothing---- | Convert between a policy-labeled value and a labeled BSON value.-instance (Bson.Val a, Label l) => Val l (PolicyLabeled l a) where- val (PU x) = PolicyLabeledVal . PU . Bson.val $ x- val (PL lv) = let l = labelOf lv- v = unlabelTCB lv- in PolicyLabeledVal . PL $ labelTCB l (Bson.val v)- cast' (PolicyLabeledVal (PU v)) = Bson.cast' v >>= return . PU- cast' (PolicyLabeledVal (PL lv)) = let l = labelOf lv- v = unlabelTCB lv- in Bson.cast' v >>=- return . PL . labelTCB l- cast' _ = Nothing----- | Convert Value to expected type, or fail (Nothing) if not of that type-cast :: forall m l a. (Label l, Val l a, Monad m) => Value l -> m a-cast v = maybe notType return (cast' v)- where notType = fail $ "expected " ++ show (typeOf (undefined :: a))- ++ ": " ++ show v----- | Convert Value to expected type. Error if not that type.-typed :: (Val l a, Label l) => Value l -> a-typed = runIdentity . cast------- Misc.-------- | Necessary instance that just fails.-instance (Show a, Label l) => Show (Labeled l a) where-#if DEBUG- show = showTCB -#else- show = error "Instance of show for Labeled not supported"-#endif---- | Necessary instance that just fails.-instance Label l => Eq (Labeled l a) where- (==) = error "Instance of Eq for Labeled not supported"---- | Generate fresh 'ObjectId'.-genObjectId :: LabelState l p s => LIO l p s ObjectId-genObjectId = rtioTCB $ Bson.genObjectId-------- Policy labeled values------- | Simple sum type used to denote a policy-labeled type. A--- @PolicyLabeled@ type can be either labeled (policy applied),--- or unabled (policy not yet applied).-data PolicyLabeled l a = PU a -- ^ Policy was not applied - | PL (Labeled l a) -- ^ Policy applied- deriving (Typeable)---- | Wrap an unlabeled value by 'PolicyLabeled'.-pu :: (Label l, Bson.Val a) => a -> PolicyLabeled l a-pu = PU---- | Wrap an already-labeled value by 'PolicyLabeled'.-pl :: (Label l, Bson.Val a) => Labeled l a -> PolicyLabeled l a-pl = PL---- | Necessary instance that just fails.-instance (Show a, Label l) => Show (PolicyLabeled l a) where-#if DEBUG- show (PU x) = show x - show (PL x) = showTCB x -#else- show = error "Instance of show for PolicyLabeled not supported"-#endif---- | Necessary instance that just fails.-instance Label l => Eq (PolicyLabeled l a) where- (==) = error "Instance of show for PolicyLabeled not supported"------- Serializing 'Value's------- | Export 'Bson.Value'-type BsonValue = Bson.Value---- | Safely convert from a 'Value' to a 'BsonValue'.-safeToBsonValue :: (Label l) => Value l -> Maybe BsonValue-safeToBsonValue (BsonVal v) = Just v-safeToBsonValue _ = Nothing---- | Safely convert from a 'BsonValue' to a 'Value'.-safeFromBsonValue :: (Serialize l, Label l) => BsonValue -> Maybe (Value l)-safeFromBsonValue v' = case fromBsonValue v' of- mv@(Just (BsonVal _)) -> mv- _ -> Nothing---- | Export 'Bson.Document'-type BsonDocument = Bson.Document---- | Safe version of 'toBsonDoc'.-safeToBsonDoc :: (Serialize l, Label l) => Document l -> Maybe BsonDocument-safeToBsonDoc = mapM (\(k := v) -> do v' <- safeToBsonValue v- return (k Bson.:= v')) . exceptInternal---- | Safe version of 'fromBsonDoc'.-safeFromBsonDoc :: (Serialize l, Label l) => BsonDocument -> Maybe (Document l)-safeFromBsonDoc d = do- d' <- forM d $ \(k Bson.:= v) -> do v' <- safeFromBsonValue v- return (k := v')- return $ exceptInternal d'---- | Convert a 'Document' to a Bson @Document@. It is an error to call--- this function with malformed 'Document's (i.e., those for which--- a policy has not been applied.-toBsonDoc :: (Serialize l, Label l) => Document l -> Bson.Document-toBsonDoc = map (\(k := v) -> (k Bson.:= toBsonValue v)) . exceptInternal---- | Convert a Bson @Document@ to a 'Document'. This implementation is--- relaxed and omits any fields that were not converted. Use the--- 'fromBsonDocStrict' for a strict conversion. -fromBsonDoc :: (Serialize l, Label l) => Bson.Document -> Document l-fromBsonDoc d = - let cs' = map (\(k Bson.:= v) -> (k, fromBsonValue v)) d- cs = map (\(k, Just v) -> k := v) $ filter (isJust . snd) cs'- in exceptInternal cs---- | Same as 'fromBsonDoc', but fails (returns @Nothing@) if any of--- the field values failed to be serialized.-fromBsonDocStrict :: (Serialize l, Label l)- => Bson.Document -> Maybe (Document l)-fromBsonDocStrict d = - let cs' = map (\(k Bson.:= v) -> (k, fromBsonValue v)) d- cs = map (\(k, Just v) -> k := v) $ filter (isJust . snd) cs'- ok = all (isJust .snd) cs'- in if ok then Just . exceptInternal $ cs else Nothing---- | Check if a key is unsafe.-isUnsafeKey :: Key -> Bool-isUnsafeKey k = or- [ hailsInternalKeyPrefix `isPrefixOf` k - , (u "$") `isPrefixOf` k- ]---- | If value is a document, remove any fields that have--- 'hailsInternalKeyPrefix' as a prefix, otherwise return the value--- unchanged. This is equivilant to 'exceptInternal' except it--- operates on BSON values as opposed to Hails Documents.-sanitizeBsonValue :: Bson.Value -> Bson.Value-sanitizeBsonValue (Bson.Doc doc) = Bson.Doc $ doExcludes doc- where doExcludes [] = []- doExcludes (f@(k Bson.:= _):fs) =- let rest = doExcludes fs- in if isUnsafeKey k- then rest- else f:rest-sanitizeBsonValue v = v---- | Remove any fields from the document that have--- 'hailsInternalKeyPrefix' as a prefix-exceptInternal :: Label l => Document l -> Document l-exceptInternal [] = []-exceptInternal (f@(k := _):fs) =- let rest = exceptInternal fs- in if isUnsafeKey k- then rest- else f:rest---- | This prefix is reserved for HAILS keys. It should not be used by--- arbitrary code.-hailsInternalKeyPrefix :: Key-hailsInternalKeyPrefix = u "__hails_internal_"---- | Serializing a 'Labeled' to a BSON @Document@ with key --- @lBsonLabeledValKey@.-lBsonLabeledValKey :: Key-lBsonLabeledValKey = hailsInternalKeyPrefix `append` u "Labeled"---- | Serializing a 'PolicyLabeled' to a BSON @Document@ with key --- @lBsonPolicyLabeledValKey@.-lBsonPolicyLabeledValKey :: Key-lBsonPolicyLabeledValKey = hailsInternalKeyPrefix `append` u "PolicyLabeled"---- | When serializing a 'Labeled' we serialize it to a document--- containing the label and value, the key for the label is--- @lBsonLabelKey@.-lBsonLabelKey :: Key-lBsonLabelKey = u "label"---- | When serializing a 'Labeled' (or 'PolicyLabeled') we serialize--- it to a document containing the value, the key for the value--- is @lBsonValueKey@.-lBsonValueKey :: Key-lBsonValueKey = u "value"---- | Convert 'Value' to Bson @Value@-toBsonValue :: (Serialize l, Label l) => Value l -> Bson.Value-toBsonValue mV = - case mV of - (BsonVal v) -> v- (LabeledVal lv) -> Bson.val [ lBsonLabeledValKey Bson.=:- [ lBsonLabelKey Bson.=: Binary (encode (labelOf lv))- , lBsonValueKey Bson.:= unlabelTCB lv ] ]- (PolicyLabeledVal (PL lv)) -> Bson.val [ lBsonPolicyLabeledValKey Bson.=:- [ lBsonValueKey Bson.:= unlabelTCB lv ] ]- (PolicyLabeledVal (PU _)) -> error "toBsonValue: Invalid use (PU _)."----- | Convert Bson @Value@ to 'Value'-fromBsonValue :: (Serialize l, Label l) => Bson.Value -> Maybe (Value l)-fromBsonValue mV =- case mV of- x@(Bson.Doc d) ->- let haveL = isJust $ Bson.look lBsonLabeledValKey d- havePL = isJust $ Bson.look lBsonPolicyLabeledValKey d- in if haveL || havePL- then getLabeled d `orMaybe` getPolicyLabeled d- else Just (BsonVal x)- x -> Just (BsonVal x)- where getLabeled :: (Serialize l, Label l) => Bson.Document -> Maybe (Value l)- getLabeled d = do- (Bson.Doc lv) <- Bson.look lBsonLabeledValKey d- (Binary b) <- Bson.lookup lBsonLabelKey lv- l <- either (const Nothing) return (decode b)- v <- Bson.look lBsonValueKey lv- return . LabeledVal $ labelTCB l v- --- getPolicyLabeled :: (Serialize l, Label l)- => Bson.Document -> Maybe (Value l)- getPolicyLabeled d = do- (Bson.Doc lv) <- Bson.look lBsonPolicyLabeledValKey d- v <- Bson.look lBsonValueKey lv- return . PolicyLabeledVal . PU $ v- --- orMaybe :: Maybe a -> Maybe a -> Maybe a- orMaybe x y = if isJust x then x else y-------- Encoding/decoding Bson documents------- | Class used to encode/decode 'BsonDocument's, and 'Document's that--- do not have 'PolicyLabeled' or 'Labeled' values.-class BsonDocSerialize doc where- encodeDoc :: doc -> L.ByteString- -- ^ Encodea document- decodeDoc :: L.ByteString -> doc- -- ^ Decode a document--instance BsonDocSerialize BsonDocument where- encodeDoc doc' = let (Bson.Doc doc) = sanitizeBsonValue . Bson.Doc $ doc'- in runPut $ putDocument doc- decodeDoc bs = let (Bson.Doc doc) = sanitizeBsonValue- . Bson.Doc $ runGet getDocument bs- in doc--instance (Serialize l, Label l) => BsonDocSerialize (Document l) where- encodeDoc = encodeDoc . fromJust . safeToBsonDoc- decodeDoc = fromJust . safeFromBsonDoc . decodeDoc
Hails/Database.hs view
@@ -1,73 +1,99 @@-{-# LANGUAGE Trustworthy, ScopedTypeVariables #-}+{-# LANGUAGE Trustworthy #-} -module Hails.Database ( mkPolicy, withDB ) where+{- | -import Data.Typeable-import LIO.MonadCatch-import LIO.DCLabel-import LIO.TCB-import DCLabel.Core-import Data.String.Utils-import Hails.Database.MongoDB.TCB.Types-import Hails.Database.MongoDB.TCB.DCAccess-import qualified Data.UString as U-import System.Environment-import qualified Data.ByteString.Char8 as C+This module exports the database interface used by apps and policy+modules to carry out database queries. The Hails data model is similar+to that of MongoDB. Below we highlight some similarities and+difference. We refer the interested reader to the documentation in+"Hails.PolicyModule" for more details on the role of labels in Hails. --- | Given a principal corresponding to the database owner and a--- database name create the corresponding database object in @LIO@.-loadDatabase :: DatabasePolicy dbp- => Principal- -> DatabaseName- -> (DC dbp)-loadDatabase dbPrincipal dbName = do- let policyPriv = createPrivTCB $ newPriv dbPrincipal- let dbConf = DBConf dbName policyPriv- clr <- getClearance- lowerClrTCB $ newDC dbPrincipal (<>)- res <- createDatabasePolicy dbConf policyPriv- lowerClrTCB clr- return res+At the coarsest level code can execute database actions ('DBAction')+against the 'Database' of a policy module using 'withPolicyModule'.+Different from MongoDB's notion of a database, Hails databases have an+associated 'Label' which is used to restrict who can access the+database. --- | Create a @DatabasePolicy@ with the appropriate underline databse--- name and privileges, determined by the actual instance requested.-mkPolicy :: forall dbp. (DatabasePolicy dbp, Typeable dbp) => DC dbp-mkPolicy = do- let tp = typeRepTyCon $ typeOf $ (undefined :: dbp)- let typeName = tyConPackage tp ++ ":" ++ tyConModule tp ++- "." ++ tyConName tp- dbs <- ioTCB $ databases- maybe (err typeName) doit $ lookup typeName dbs- where doit (dbName, dbPrincipal) = loadDatabase dbPrincipal dbName- err tn = throwIO . userError $ "mkPolicy: could not find policy for "- ++ tn+Each 'Database' is composed of a set of 'Collection's. The existence+of a collection is protected by a collection-set label, which is,+intern, protected by the database label. A collection is an approach+to organizing and grouping elements of the same model. For example,+collection \"users\" may contain elements (documents) corresponding to+users of the system. Each collection has a label, clearance, and+associated collection policy. The label of a collection serves the+same role as the database label, but at a finer grain: it protects who+can read and write to the collection. The collection clearance is also+a label, but its role is to set an upper bound on the sensitivity of+data that is and can be stored in the collection. For example, the+collection \"user\" may set a clearance such that the system\'s+private keys cannot be stored in the collection (by accident or+malice). The collection policy specifies how elements of the+collection are to be labeled when retrieved from the database. --- | Get the DB pair from a configuration line.-confLineToConfPair :: String- -> (String, (DatabaseName, Principal))-confLineToConfPair line = do- case split "," line of- (typeName:dbPrincipal:dbName:[]) -> (typeName, (dbN, dbP))- where dbP = principal . C.pack $ dbPrincipal- dbN = U.pack dbName- _ -> ("",(undefined, undefined))+The aforementioned elements of a collection are documents of type+'HsonDocument'. Documents are the basic storage units composed of a+fields (of type 'HsonField'), which are effectively key-value pairs.+The first part of the collection policy is to specify how such+documents are labeled upon retrieval from the database. Namely, by+providing a function from the document to a label. Keys, or field+names, have type 'FieldName' while values have type 'HsonValue'. Hails+values are a subset of MongoDB's BSON specification. The second part+of the collection policy is used to specify if a field value is+publicly-searchable (i.e., readable by anybody that can read from the+collection) or labeled according to a function that may depend on the+data contained within the document itself. Hence, different form+MongoDB\'s documents, Hails documents are typically labeled and thus+protect the potentially-sensitive data contained within. --- | Cache database specifications-databases :: IO [(String, (DatabaseName, Principal))]-databases = do- env <- getEnvironment- let configFile = maybe "/etc/share/hails/conf/databases.conf" id- (lookup "DATABASE_CONFIG_FILE" env)- confLines <- fmap lines $ readFile configFile- return $ map confLineToConfPair $ filter (not.null) confLines+This module is analogous to "Database.MongoDB" and uses MongoDB as the+backed. Since the interfaces are similar we recommend glancing at+their documentation as well. --- | Given a database name and a database action, execute the action--- on the database.-withDB :: DatabasePolicy dbp- => dbp- -> DCAction a- -> DC (Either Failure a)-withDB dbp act = do- let db = policyDB dbp- dcAccess db act+-} +module Hails.Database (+ -- * Hails database monad+ DBAction, MonadDB(..)+ , withPolicyModule+ , getDatabase, getDatabaseP+ -- ** Exception thrown by failed database actions+ , DBError(..)+ -- * Database layers+ -- ** Database+ , DatabaseName+ , Database, databaseName, databaseLabel, databaseCollections+ -- ** Collection+ , CollectionName+ , CollectionSet+ , Collection, colName, colLabel, colClearance, colPolicy+ -- ** Policy errors+ , PolicyError(..)+ -- ** Documents+ , module Hails.Data.Hson+ , LabeledHsonDocument + -- * Database queries+ -- ** Write (insert/save)+ , InsertLike(..)+ -- ** Read+ , find, findP+ , next, nextP+ , findOne, findOneP+ -- *** Cursor+ , Cursor, curLabel+ -- *** Selection+ , Select(..)+ , Selection(..)+ , Selector+ -- *** Query+ , Query(..)+ , QueryOption(..)+ , Limit+ , BatchSize+ , Order(..)+ ) where++import Hails.Data.Hson+import Hails.Database.Core+import Hails.Database.TCB+import Hails.Database.Query+import Hails.PolicyModule
+ Hails/Database/Core.hs view
@@ -0,0 +1,84 @@+{-# LANGUAGE Trustworthy #-}++{- |++This module exports labeled documents and the databse monad+('DBAction'). The database monad is used by apps and policy modules to+execute database actions against a policy module's databse (see+"Hails.PolicyModule"). The Hails database model and interface is+documented in "Hails.Database".++-}++module Hails.Database.Core (+ -- * Collection+ CollectionName+ , CollectionSet+ , Collection, colName, colLabel, colClearance, colPolicy+ -- * Database+ , DatabaseName+ , Database, databaseName, databaseLabel, databaseCollections+ -- * Labeled documents+ , LabeledHsonDocument + -- * Hails DB monad+ , DBAction, DBActionState(..)+ , MonadDB(..)+ , runDBAction, evalDBAction+ , getDatabase, getDatabaseP+ -- ** Database system configuration+ , Pipe, AccessMode(..), master, slaveOk+ ) where++import Control.Monad+import Control.Monad.Trans.State++import LIO+import LIO.DCLabel++import Hails.Data.Hson+import Hails.Database.TCB+++--+-- Labeled documents+--+-- | A labeled 'HsonDocument'.+type LabeledHsonDocument = DCLabeled HsonDocument++--+-- DB monad+--++-- | Execute a database action returning the final result and state.+-- In general, code should instead use 'evalDBAction'. This function+-- is primarily used by trusted code to initialize a policy module+-- which may have modified the underlying database.+runDBAction :: DBAction a -> DBActionState -> DC (a, DBActionState)+runDBAction = runStateT . unDBAction++-- | Execute a database action returning the final result.+evalDBAction :: DBAction a -> DBActionState -> DC a+evalDBAction a s = fst `liftM` runDBAction a s++-- | Get the underlying database. Must be able to read from the+-- database as enforced by applying 'taint' to the database label.+-- This is required because the database label protects the+-- label on collections which can be projected given a 'Database'+-- value.+getDatabase :: DBAction Database+getDatabase = getDatabaseP noPriv++-- | Same as 'getDatabase', but uses privileges when raising the+-- current label.+getDatabaseP :: DCPriv -> DBAction Database+getDatabaseP p = do+ db <- dbActionDB `liftM` getActionStateTCB+ taintP p (databaseLabel db)+ return db++-- | Arbitrary monad that can perform database actions.+class Monad m => MonadDB m where+ -- | Lift a database action into the database monad.+ liftDB :: DBAction a -> m a++instance MonadDB DBAction where liftDB = id
− Hails/Database/MongoDB.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-module Hails.Database.MongoDB ( module Hails.Data.LBson- -- * Types- , CollectionName- , CollectionPolicy- , Collection- , CollectionMap- , collection, collectionP- , DatabaseName- , Database- , assocCollection, assocCollectionP- , RawPolicy(..)- , FieldPolicy(..)- , isSearchableField- , PolicyError(..)- , Action, getDatabase- , Selection(..)- , Query(..)- , Cursor- , DBConf- , DCAction- , dcAccess- , labelDatabase- , DatabasePolicy(..)- , PolicyGroup(..)- , relabelGroupsP, relabelGroupsSafe- , PrivilegeGrantGate(..)- , withLabel- , gateToLabeled- -- * Query- , insert, insert_- , insertP, insertP_- , save, saveP- , deleteOne, deleteOneP- , find, findP- , findOne, findOneP- , next, nextP- , select- -- * Misc- , Failure- , labeledDocI- ) where--import Hails.Database.MongoDB.TCB.Types-import Hails.Database.MongoDB.TCB.Query-import Hails.Database.MongoDB.TCB.DCAccess-import Hails.Data.LBson hiding (sort, find)-import Hails.Database.MongoDB.TCB.Convert-
− Hails/Database/MongoDB/Structured.hs
@@ -1,193 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Safe #-}-#endif-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}--module Hails.Database.MongoDB.Structured ( DCRecord(..)- , DCLabeledRecord(..)- , MkToLabeledDocument(..)- , toDocumentP- ) where--import LIO-import LIO.DCLabel--import Hails.Database-import Hails.Database.MongoDB--import Data.Monoid (mappend)-import Control.Monad (liftM)---- | Class for converting from \"structured\" records to documents--- (and vice versa).-class DCRecord a where- -- | Convert a document to a record- fromDocument :: Monad m => Document DCLabel -> m a- -- | Convert a record to a document- toDocument :: a -> Document DCLabel- -- | Get the collection name for the record- collectionName :: a -> CollectionName- -- | Find an object with mathing value for the given key. If the- -- object does exist but cannot be read (above clearance), this- -- returns 'Nothing'.- findBy :: (Val DCLabel v, DatabasePolicy p)- => p -> CollectionName -> Key -> v -> DC (Maybe a)- -- | Find an object with given query- findWhere :: (DatabasePolicy p)- => p -> Query DCLabel -> DC (Maybe a)- -- | Insert a record into the database- insertRecord :: (DatabasePolicy p)- => p -> a -> DC (Either Failure (Value DCLabel))- -- | Insert a record into the database- saveRecord :: (DatabasePolicy p)- => p -> a -> DC (Either Failure ())- -- | Delete a record from the database given a matching value for- -- given key. The deleted record is returned.- deleteBy :: (Val DCLabel v, DatabasePolicy p)- => p -> CollectionName -> Key -> v -> DC (Maybe a)- -- | Delete an object matching the given query.- -- The deleted record is returned.- deleteWhere :: (DatabasePolicy p)- => p -> Selection DCLabel -> DC (Maybe a)- -- | Same as 'findBy', but using explicit privileges.- findByP :: (Val DCLabel v, DatabasePolicy p)- => DCPrivTCB -> p -> CollectionName -> Key -> v -> DC (Maybe a)- -- | Same as 'findWhere', but using explicit privileges.- findWhereP :: (DatabasePolicy p)- => DCPrivTCB -> p -> Query DCLabel -> DC (Maybe a)- -- | Same as 'insertRecord', but using explicit privileges.- insertRecordP :: (DatabasePolicy p)- => DCPrivTCB -> p -> a -> DC (Either Failure (Value DCLabel))- -- | Same as 'saveRecord', but using explicit privileges.- saveRecordP :: (DatabasePolicy p)- => DCPrivTCB -> p -> a -> DC (Either Failure ())- -- | Same as 'deleteBy', but using explicit privileges.- deleteByP :: (Val DCLabel v, DatabasePolicy p)- => DCPrivTCB -> p -> CollectionName -> Key -> v -> DC (Maybe a)- -- | Same as 'deleteWhere', but using explicit privileges.- deleteWhereP :: (DatabasePolicy p)- => DCPrivTCB -> p -> Selection DCLabel -> DC (Maybe a)-- --- -- Default definitions- ---- --- findBy = findByP noPrivs- --- findWhere = findWhereP noPrivs- --- insertRecord = insertRecordP noPrivs- --- saveRecord = saveRecordP noPrivs- --- deleteBy = deleteByP noPrivs- --- deleteWhere = deleteWhereP noPrivs- --- insertRecordP p policy record = do- let colName = collectionName record- p' <- getPrivileges- withDB policy $ insertP (p' `mappend` p) colName $ toDocument record- --- saveRecordP p policy record = do- let colName = collectionName record- p' <- getPrivileges- withDB policy $ saveP (p' `mappend` p) colName $ toDocument record- --- findByP p policy colName k v = - findWhereP p policy (select [k =: v] colName)- --- findWhereP p policy query = do- result <- withDB policy $ findOneP p query- c <- getClearance- case result of- Right (Just r) | leqp p (labelOf r) c -> fromDocument `liftM` unlabelP p r- _ -> return Nothing- --- deleteByP p policy colName k v = - deleteWhereP p policy (select [k =: v] colName)- --- deleteWhereP p policy sel = do- -- Find with only supplied privileges- mdoc <- findWhereP p policy $ select (selector sel) (coll sel)- -- User underlying privileges as well:- p' <- getPrivileges- res <- withDB policy $ deleteOneP (p' `mappend` p) sel- case res of- Right _ -> return mdoc- _ -> return Nothing- ------ | Class for inserting and saving labeled records.-class DCRecord a => DCLabeledRecord a where- -- | Insert a labeled record into the database- insertLabeledRecord :: (MkToLabeledDocument p)- => p -> DCLabeled a -> DC (Either Failure (Value DCLabel))- -- | Insert a labeled record into the database- saveLabeledRecord :: (MkToLabeledDocument p)- => p -> DCLabeled a -> DC (Either Failure ())- -- | Same as 'insertLabeledRecord', but using explicit privileges.- insertLabeledRecordP :: (MkToLabeledDocument p)- => DCPrivTCB -> p -> DCLabeled a -> DC (Either Failure (Value DCLabel))- -- | Same as 'saveLabeledRecord', but using explicit privileges.- saveLabeledRecordP :: (MkToLabeledDocument p)- => DCPrivTCB -> p -> DCLabeled a -> DC (Either Failure ())-- --- -- Default definitions for insert/save- ---- --- insertLabeledRecord = insertLabeledRecordP noPrivs- --- saveLabeledRecord = saveLabeledRecordP noPrivs- --- insertLabeledRecordP p policy lrecord = do- let colName = collectionName (forceType lrecord)- p' <- getPrivileges- ldoc <- mkToLabeledDocument policy lrecord- withDB policy $ insertP (p' `mappend` p) colName ldoc- --- saveLabeledRecordP p policy lrecord = do- let colName = collectionName (forceType lrecord)- p' <- getPrivileges- ldoc <- mkToLabeledDocument policy lrecord- withDB policy $ saveP (p' `mappend` p) colName ldoc- ------ | Classe used by a database policy to translate a labeled record to--- a labeled document.-class DatabasePolicy p => MkToLabeledDocument p where- -- | Given a policy, return a function that can be used to translate- -- labeled records to labeled documents. It is recommended to simply- -- create the instance by defining @mkToDocumentP@ as:- --- -- > mkToDocumentP (Policy ... priv ..) = toDocumentP priv- --- mkToLabeledDocument :: DCRecord a- => p- -> DCLabeled a- -> DC (DCLabeled (Document DCLabel))---- | Same as 'toDocument' but for uses the policy's privileges to--- convert a labeled record to a labeled document.-toDocumentP :: DCRecord a- => DCPrivTCB -> DCLabeled a -> DC (DCLabeled (Document DCLabel))-toDocumentP privs lr = do- lcur <- getLabel- let lres = lostar privs lcur (labelOf lr)- r <- unlabelP privs lr- labelP privs lres $ toDocument r-------- Misc helpers------- | Get the type of a 'DCLabeled' value-forceType :: DCLabeled a -> a-forceType = undefined
− Hails/Database/MongoDB/TCB/Access.hs
@@ -1,127 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif--module Hails.Database.MongoDB.TCB.Access ( -- * Policy application- applyRawPolicyP- , applyRawPolicyTCB- -- * Running actions against DB- , accessTCB- ) where--import LIO-import LIO.TCB ( getTCB- , putTCB- , setLabelTCB- , lowerClrTCB- )-import LIO.MonadCatch-import Hails.Data.LBson.TCB-import Hails.Database.MongoDB.TCB.Types--import qualified Data.List as List-import Database.MongoDB.Connection-import qualified Database.MongoDB as M-import Control.Monad.Error hiding (liftIO)-import Control.Monad.Reader hiding (liftIO)---- | Apply a raw field/column policy to the field corresponding to the--- key. If the policy has not been specified for this key, the function--- throws an exception. Similarly, if the policy has already been--- applied for this key and the label existing label does not match the--- newly policy-generated label, an exception is thrown.--- It is required that the label of any 'Labeled' and 'PolicyLabeled'--- values be below the clearnce of the collection (this is enforced in--- 'applyRawPolicyP').-applyRawFieldPolicyP :: (LabelState l p s)- => p - -> CollectionPolicy l- -> Document l- -> Key- -> LIO l p s (Field l)-applyRawFieldPolicyP p col doc k = do- let policies = rawFieldPolicies . colPolicy $ col- -- Find policy corresponding to key k:- f <- maybe (throwIO NoFieldPolicy) return $ List.lookup k policies- -- Ensure field is not searchable- when (isSearchableField f) $ throwIO InvalidPolicy- let (FieldPolicy fp) = f- -- Get the 'PolicyLabeled' value corresponding to k:- plv <- getPolicyLabeledVal- -- Apply policy, or check matching labels:- lv <- case plv of- (PU v) -> labelP p (fp doc) v- (PL lv) -> do unless (labelOf lv == fp doc) $- throwIO PolicyViolation- return lv- -- Return new field, with policy applied value- return (k := (PolicyLabeledVal . PL $ lv))- where getPolicyLabeledVal = case look k doc of- (Just (PolicyLabeledVal x)) -> return x- _ -> throwIO InvalidPolicy---- | Apply a raw field/column policy to all the fields of type--- 'PolicyLabeled'.-applyRawFieldPoliciesP :: (LabelState l p s)- => p - -> CollectionPolicy l- -> Document l- -> LIO l p s (Document l)-applyRawFieldPoliciesP p col doc = forM doc $ \field@(k := v) ->- case v of- (PolicyLabeledVal _) -> applyRawFieldPolicyP p col doc k- _ -> case List.lookup k (rawFieldPolicies . colPolicy $ col) of- Just (FieldPolicy _) -> throwIO InvalidFieldPolicyType- _ -> return field---- | Apply a raw field/column policy to all the fields of type--- 'PolicyLabeled', and then apply the raw document/row policy. It--- must be that every labeled value in the document (including the--- document itself) have a label that is below the clearance of--- the collection. However, this is not checked by @applyRawPolicyP@.--- Instead 'insert' (and similar operators) performs this check.-applyRawPolicyP :: (LabelState l p s)- => p - -> CollectionPolicy l- -> Document l- -> LIO l p s (LabeledDocument l)-applyRawPolicyP p' col doc = withCombinedPrivs p' $ \p -> do- let docP = rawDocPolicy . colPolicy $ col- -- Apply field/column policies:- doc' <- applyRawFieldPoliciesP p col doc- -- Apply document/row policy:- labelP p (docP doc') doc'---- | Same as 'applyRawPolicy', but ignores the current label and--- clearance when applying policies.-applyRawPolicyTCB :: (LabelState l p s)- => CollectionPolicy l- -> Document l- -> LIO l p s (LabeledDocument l)-applyRawPolicyTCB col doc = do- -- Save current state:- s0 <- getTCB- -- Set state to most permissive label & clearance:- setLabelTCB lbot- lowerClrTCB ltop- -- Apply policy to document:- ldoc <- applyRawPolicyP noPrivs col doc- -- Restore state:- putTCB s0- return ldoc---- | Run action against database on server at other end of pipe. Use--- access mode for any reads and writes. Return 'Left' on connection--- failure or read/write failure.--- The current label is raised to the the join of the database label--- and current label.-accessTCB :: LabelState l p s- => Pipe- -> M.AccessMode- -> Database l- -> Action l p s a- -> LIO l p s (Either M.Failure a)-accessTCB pipe mode db (Action act) = - let lioAct = runReaderT act db- in unUnsafeLIO $ M.access pipe mode (dbIntern db) (unLIOAction lioAct)
− Hails/Database/MongoDB/TCB/Convert.hs
@@ -1,69 +0,0 @@-{-# LANGUAGE Trustworthy #-}-module Hails.Database.MongoDB.TCB.Convert ( -- * Converting HTTP requests- -- to 'Labeled' 'Document'- labeledDocI- ) where--import LIO-import LIO.TCB-import qualified Data.Bson as B (Value(..))-import qualified Data.UString as U-import Data.IterIO-import Data.IterIO.Http-import qualified Data.ByteString.Lazy.Char8 as L-import qualified Data.ByteString.Char8 as S-import Data.List-import Data.List.Utils-import Data.UString (pack)-import Hails.Data.LBson.TCB----- | Trusted transformer that takes a 'Labeled' tuple with 'HttpReq'--- and the request body as a 'L.ByteString' and returns a 'Labeled'--- 'Document' with keys and values corresponding to the form fields--- from the request. The label on the @Labeled@ result is the same as--- input. Arguments values are parsed in to BSON Strings except if the--- key is of the form \"key_name[]\" in which case all such arguments--- will be combined into an array of Strings.-labeledDocI :: (LabelState l p s)- => HttpReq a- -> Labeled l L.ByteString- -> LIO l p s (Labeled l (Document l))-labeledDocI req lbody = do- let lbl = labelOf lbody- doc <- enumPure (unlabelTCB lbody) |$ formFolder req- return $ labelTCB lbl doc---- | Parases query or request body into a BSON document. Query components--- become 'Key' 'String' pairs in the BSON doc. If a query argument has the--- form \"key1[]=blah\" it will be parsed as an array of 'String's and equally--- named arguments will be combined.-formFolder :: (LabelState l p s)- => HttpReq a -> Iter L.ByteString (LIO l p s) (Document l)-formFolder req = foldForm req docontrol []- where docontrol acc field = do- formVal <- fmap L.unpack pureI- let k = S.unpack $ ffName field- if endswith "[]" k then- return $ appendVal acc k formVal- else do- let lfld = pack (S.unpack.ffName $ field) =: formVal- return $ lfld : acc---- | Appends the a value to the corresponding field in a document. If the field--- already exists in the document, appends the value to the array. Otherwise the--- field is added with the passed in value the only element in the array.-appendVal :: LabelState l p s => Document l -> String -> String -> Document l-appendVal doc k' formVal =- let k = U.pack $ takeWhile (/= '[') k'- field = (k := BsonVal (B.Array [B.String $ U.pack formVal]))- in case find (isKey k) doc of- Just _ -> map (upsert k) doc- Nothing -> field:doc- where upsert k f@(k0 := (BsonVal (B.Array arr))) =- if k0 == k then- (k =: (B.String $ U.pack formVal):arr)- else f- upsert _ f = f- isKey kk (k := _) = k == kk-
− Hails/Database/MongoDB/TCB/DCAccess.hs
@@ -1,249 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-module Hails.Database.MongoDB.TCB.DCAccess ( DBConf(..)- , DCAction- , dcAccess- , labelDatabase- , DatabasePolicy(..)- -- * Groups- , PolicyGroup(..)- , relabelGroupsP- , relabelGroupsSafe- -- * Privilege granting gate- , PrivilegeGrantGate(..)- , withLabel, gateToLabeled- ) where--import Control.Monad (foldM, liftM)-import Data.Bson (u)-import qualified Data.Bson as Bson-import Hails.Data.LBson (Document)-import Hails.Database.MongoDB.TCB.Types-import Hails.Database.MongoDB.TCB.Access-import Database.MongoDB ( runIOE- , connect- , host- , master- , slaveOk- , GetLastError- , AccessMode(..) )-import LIO-import LIO.TCB ( rtioTCB )-import LIO.MonadCatch-import LIO.DCLabel--import System.Environment--import Data.Maybe (fromMaybe)-import qualified Data.Map as Map-import qualified Data.List as List--import Text.Parsec hiding (label)---- | Database configuration, used to invoke @withDB@-data DBConf = DBConf { dbConfName :: DatabaseName- , dbConfPriv :: DCPrivTCB- } deriving (Show)--type DCAction = Action DCLabel DCPrivTCB ()---- | Open a pipe to a supplied server, or @localhost@.--- TODO: add support for connecting to replicas.-dcAccess :: Database DCLabel- -> DCAction a- -> DC (Either Failure a)-dcAccess db act = do- env <- rtioTCB getEnvironment- let hostName = fromMaybe "localhost" (List.lookup "HAILS_MONGODB_SERVER" env)- let mode = maybe master parseMode (List.lookup "HAILS_MONGODB_MODE" env)- pipe <- rtioTCB $ runIOE $ connect (host hostName)- accessTCB pipe mode db act----- | The @withDB@ functions should use this function to label--- their databases.--- TODO (DS/AL(: make every searchable field indexable.-labelDatabase :: DBConf -- ^ Database configuratoin- -> DCLabel -- ^ Label of collection policies- -> DCLabel -- ^ Database label- -> DC (Database DCLabel)-labelDatabase conf lcoll lacc = do- let dbName = dbConfName conf- p = dbConfPriv conf- initColl <- labelP p lcoll Map.empty- databaseP p dbName lacc initColl---- | Policy modules are instances of this class. In particular, when--- an application accesses a database, the runtime invokes--- @createDatabasePolicy@ in the appropriate policy module.-class DatabasePolicy dbp where- -- | Given a 'DBConf' generate an instance of this- -- @DatabasePolicy@. This is the main entry point for policy- -- modules. Policies should, in general, ether discard @DBConf@ or- -- store it in such a way that it is inaccessible to other modules- -- since it contains the priviledge of the policy.- createDatabasePolicy :: DBConf -> DCPrivTCB -> DC dbp-- -- | Get the actual underlying @Database@ instance for this policy.- policyDB :: dbp -> Database DCLabel---- | Class used to define groups in a policy-specific manner.-class DatabasePolicy dbp => PolicyGroup dbp where- -- | Expands a principal of the form \"#group_name\" into a list of- -- @Principal@s- expandGroup :: dbp -> Principal -> DCAction [Principal]- expandGroup _ princ = return [princ]-- -- | Relabeles the 'Labeled' value by using the policy's privilege- -- to downgrade the label and optionally re-taint in an application- -- specific way, e.g. exanding groups of the form \"#group_name\"- -- to a policy specified disjuction of real principals.- --- -- Policies are expected to implement this function by wrapping- -- 'relabelGroupsP' using their privilege and implementing- -- 'expandGroup', which is called by 'relabelGroupsP'.- relabelGroups :: dbp -> DCLabeled a -> DC (DCLabeled a)- relabelGroups _ = return----- | Class used to define policy-specifi privilege granting gate.-class DatabasePolicy dbp => PrivilegeGrantGate dbp where- -- | Request the policy's privilege-granting gate.- grantPriv :: dbp -- ^ Policy- -> Principal -- ^ App principal- -> DC (DCGate DCPrivTCB)---- | A wrapper around 'relabelGroups' that drops the current--- privileges and restores them after getting a result from--- 'relabelGroups'.-relabelGroupsSafe :: PolicyGroup dbp- => dbp- -> Labeled DCLabel a- -> DC (DCLabeled a)-relabelGroupsSafe dbp lbl = withPrivileges noPrivs $- relabelGroups dbp lbl---- | Looks for disjuctions the privilege is able to downgrade and--- rewrites them by invoking 'expandGroup' on each principle in the--- disjuction. Using the result, the function relabels the 'Labeled'--- value. Clients should not call this directly, instead clients--- should call 'relabelGroups' which policies may implement by--- wrapping this function.-relabelGroupsP :: PolicyGroup dbp- => dbp- -> DCPrivTCB- -> Labeled DCLabel a- -> DC (DCLabeled a)-relabelGroupsP dbp p inp = do- let (MkDCLabel sec' inte') = labelOf inp- sec <- expandComponent sec'- inte <- expandComponent inte'- let lbl = MkDCLabel sec inte- relabelP p lbl inp- where expandComponent l | l == (><) = return l- expandComponent comp = do- ds <- mapM gocmp $ componentToList comp- return $ listToComponent ds- gocmp d = do- let db = policyDB dbp- result <-- if p `owns` d- then dcAccess db $ liftM listToDisj $- foldM (\res grp -> do next <- expandGroup dbp grp- return $ res ++ next) [] $ disjToList d- else return $ Right d- return $ case result of- Right dr -> dr- Left _ -> d------- Parser for getLastError-------- | Parse the access mode.------ > slaveOk : slaveOk--- > unconfirmedWrites : UnconfirmedWrites--- > onfirmWrites <options> : ConfirmWrites [corresponding-options]--- > _ : master------ where @options@ can be:------ > fsync | journal | writes=<N>------ separated by \',\', and @N@ is an integer.--- Example: ------ > HAILS_MONGODB_MODE = "slaveOk"--- > HAILS_MONGODB_MODE = "confirmWrites: writes=3, journal"--- > HAILS_MONGODB_MODE = "master"----parseMode :: String -> AccessMode-parseMode "slaveOk" = slaveOk-parseMode "unconfirmedWrites" = UnconfirmedWrites-parseMode xs = case parse wParser "" xs of- Right le -> ConfirmWrites le- Left _ -> master- where wParser = do _ <- string "confirmWrites" - spaces- _ <- char ':'- spaces- gle_opts--gle_opts :: Stream s m Char => ParsecT s u m GetLastError-gle_opts = do opt_first <- gle_opt- opt_rest <- gle_opts'- return $ opt_first ++ opt_rest- where gle_opt = gle_opt_fsync <|> gle_opt_journal <|> gle_opt_write - gle_opts' :: Stream s m Char => ParsecT s u m GetLastError- gle_opts' = (spaces >> char ',' >> spaces >> gle_opts) <|> (return [])--gle_opt_fsync :: Stream s m Char => ParsecT s u m GetLastError-gle_opt_fsync = string "fsync" >> return [ (u "fsync") Bson.=: True ]--gle_opt_journal :: Stream s m Char => ParsecT s u m GetLastError-gle_opt_journal = string "journal" >> return [ (u "j") Bson.=: True ]--gle_opt_write :: Stream s m Char => ParsecT s u m GetLastError-gle_opt_write = do _ <- string "write"- spaces- _ <- char '='- spaces- dgt <- many1 digit- return [ (u "w") Bson.=: (read dgt :: Integer) ]----- | Given a set of privileges, a labeled document and computaiton on--- the (unlabeled version of the) documnet, downgrade the current label with--- the supplied privileges execute (only integrity), unlabel the document--- and apply the computation to it. The result is then labeled with the current--- label and the current label is reset to the original (if possible).-gateToLabeled :: DCPrivTCB- -> DCLabeled (Document DCLabel)- -> (Document DCLabel -> DC a) -> DC (DCLabeled a)-gateToLabeled privs ldoc act = do- l <- getLabel- withLabel privs (newDC (secrecy l) (><)) $ do- doc <- unlabel ldoc- res <- act doc- lr <- getLabel- label lr res----- | Given a set of privileges, a desired label and action. Lower the--- current label as close tothe desired label as possible, execute the--- action and raise the current label.-withLabel :: DCPrivTCB -> DCLabel -> DC a -> DC a-withLabel privs l act = do- -- Lower the current label:- l0 <- getLabel- setLabelP privs $ lostar privs l0 l- -- Execute action- act `finally` do l1 <- getLabel- -- Raise current label:- setLabelP privs (lostar privs l1 l0)
− Hails/Database/MongoDB/TCB/Query.hs
@@ -1,417 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif-{-# LANGUAGE MultiParamTypeClasses,- FlexibleContexts,- FlexibleInstances,- OverloadedStrings #-}--module Hails.Database.MongoDB.TCB.Query ( insert, insert_- , insertP, insertP_- , save, saveP- , deleteOne, deleteOneP- -- * Finding objects- , find, findP- , findOne, findOneP- , next, nextP- , Query(..), Selection(..), Selector- , select- ) where--import Hails.Database.MongoDB.TCB.Access-import Hails.Database.MongoDB.TCB.Types--import LIO-import LIO.TCB--import Data.Word-import Data.Functor ((<$>))-import Data.Serialize (Serialize)-import qualified Data.Map as Map-import Hails.Data.LBson.TCB hiding (lookup)-import qualified Database.MongoDB as M--import Control.Monad.Reader hiding (liftIO)---- | Use select to create a basic query with defaults, then modify if--- desired. Example: @(select sel col) {limit =: 10}@. Note that unlike--- MongoDB's query functionality, our queries do not allow for--- projections (since policies may need a field that is not projects).--- Both the selection and sorting are restricted to searchable fields.------ TODO: add snapshot.-data Query l = Query { options :: [M.QueryOption]- -- ^ Query options, default @[]@.- , selection :: Selection l- -- ^ @WHERE@ clause,default @[]@.- , skip :: Word32- -- ^ Number of documents to skip, default 0.- , limit :: M.Limit- -- ^ Max number of documents to return. Default, 0,- -- means no limit.- , sort :: Order l- -- ^ Sort result by given order, default @[]@.- , batchSize :: M.BatchSize- -- ^ The number of document to return in each- -- batch response from the server. 0 means- -- Mongo default.- , hint :: Order l- -- ^ Force mongoDB to use this index (must be- -- only searchable fields). Default @[]@, no hint. - }---- | Convert a 'Query' to the mongoDB equivalent. Note: keys that have --- the prefix 'hailsInternalKeyPrefix' are filtered out.-queryToMQuery :: (Serialize l, Label l) => Query l -> M.Query-queryToMQuery q = M.Query { M.options = options q- , M.selection = selectionToMSelection $ selection q- , M.project = []- , M.skip = skip q- , M.limit = limit q- , M.batchSize = batchSize q- , M.sort = toBsonDoc $ sort q- , M.snapshot = False- , M.hint = toBsonDoc $ hint q- }----- | Filter for a query, analogous to the @WHERE@ clause in--- SQL. @[]@ matches all documents in collection. @["x" =: a,--- "y" =: b]@ is analogous to @WHERE x = a AND y = b@ in SQL.------ /Note/: all labeld (including policy-labeled) values are removed--- from the @Selector@.-type Selector l = Document l----- | Selects documents in specified collection that match the selector.-data Selection l = Selection { selector :: Selector l -- ^ Selector- , coll :: CollectionName -- ^ Collection operaing- }---- | Convert a 'Selection' to the mongoDB equivalent.-selectionToMSelection :: (Serialize l, Label l) => Selection l -> M.Selection-selectionToMSelection s = M.Select { M.selector = toBsonDoc $ selector s- , M.coll = coll s }---- | Convert a 'Selector' to a 'Selection' or 'Query'-class Select selectionOrQuery where- select :: Label l => Selector l -> CollectionName -> selectionOrQuery l- -- ^ 'Query' or 'Selection' that selects documents in collection that match- -- selector. The choice of end type depends on use, for example, in 'find'- -- @select sel col@ is a 'Query', but in delete it is a 'Selection'.--instance Select Selection where- select = Selection--instance Select Query where- select s c = Query { options = []- , selection = select s c- , skip = 0- , limit = 0- , sort = []- , batchSize = 0- , hint = [] - }---- | Fields to sort by. Each one is associated with a @1@ or @-1@. For--- example @[ "x" =: 1, "y" =: -1]@ denotes sort by @x@ ascending then--- @y@ descending. The sorts allowed in an order must be searchable--- fields.-type Order l = Document l------- Write-----class (LabelState l p s, Serialize l) => Insert l p s doc where- -- | Insert document into collection and return its @_id@ value,- -- which is created automatically if not supplied. It is required that- -- the current label flow to the label of the collection and database- -- (and vice versa). Additionally, the document must be well-formed- -- with respect to the collection policy. In other words, all the- -- labeled values must be below the collection clearance and the- -- policy be applied successfully.- insert :: CollectionName- -> doc- -> Action l p s (Value l)- insert = insertP noPrivs-- -- | Same as 'insert' except it does not return @_id@- insert_ :: CollectionName- -> doc- -> Action l p s ()- insert_ c d = void $ insert c d-- -- | Same as 'insert', but uses privileges when applying the- -- collection policies, and doing label comparisons.- insertP :: p- -> CollectionName- -> doc- -> Action l p s (Value l)- insertP p colName doc = do- db <- getDatabase- bsonDoc <- mkDocForInsertTCB p colName doc- liftAction $ liftM BsonVal $ M.useDb (dbIntern db) $ M.insert colName bsonDoc-- -- | Same as 'insertP' except it does not return @_id@- insertP_ :: p- -> CollectionName- -> doc- -> Action l p s ()- insertP_ p c d = void $ insertP p c d-- -- | Update a document based on the @_id@ value. The IFC requirements- -- subsume those of 'insert'. Specifically, in addition to being able- -- to apply all the policies and requiring that the current label flow- -- to the label of the collection and database @save@ requires that - -- the current label flow to the label of the existing database record.- save :: CollectionName- -> doc- -> Action l p s ()- save = saveP noPrivs-- -- | Like 'save', but uses privileges when performing label- -- comparisons.- saveP :: p- -> CollectionName- -> doc- -> Action l p s ()-- -- | Convert a 'Document' to a MongoDB @Document@, applying policies- -- and checking that we can insert to DB and collection.- -- Because the returned document is \"serialized\" document, this- -- function must be part of the TCB.- mkDocForInsertTCB :: p- -> CollectionName- -> doc- -> Action l p s M.Document------ | Perform an 'LIO' action on a 'CollectionPolicy'-doForCollectionP :: (LabelState l p s, Serialize l)- => p- -> CollectionName- -> (p -> Database l- -> CollectionPolicy l -> LIO l p s a)- -> Action l p s a-doForCollectionP p' colName act = do- db <- getDatabase- liftLIO $ withCombinedPrivs p' $ \p -> do- -- Check that we can read collection names associated with DB:- colMap <- unlabelP p $ dbColPolicies db- -- Lookup collection name in the collection map associated with DB:- col <- maybe (throwIO NoColPolicy) return $ Map.lookup colName colMap- -- Get the collection clearance:- act p db col-----instance (LabelState l p s, Serialize l) => Insert l p s (Document l) where- saveP p colName doc = do- db <- getDatabase- -- check that we can insert documetn as is:- bsonDoc <- mkDocForInsertTCB p colName doc- case M.look "_id" bsonDoc of- Nothing -> dbAct db $ M.insert colName bsonDoc- Just i -> do- mdoc <- findOneP p $ select ["_id" := BsonVal i] colName- -- If document exists make sure that we can overwrite the- -- existing document:- maybe (return ()) (lioWGuard . labelOf) mdoc- dbAct db $ M.save colName bsonDoc- where lioWGuard l = liftLIO $ withCombinedPrivs p $ \p' -> wguardP p' l- dbAct db = void . liftAction . M.useDb (dbIntern db)-- mkDocForInsertTCB p' colName doc = do- ldoc <- doForCollectionP p' colName $ \p _ col ->- withClearance (colClear col) $ applyRawPolicyP p col doc- mkDocForInsertTCB p' colName ldoc--instance (LabelState l p s, Serialize l, Insert l p s (Document l)) =>- Insert l p s (Labeled l (Document l)) where- saveP p colName ldoc = do- db <- getDatabase- -- check that we can insert documetn as is:- bsonDoc <- mkDocForInsertTCB p colName ldoc- case M.look "_id" bsonDoc of- Nothing -> dbAct db $ M.insert colName bsonDoc- Just i -> do- mdoc <- findOneP p $ select ["_id" := BsonVal i] colName- -- If document exists make sure that we can overwrite the- -- existing document:- maybe (return ()) (lioWGuard . labelOf) mdoc- dbAct db $ M.save colName bsonDoc- where lioWGuard l = liftLIO $ withCombinedPrivs p $ \p' ->- unless (leqp p' (labelOf ldoc) l) $ throwIO LerrHigh- dbAct db = void . liftAction . M.useDb (dbIntern db)-- mkDocForInsertTCB p' colName ldoc = - doForCollectionP p' colName $ \p db col -> do- -- Check that we can write to database:- wguardP p (dbLabel db)- -- Check that we can write to collection:- wguardP p (colLabel col)- -- Document was labeled, policy was OK, remove label- let udoc = unlabelTCB ldoc- -- Apply policies (data should not be labeled with a label- -- that is above the collection clearance):- asIfLDoc <- applyRawPolicyTCB col udoc- -- Check that label of the passed in @Document@ `canflowto`- -- the label that would be generated by the policy.- unless (leqp p (labelOf ldoc) (labelOf asIfLDoc)) $ throwIO LerrHigh- -- Check that 'Labeled' values have labels below clearance:- guardLabeledVals udoc $ colClear col- -- Check that 'SearchableField's are not set to labeled- -- values:- guardSerachables udoc col- -- Policies applied, labels are below clearance,- -- searchables are Bson values and unlabeled, done:- return $ toBsonDoc udoc- where guardLabeledVals ds c = forM_ ds $ \(_ := v) ->- case v of- (LabeledVal lv) -> unless (labelOf lv `leq` c) $- throwIO $ LerrClearance- _ -> return ()- --- guardSerachables ds col =- let srchbls = searchableFields . colPolicy $ col- in forM_ ds $ \(k := v) ->- case v of- (BsonVal _) -> return ()- _ -> when (k `elem` srchbls) $- throwIO InvalidSearchableType---- | Returns true if the clause contains only searchable fields from--- the collection policy-validateSearchableClause :: M.Document -> CollectionPolicy l -> Bool-validateSearchableClause doc policy = and (map isSearchable doc)- where isSearchable ("_id" M.:= _) = True- isSearchable (k M.:= _) = maybe False isSearchableField $ - lookup k fieldPolicies- fieldPolicies = rawFieldPolicies . colPolicy $ policy------- Read------- | Fetch documents satisfying query. A labeled 'Cursor' is returned,--- which can be used to retrieve the actual 'Document's. Current label--- is raised to the join of the collection, database, and--- ccollection-policy label.-find :: (Serialize l, LabelState l p s)- => Query l -> Action l p s (Cursor l)-find = findP noPrivs----- | Same as 'find', but uses privileges when raising the current--- label-findP :: (Serialize l, LabelState l p s)- => p -> Query l -> Action l p s (Cursor l)-findP p' q' = do- db <- getDatabase- let q = queryToMQuery q'- slct = M.selection q- colName = M.coll slct- col <- liftLIO $ withCombinedPrivs p' $ \p -> do- -- Check that we can read collection names associated with database:- colMap <- unlabelP p $ dbColPolicies db- -- Lookup collection name in the collection map associated with DB:- maybe (throwIO NoColPolicy) return $ Map.lookup colName colMap- -- Check that we can read from the database and collection:- liftLIO $ withCombinedPrivs p' $ \p -> do- taintP p $ (colLabel col) `lub` (dbLabel db)- -- Make sure that the selection, sort and hint soleley contain- -- searchable fields:- unless (and $ map (validate col) [ M.selector slct, M.sort q, M.hint q]) $- liftIO $ throwIO InvalidFieldPolicyType- -- Perform actual fetch:- cur <- liftAction $ M.useDb (dbIntern db) $ M.find (q {M.project = []})- -- Return a labeled cursor- return $ Cursor { curLabel = (colLabel col) `lub` (dbLabel db)- , curIntern = cur - , curProject = M.project q- , curPolicy = col }- where validate = flip validateSearchableClause---- | Fetch the first document satisfying query, or @Nothing@ if not--- documents matched the query.-findOne :: (LabelState l p s, Serialize l)- => Query l -> Action l p s (Maybe (LabeledDocument l))-findOne = findOneP noPrivs---- | Same as 'findOne', but uses privileges when performing label--- comparisons.-findOneP :: (LabelState l p s, Serialize l)- => p -> Query l -> Action l p s (Maybe (LabeledDocument l))-findOneP p q = findP p q >>= nextP p---- | Return next document in query result, or @Nothing@ if finished.--- The current label is raised to join of the current label and--- 'Cursor' label. The document is labeled according to the--- underlying 'Collection'\'s policies.-next :: (LabelState l p s, Serialize l)- => Cursor l- -> Action l p s (Maybe (LabeledDocument l))-next = nextP noPrivs---- | Same as 'next', but usess privileges raising the current label.-nextP :: (LabelState l p s, Serialize l)- => p- -> Cursor l- -> Action l p s (Maybe (LabeledDocument l))-nextP p' cur = do- -- Rause current label, can read from DB+collection:- liftLIO $ withCombinedPrivs p' $ \p -> taintP p (curLabel cur)- md <- fromBsonDoc' <$> (liftAction $ M.next (curIntern cur))- case md of- Nothing -> return Nothing- Just d -> Just <$> (liftLIO $ applyProjection `liftM`- applyRawPolicyTCB (curPolicy cur) d)- where fromBsonDoc' = maybe Nothing fromBsonDocStrict- applyProjection doc =- if null $ curProject cur- then doc- else let udoc = unlabelTCB doc- in labelTCB (labelOf doc) $ filter inProjection udoc- inProjection (k := _) = case M.look k $ curProject cur of- Just (M.Int32 1) -> True- _ -> False------ Delete------- | Given a query, delete first object in selection. In addition to--- being able to read the object, write to the database and collection,--- it must be that the current label flow to the label of the existing--- document.-deleteOne :: (LabelState l p s, Serialize l)- => Selection l -> Action l p s ()-deleteOne = deleteOneP noPrivs---- | Same as 'deleteOne', but uses privileges when performing label--- comparisons.-deleteOneP :: (LabelState l p s, Serialize l)- => p -> Selection l -> Action l p s ()-deleteOneP p' sel = do- p <- liftLIO $ withCombinedPrivs p' return- let colName = coll sel- mobj <- findOneP p $ select (selector sel) colName- voidIfNothing mobj $ \ldoc -> do- doForCollectionP p' (coll sel) $ \_ db col -> do- -- Check that we can write to database:- wguardP p (dbLabel db)- -- Check that we can write to collection:- wguardP p (colLabel col)- -- Check that we can overwrite document:- wguardP p $ labelOf ldoc- i <- look "_id" $ unlabelTCB ldoc- dbAct . M.deleteOne . selectionToMSelection $ select ["_id" := i] colName- where dbAct act = do- db <- getDatabase- void . liftAction . M.useDb (dbIntern db) $ act- voidIfNothing mv m = maybe (return ()) m mv-
− Hails/Database/MongoDB/TCB/Types.hs
@@ -1,374 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif-{-# LANGUAGE DeriveDataTypeable,- GeneralizedNewtypeDeriving,- FlexibleInstances,- MultiParamTypeClasses,- TypeFamilies #-}-module Hails.Database.MongoDB.TCB.Types ( -- * Collection- CollectionName- , CollectionMap- , CollectionPolicy(..)- , Collection(..)- , collection, collectionP, collectionTCB- -- * Database- , DatabaseName- , Database(..)- , database, databaseP, databaseTCB- , assocCollection, assocCollectionP- , assocCollectionTCB - -- * Policies- , RawPolicy(..)- , FieldPolicy(..)- , isSearchableField- , searchableFields- , PolicyError(..)- , NoSuchDatabaseError(..)- -- * Monad- , UnsafeLIO(..)- , LIOAction(..)- , Action(..)- , liftAction- , getDatabase- -- * Cursor- , Cursor(..)- -- * Misc- , Failure- ) where--import LIO-import LIO.TCB ( LIO(..)- , LIOstate- , unlabelTCB- , labelTCB- , rtioTCB )--import qualified Database.MongoDB as M-import Database.MongoDB (Failure)--import Hails.Data.LBson.TCB-import Data.Map (Map)-import qualified Data.Map as Map-import Data.Typeable--import Control.Applicative (Applicative)-import Control.Monad.Error hiding (liftIO)-import Control.Monad.Reader hiding (liftIO)-import Control.Monad.State hiding (liftIO)-import qualified Control.Monad.IO.Class as IO-import Control.Monad.Base (MonadBase(..))-import Control.Monad.Trans.Control (MonadBaseControl(..))-import qualified Control.Exception as E------- Collections------- | A collection policy is is a label,--- clearance and labeling policy. The label specifies who can write to a--- collection (i.e., only computatoin whose current label flows to the--- label of the collection). The clearance limits the sensitivity of the--- data written to the collection (i.e., the labels of all data in the--- collection must flow to the clearance). Note that the collection label--- does /not/ impose a restriction on the data (i.e., data can have--- high integrity). The collection policy specifies the policies for--- labeling documents and fields of documents.-data Collection l = Collection { colIntern :: CollectionName- -- ^ Collection name- , colSec :: CollectionPolicy l- -- ^ Collection secutiry policies: access control- -- and labeling policies- }---- | Labels and policies associated with a collection. See 'Collection'.-data CollectionPolicy l = CollectionPolicy { colLabel :: l- -- ^ Collection label- , colClear :: l- -- ^ Collection clearance- , colPolicy :: RawPolicy l- -- ^ Collection labeling policy- }---- | Name of collection-type CollectionName = M.Collection---- | Create a collection given a collection name, label, clearance, --- and policy. Note that the collection label and clearance must be--- above the current label and below the current clearance.-collection :: LabelState l p s- => CollectionName -- ^ Collection name- -> l -- ^ Collection label- -> l -- ^ Collection clearance- -> RawPolicy l -- ^ Collection policy- -> LIO l p s (Collection l)-collection = collectionP noPrivs---- | Same as 'collection', but uses privileges when comparing the--- collection label and clearance with the current label and clearance.-collectionP :: LabelState l p s- => p -- ^ Privileges- -> CollectionName -- ^ Collection name- -> l -- ^ Collection label- -> l -- ^ Collection clearance- -> RawPolicy l -- ^ Collection policy- -> LIO l p s (Collection l)-collectionP p' n l c pol = withCombinedPrivs p' $ \p -> do- aguardP p l- aguardP p c- collectionTCB n l c pol---- | Same as 'collection', but ignores IFC.-collectionTCB :: LabelState l p s- => CollectionName -- ^ Collection name- -> l -- ^ Collection label- -> l -- ^ Collection clearance- -> RawPolicy l -- ^ Collection policy- -> LIO l p s (Collection l)-collectionTCB n l c pol = - return $ Collection { colIntern = n- , colSec = CollectionPolicy { colLabel = l- , colClear = c- , colPolicy = pol }- }------- Databases-------- | Name of database-type DatabaseName = M.Database---- | A labeled 'Collection' map.-type CollectionMap l = Labeled l (Map CollectionName (CollectionPolicy l))---- | A database has a label, which is used for controlling access to--- the database, an internal identifier corresponding to the underlying--- MongoDB database, and a set of 'Collection's protected by a label.-data Database l = Database- { dbIntern :: DatabaseName- -- ^ Actual MongoDB- , dbLabel :: l- -- ^ Label of database- , dbColPolicies :: CollectionMap l- -- ^ Collections associated with databsae- }----- | Create a 'Database'. Given a set of privileges, the name of the--- database, the database label, and set of collections, create a--- database. Note that this does not restrict an application from--- creating arbitrary databases and collections---this should be--- handled by a shim layer.-databaseP :: LabelState l p s- => p -- ^ Privileges- -> DatabaseName -- ^ Name of database- -> l -- ^ Label of database- -> CollectionMap l -- ^ Labeled colleciton map- -> LIO l p s (Database l)-databaseP p' n l cs = withCombinedPrivs p' $ \p -> do- aguardP p l- databaseTCB n l cs---- | Sameas 'databaseP', but ignores IFC checks.-databaseTCB :: LabelState l p s- => DatabaseName- -> l- -> CollectionMap l- -> LIO l p s (Database l)-databaseTCB n l cs = return $ Database { dbIntern = n- , dbLabel = l- , dbColPolicies = cs- }---- | Same as 'databaseP', but does not use privileges when comparing--- the current label (and clearance) with the supplied database label.-database :: LabelState l p s- => DatabaseName- -> l- -> CollectionMap l- -> LIO l p s (Database l)-database = databaseP noPrivs----- | Associate a collection with the underlying database.-assocCollectionP :: LabelState l p s- => p- -> Collection l- -> Database l- -> LIO l p s (Database l)-assocCollectionP p' (Collection n cp) db = do- (l, colMap) <- liftLIO $ withCombinedPrivs p' $ \p -> do- let colMap = unlabelTCB $ dbColPolicies db- l = labelOf $ dbColPolicies db- wguardP p l- return (l, colMap)- let dCPs = Map.insert n cp colMap- return $ db { dbColPolicies = labelTCB l dCPs }---- | Same as 'assocCollectionP', but does not use privileges when--- writing to database collection map.-assocCollection :: LabelState l p s- => Collection l- -> Database l- -> LIO l p s (Database l)-assocCollection = assocCollectionP noPrivs---- | Same as 'assocCollectionP', but ignores IFC.-assocCollectionTCB :: LabelState l p s- => Collection l- -> Database l- -> LIO l p s (Database l)-assocCollectionTCB (Collection n cp) db = do- let colMap = unlabelTCB $ dbColPolicies db- l = labelOf $ dbColPolicies db- let dCPs = Map.insert n cp colMap- return $ db { dbColPolicies = labelTCB l dCPs }-------- Policies-------- | A @RawPolicy@ encodes a document policy, and all--- field policies. It is required that all fields of type--- 'PolicyLabled' have a field/column policy -- if using only this--- low-level interface a runtime-error will occur if this is not--- satisfied.-data RawPolicy l = RawPolicy {- rawDocPolicy :: Document l -> l- -- ^ A row (document) policy is a function from a 'Document' to a 'Label'.- , rawFieldPolicies :: [(Key, FieldPolicy l)]- -- ^ A column (field) policy is a function from a 'Document' to a- -- 'Label', for each field of type 'PolicyLabeled'.- }---- | A @FieldPolicy@ specifies the policy-generated label of--- a field. @SearchabelField@ specifies that the field can be--- referenced in the selection clause of a @Query@, and therefore--- the document label does not apply to it.-data FieldPolicy l = SearchableField- | FieldPolicy (Document l -> l)---- | Returns True if the policy is for a searchable field-isSearchableField :: FieldPolicy l -> Bool-isSearchableField SearchableField = True-isSearchableField _ = False---- | Returns a list of the @SearchableField@s speicified in a--- @RawPolicy@-searchableFields :: RawPolicy l -> [Key]-searchableFields policy = map fst $- filter (\(_, f) -> isSearchableField f) fields- where fields = rawFieldPolicies policy------- Exceptions------- | Field/column policies are required for every 'PolicyLabled' value--- in a document.-data PolicyError = NoFieldPolicy -- ^ Policy for field not specified- | InvalidPolicy -- ^ Policy application invalid- | NoColPolicy -- ^ Policy for Collection not specified- | InvalidFieldPolicyType- -- ^ Field with associated policy is not of PolicyLabeled type- | InvalidSearchableType- -- ^ Searchable fields cannot contain labeled values- | PolicyViolation -- ^ Policy has been violated- deriving (Typeable)--instance Show PolicyError where- show NoFieldPolicy = "NoFieldPolicy: Field policy not found"- show NoColPolicy = "NoColPolicy: Collection policy not found"- show InvalidPolicy = "InvalidPolicy: Invalid policy application"- show PolicyViolation = "PolicyViolation: Policy has been violated"- show InvalidFieldPolicyType = "InvalidFieldPolicyType: " ++- "Expected \'PolicyLabeled\' type"- show InvalidSearchableType = "InvalidSearchableType: Searchable" ++- "fields cannot contain labeled values"--instance E.Exception PolicyError--data NoSuchDatabaseError = NoSuchDatabase- deriving (Typeable)--instance Show NoSuchDatabaseError where- show NoSuchDatabase = "NoSuchDatabase: No such database exists"--instance E.Exception (NoSuchDatabaseError)------- Monad------- | Since it would be a security violation to make 'LIO' an instance--- of @MonadIO@, we create a Mongo-specific, wrapper for--- 'LIO' that is instance of @MonadIO@.------ NOTE: IT IS IMPORTANT THAT @UnsafeLIO@ NEVER BE EXPOSED BY MODULES--- THAT ARE NOT Unsafe.-newtype UnsafeLIO l p s a = UnsafeLIO { unUnsafeLIO :: LIO l p s a }- deriving (Functor, Applicative, Monad)---- | UNSAFE: Instance of @MonadIO@.-instance LabelState l p s => MonadIO (UnsafeLIO l p s) where- liftIO = UnsafeLIO . rtioTCB---- | UNSAFE: Instance of @MonadBase IO@.-instance LabelState l p s => MonadBase IO (UnsafeLIO l p s) where- liftBase = UnsafeLIO . rtioTCB---- | UNSAFE: Instance of @MonadBaseControl IO@.--- NOTE: This instance is a hack. I got this to work by tweaking Bas'--- Annex example, but should spend time actually understanding the--- details.-instance LabelState l p s => MonadBaseControl IO (UnsafeLIO l p s) where- newtype StM (UnsafeLIO l p s) a = StUnsafeLIO {- unStUnsafeLIO :: (StM (StateT (LIOstate l p s) IO) a) }- liftBaseWith f = UnsafeLIO . LIO $ liftBaseWith $ \runInIO ->- f $ liftM StUnsafeLIO . runInIO- . (\(LIO x) -> x) . unUnsafeLIO- restoreM = UnsafeLIO . LIO . restoreM . unStUnsafeLIO---- | An LIO action with MongoDB access.-newtype LIOAction l p s a =- LIOAction { unLIOAction :: M.Action (UnsafeLIO l p s) a }- deriving (Functor, Applicative, Monad)--newtype Action l p s a = Action (ReaderT (Database l) (LIOAction l p s) a)- deriving (Functor, Applicative, Monad)--instance LabelState l p s => MonadLIO (UnsafeLIO l p s) l p s where- liftLIO = UnsafeLIO--instance LabelState l p s => MonadLIO (LIOAction l p s) l p s where- liftLIO = LIOAction . liftLIO--instance LabelState l p s => MonadLIO (Action l p s) l p s where- liftLIO = Action . liftLIO---- | Get underlying database.-getDatabase :: Action l p s (Database l)-getDatabase = Action $ ask----- | Lift a MongoDB action into 'Action' monad.-liftAction :: LabelState l p s => M.Action (UnsafeLIO l p s) a -> Action l p s a-liftAction = Action . lift . LIOAction------- Cursor------- | A labeled cursor. The cursor is labeled with the join of the--- database and collection it reads from.-data Cursor l = Cursor { curLabel :: l -- ^ Cursorlabel- , curIntern :: M.Cursor -- ^ Actual cursor- , curProject :: M.Projector -- ^ Projector from query- , curPolicy :: CollectionPolicy l -- ^ Collection policy- } -
+ Hails/Database/Query.hs view
@@ -0,0 +1,631 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE ConstraintKinds,+ FlexibleContexts,+ DeriveDataTypeable,+ FlexibleInstances,+ ScopedTypeVariables,+ TypeSynonymInstances #-}++{- |++This module exports the basic types used to create queries and+selections. Different from standard MongoDB, Hails queries are limited+to 'SearchableField's (similarly, ordering a query result is limited+to such fields) and projections are carried out by this library and+not the database. The later is a result of allowing policy modules to+express a labeling policy as a function of a document -- hence we+cannot determine at compile time if a field is used in a policy and+thus must be included in the projection. ++-}++module Hails.Database.Query (+ -- * Write+ InsertLike(..)+ -- * Read+ -- ** Selection+ , Select(..)+ , Selection(..)+ , Selector+ -- ** Query+ , Query(..)+ , QueryOption(..)+ , Limit+ , BatchSize+ , Order(..), orderName+ -- * Find+ , Cursor, curLabel+ , find, findP+ , next, nextP+ , findOne, findOneP+ -- * Query failures+ , DBError(..)+ -- * Applying policies+ , applyCollectionPolicyP+ -- ** Policy errors+ , PolicyError(..)+ -- * Internal+ , typeCheckDocument+ ) where+++import Prelude hiding (lookup)+import Data.Maybe+import Data.List (sortBy)+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Word (Word32)+import qualified Data.Set as Set+import Data.Typeable+import qualified Data.Text as Text+import qualified Data.Traversable as T++import Control.Monad+import Control.Exception (Exception)++import qualified Data.Bson as Bson+import qualified Database.MongoDB as Mongo+import Database.MongoDB.Query ( QueryOption(..)+ , Limit+ , BatchSize)++import LIO+import LIO.DCLabel+import LIO.DCLabel.Privs.TCB (allPrivTCB)+import LIO.Labeled.TCB (unlabelTCB, labelTCB)++import Hails.Data.Hson+import Hails.Data.Hson.TCB+import Hails.Database.Core+import Hails.Database.TCB+import Hails.Database.Query.TCB++--+-- Query+--+++-- | Sorting fields in 'Asc'ending or 'Desc'ending order.+data Order = Asc FieldName -- ^ Ascending order+ | Desc FieldName -- ^ Descending order+ deriving (Eq, Ord, Show)++-- | Get the field name in the order.+orderName :: Order -> FieldName+orderName (Asc n) = n+orderName (Desc n) = n++-- | Use select to create a basic query with defaults, then modify if+-- desired. Example: @(select sel col) {limit =: 10}@. For simplicity,+-- and since policies may be specified in terms of arbitrary fields,+-- The 'selection' and 'sort' fields are restricted to 'SearchableField's,+-- or the @"_id"@ field that is implicitly a 'SearchableField'.+data Query = Query { options :: [QueryOption]+ -- ^ Query options, default @[]@.+ , selection :: Selection+ -- ^ @WHERE@ clause,default @[]@.+ -- Non-'SearchableField's ignored.+ , project :: [FieldName]+ -- ^ The fields to project. Default @[]@+ -- corresponds to all.+ , skip :: Word32+ -- ^ Number of documents to skip, default 0.+ , limit :: Limit+ -- ^ Max number of documents to return. Default, 0,+ -- means no limit.+ , sort :: [Order]+ -- ^ Sort result by given order, default @[]@.+ -- Non-'SearchableField's ignored.+ , batchSize :: BatchSize+ -- ^ The number of document to return in each+ -- batch response from the server. 0 means+ -- MongoDB default.+ , hint :: [FieldName]+ -- ^ Force mongoDB to use this index, default @[]@,+ -- no hint. + -- Non-'SearchableField's ignored.+ }++-- | Filter for a query, analogous to the @WHERE@ clause in+-- SQL. @[]@ matches all documents in collection. For example,+-- @[x '-:' a, y '-:' b]@ is analogous to+-- @WHERE x = a AND y = b@ in SQL.+--+-- /Note/: only 'FieldName's of 'SearchableField's may be used in+-- selections, and thus all other fields are ignored.+type Selector = BsonDocument+++-- | A @Section@ is a 'Selector' query on a 'Collection'. In other+-- words, a @Selection@ is the necessary information for performing a+-- database query.+data Selection = Selection { selectionSelector :: Selector+ -- ^ Selection query.+ , selectionCollection :: CollectionName+ -- ^ Collection to perform query on.+ } deriving (Show)++-- | Class used to simplicy the creation of a 'Selection'/'Query'.+-- Specifically, 'select' can be used to create a 'Section' in a+-- straight foward manner, but similarly can be used to create a+-- 'Query' with a set of default options.+class Select selectionOrQuery where+ -- | Given a selector and collection name create a 'Query'.+ -- The resultant type depends on the use case, for example,+ -- in 'find' @select mySel myCol@ is a 'Query', but in 'delete'+ -- it is a 'Selection'.+ select :: Selector -> CollectionName -> selectionOrQuery++instance Select Selection where+ select = Selection++instance Select Query where+ select s c = Query { options = []+ , selection = select s c+ , project = []+ , skip = 0+ , limit = 0+ , sort = []+ , batchSize = 0+ , hint = [] + }+--+-- Write+--++-- | Class used to generalize insertion and saving of documents.+-- Specifically, it permits reusing function names when inserting/saving+-- both already-labeled and unlabeled documents.+-- Minimal definition: 'insertP' and 'saveP'.+class InsertLike doc where+ -- | Insert document into collection and return its @_id@ value. When+ -- performing an @insert@ it is required that the computation be able+ -- to write to both the database and collection. To this end, 'insert'+ -- internally applies 'guardWrite' on the database label and collection+ -- label. Of course, the computation must be able to name the+ -- collection in the database, and thus must be able to read the+ -- database collection map as verified by applying 'taint' to the+ -- collections label.+ -- + -- When inserting an unlabeled document, all policies must be+ -- succesfully applied using 'applyCollectionPolicyP' and the document+ -- must be \"well-typed\" (see 'applyCollectionPolicyP').+ -- + -- When inserting an already-labeled document, the labels on fields+ -- and the document itself are compared against the policy-generated+ -- labels. Note that this approach allows an untrusted piece of code+ -- to insert a document it could not label according to the policy+ -- module.+ insert :: CollectionName+ -> doc+ -> DBAction ObjectId+ insert = insertP noPriv++ -- | Same as 'insert' except it does not return @_id@+ insert_ :: CollectionName+ -> doc+ -> DBAction ()+ insert_ c d = void $ insert c d++ -- | Same as 'insert', but uses privileges when applying the+ -- policies and performing label comparisons.+ insertP :: DCPriv+ -> CollectionName+ -> doc+ -> DBAction ObjectId++ -- | Same as 'insertP' except it does not return the @_id@.+ insertP_ :: DCPriv+ -> CollectionName+ -> doc+ -> DBAction ()+ insertP_ p c d = void $ insertP p c d++ -- | Update a document according to its @_id@ value. The IFC requirements+ -- subsume those of 'insert'. Specifically, in addition to being able+ -- to apply all the policies and requiring that the current label flow+ -- to the label of the collection and database, @save@ requires that + -- the current label flow to the label of the existing database+ -- record (i.e, the existing document can be overwritten).+ save :: CollectionName+ -> doc+ -> DBAction ()+ save = saveP noPriv++ -- | Same as 'save', but uses privileges when applying the+ -- policies and performing label comparisons.+ -- Note that a find is performed if the provided document contains+ -- an @_id@ field. This lookup does _not_ leak timing information+ -- since the @_id@ field is always searchable and thus solely+ -- protected by the collection label (which the computation is+ -- tainted by).+ saveP :: DCPriv+ -> CollectionName+ -> doc+ -> DBAction ()++instance InsertLike HsonDocument where+ insertP priv cName doc = do+ withCollection priv True cName $ \col -> do+ -- Already checked that we can write to DB and collection,+ -- apply policies:+ ldoc <- liftLIO $ applyCollectionPolicyP priv col doc+ -- No IFC violation, perform insert:+ let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc+ _id `liftM` (execMongoActionTCB $ Mongo.insert cName bsonDoc)+ where _id i = let HsonValue (BsonObjId i') = dataBsonValueToHsonValueTCB i+ in i'+ saveP priv cName doc = do+ withCollection priv True cName $ \col -> do+ -- Already checked that we can write to DB and collection,+ -- apply policies:+ ldoc <- liftLIO $ applyCollectionPolicyP priv col doc+ let _id_n = Text.pack "_id"+ case lookup _id_n doc of+ Nothing -> saveIt ldoc+ Just (_id :: ObjectId) -> do+ mdoc <- findOneP priv $ select [_id_n -: _id] cName+ -- If document exists, check that we can overwrite it:+ maybe (return ()) (guardWriteP priv . labelOf) mdoc+ -- Okay, save document:+ saveIt ldoc+ where saveIt ldoc =+ let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc+ in execMongoActionTCB $ Mongo.save cName bsonDoc++instance InsertLike LabeledHsonDocument where+ -- | When inserting a labeled document, all the policy-labeled+ -- fields must already be labeled with the correct label.+ -- Additinally, the document label must flow to the label of the+ -- policy-specified document label. Note, however, that that the+ -- current computation may insert a document it could otherwise not+ -- have created.+ insertP priv cName ldoc' = do+ guardInsertOrSaveLabeledHsonDocument priv cName ldoc' $ \ldoc ->+ -- No IFC violation, perform insert:+ let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc+ in _id `liftM` (execMongoActionTCB $ Mongo.insert cName bsonDoc)+ where _id i = let HsonValue (BsonObjId i') = dataBsonValueToHsonValueTCB i+ in i'++ -- | When saving a labeled document, all the policy-labeled+ -- fields must already be labeled with the correct label.+ -- Additinally, the document label must flow to the label of the+ -- policy-specified document label and existing document.+ -- Note, however, that that the current computation may save a+ -- document it could otherwise not have created.+ saveP priv cName ldoc' = do+ guardInsertOrSaveLabeledHsonDocument priv cName ldoc' $ \ldoc ->+ let doc = unlabelTCB ldoc+ _id_n = Text.pack "_id"+ in case lookup _id_n doc of+ Nothing -> saveIt ldoc+ Just (_id :: ObjectId) -> do+ mdoc <- findOneP priv $ select [_id_n -: _id] cName+ -- If document exists, check that we can overwrite it:+ maybe (return ()) (guardWriteP' (labelOf ldoc) . labelOf) mdoc+ -- Okay, save document:+ saveIt ldoc+ where guardWriteP' lnew lold = + unless (canFlowToP priv lnew lold) $ throwLIO $ + VMonitorFailure {+ monitorFailure = CanFlowToViolation+ , monitorMessage = "New document label doesn't flow to the old" }+ saveIt ldoc =+ let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc+ in execMongoActionTCB $ Mongo.save cName bsonDoc++--+-- Helper+--++-- | Save or insert document. This function is used to check that:+--+-- 1. The current computation can write to the database and collection.+--+-- 2. The labeled document is properly labeled: all policy-labeled+-- fields have the label as if generated by the policy, the+-- document label flows to the policy-generated label, and the+-- document is well-typed (i.e., searchables are not policy+-- labeled, etc.). Moreover all labels are checked to be below the+-- collection clearance by 'withColletion'.+--+-- After the check the supplied function is applied to the+-- policy-labeled document (which should be the same as the supplied+-- document, except for possibly the document label.)+guardInsertOrSaveLabeledHsonDocument+ :: DCPriv -- ^ Privileges+ -> CollectionName -- ^ Collection to insert/save to+ -> LabeledHsonDocument -- ^ Original documentk+ -> (LabeledHsonDocument -> DBAction a) -- ^ Insert/save action+ -> DBAction a+guardInsertOrSaveLabeledHsonDocument priv cName ldoc act = do+ withCollection priv True cName $ \col -> do+ -- Already checked that we can write to DB and collection+ -- Document is labeled, remove label:+ let doc = unlabelTCB ldoc+ -- Apply policies to the unlabeled document,+ -- asserts that labeled values are below collection clearance:+ ldocTCB <- liftLIO $ onExceptionP priv + (applyCollectionPolicyP allPrivTCB col doc)+ (throwLIO PolicyViolation)+ -- Check that all the fields are the same (i.e., if there was a+ -- unlabeled PolicyLabeled value an this will fail):+ let same = compareDoc doc (unlabelTCB ldocTCB)+ unless same $ throwLIO PolicyViolation+ -- Check that label of the passed in document `canFlowToP`+ -- the label of document created by the policy:+ unless (canFlowToP priv (labelOf ldoc) (labelOf ldocTCB)) $+ throwLIO PolicyViolation+ -- Perform action on policy-labeled document:+ act ldocTCB+ where compareDoc d1' d2' = + let d1 = sortDoc d1'+ d2 = sortDoc d2'+ in map fieldName d1 == map fieldName d2 + && (and $ zipWith compareField d1 d2)+ compareField (HsonField n1 (HsonValue v1))+ (HsonField n2 (HsonValue v2)) =+ n1 == n2 && v1 == v2+ compareField (HsonField n1 (HsonLabeled (HasPolicyTCB v1)))+ (HsonField n2 (HsonLabeled (HasPolicyTCB v2))) =+ n1 == n2 && labelOf v1 == labelOf v2+ compareField _ _ = False+ sortDoc = sortBy (\f1 f2 -> fieldName f1 `compare` fieldName f2)++--+-- Read+--++-- | Fetch documents satisfying query. A labeled 'Cursor' is returned,+-- which can be used to retrieve the actual 'HsonDocument's. For this+-- function to succeed the current computation must be able to read from+-- the database and collection (implicilty the database's+-- collection-set). This is satisfied by applying 'taint' to the join+-- join of the collection, database, and ccollection-set label.+-- The curor label is labeled by the 'upperBound' of the database and+-- collection labels and must be used within the same 'withPolicyModule'+-- block.+--+-- Note that this function is quite permissive in the queries it+-- accepts. Specifically, any non-'SearchableField's used in 'sort',+-- 'order', or 'hint' are /ignored/ (as opposed to throwing an+-- exception).+find :: Query -> DBAction Cursor+find = findP noPriv++-- | Same as 'find', but uses privileges when reading from the+-- collection and database.+findP :: DCPriv -> Query -> DBAction Cursor+findP priv query = do+ let cName = selectionCollection . selection $ query+ dbLabel <- (databaseLabel . dbActionDB) `liftM` getActionStateTCB+ withCollection priv False cName $ \col -> do+ -- Already checked that we can read from DB and collection.+ let policy = colPolicy col+ -- Get all the searchable fields:+ searchables = Map.keys . Map.filter isSearchable $+ fieldLabelPolicies policy+ -- Remove any non-'SearchableField's from the hint+ hint' = hint query `List.intersect` searchables+ -- Remove any non-'SearchableField's from the sorthint+ sort' = filter (\f -> orderName f `elem` searchables) $ sort query+ -- Remove any non-'SearchableField's from the selection+ sel = selection $ query+ selector' = include searchables $ selectionSelector sel+ selection' = sel { selectionSelector = selector' }+ -- Create the new /clean/ query:+ query' = query { sort = sort', hint = hint', selection = selection' }+ -- Convert the query to Mongo's query type:+ mongoQuery = queryToMongoQueryTCB query'+ cur <- execMongoActionTCB $ Mongo.find mongoQuery+ return $ CursorTCB { curLabel = colLabel col `lub` dbLabel+ , curInternal = cur+ , curProject = project query'+ , curCollection = col }+ where isSearchable SearchableField = True+ isSearchable _ = False++-- | Return next 'HsonDocument' in the query result, or 'Nothing' if+-- finished. Note that the current computation must be able to read from+-- the labeled 'Cursor'. To enforce this, @next@ uses 'taint' to raise+-- the current label to join of the current label and 'Cursor'\'s label.+-- The returned document is labeled according to the underlying+-- 'Collection' policy.+next :: Cursor -> DBAction (Maybe LabeledHsonDocument)+next = nextP noPriv++-- | Same as 'next', but usess privileges when raising the current label.+nextP :: DCPriv -> Cursor -> DBAction (Maybe LabeledHsonDocument)+nextP p cur = do+ -- Rause current label, can read from DB+collection:+ taintP p $ curLabel cur+ -- Read the document:+ mMongoDoc <- execMongoActionTCB $ Mongo.next $ curInternal cur+ case mMongoDoc of+ Nothing -> return Nothing+ Just mongoDoc -> do+ let doc0 = dataBsonDocToHsonDocTCB mongoDoc+ ldoc <- liftLIO $ applyCollectionPolicyP allPrivTCB (curCollection cur) doc0+ let doc = unlabelTCB ldoc+ l = labelOf ldoc+ proj = case curProject cur of+ [] -> id+ xs -> include xs+ return . Just . labelTCB l . proj $ doc++-- | Fetch the first document satisfying query, or 'Nothing' if not+-- documents matched the query.+findOne :: Query -> DBAction (Maybe LabeledHsonDocument)+findOne = findOneP noPriv++-- | Same as 'findOne', but uses privileges when performing label+-- comparisons.+findOneP :: DCPriv -> Query -> DBAction (Maybe LabeledHsonDocument)+findOneP p q = findP p q >>= nextP p++--+-- Helpers+-- ++-- | Convert a query to queries used by "Database.Mongo"+queryToMongoQueryTCB :: Query -> Mongo.Query+queryToMongoQueryTCB q = Mongo.Query {+ Mongo.options = options q+ , Mongo.selection = selectionToMongoSelectionTCB $ selection q+ , Mongo.project = []+ , Mongo.skip = skip q+ , Mongo.limit = limit q+ , Mongo.sort = map orderToField $ sort q+ , Mongo.snapshot = False+ , Mongo.batchSize = batchSize q+ , Mongo.hint = map (\f -> (Bson.=:) f (1::Int)) $ hint q+ } where orderToField (Asc n) = (Bson.=:) n (1::Int)+ orderToField (Desc n) = (Bson.=:) n (-1::Int)++-- | Convert a selection to selection used by "Database.Mongo"+selectionToMongoSelectionTCB :: Selection -> Mongo.Selection+selectionToMongoSelectionTCB s = Mongo.Select {+ Mongo.selector = bsonDocToDataBsonDocTCB $ selectionSelector s+ , Mongo.coll = selectionCollection s }+++--+-- Helpers+--++-- | Perform an action against a collection. The current label is+-- raised to the join of the current label, database label and+-- collection-set label before performing the action.+-- If the @isWrite@ flag, this action is taken as a database write+-- and 'guardWriteP' is applied to the database and collection labels.+withCollection :: DCPriv+ -> Bool+ -> CollectionName+ -> (Collection -> DBAction a)+ -> DBAction a+withCollection priv isWrite cName act = do+ db <- getDatabaseP priv+ -- If this is a write: check that we can write to database:+ when isWrite $ guardWriteP priv (databaseLabel db)+ -- Check that we can read collection names associated with DB:+ cs <- unlabelP priv $ databaseCollections db+ -- Lookup collection name in the collection set associated with DB:+ col <- maybe (throwLIO UnknownCollection) return $ getCol cs+ -- If this is a write: check that we can write to collection:+ when isWrite $ guardWriteP priv (colLabel col)+ -- Execute action on collection:+ act col+ where getCol = listToMaybe . Set.toList . Set.filter ((==cName) . colName)++--+-- Policies+--+++-- | Apply a collection policy the given document, using privileges+-- when labeling the document and performing label comparisons.+-- The labeling proceeds as follows:+--+-- * If two fields have the same 'FieldName', only the first is kept.+-- This filtering is only perfomed at the top level.+--+-- * Each policy labeled value ('HsonLabeled') is labled if the policy+-- has not been applied. If the value is already labeled, then the+-- label is checked to be equivalent to that generated by the policy.+-- In both cases a failure results in 'PolicyViolation' being thrown;+-- the actual error must be hidden to retain the opaqueness of+-- 'PolicyLabeled'.+--+-- /Note:/ For each 'FieldNamed' in the policy there /must/ be a+-- field in the document corresponding to it. Moreover its \"type\"+-- must be correct: all policy labeled values must be 'HsonLabeled'+-- values and all searchable fields must be 'HsonValue's. The @_id@+-- field is always treated as a 'SearchableField'.+--+-- * The resulting document (from the above step) is labeled according+-- to the collection policy.+--+-- The labels on 'PolicyLabeled' values and the document must be bounded+-- by the current label and clearance as imposed by 'guardAllocP'.+-- Additionally, these labels must flow to the label of the collection+-- clearance. (Of course, in both cases privileges are used to allow for+-- more permissive flows.)+applyCollectionPolicyP :: DCPriv -- ^ Privileges+ -> Collection -- ^ Collection and policies+ -> HsonDocument -- ^ Document to apply policies to+ -> DC (LabeledHsonDocument)+applyCollectionPolicyP p col doc0 = do+ let doc1 = List.nubBy (\f1 f2 -> fieldName f1 == fieldName f2) doc0+ typeCheckDocument fieldPolicies doc1++ c <- getClearance+ let colclr = colClearance col+ -- Apply fied policies:+ doc2 <- T.for doc1 $ \f@(HsonField n v) ->+ case v of+ (HsonValue _) -> return f+ (HsonLabeled pl) -> do+ -- NOTE: typeCheckDocument MUST be run before this:+ let (FieldPolicy fieldPolicy) = fieldPolicies Map.! n+ l = fieldPolicy doc1+ case pl of+ (NeedPolicyTCB bv) -> do+ if l `canFlowTo` colclr then+ let lbv = labelTCB l bv+ in return (n -: hasPolicy lbv)+ else throwLIO PolicyViolation+ (HasPolicyTCB lbv) -> do+ unless (labelOf lbv == l) $ throwLIO PolicyViolation+ return f+ -- Apply document policy:+ let docLabel = docPolicy doc2+ if docLabel `canFlowTo` colclr then+ return $ labelTCB docLabel doc2+ else throwLIO PolicyViolation+ where docPolicy = documentLabelPolicy . colPolicy $ col+ fieldPolicies = fieldLabelPolicies . colPolicy $ col++-- | This function \"type-checks\" a document against a set of policies.+-- Specifically, it checks that the set of policy labeled values is the+-- same between the policy and document, searchable fields are not+-- policy labeled, and all searchable/policy-labeled fields named in+-- the collection policy are present in the document (except for @_id@).+typeCheckDocument :: Map FieldName FieldPolicy -> HsonDocument -> DC ()+typeCheckDocument ps doc = do+ -- Check that every policy-named value exists and is well-typed+ void $ T.for psList $ \(k,v) -> do+ case look k doc of+ -- Field exists in document, type check it:+ Just v' -> case v of+ SearchableField -> isHsonValue k v'+ FieldPolicy _ -> isHsonLabeled k v'+ -- Ignore case where _id does not exist:+ _ | k == Text.pack "_id" -> return ()+ -- Field missing from document:+ _ -> throwLIO $ TypeError $ "Missing field with name " ++ show k+ -- Check that no policy-labeled values not named in the policy+ -- exist:+ let doc' = exclude (map fst psList) doc+ unless (isBsonDoc doc') $ throwLIO $ TypeError $+ "Fields " ++ show (map fieldName doc') ++ " should NOT be policy labeled."+ where psList = Map.toList ps+ isHsonValue _ (HsonValue _) = return ()+ isHsonValue k _ = throwLIO $ TypeError $+ show k ++ " should NOT be policy labeled"+ isHsonLabeled _ (HsonLabeled _) = return ()+ isHsonLabeled k _ = throwLIO $ TypeError $+ show k ++ " should be policy labeled"+++--+-- Policy error+--++-- | A document policy error.+data PolicyError = TypeError String -- ^ Document is not \"well-typed\"+ | PolicyViolation -- ^ Policy has been violated+ deriving (Show, Typeable)++instance Exception PolicyError
+ Hails/Database/Query/TCB.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE Unsafe #-}++{- |++This module exports the trusted types and functions used by+"Hails.Database.Query" when performing database queries.++-}++module Hails.Database.Query.TCB ( + -- * Labeled cursor+ Cursor(..)+ ) where++import LIO.DCLabel+import Hails.Data.Hson+import Hails.Database.TCB+import qualified Database.MongoDB as Mongo++-- | A labeled cursor. The cursor is labeled with the join of the+-- database and collection it reads from. The collection policies+-- are \"carried\" along since they are applied on-demand.+data Cursor = CursorTCB { curLabel :: DCLabel+ -- ^ Cursor label+ , curInternal :: Mongo.Cursor+ -- ^ Internal MongoDB cursor+ , curProject :: [FieldName]+ -- ^ Projector from query. Used to remove+ -- fields after performing query.+ , curCollection:: Collection+ -- ^ Collection cursor is reading from+ }
+ Hails/Database/Structured.hs view
@@ -0,0 +1,210 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE FlexibleContexts,+ MultiParamTypeClasses,+ FunctionalDependencies,+ FlexibleInstances,+ ScopedTypeVariables,+ TypeSynonymInstances #-}++{- |++This module exports classes 'DCRecord' and 'DCLabeledRecord' that+provide a way for Hails applications to interact with persistent data+more easily. Specifically, it provides a way to work with Haskell+types as opposed to \"unstructured\" 'Document's.++-}+module Hails.Database.Structured ( DCRecord(..)+ , findAll, findAllP+ , DCLabeledRecord(..)+ ) where++import qualified Data.Map as Map+import Data.Monoid (mappend)+import Control.Monad (liftM)+ +import LIO+import LIO.DCLabel+import LIO.Privs.TCB (mintTCB) + +import Hails.Data.Hson+import Hails.PolicyModule+import Hails.Database.Core+import Hails.Database.Query+++-- | Class for converting from \"structured\" records to documents+-- (and vice versa). Minimal definition consists of 'toDocument',+-- 'fromDocument', and 'recordCollection'. All database operations+-- performed on the collection defined by 'recordCollection'.+class DCRecord a where+ -- | Convert a document to a record+ fromDocument :: Monad m => Document -> m a+ -- | Convert a record to a document+ toDocument :: a -> Document+ -- | Get the collection name for the record+ recordCollection :: a -> CollectionName+ -- | Find an object with matching value for the given key. If the+ -- object does not exist or cannot be read (its label is above the+ -- clearance), this returns 'Nothing'.+ findBy :: (BsonVal v, MonadDB m)+ => CollectionName -> FieldName -> v -> m (Maybe a)+ -- | Find an object with given query+ findWhere :: MonadDB m => Query -> m (Maybe a)+ -- | Insert a record into the database+ insertRecord :: MonadDB m => a -> m ObjectId+ -- | Update a record in the database+ saveRecord :: MonadDB m => a -> m ()+ -- | Same as 'findBy', but uses privileges. + findByP :: (BsonVal v, MonadDB m)+ => DCPriv -> CollectionName -> FieldName -> v -> m (Maybe a)+ -- | Same as 'findWhere', but uses privileges. + findWhereP :: MonadDB m => DCPriv -> Query -> m (Maybe a)+ -- | Same as 'insertRecord', but uses privileges. + insertRecordP :: MonadDB m => DCPriv -> a -> m ObjectId+ -- | Same as 'saveRecord', but uses privileges. + saveRecordP :: MonadDB m => DCPriv -> a -> m ()++ --+ -- Default definitions+ --++ --+ findBy = findByP noPriv+ --+ findWhere = findWhereP noPriv+ --+ insertRecord = insertRecordP noPriv+ --+ saveRecord = saveRecordP noPriv+ --+ insertRecordP p r = liftDB $ do+ insertP p (recordCollection r) $ toDocument r+ --+ saveRecordP p r = liftDB $ do+ saveP p (recordCollection r) $ toDocument r+ --+ findByP p cName k v = + findWhereP p (select [k -: v] cName)+ --+ findWhereP p query = liftDB $ do+ mldoc <- findOneP p query+ c <- getClearance+ case mldoc of+ Just ldoc | canFlowToP p (labelOf ldoc) c ->+ fromDocument `liftM` (liftLIO $ unlabelP p ldoc)+ _ -> return Nothing+-- --+-- deleteByP p policy colName k v = +-- deleteWhereP p policy (select [k =: v] colName)+-- --+-- deleteWhereP p policy sel = do+-- -- Find with only supplied privileges+-- mdoc <- findWhereP p policy $ select (selector sel) (coll sel)+-- -- User underlying privileges as well:+-- p' <- getPrivileges+-- res <- withDB policy $ deleteOneP (p' `mappend` p) sel+-- case res of+-- Right _ -> return mdoc+-- _ -> return Nothing+-- --+++-- | Find all records that satisfy the query and can be read, subject+-- to the current clearance.+findAll :: (DCRecord a, MonadDB m) => Query -> m [a]+findAll = findAllP noPriv++-- | Same as 'findAll', but uses privileges.+findAllP :: (DCRecord a, MonadDB m)+ => DCPriv -> Query -> m [a]+findAllP p query = liftDB $ do+ cursor <- findP p query+ cursorToRecords cursor []+ where cursorToRecords cur docs = do+ mldoc <- nextP p cur+ case mldoc of+ Just ldoc -> do+ c <- getClearance+ if canFlowToP p (labelOf ldoc) c+ then do md <- fromDocument `liftM` (liftLIO $ unlabelP p ldoc)+ cursorToRecords cur $ maybe docs (:docs) md+ else cursorToRecords cur docs+ _ -> return $ reverse docs++-- | Class used by a policy module to translate a labeled record to a+-- labeled document. Since the insert and save functions use the+-- policy module\'s privileges, only the policy module should be+-- allowed to create an instance of this class. Thus, we leverage the +-- fact that the value constructor for a 'PolicyModule' is not exposed+-- to untrusted code and require the policy module to create such a+-- value in 'endorseInstance'.+class (PolicyModule pm, DCRecord a) => DCLabeledRecord pm a | a -> pm where+ -- | Insert a labeled record into the database.+ insertLabeledRecord :: MonadDB m => DCLabeled a -> m ObjectId+ -- | Insert a labeled record into the database+ saveLabeledRecord :: MonadDB m => DCLabeled a -> m ()++ -- | Same as 'insertLabeledRecord', but using explicit privileges.+ insertLabeledRecordP :: MonadDB m => DCPriv -> DCLabeled a -> m ObjectId+ -- | Same as 'saveLabeledRecord', but using explicit privileges.+ saveLabeledRecordP :: MonadDB m => DCPriv -> DCLabeled a -> m ()++ -- | Endorse the implementation of this instance. Note that this is+ -- reduced to WHNF to catch invalid instances that use 'undefined'.+ --+ -- Example implementation:+ --+ -- > endorseInstance _ = MyPolicyModuleTCB {- May leave other values undefined -}+ endorseInstance :: DCLabeled a -> pm++ --+ -- Default definitions for insert/save+ --++ --+ insertLabeledRecord = insertLabeledRecordP noPriv+ --+ saveLabeledRecord = saveLabeledRecordP noPriv+ --+ insertLabeledRecordP p lrec = liftDB $ do+ let cName = recordCollection (forceType lrec)+ ldoc <- liftLIO $ toDocumentP p lrec+ insertP p cName ldoc++ --+ saveLabeledRecordP p lrec = liftDB $ do+ let cName = recordCollection (forceType lrec)+ ldoc <- liftLIO $ toDocumentP p lrec+ saveP p cName ldoc+++-- | Uses the policy modules\'s privileges to convert a labeled record+-- to a labeled document, if the policy module created an instance of+-- 'DCLabeledRecord'.+toDocumentP :: (DCLabeledRecord pm a)+ => DCPriv -- ^ Policy module privileges+ -> DCLabeled a -- ^ Labeled record+ -> DC (DCLabeled Document)+toDocumentP p' lr = do+ -- Fail if not endorsed:+ pmPriv <- getPMPrivTCB (endorseInstance lr)+ let p = p' `mappend` pmPriv+ r <- unlabelP p lr+ lcur <- getLabel+ let lres = partDowngradeP p lcur (labelOf lr)+ labelP p lres $ toDocument r+ where getPMPrivTCB pm = do+ _ <- evaluate pm+ let tn = policyModuleTypeName pm+ f = mintTCB . dcPrivDesc . fst+ return $ maybe noPriv f $ Map.lookup tn availablePolicyModules++--+-- Misc helpers+--++-- | Get the type of a 'DCLabeled' value+forceType :: DCLabeled a -> a+forceType = undefined+
+ Hails/Database/TCB.hs view
@@ -0,0 +1,295 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ StandaloneDeriving,+ DeriveDataTypeable,+ TypeSynonymInstances #-}++{- |++This module exports the basic database types and constructors.+See "Hails.Database" for a description of the Hails database system.++-}++module Hails.Database.TCB (+ -- * Collection+ CollectionName+ , CollectionSet+ , Collection(..)+ , collectionTCB+ -- * Database+ , DatabaseName+ , Database(..)+ -- * Policies+ , CollectionPolicy(..)+ , FieldPolicy(..)+ -- * Hails DB monad+ , DBAction(..), DBActionState(..)+ , getActionStateTCB+ , putActionStateTCB+ , updateActionStateTCB+ , makeDBActionStateTCB + , setDatabaseLabelTCB+ , setCollectionSetLabelTCB + , associateCollectionTCB + -- ** Database system configuration+ , Pipe, AccessMode(..), master, slaveOk+ -- ** Exception thrown by failed database actions+ , DBError(..)+ -- ** Lifting "Database.MongoDB" actions+ , execMongoActionTCB + ) where++import Data.Text (Text)+import Data.Set (Set)+import qualified Data.Set as Set+import Data.Map (Map)+import Data.Typeable++import Control.Applicative+import Control.Monad.Trans+import Control.Monad.Trans.State+import Control.Exception++import qualified Database.MongoDB as Mongo+import Database.MongoDB.Connection ( Pipe )+import Database.MongoDB.Query ( AccessMode(..)+ , master+ , slaveOk+ , Failure(..)+ )++import LIO+import LIO.TCB (rethrowIoTCB)+import LIO.Labeled.TCB (labelTCB, unlabelTCB)+import LIO.DCLabel++import Hails.Data.Hson++--+-- Collections+--++-- | The name of a collection.+type CollectionName = Text+++-- | A @Collection@ is a MongoDB collection name with an associated+-- label, clearance and labeling policy. Access to the collection is+-- restricted according to the collection label. Data inserted-to and+-- retrieved-from the collection will be labeled according to the+-- collection policy, with the guarantee that no data more sensitive than+-- the collection clearance can be inserted into the collection.+data Collection = CollectionTCB { colName :: CollectionName+ -- ^ Collection name+ , colLabel :: DCLabel+ -- ^ Collection label+ , colClearance :: DCLabel+ -- ^ Collection clearance+ , colPolicy :: CollectionPolicy+ -- ^ Collection labeling policies+ }++instance Eq Collection where+ c1 == c2 = colName c1 == colName c2++instance Ord Collection where+ c1 <= c2 = colName c1 <= colName c2++-- | Create a 'Collection', ignoring any IFC restrictions.+collectionTCB :: CollectionName -- ^ Collection name+ -> DCLabel -- ^ Collection label+ -> DCLabel -- ^ Collection clearance+ -> CollectionPolicy -- ^ Collection policy+ -> Collection+collectionTCB n l c p = CollectionTCB { colName = n+ , colLabel = l+ , colClearance = c+ , colPolicy = p+ }++--+-- Policies+--++-- | A collection policy contains the policy for labeling documents+-- ('documentLabelPolicy') at a coarse grained level, and a set of+-- policies for labeling fields of a document ('fieldLabelPolicies').+-- +-- Specific fields can be associated with a 'FieldPolicy', which+-- allows the policy module to either:+-- +-- * Explicitly make a field publicly readable to anyone who can+-- access the collection by declaring the field to be a+-- 'SearchableField', or+--+-- * Label a field given the full documnet (see 'FieldPolicy').+--+-- Fields that do not have an associated policy are (conceputally)+-- labeled with the document label ('documentLabelPolicy').+-- Similarly, the labels on the label of a policy-labeled field is the+-- document label created with 'documentLabelPolicy'. /Note:/ the+-- label on 'SearchableField's is solely the collection label.+data CollectionPolicy = CollectionPolicy {+ documentLabelPolicy :: HsonDocument -> DCLabel+ -- ^ The label on documents of the collection.+ , fieldLabelPolicies :: Map FieldName FieldPolicy+ -- ^ The policies associated with specific fields.+ }++-- | A @FieldPolicy@ is a security policy associated with fields.+-- 'SearchabelField' specifies that the field can be referenced in the+-- selection clause of a @Query@, and therefore only the collection label+-- protects such fields. Conversely, 'FieldPolicy' specifies a labeling+-- policy for the field.+data FieldPolicy = SearchableField+ -- ^ Unlabeled, searchable field.+ | FieldPolicy (HsonDocument -> DCLabel)+ -- ^ Policy labeled field.++--+-- Databases+--+++-- | The name of a database.+type DatabaseName = Text++-- | A labeled 'Collection' set.+type CollectionSet = DCLabeled (Set Collection)++-- | A @Database@ is a MongoDB database with an associated label and set+-- of collections. The label is used to restrict access to the database.+-- Since collection policies are specified by policy modules, every+-- collection must /always/ be associated with some database (and+-- thereby, policy module); a policy module is /not/ allowed to create a+-- collection (and specify policies on it) in an arbitrary database. We+-- allow for the existance of a collection to be secrect, and thus+-- protect the set of collections with a label.+data Database = DatabaseTCB { databaseName :: DatabaseName+ -- ^ Database name+ , databaseLabel :: DCLabel+ -- ^ Label of database+ , databaseCollections :: CollectionSet+ -- ^ Collections associated with databsae+ }++--+-- DB monad+--++-- | The database system state threaded within a Hails computation.+data DBActionState = DBActionState {+ dbActionPipe :: Pipe+ -- ^ Pipe to underlying database system+ , dbActionMode :: AccessMode+ -- ^ Types of reads/write to perform+ , dbActionDB :: Database+ -- ^ Current database executing computation against+ }++-- | A @DBAction@ is the monad within which database actions can be+-- executed, and policy modules are defined. The monad is simply a+-- state monad with 'DC' as monad as the underlying monad with access to+-- a database system configuration ('Pipe', 'AccessMode', and+-- 'Database'). The value constructor is part of the @TCB@ as to+-- disallow untrusted code from modifying the access mode.+newtype DBAction a = DBActionTCB { unDBAction :: StateT DBActionState DC a }+ deriving (Monad, Functor, Applicative)++-- | Get the underlying state.+getActionStateTCB :: DBAction DBActionState+getActionStateTCB = DBActionTCB get++-- | Get the underlying state.+putActionStateTCB :: DBActionState -> DBAction ()+putActionStateTCB = DBActionTCB . put++-- | Update the underlying state using the supplied function.+updateActionStateTCB :: (DBActionState -> DBActionState) -> DBAction ()+updateActionStateTCB f = do+ s <- getActionStateTCB + putActionStateTCB $ f s++instance MonadLIO DCLabel DBAction where+ liftLIO = DBActionTCB . lift++-- | Given a policy module's privileges, database name, pipe and access+-- mode create the initial state for a 'DBAction'. The underlying+-- database is labeled with the supplied privileges: both components of+-- the label (secrecy and integrity) are set to the privilege+-- description. In other words, only code that owns the policy module's+-- privileges can modify the database configuration. Policy modules can+-- use 'setDatabaseLabelP' to change the label of their database, and+-- 'setCollectionMapLabelP' to change the label of the collection map.+makeDBActionStateTCB :: DCPriv+ -> DatabaseName+ -> Pipe+ -> AccessMode+ -> DBActionState+makeDBActionStateTCB priv dbName pipe mode = + DBActionState { dbActionPipe = pipe+ , dbActionMode = mode+ , dbActionDB = db }+ where db = DatabaseTCB { databaseName = dbName + , databaseLabel = l+ , databaseCollections = labelTCB l Set.empty }+ l = dcLabel prin prin+ prin = privDesc priv++-- | Set the label of the underlying database to the supplied label,+-- ignoring IFC.+setDatabaseLabelTCB :: DCLabel -> DBAction ()+setDatabaseLabelTCB l = updateActionStateTCB $ \s -> + let db = dbActionDB s+ in s { dbActionDB = db { databaseLabel = l } }++-- | Set the label of the underlying database to the supplied label,+-- ignoring IFC.+setCollectionSetLabelTCB :: DCLabel -> DBAction ()+setCollectionSetLabelTCB l = updateActionStateTCB $ \s -> + let db = dbActionDB s+ cs = databaseCollections db+ cs' = labelTCB l $! unlabelTCB cs+ in s { dbActionDB = db { databaseCollections = cs' } }++-- | Associate a collection with underlying database, ignoring IFC.+associateCollectionTCB :: Collection -- ^ New collection+ -> DBAction ()+associateCollectionTCB col = updateActionStateTCB $ \s -> + let db = dbActionDB s+ in s { dbActionDB = doUpdate db }+ where doUpdate db = + let cs = databaseCollections db+ in db { databaseCollections = labelTCB (labelOf cs) $+ Set.insert col $ unlabelTCB cs }++-- | Lift a mongoDB action into the 'DBAction' monad. This function+-- always executes the action with "Database.MongoDB"\'s @access@. If+-- the database action fails an exception of type 'Failure' is thrown.+execMongoActionTCB :: Mongo.Action IO a -> DBAction a+execMongoActionTCB act = do+ s <- getActionStateTCB+ let pipe = dbActionPipe s+ mode = dbActionMode s+ db = databaseName . dbActionDB $ s+ liftLIO $ rethrowIoTCB $ do+ res <- Mongo.access pipe mode db act+ case res of+ Left err -> throwIO $ ExecFailure err+ Right v -> return v+++--+-- DB failures+--+++-- | Exceptions thrown by invalid database queries.+data DBError = UnknownCollection -- ^ Collection does not exist+ | UnknownPolicyModule -- ^ Policy module not found+ | ExecFailure Failure -- ^ Execution of action failed+ deriving (Show, Typeable)++instance Exception DBError
+ Hails/HttpClient.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE FlexibleInstances,+ MultiParamTypeClasses #-}+{- |++Exports basic HTTP client functions inside the 'DC' Monad.+Computations are allowed to communicate over HTTP as long as they can+read and write to a labeled origin. An origin is associated with two+labels. When writing, the origin has a label of the form+@\< \"scheme:\/\/authority\", |True \>@, where @scheme@ is+either \'http\' or \'https\', and @authority@ is the domain name or IP+address used in the request and port number of the connection. In+other words, the secrecy component contains the origin information,+while the integrity component is the same as that of public data.+When reading, the origin has a label of the form+@\< |True, \"scheme:\/\/authority\" \>@.++This means that 'DC' computations can export data if the current label+is not higher than that of the labeled origin, and read data that is+no more trustworthy than that of the origin. Practically, this means+that untrusted computation can export data so long as the they have+not observed any data more sensitive than the label of the target+domain. Reading (which also occurs on every request/write) further+raises the current label to the join of the current label and origin.+ +For example, suppose some piece of data, @myLoc@, has the label:++> aliceLocL = dcLabel ("alice" /\ "http://maps.googleapis.com:80") dcTrue++created as:++> myLoc <- labelP alicePriv aliceLocL "3101 24th Street, San Francisco, CA"+++Then, untrusted code (with initial label set to public) running on+behalf of \"alice\" , may perform the following operation:++> let mapBase = "http://maps.googleapis.com/maps/api/geocode/json?sensor=false"+> aliceLoc <- unlabelP alicePriv myLoc+> resp <- simpleGetHttp $ mapBase ++ "&address=" ++ aliceLoc++In this case the 'unlabelP' will raise the current label to the label:++> < "http://maps.googleapis.com:80", |True >++by exercising \"alice\"s privilges. Directly, the 'simpleHttp'+will be permitted. However, if++> let mapBase = "http://maps.evilalternatives.org/geocode/json?sensor=false"++an exception will be thrown since the current label does not flow to+the label of @mapBase@.++++This module uses 'http-conduit' as the underlying client, we recommend+looking at the "Network.HTTP.Conduit" documentation on how to+construct 'C.Request's. Here, we highlight some important details:++* The headers @Content-Length@ and @Host@ are automatically set, and+ should not be added to 'requestHeaders'.++* By default, the functions in this package will /not/ throw+ exceptions for non-2xx status codes. If you would like to use the+ default http-conduit behavior, you should use 'checkStatus', e.g.:++> req <- parseUrl mapBase+> resp <- simpleGetHttp $ req { checkStatus = \s@(Status sci _) hs ->+> if 200 <= sci && sci < 300+> then Nothing+> else Just $ toException $ StatusCodeException s hs }++-}++module Hails.HttpClient (+ -- * Request type+ Request+ , method, secure, host, port, path, queryString+ , requestHeaders+ , requestBody, rawBody+ , redirectCount+ , checkStatus, decompress+ , module Network.HTTP.Types+ -- * Response type+ , Response(..)+ -- * Simple HTTP interface+ , parseUrl+ , applyBasicAuth+ , simpleHttp, simpleHttpP+ , simpleGetHttp, simpleGetHttpP+ , simpleHeadHttp, simpleHeadHttpP+ -- * Exceptions+ , HttpException(..)+ ) where++import qualified Data.ByteString.Char8 as S8+import qualified Data.Conduit as C+ +import Control.Failure+import Control.Exception++import qualified Network.HTTP.Conduit as C+import Network.HTTP.Conduit (+ method, secure, host, port, path, queryString+ , requestHeaders+ , requestBody, rawBody+ , redirectCount+ , checkStatus, decompress+ , proxy, socksProxy+ , applyBasicAuth+ , HttpException(..)+ )+import Hails.HttpServer (Response(..))+import Network.HTTP.Types++import LIO+import LIO.TCB+import LIO.DCLabel+++-- | Reques type, wrapper for the conduit 'C.Request'.+type Request = C.Request (C.ResourceT IO)++--+-- Basic functions+--++-- | Perform a simple HTTP(S) request.+simpleHttp :: Request -- ^ Request+ -> DC Response+simpleHttp = simpleHttpP noPriv++-- | Same as 'simpleHttp', but uses privileges.+simpleHttpP :: DCPriv -- ^ Privilege+ -> Request -- ^ Request+ -> DC Response+simpleHttpP p req' = do+ let req = req' { proxy = Nothing, socksProxy = Nothing }+ guardWriteURLP p req+ resp <- rethrowIoTCB $ C.withManager $ C.httpLbs req+ return $ Response { respStatus = C.responseStatus resp+ , respHeaders = C.responseHeaders resp+ , respBody = C.responseBody resp+ }++-- +-- Simple HEAD/GET Wrappers+--++-- | Simple HTTP GET request.+simpleGetHttpP :: DCPriv -- ^ Privilege+ -> String -- ^ URL+ -> DC Response+simpleGetHttpP p url = do+ req <- parseUrl url+ simpleHttpP p req++-- | Simple HTTP GET request.+simpleGetHttp :: String -> DC Response+simpleGetHttp = simpleGetHttpP noPriv++-- | Simple HTTP HEAD request.+simpleHeadHttpP :: DCPriv -- ^ Privilege+ -> String -- ^ URL+ -> DC Response+simpleHeadHttpP p url = do+ req <- parseUrl url+ simpleHttpP p $ req { method = methodHead }++-- | Simple HTTP HEAD request.+simpleHeadHttp :: String -> DC Response+simpleHeadHttp = simpleHeadHttpP noPriv+++--+-- Misc+--++-- | Check that current label can flow to label of request.+guardWriteURLP :: DCPriv -> Request -> DC ()+guardWriteURLP p req = do+ let (lr, lw) = labelOfReq req+ guardAllocP p lr+ taintP p lw++-- | Return the labels corresponding to the absolute URI of a request header.+-- The created labels will have the scheme and authority (including port) in the+-- secrecy componenet, and @|True@ in the integrity component for the+-- read label (and the dual for write label). Specifically, the+-- labels will have the form:+--+-- > (< scheme://authority, |True >,< |True, scheme://authority >)+--+-- For example, the read label of a request to \"http:\/\/gitstar.com/\" is:+-- +-- > < "http://gitstar.com:80" , |True>+--+-- while the read label of \"https:\/\/gitstar.com:444/\"+--+-- > < "https://gitstar.com:444" , |True>+--+-- This should be used for only for single-connection requests, where the+-- absolute URL makes senes.+labelOfReq :: Request -> (DCLabel, DCLabel)+labelOfReq req =+ let scheme = if secure req then "https://" else "http://"+ prin = concat [scheme, S8.unpack (host req), ':' : show (port req)]+ in (dcLabel (toComponent prin) dcTrue, dcLabel dcTrue (toComponent prin))++-- | Convert a URL into a 'Request'.+--+-- This defaults some of the values in 'Request', such as setting+-- method to GET and 'requestHeaders' to [].+--+parseUrl :: String -> DC Request+parseUrl = C.parseUrl++instance Exception e => Failure e (LIO DCLabel) where+ failure = throwLIO
Hails/HttpServer.hs view
@@ -1,111 +1,257 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif-+{-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-}+{- | -module Hails.HttpServer ( secureHttpServer ) where+This module exports the core of the Hails HTTP server. Specifically it+defines basic types, such as HTTP 'Request' and 'Response', used by+the Hails web server and untrusted Hails 'Application's. -import qualified Data.ByteString.Lazy.Char8 as L8+At a high level, a Hails 'Application', is a function from 'Request'+to 'Response' in the 'DC' monad. Every application response is+sanitized and sanity checked with the 'secureApplication'+'Middleware'.++Hails uses Wai, and as such we provide two functions for converting+Hails 'Application's to Wai 'W.Applicatoin's: '+'devHailsApplication' used to execute Hails apps in development+mode, and 'hailsApplicationToWai' that should be used in production+with an authentication service from "Hails.HttpServer.Auth".++-}+module Hails.HttpServer (+ module Hails.HttpServer.Types+ -- ** Execute Hails application in development mode+ , devHailsApplication+ -- ** Execute Hails application+ , hailsApplicationToWai+ -- ** Middleware used by Hails+ , browserLabelGuard+ , guardSensitiveResp + , sanitizeResp+ -- * Network types+ , module Network.HTTP.Types+ -- * Converting labeled requests+ , requestToDocument+ , labeledRequestToLabeledDocument+ ) where++import qualified Data.List as List+import Data.Text.Encoding (decodeUtf8)+import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8-import Data.Monoid (mempty)-import Data.IterIO-import Data.IterIO.Http-import Data.IterIO.HttpRoute (runHttpRoute, routeName)-import Data.IterIO.Server.TCPServer-import Data.Functor ((<$>))+import qualified Data.ByteString.Lazy as L+import Data.Conduit+import Data.Conduit.List -import Hails.TCB.Types+import Control.Monad.IO.Class (liftIO)+import Control.Exception (fromException) -import Hails.IterIO.Mime-import Hails.IterIO.Conversions-import Hails.IterIO.HailsRoute-import DCLabel.TCB-import LIO.DCLabel-import LIO.MonadLIO hiding (liftIO)-import LIO.TCB-import Network.Socket as Net -import Hails.HttpServer.Auth+import Network.HTTP.Types+import qualified Network.Wai as W+import qualified Network.Wai.Application.Static as W -type L = L8.ByteString+import LIO+import LIO.TCB+import LIO.DCLabel+import LIO.DCLabel.Core (principalName)+import LIO.DCLabel.Privs.TCB+import LIO.Labeled.TCB --- | Given an 'App' return handler.-httpApp :: AuthFunction DC () -> AppReqHandler -> Inum L L DC ()-httpApp authFunc lrh = mkInumM $ do- req0 <- httpReqI- authRes <- liftLIO $ authFunc req0- case authRes of- Left resp -> irun $ enumHttpResp resp- Right req1 -> do- appState <- getAppConf req1- irun . enumHttpResp =<<- case appState of- Nothing -> return $ resp500 "Missing x-hails-user header"- Just appC | isStaticReq appC -> liftI $ respondWithFS (appReq appC)- | otherwise -> do- let userLabel = newDC (appUser appC) (<>)- req = appReq appC- -- Set current label to be public, clearance to the user's label- -- and privilege to the app's privilege.- liftLIO $ do taint lpub- lowerClr userLabel- setPrivileges (appPriv appC)- body <- inumHttpBody req .| pureI- -- TODO: catch exceptions:- resp <- liftLIO $ lrh req (labelTCB (newDC (<>) (appUser appC)) body)- resultLabel <- liftLIO getLabel- return $ if resultLabel `leq` userLabel- then resp- else resp500 "App violated IFC"- where isStaticReq appC | null . reqPathLst . appReq $ appC = False- | otherwise =- (head . reqPathLst . appReq $ appC) == "static"- -- if /static, respond by routing files from filesystem- respondWithFS req = - let rh = runHttpRoute $ routeName "static" $- routeFileSys systemMimeMap (const mempty) "static"- in inumHttpBody req .| rh req+import Hails.HttpServer.Auth+import Hails.HttpServer.Types+import Hails.Data.Hson hiding (lookup) --- | Return a server, given a port number and app.-secureHttpServer :: AuthFunction DC ()- -> PortNumber- -> AppReqHandler- -> TCPServer L DC-secureHttpServer authFunc port appHandler =- TCPServer port app dcServerAcceptor handler- where handler m = fst <$> evalDC m- app = httpApp authFunc appHandler+import System.IO --- | Given a socket, return the to/from-browser pipes.-dcServerAcceptor :: Net.Socket -> DC (Iter L DC (), Onum L DC ())-dcServerAcceptor sock = do- (iterIO, onumIO) <- ioTCB $ defaultServerAcceptor sock- s <- getTCB- return (iterIOtoIterLIO iterIO, inumIOtoInumLIO onumIO s)+-- | Convert a WAI 'W.Request' to a Hails 'Request' by consuming the body into+-- a 'L.ByteString'.+waiToHailsReq :: W.Request -> ResourceT IO Request+waiToHailsReq req = do+ body <- fmap L.fromChunks $ W.requestBody req $$ consume+ return $ Request { requestMethod = W.requestMethod req+ , httpVersion = W.httpVersion req+ , rawPathInfo = W.rawPathInfo req+ , rawQueryString = W.rawQueryString req+ , serverName = W.serverName req+ , serverPort = W.serverPort req+ , requestHeaders = W.requestHeaders req+ , isSecure = W.isSecure req+ , remoteHost = W.remoteHost req+ , pathInfo = W.pathInfo req+ , queryString = W.queryString req+ , requestBody = body } +-- | Convert a Hails 'Response' to a WAI 'W.Response'+hailsToWaiResponse :: Response -> W.Response+hailsToWaiResponse (Response stat rhd body) = W.responseLBS stat rhd body++-- | Hails '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 :: Middleware+browserLabelGuard hailsApp conf req = do+ response <- hailsApp conf req+ resultLabel <- getLabel+ return $ if resultLabel `canFlowTo` (browserLabel conf)+ then response+ else Response status403 [] ""++-- | Adds the header @X-Hails-Label@ to the response. If the+-- label of the computation does not flow to the public label,+-- 'dcPub', the JSON field @isPublic@ is set to @true@, otherwise+-- it is set to @true@ and the JSON @label@ is set to the secrecy+-- component of the response label (if it is a disjunction+-- of principals is added). An example may be: --+-- > X-Hails-Label = { isPublic: true }+-- +-- or+--+-- > X-Hails-Label = { isPublic: false, label : ["http://google.com:80", "alice"] }+--+guardSensitiveResp :: Middleware+guardSensitiveResp happ p req = do+ response <- happ p req+ resultLabel <- getLabel+ return $ addResponseHeader response $ + ("X-Hails-Label", S8.pack $+ if resultLabel `canFlowTo` dcPub+ then "{\"isPublic\": true}"+ else "{\"isPublic\": false, \"label\": [" ++ mkClientLabel resultLabel ++ "]}")+ where mkClientLabel l = let s = dcSecrecy l+ cs = toList s+ in if s == dcFalse || length cs /= 1+ then ""+ else List.intercalate ", " $ + List.map (show . S8.unpack . principalName) $+ List.head cs++-- | Remove anything from the response that could cause inadvertant+-- declasification. Currently this only removes the @Set-Cookie@+-- header.+sanitizeResp :: Middleware+sanitizeResp hailsApp conf req = do+ response <- hailsApp conf req+ return $ removeResponseHeader response "Set-Cookie"+ ++-- | Returns a secure Hails app such that the result 'Response' is guaranteed+-- to be safe to transmit to the client's browser. The definition is+-- straight forward from other middleware:+--+-- > secureApplication = 'browserLabelGuard' -- Return 403, if user should not read+-- > . 'guardSensitiveResp' -- Add X-Hails-Sensitive if not public+-- > . 'sanitizeResp' -- Remove Cookies+secureApplication :: Middleware+secureApplication = browserLabelGuard -- Return 403, if user should not read+ . guardSensitiveResp -- Add X-Hails-Sensitive if not public+ . sanitizeResp -- Remove Cookies++--+-- Executing Hails applications+--++-- | A default Hails handler for development environments. Safely runs+-- a Hails 'Application', using basic HTTP authentication for+-- authenticating users. Note: authentication will accept any+-- username/password pair, it is solely used to set the user-name.+devHailsApplication :: Application -> W.Application+devHailsApplication = devBasicAuth . hailsApplicationToWai+++-- | Safely wraps a Hails 'Application' in a Wai 'W.Application' that can+-- be run by an application server. The application is executed with the+-- 'secureApplication' 'Middleware'. The function returns status 500 if+-- the Hails application throws an exception and the label of the+-- exception flows to the browser label (see 'browserLabelGuard'); if the+-- label does not flow, it responds with a 403.+--+-- All applications serve static content from a @\"static\"@ directory.+hailsApplicationToWai :: Application -> W.Application+hailsApplicationToWai app0 req0 | isStatic req0 =+ -- Is static request, serve files:+ W.staticApp (W.defaultWebAppSettings "./") req0+ | otherwise = do+ -- Not static request, serve dynamic content:+ -- Convert request to Hails request+ hailsRequest <- waiToHailsReq req0+ -- Extract browser/request configuration+ let conf = getRequestConf hailsRequest+ result <- liftIO $ paranoidDC' conf $ do+ let lreq = labelTCB (requestLabel conf) hailsRequest+ app conf lreq+ case result of+ Right (response,_) -> return $ hailsToWaiResponse response+ Left err -> do+ liftIO $ hPutStrLn stderr $ "App threw exception: " ++ show err+ return $ case fromException err of+ Just (LabeledExceptionTCB l _) -> + -- as in browserLabelGuard :+ if l `canFlowTo` (browserLabel conf)+ then resp500 else resp403 + _ -> resp500+ where app = secureApplication app0+ isStatic req = case W.pathInfo req of+ ("static":_) -> True+ _ -> False+ resp403 = W.responseLBS status403 [] "" + resp500 = W.responseLBS status500 [] ""+ paranoidDC' conf act =+ paranoidLIO act $ LIOState { lioLabel = dcPub+ , lioClearance = browserLabel conf}+++--+--+--++-- | Convert a labeled request to a labeled document+labeledRequestToLabeledDocument :: DCLabeled Request -> DCLabeled HsonDocument+labeledRequestToLabeledDocument lreq =+ labelTCB (labelOf lreq) (requestToDocument . unlabelTCB $ lreq)++-- | Convert a form post from a request into a document.+-- Each field value is a 'BsonBlob', hence further \"casting\"+-- may be necessary. Note that if a field with the same name is found,+-- the values are grouped into a 'BsonArray'.+requestToDocument :: Request -> HsonDocument+requestToDocument req = groupFields $ List.map itemToField $ parseQuery body+ where body = strictify $ requestBody req+ --+ itemToField (n, mv) = let nt = decodeUtf8 n+ hv = maybe BsonNull (BsonBlob . Binary) mv+ in nt -: hv+ --+ strictify = S.concat . L.toChunks+ --+ groupFields :: HsonDocument -> HsonDocument+ groupFields xs =+ let gs = List.groupBy (\x y -> fieldName x == fieldName y) xs+ in List.concat $ List.map groupFunc gs+ groupFunc xs = let n = fieldName . List.head $ xs+ ys :: [BsonValue]+ ys = List.map (\(HsonField _ (HsonValue x)) -> x) xs+ in [n -: ys]+++-- -- Helper -- --- | Get the authenticated user, application name, and new (safe)--- request. Note: all cookies are removed.-getAppConf :: (Monad m)- => HttpReq ()- -> m (Maybe AppConf)-getAppConf req =- let hdrs = reqHeaders req- in case lookup "x-hails-user" hdrs of- Nothing -> return Nothing- Just user ->- let usrN = principal user- appN = S8.unpack . S8.takeWhile (/= '.') $ reqHost req- privs = createPrivTCB $ newPriv appN- in return . Just $ AppConf { appUser = usrN- , appName = appN- , appPriv = privs- , appReq = modReq appN hdrs}- where modReq n hdrs =- req { reqHeaders = ("x-hails-app", S8.pack n) : hdrs- , reqCookies = [] }+-- | Get the browser label (secrecy of the user), request label (integrity of+-- the user), and application privilege (minted with the app's cannonical name)+getRequestConf :: Request -> RequestConfig+getRequestConf req =+ let headers = requestHeaders req+ userName = toComponent `fmap` lookup "x-hails-user" headers+ appName = '@' : (S8.unpack . S8.takeWhile (/= '.') $ serverName req)+ appPriv = DCPrivTCB $ toComponent appName+ in RequestConfig+ { browserLabel = maybe dcPub (\un -> dcLabel un anybody) userName+ , requestLabel = maybe dcPub (\un -> dcLabel anybody un) userName+ , appPrivilege = appPriv }++
Hails/HttpServer/Auth.hs view
@@ -1,104 +1,151 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704 {-# LANGUAGE Trustworthy #-}-#endif {-# LANGUAGE OverloadedStrings #-}-{-| This module exports various authentication methods. -}-module Hails.HttpServer.Auth ( AuthFunction- -- * Basic authentication- , basicAuth, basicNoAuth- -- * External authentication- , externalAuth- ) where+{- | -import qualified Data.ByteString.Lazy.Char8 as L8-import qualified Data.ByteString.Char8 as S8-import Data.ByteString.Base64-import Data.IterIO.Http-import Data.Functor ((<$>))+This module exports generic definitions for Wai-authentication pipelines+in Hails. 'requireLoginMiddleware' looks for the @X-Hails-Login@+header from an 'Application' \'s 'Response' and, if present, responds to+the user with an authentication request instead of the 'Application'+response (e.g., a redirect to a login page or an HTTP response with+status 401). -import Hails.Crypto+Additionally, this module exports authentication 'Middleware's for basic HTTP+authentication, 'devBasicAuth', (useful in development environments)+and federated (OpenID) authentication, 'openIdAuth'. In general,+authentication 'Middleware's are expected to set the @X-Hails-User@+header on the request if it is from an authenticated user. -import LIO.DCLabel+-}+module Hails.HttpServer.Auth+ ( requireLoginMiddleware+ -- * Production: OpenID+ , openIdAuth+ -- * Development: basic authentication+ , devBasicAuth+ ) where+import Control.Monad.IO.Class (liftIO)+import Blaze.ByteString.Builder (toByteString)+import Control.Monad+import Control.Monad.Trans.Resource+import Data.Time.Clock+import Data.ByteString.Base64+import qualified Data.Text as T+import Data.Maybe (fromMaybe, isJust, fromJust)+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.HTTP.Conduit (withManager)+import Network.HTTP.Types+import Network.Wai+import Web.Authenticate.OpenId+import Web.Cookie -type S = S8.ByteString-type L = L8.ByteString --- |Authentication function-type AuthFunction m s = HttpReq s -- ^ Request- -> m (Either (HttpResp m) (HttpReq s))+-- | Basic HTTP authentication middleware for development. Accepts any username+-- and password.+devBasicAuth :: Middleware+devBasicAuth app0 req0 = do+ let resp = responseLBS status401+ [( "WWW-Authenticate", "Basic realm=\"Hails development.\"")] ""+ let req = case getBasicAuthUser req0 of+ Nothing -> req0+ Just user -> req0 { requestHeaders = ("X-Hails-User", user)+ : requestHeaders req0 }+ requireLoginMiddleware (return resp) app0 req ------ Basic authentication--- --- | Perform basic authentication-basicAuth :: Monad m- => (HttpReq s -> m Bool) -- ^ Authentication function- -> AuthFunction m s-basicAuth authFunc req = - case userFromReq of- Just [user,_] -> do- success <- authFunc req- if not success- then return . Left $ respAuthRequired- else let hdrs = filter ((/=authField) . fst) $ reqHeaders req- in return . Right $- req { reqHeaders = ("x-hails-user", user) : hdrs }- _ -> return . Left $ respAuthRequired- where authField = "authorization"- -- No login, send an auth response-header:- respAuthRequired =- let resp = mkHttpHead stat401- authHdr = ("WWW-Authenticate", "Basic realm=\"Hails\"")- in respAddHeader authHdr resp- -- Get user and password information from request header:- userFromReq = let mAuthCode = lookup authField $ reqHeaders req- in extractUser . S8.dropWhile (/= ' ') <$> mAuthCode- extractUser b64u = S8.split ':' $ decodeLenient b64u+-- | Perform OpenID authentication.+openIdAuth :: T.Text -- ^ OpenID Provider + -> Middleware+openIdAuth openIdUrl app0 req0 = do+ case pathInfo req0 of+ "_hails":"logout":_ -> do+ let cookie = toByteString . renderSetCookie $ def+ { setCookieName = "hails_session"+ , setCookiePath = Just "/"+ , setCookieValue = "deleted"+ , setCookieExpires = Just $ UTCTime (toEnum 0) 0}+ let redirectTo = fromMaybe "/" $ lookup "Referer" $ requestHeaders req0+ return $ responseLBS status302 [ ("Set-Cookie", cookie)+ , ("Location", redirectTo)] ""+ "_hails":"login":_ -> do+ let qry = map (\(n,v) -> (n, fromJust v)) $ filter (isJust . snd) $+ parseQueryText $ rawQueryString req0+ oidResp <- withManager $ authenticateClaimed qry+ liftIO $ print $ oirParams oidResp+ let cookie = toByteString . renderSetCookie $ def+ { setCookieName = "hails_session"+ , setCookiePath = Just "/"+ , setCookieValue = S8.pack . T.unpack . identifier . oirOpLocal $ oidResp }+ let redirectTo = fromMaybe "/" $ do+ rawCookies <- lookup "Cookie" $ requestHeaders req0+ lookup "redirect_to" $ parseCookies rawCookies+ return $ responseLBS status200 [] (L8.pack $ show qry) -- [ ("Set-Cookie", cookie)+ -- , ("Location", redirectTo)] ""+ _ -> do+ let req = fromMaybe req0 $ do+ rawCookies <- lookup "Cookie" $ requestHeaders req0+ user <- lookup "hails_session" $ parseCookies rawCookies+ return $ req0 { requestHeaders =+ ("X-Hails-User", user):(requestHeaders req0)+ }+ let redirectResp = do+ let returnUrl = T.pack . S8.unpack $ requestToUri req "/_hails/login"+ url <- withManager $ getForwardUrl openIdUrl returnUrl Nothing+ [ ("openid.ns.ax", "http://openid.net/srv/ax/1.0")+ , ("openid.ax.mode", "fetch_request")+ , ("openid.ax.type.email", "http://schema.openid.net/contact/email")+ , ("openid.ax.required", "email")]+ let cookie = toByteString . renderSetCookie $ def+ { setCookieName = "redirect_to"+ , setCookiePath = Just "/_hails/"+ , setCookieValue = rawPathInfo req }+ return $ responseLBS status302 [ ("Location", (S8.pack . T.unpack $ url))+ , ("Set-Cookie", cookie)] ""+ requireLoginMiddleware redirectResp app0 req --- | Basic authentication, that always succeeds. The function uses the--- username in the cookie (as in 'externalAuth'), if it is set. If the--- cookie is not set, 'bsicAuth' is used.-basicNoAuth :: Monad m => AuthFunction m s-basicNoAuth req =- let cookies = reqCookies req- in case lookup _hails_cookie cookies of- Just user -> return . Right $ req { reqCookies =- filter (not . S8.isPrefixOf _hails_cookie . fst) cookies- , reqHeaders = ("x-hails-user", user) : reqHeaders req }- Nothing -> basicAuth (const $ return True) req+-- | Executes the app and if the app 'Response' has header+-- @X-Hails-Login@ and the user is not logged in, respond with an+-- authentication response (Basic Auth, redirect, etc.)+requireLoginMiddleware :: ResourceT IO Response -> Middleware+requireLoginMiddleware loginResp app0 req = do+ appResp <- app0 req+ if hasLogin appResp && notLoggedIn+ then loginResp+ else return appResp+ where hasLogin r = "X-Hails-Login" `isIn` responseHeaders r+ notLoggedIn = not $ "X-Hails-User" `isIn` requestHeaders req+ isIn n xs = isJust $ lookup n xs +-- | Get the hreaders from a response.+responseHeaders :: Response -> ResponseHeaders+responseHeaders (ResponseFile _ hdrs _ _) = hdrs+responseHeaders (ResponseBuilder _ hdrs _) = hdrs+responseHeaders (ResponseSource _ hdrs _) = hdrs+ ----- Cookie authentication+-- Helpers -- --- | Use an external authentication service that sets a cookie.--- The cookie name is @_hails_user@, and its contents contain--- a string of the form @user-name:HMAC-SHA1(user-name)@. This--- function simply checks that the cookie exits and the MAC'd--- user name is correct. If this is the case, it returns a request--- with the cookie removed. Otherwise it retuns a redirect (to the--- provided url) response.-externalAuth :: L -> String -> AuthFunction DC s-externalAuth key url req = - let cookies = reqCookies req- res = do user <- lookup _hails_cookie cookies- mac0 <- lookup _hails_cookie_hmac cookies- let mac1 = showDigest $ hmacSha1 key (lazyfy user)- if S8.unpack mac0 == mac1- then return $ req { reqCookies =- filter (not . S8.isPrefixOf _hails_cookie . fst) cookies- , reqHeaders = ("x-hails-user", user) : reqHeaders req }- else Nothing- in return $ maybe redirect Right res- where redirect = Left $ resp303 url- lazyfy = L8.pack . S8.unpack---- | Cookie user token-_hails_cookie :: S-_hails_cookie = "_hails_user"+-- | Helper method for implementing basic authentication. Given a+-- 'Request' returns the usernamepair from the basic authentication+-- header if present.+getBasicAuthUser :: Request -> Maybe S8.ByteString+getBasicAuthUser 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:_:[]) -> return user+ _ -> fail "Malformed basic auth header." --- | Cookie user HMAC token-_hails_cookie_hmac :: S-_hails_cookie_hmac = "_hails_user_hmac"+-- | Given a request and path, extract the scheme,+-- hostname and port from the request and createand a URI+-- @scheme://hostname[:port]/path@.+requestToUri :: Request -> S8.ByteString -> S8.ByteString+requestToUri req path = S8.concat $+ [ "http"+ , if isSecure req then "s://" else "://"+ , serverName req+ , if serverPort req `notElem` [80, 443] then portBS else ""+ , path ]+ where portBS = S8.pack $ ":" ++ show (serverPort req)
+ Hails/HttpServer/Types.hs view
@@ -0,0 +1,106 @@+module Hails.HttpServer.Types (+ -- * Requests+ Request(..)+ -- * Responses+ , Response(..)+ , addResponseHeader, removeResponseHeader+ -- * Applications and middleware+ , Application, RequestConfig(..)+ , Middleware) where++import qualified Data.List as List+import Data.Text (Text)+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L++import Network.Socket (SockAddr)+import qualified Network.HTTP.Types as H+import qualified Network.HTTP.Types.Header as H++import LIO.DCLabel++--+-- Request+--++-- | A request sent by the end-user.+data Request = Request { + -- | HTTP Request (e.g., @GET@, @POST@, etc.).+ requestMethod :: H.Method+ -- | HTTP version (e.g., 1.1 or 1.0).+ , httpVersion :: H.HttpVersion+ -- | Extra path information sent by the client.+ , rawPathInfo :: S.ByteString+ -- | If no query string was specified, this should be empty. This value+ -- /will/ include the leading question mark.+ -- Do not modify this raw value- modify queryString instead.+ , rawQueryString :: S.ByteString+ -- | Generally the host requested by the user via the Host request header.+ -- Backends are free to provide alternative values as necessary. This value+ -- should not be used to construct URLs.+ , serverName :: S.ByteString+ -- | The listening port that the server received this request on. It is+ -- possible for a server to listen on a non-numeric port (i.e., Unix named+ -- socket), in which case this value will be arbitrary. Like 'serverName',+ -- this value should not be used in URL construction.+ , serverPort :: Int+ -- | The request headers.+ , requestHeaders :: H.RequestHeaders+ -- | Was this request made over an SSL connection?+ , isSecure :: Bool+ -- | The client\'s host information.+ , remoteHost :: SockAddr+ -- | Path info in individual pieces- the url without a hostname/port+ -- and without a query string, split on forward slashes,+ , pathInfo :: [Text]+ -- | Parsed query string information+ , queryString :: H.Query+ -- | Lazy ByteString containing the request body.+ , requestBody :: L.ByteString+ } deriving Show+++--+-- Response+--++-- | A response sent by the app.+data Response = Response {+ -- | Response status+ respStatus :: H.Status+ -- | Response headers+ , respHeaders :: H.ResponseHeaders + -- | Response body+ , respBody :: L.ByteString+ } deriving Show++-- | Add/replace a 'H.Header' to the 'Response'+addResponseHeader :: Response -> H.Header -> Response+addResponseHeader resp hdr@(hname, _) = resp { respHeaders = hdr:headers }+ where headers = List.filter ((/= hname) . fst) $ respHeaders resp++-- | Remove a header (if it exists) from the 'Response'+removeResponseHeader :: Response -> H.HeaderName -> Response+removeResponseHeader resp hname = resp { respHeaders = headers }+ where headers = List.filter ((/= hname) . fst) $ respHeaders resp+++--+-- Application & middleware+--++-- | The settings with which the app will run.+data RequestConfig = RequestConfig {+ -- | The label of the browser the reponse will be sent to.+ browserLabel :: DCLabel+ -- | The label of the incoming request (with the logged in user's integrity).+ , requestLabel :: DCLabel+ -- | A privilege minted for the app.+ , appPrivilege :: DCPriv+ } deriving Show++-- | Base Hails type implemented by untrusted applications.+type Application = RequestConfig -> DCLabeled Request -> DC Response++-- | Convenience type for middleware components.+type Middleware = Application -> Application
− Hails/IterIO/Conversions.hs
@@ -1,79 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif-module Hails.IterIO.Conversions ( iterIOtoIterLIO- , ioIterRtoLIO- , onumIOtoOnumLIO- , inumIOtoInumLIO - ) where--import qualified Data.ByteString.Lazy.Char8 as L-import Data.IORef-import Data.IterIO-import LIO.DCLabel-import LIO.TCB-import Control.Monad-import Control.Monad.Trans--type L = L.ByteString---- | Lift the underlying monad of an 'Iter' from 'IO' to 'LIO'.-iterIOtoIterLIO :: (LabelState l p s, ChunkData t)- => Iter t IO a -> Iter t (LIO l p s) a-iterIOtoIterLIO = adaptIterM rtioTCB---- | Lift the underlying monad of an 'IterR' from 'IO' to 'LIO'.-ioIterRtoLIO :: (LabelState l p s, ChunkData t)- => IterR t IO a -> IterR t (LIO l p s) a-ioIterRtoLIO (Done a (Chunk b c)) = Done a (Chunk b c)-ioIterRtoLIO (IterM m) = IterM $ fmap ioIterRtoLIO $ rtioTCB m-ioIterRtoLIO (IterF next) = IterF $ iterIOtoIterLIO next-ioIterRtoLIO (Fail itf ma mb) = Fail itf ma mb-ioIterRtoLIO (IterC (CtlArg carg f c)) =- let g = \cres -> iterIOtoIterLIO $ f cres- in IterC (CtlArg carg g c)---- | Lift the underlying monad of an 'Inum' from 'IO' to 'LIO'.-onumIOtoOnumLIO :: LabelState l p s => Onum L IO L -> Onum L (LIO l p s) a-onumIOtoOnumLIO inO = mkInum $ iterIOtoIterLIO (inO .| dataI)----- | Lift the underlying monad of the Iter and IterR result type.-inumResIOtoIO :: (LabelState l p s, ChunkData tIn, ChunkData tOut)- => Iter tIn IO (IterR tOut IO a)- -> Iter tIn (LIO l p s) (IterR tOut (LIO l p s) a)-inumResIOtoIO iIn = liftM ioIterRtoLIO $ iterIOtoIterLIO iIn---- | Run an LIO computation.-iterLIOtoIterIO :: (LabelState l p s, ChunkData t)- => Iter t (LIO l p s) a- -> LIOstate l p s- -> Iter t IO (a, LIOstate l p s)-iterLIOtoIterIO iter0 s0 = adaptIter (\a -> (a, s0)) adapt iter0- where adapt m = lift (runLIO m s0) >>= uncurry iterLIOtoIterIO--- iterLIOtoIterIO lio = runStateTLI (adaptIterM peelLIO lio)--- where peelLIO (LIO x) = x---inumIOtoInumLIO :: (ChunkData tIn, ChunkData tOut)- => Inum tIn tOut IO a- -> LIOstate DCLabel TCBPriv ()- -> Inum tIn tOut DC a-inumIOtoInumLIO io12 s0 = \dc1 -> do- -- Create ref that will be used to store the final state after- -- running dc1- ref <- lift $ ioTCB $ newIORef s0 - -- run dc1- let io1 = do (x, s1) <- iterLIOtoIterIO dc1 s0 {- Iter tOut IO (a, LIOstate) -}- -- save end state- liftIO $ writeIORef ref s1- return x- -- apply io1 to the inum- io2 = io12 io1 {- Iter tIn IO (IterR tOut IO a) -}- -- change the monad from IO to DC- res <- inumResIOtoIO io2 {- Iter tIn DC (IterR tOut DC a) -}- -- set the end label to the end of that running dc1- lift $ do s1 <- ioTCB $ readIORef ref- putTCB s1- return res
− Hails/IterIO/HailsRoute.hs
@@ -1,47 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 704)-{-# LANGUAGE Unsafe #-}-#endif-module Hails.IterIO.HailsRoute ( routeFileSys ) where--import Hails.IterIO.Conversions-import qualified Data.ByteString.Char8 as S8-import Data.IterIO-import Data.IterIO.HttpRoute hiding (routeFileSys)-import LIO.TCB-import LIO (liftLIO)-import System.Posix.Files-import System.Posix.IO-import System.Posix.Types--routeFileSys :: LabelState l p st =>- (String -> S8.ByteString)- -- ^ Map of file suffixes to mime types (see 'mimeTypesI')- -> (FilePath -> HttpRoute (LIO l p st) s)- -- ^ Handler to invoke when the URL maps to a directory- -- in the file system. Reasonable options include:- --- -- * @('const' 'mempty')@ to do nothing, which results in a- -- 403 forbidden,- --- -- * @('dirRedir' \"index.html\")@ to redirect directory- -- accesses to an index file, and- --- -- * a recursive invocation such as @(routeFileSys- -- typemap . (++ \"/index.html\"))@ to re-route the- -- request directly to an index file.- -> FilePath- -- ^ Pathname of directory to serve from file system- -> HttpRoute (LIO l p st) s-routeFileSys = routeGenFileSys defaultFileSystemCalls--defaultFileSystemCalls :: LabelState l p st => FileSystemCalls Fd (LIO l p st)-defaultFileSystemCalls = FileSystemCalls { fs_stat = liftLIO . ioTCB . getFileStatus- , fs_open = liftLIO . ioTCB . pathToFd- , fs_close = liftLIO . ioTCB . closeFd- , fs_fstat = liftLIO . ioTCB . getFdStatus- , fs_enum = liftLIO . ioTCB . fdToOnum- }- where pathToFd path = openFd path ReadOnly Nothing defaultFileFlags- fdToOnum fd = do h <- fdToHandle fd- return $ onumIOtoOnumLIO $ enumHandle h
− Hails/IterIO/HttpClient.hs
@@ -1,302 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--{- |--Exports basic HTTP client functions inside the 'DC' Monad.-Computations are allowed to communicate over HTTP as long as they can-read and write to a labeled origin. An origin is associated with two-labels. When writing, the origin has a label of the form-@\< {[\"scheme:\/\/authority\"]}, True \>@, where @scheme@ is-either \'http\' or \'https\', and @authority@ is the domain name or IP-address used in the request and port number of the connection. In-other words, the secrecy component contains the origin information,-while the integrity component is the same as that of public data.-When reading, the origin has a label of the form-@\< True, {[\"scheme:\/\/authority\"]} \>@.--This means that 'LIO' (specifically, 'DC') computations can export-data if the current label is not higher than that of the labeled-origin, and read data that is no more trustworthy than that of the-origin. Practically, this means that untrusted computation can export-data so long as the they have not observed any data more sensitive-than the label of the target domain. Reading (which also occurs on-every request/write) further raises the current label to the join of-the current label and origin.- -For example, suppose some piece of data, @myLoc@, has the label:--> aliceLocL = newDC ("alice" ./\. "http://maps.googleapis.com:80") (<>)--created as:--> myLoc <- labelP alicePriv aliceLocL "3101 24th Street, San Francisco, CA"---Then, untrusted code (with initial label set to public) running on-behalf of \"alice\" , may perform the following operation:--> let mapBase = "http://maps.googleapis.com/maps/api/geocode/json?sensor=false"-> aliceLoc <- urlEncode <$> (unlabelP alicePriv myLoc)-> resp <- simpleGetHttp $ mapBase ++ "&address=" ++ aliceLoc--In this case the 'unlabelP' will raise the current label to the label:--> < {["http://maps.googleapis.com:80"]}, True >--by exercising \"alice\"s privilges. Directly, the 'simpleHttp'-will be permitted. However, if--> let mapBase = "http://maps.evilalternatives.org/geocode/json?sensor=false"--an exception will be thrown since the current label does not flow to-the label of @mapBase@.--}--module Hails.IterIO.HttpClient ( -- * Simple interface- HttpRespDC(..)- , simpleHttp, simpleHttpP- , simpleGetHttp, simpleGetHttpP- , simpleHeadHttp, simpleHeadHttpP- , extractBody- -- * Advanced interface- , multiHttp, DCHttpResponseHandler- -- * Basic requests- , headRequest, getRequest, postRequest- ) where--import qualified Data.ByteString as S-import qualified Data.ByteString.Char8 as S8-import qualified Data.ByteString.Lazy as L--import Data.IterIO-import Data.IterIO.Http-import Data.IterIO.HttpClient ( headRequest- , getRequest- , postRequest- , mkHttpClient- , httpConnect )-import qualified Data.IterIO.HttpClient as I-import Hails.IterIO.Conversions--import LIO-import LIO.TCB (rtioTCB, getTCB)-import LIO.DCLabel-import LIO.LIORef-import LIO.MonadCatch--import Control.Monad-import Control.Exception (SomeException(..))--import qualified OpenSSL.Session as SSL-import System.Environment--type L = L.ByteString-type S = S.ByteString----- | Convert an "IterIO" 'HttpResp' to an 'HttpRespDC'-httpRespToDC :: HttpResp IO -> HttpRespDC-httpRespToDC resp =- HttpRespDC { respStatusDC = respStatus resp- , respHeadersDC = respHeaders resp- , respBodyDC = getTCB >>= \s -> - return $ inumIOtoInumLIO enumHttpBodyResp s }- where enumHttpBodyResp = respBody resp |. maybeChunk- maybeChunk = if respChunk resp then inumToChunks else inumNop------- HTTP Response------- | A HTTP response, containing the status, headers, and parsed body.-data HttpRespDC = HttpRespDC { respStatusDC :: !HttpStatus- -- ^ Response status- , respHeadersDC :: ![(S, S)]- -- ^ Response headers- , respBodyDC :: DC (Onum L DC ())- -- ^ Response body- } ---- | Extract body from response-extractBody :: HttpRespDC -> DC L-extractBody resp = do- bodyOnum <- respBodyDC resp- l <- getLabel- ref <- newLIORef l L.empty- bodyOnum |$ do bdy <- pureI- liftLIO $ writeLIORef ref bdy- readLIORef ref------- Basic functions------- | Perform a simple HTTP request, given the the request header, body--- and SSL context, if any. Note that that request must have the scheme,--- host fields set.-simpleHttp :: HttpReq () -- ^ Request header- -> L -- ^ Request body- -> DC HttpRespDC-simpleHttp = simpleHttpP noPrivs---- | Same as 'simpleHttp', but uses privileges.-simpleHttpP :: DCPrivTCB -- ^ Privilege- -> HttpReq () -- ^ Request header- -> L -- ^ Request body- -> DC HttpRespDC-simpleHttpP p req body = do- wguardURLP p req- ctx <- mkSSLContext- liftM httpRespToDC . rtioTCB $ I.simpleHttp req body ctx---- --- Simple HEAD/GET Wrappers------- | Simple HTTP GET request.-simpleGetHttpP :: DCPrivTCB -- ^ Privilege- -> String -- ^ URL- -> DC HttpRespDC-simpleGetHttpP p url = simpleHttpP p (getRequest url) L.empty---- | Simple HTTP GET request.-simpleGetHttp :: String -> DC HttpRespDC-simpleGetHttp = simpleGetHttpP noPrivs---- | Simple HTTP HEAD request.-simpleHeadHttpP :: DCPrivTCB -- ^ Privilege- -> String -- ^ URL- -> DC HttpRespDC-simpleHeadHttpP p url = simpleHttpP p (getRequest url) L.empty---- | Simple HTTP HEAD request.-simpleHeadHttp :: String -> DC HttpRespDC-simpleHeadHttp = simpleHeadHttpP noPrivs-------- Labeling URI's-------- | Return the labels corresponding to the absolute URI of a request header.--- The created labels will have the scheme and authority (including port) in the--- secrecy componenet, and @True@ in the integrity component for the--- read label (and the dual for write label). Specifically, the--- labels will have the form:------ > (< {[scheme://authority]}, True >,< True, {[scheme://authority]} >0------ For example, the read label of a request to \"http:\/\/gitstar.com/\" is:--- --- > <{["http://gitstar.com:80"]} , True>------ while the read label of \"https:\/\/gitstar.com:444/\"------ > <{["https://gitstar.com:444"]} , True>------ This should be used for only for single-connection requests, where the--- absolute URL makes senes.-labelOfReq :: HttpReq () -> Maybe (DCLabel, DCLabel)-labelOfReq req = do- scheme <- notNull $ reqScheme req- host <- notNull $ reqHost req- port <- maybe (defaultPort scheme) Just $ reqPort req- let prin = S8.concat [ scheme- , S8.pack "://"- , host- , S8.pack $ ':' : show port ]- return (newDC (principal prin) (<>), newDC (<>) (principal prin))- where defaultPort s | s == S8.pack "http" = return 80- | s == S8.pack "https" = return 443- | otherwise = Nothing- notNull s = if S.null s then Nothing else Just s------- Misc------- | Check that current label can flow to label of request.-wguardURLP :: DCPrivTCB -> HttpReq () -> DC ()-wguardURLP p' req = withCombinedPrivs p' $ \p -> do- l <- getLabel- case labelOfReq req of- Nothing -> throwIO . userError $ "Parse error: cannot create request label"- Just (lr, lw) -> do- unless (leqp p l lr) $ throwIO . userError $ - "Current label must flow to origin read label"- taintP p lw---- | Get the CA directory from environment variable. If set, a --- new context is returned.--- TODO: cache the context.-mkSSLContext :: DC (Maybe SSL.SSLContext)-mkSSLContext = rtioTCB $ do- env <- getEnvironment- case lookup "HAILS_SSL_CA_FILE" env of- Nothing -> return Nothing- Just caDir -> do ctx <- SSL.context- SSL.contextSetCADirectory ctx caDir- return $! Just ctx---- | An HTTP client that reuses a connection to perform multiple--- requests. Note that a @wguard@ is only performed at the connection--- establishment.-multiHttp :: (HttpReq (), L) -- ^ Initial request- -> DCHttpResponseHandler -- ^ Request handler- -> DC ()-multiHttp = multiHttpP noPrivs---- | Same as 'multiHttp' but uses privileges when performin label--- comparisons.-multiHttpP :: DCPrivTCB -- ^ Privilege- -> (HttpReq (), L) -- ^ Initial request- -> DCHttpResponseHandler -- ^ Request handler- -> DC ()-multiHttpP p' (req, body) handler = withCombinedPrivs p' $ \p -> do- let scheme = reqScheme req- isHttps = scheme == (S8.pack "https")- port <- maybe (defaultPort scheme) return $ reqPort req- --- wguardURLP p req- ctx <- mkSSLContext- s <- getTCB- (sIter,sOnum) <- rtioTCB $ do- client <- mkHttpClient (reqHost req) port ctx isHttps- (i,o) <- httpConnect client- return (iterIOtoIterLIO i, inumIOtoInumLIO o s)- sOnum |$ dcInumHttpClient (req, body) handler .| sIter- where defaultPort s | s == S8.pack "http" = return 80- | s == S8.pack "https" = return 443- | otherwise = throwIO . userError $- "Unrecognized scheme" ++ S8.unpack s----- | An HTTP response handler in the 'DC' monad.-type DCHttpResponseHandler = HttpRespDC -> Iter L DC (Maybe (HttpReq (), L)) ---- | Given an initial request, and a response handler, create an inum--- that provides underlying functionality of an http client in the 'DC'--- monad.-dcInumHttpClient :: (HttpReq s, L)- -> DCHttpResponseHandler- -> Inum L L DC a-dcInumHttpClient (req, body) respHandler = mkInumM $ - tryI (irun $ enumHttpReq req body) >>=- either (fatal . fst) (const loop)- where loop = do eof <- atEOFI- unless eof doresp- doresp = do- resp <- liftI $ iterIOtoIterLIO httpRespI- mreq <- catchI (liftI $ respHandler (httpRespToDC resp)) errH- maybe (return ())- (\(req', body') -> do- er <- tryI (irun $ enumHttpReq req' body')- either (fatal . fst) (const loop) er- ) mreq- fatal (SomeException _) = return ()- errH (SomeException _) = return . return $ Nothing-
− Hails/IterIO/Mime.hs
@@ -1,25 +0,0 @@-{-# LANGUAGE CPP #-}-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 704)-{-# LANGUAGE Trustworthy #-}-#endif-module Hails.IterIO.Mime ( systemMimeMap ) where--import qualified Data.ByteString.Char8 as S8-import Data.IterIO-import Data.IterIO.HttpRoute hiding (routeFileSys)-import System.IO.Unsafe-import Control.Exception (SomeException(..))---- | Given a file extension (e.g., \"hs\") return its MIME type (e.g.,--- \"text\/x-haskell\"). If there is no recognized MIME type (or none--- of the default paths exist), this function returns--- \"application\/octet-stream\"-systemMimeMap :: String -> S8.ByteString-systemMimeMap = unsafePerformIO $ - foldr1 cat (map enumMimeFile defaultPaths) |$- mimeTypesI "application/octet-stream"- where defaultPaths = ["mime.types"- , "/etc/mime.types"- , "/var/www/conf/mime.types"]- enumMimeFile f = inumCatch (enumFile f) $ \(SomeException _) res ->- resumeI res
− Hails/Policy.hs
@@ -1,19 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif-module Hails.Policy ( module Data.Typeable- , module Hails.Database- , module Hails.Database.MongoDB- , module LIO.DCLabel- , module LIO.Safe- ) where--import Data.Typeable (Typeable(..))-import Hails.Database-import Hails.Database.MongoDB hiding ( Action, map, head, break- , tail, words, key, filter- , dropWhile, split, foldl- , notElem, isInfixOf, singleton)-import LIO.DCLabel-import LIO.Safe
+ Hails/PolicyModule.hs view
@@ -0,0 +1,518 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE FlexibleContexts,+ ScopedTypeVariables #-}++{- |++A /policy module/ is a library with access to the privileges of a+dedicated principal (conceptually, the author of the library) and+associated with a dedicated database. The job of the policy module is+to specify what sort of data may be stored in this database, and what+access-control policies should be applied to it. However, because+Hails uses information flow control (IFC) to enforce policies, a+policy specified by a policy module on a piece of data is enforce even+when an app gets a hold of the data.++IFC lets /apps/ and policy modules productively use other policy+modules despite mutual distrust. Moreover, IFC prevents malicious+apps from violating any of the policies specified by a policy module.+As a consequence, users need not place as much trust in apps. Rather,+they need to trust or verify the policies specified by policy modules.++This moule exports the class which every policy module must be an+instance of. Though simple, the class allows a policy module to create+collections with a set of policies and associate them with the policy+module's underlying database.++-}+++module Hails.PolicyModule (+ -- * Creating policy modules+ PolicyModule(..)+ , PMAction+ -- ** Database and collection-set+ -- $db+ , labelDatabaseP+ , setDatabaseLabel, setDatabaseLabelP+ , setCollectionSetLabel, setCollectionSetLabelP+ -- * Collections+ -- $collection+ -- ** Creating collections+ , createCollection, createCollectionP+ -- ** Collection policies+ , CollectionPolicy(..), FieldPolicy(..)+ , isSearchableField+ , searchableFields+ -- * Using policy module databases+ -- $withPM+ , withPolicyModule + -- * Internal+ , TypeName+ , policyModuleTypeName+ , availablePolicyModules+ ) where+++import Data.Maybe+import qualified Data.List as List+import Data.Map (Map)+import qualified Data.Map as Map+import Data.Typeable+import qualified Data.ByteString.Char8 as S8+import qualified Data.Text as T+import qualified Data.Bson as Bson++import Control.Monad++import qualified Database.MongoDB as Mongo+import Database.MongoDB (GetLastError)++import LIO+import LIO.Privs.TCB (mintTCB)+import LIO.TCB (ioTCB, rethrowIoTCB)+import LIO.DCLabel+import Hails.Data.Hson+import Hails.Database.Core+import Hails.Database.TCB+import Hails.PolicyModule.TCB++import Text.Parsec hiding (label)++import System.Environment+import System.IO.Unsafe++-- | A policy module is specified as an instance of the @PolicyModule@+-- class. The role of this class is to define an entry point for+-- policy modules. The policy module author should set up the database+-- labels and create all the database collections in 'initPolicyModule'.+-- It is these collections and corresponding policies that apps and+-- other policy modules use when interacting with the policy module's+-- database using 'withPolicyModule'.+--+-- The Hails runtime system relies on the policy module's type @pm@ to+-- load the corresponding 'initPolicyModule' when some code \"invokes\"+-- the policy module using 'withPolicyModule'. In fact when a piece of+-- code wishes to execute a database action on the policy module,+-- 'withPolicyModule' first executes the policy module's+-- 'initPolicyModule' and passes the result (of type @pm@) to the+-- invoking code.+--+-- Observe that 'initPolicyModule' has access to the policy module's+-- privileges, which are passed in as an argument. This allows the+-- policy module to encapsulate its privileges in its @pm@ type and allow+-- code it trusts to use its privileges when executing a database action+-- using 'withPolicyModule'. Of course, untrusted code (which is usually+-- the case) should not be allow to inspect values of type @pm@ to get+-- the encapsulated privileges.+--+-- Consider the example below:+--+-- > module My.Policy ( MyPolicyModule ) where+-- >+-- > import LIO+-- > import LIO.DCLabel+-- > import Data.Typeable+-- > import Hails.PolicyModule+-- > +-- > -- | Handle to policy module, not exporting @MyPolicyModuleTCB@+-- > data MyPolicyModule = MyPolicyModuleTCB DCPriv deriving Typeable+-- > +-- > instance PolicyModule MyPolicyModule where+-- > initPolicyModule priv = do+-- > -- Get the policy module principal:+-- > let this = privDesc priv+-- > -- Create label:+-- > l = dcLabel dcTrue -- Everybody can read+-- > this -- Only policy module can modify+-- > -- Label database and collection-set:+-- > labelDatabaseP priv l l+-- > -- Create collections:+-- > createCollectionP priv "collection1" ...+-- > createCollectionP priv "collection2" ...+-- > ....+-- > createCollectionP priv "collectionN" ...+-- > -- Return the policy module:+-- > return (MyPolicyModuleTCB priv)+--+-- Here the policy module labels the database, labels the list of+-- collections and finally creates @N@ collections. The computation+-- returns a value of type @MyPolicyModule@ which wraps the policy+-- module's privileges. As a consequence, trustworthy code that has+-- access to the value constructor can use the policy module's+-- privileges:+--+-- > -- Trustworthy code within the same module (My.Policy)+-- >+-- > alwaysInsert doc = withPolicyModule $ \(MyPolicyModuleTCB priv) ->+-- > insertP priv "collection1" doc+--+-- Here @alwaysInsert@ uses the policy module's privileges to insert a+-- document into collection \"collection1\". As such, if @doc@ is well-formed+-- the function always succeeds. (Of course, such functions should not be+-- exported.)+--+-- Untrusted code in a different module cannot, however use the policy+-- module's privilege:+--+-- > -- Untrusted code in a separate module+-- > import My.Policy+-- >+-- > maybeInsertIntoDB appPriv doc = withPolicyModule $ (_ :: MyPolicyModule) ->+-- > insertP appPriv "collection1" doc+--+-- Depending on the privileges passed to @maybeInsertIntoDB@, and set+-- policies, the insertion may or may not succeed.+class Typeable pm => PolicyModule pm where+ -- | Entry point for policy module. Before executing the entry function,+ -- the current clearance is \"raised\" to the greatest lower bound of the+ -- current clearance and the label @\<\"Policy module principal\", |True\>@, + -- as to allow the policy module to read data labeled with its principal.+ initPolicyModule :: DCPriv -> PMAction pm++--+-- Setting database and collections labels+--++{- $db++The main role of a policy module is to provide a data model and+security policies on said data. To this end and as previously+mentioned, every policy module has access to a underlying MongoDB+database. Each database, in turn, has an associated collection-set: a+set of collections and their security policies.++At the coarsest level, the policy module can restrict access to the+database by labeling it with 'setDatabaseLabel'. By default, only the+policy module itself may access the database. Whenever an app or+another policy module accesses the database it is \"tainted\" by this+label. Strictly speaking, the database label is the label on the+database collection-set label. Hence, changing or observing the+collection-set label is directed by the database label. Any+meaningful database action (e.g., insert, update, etc.) involves a+collection, and to observe the existence of collection in the database+requires reading the collection-set. As already noted, the+collection-set itself is protected by a label, which a policy module+sets with 'setCollectionSetLabel', which is used to taint code that+names collections of the database. Since the database label and+collection-set labels are closely related Hails allows policy modules+to set them using a single function 'labelDatabaseP'.++-}++-- | Set the label of the underlying database. The supplied label must+-- be bounded by the current label and clearance as enforced by+-- 'guardAlloc'. Moreover the current computation mut write to the+-- database, as enforce by applying 'guardWrite' to the current+-- database label. The latter requirement suggests that every policy+-- module use 'setDatabaseLabelP' when first changing the label.+setDatabaseLabel :: DCLabel -> PMAction ()+setDatabaseLabel = setDatabaseLabelP noPriv++-- | Same as 'setDatabaseLabel', but uses privileges when performing+-- label comparisons. If a policy module wishes to allow other policy+-- modules or apps to access the underlying databse it must use +-- @setDatabaseLabelP@ to \"downgrade\" the database label, which by+-- default only allows the policy module itself to access any of the+-- contents (including collection-set).+setDatabaseLabelP :: DCPriv -- ^ Set of privileges+ -> DCLabel -- ^ New database label+ -> PMAction ()+setDatabaseLabelP p l = liftDB $ do+ guardAllocP p l+ db <- dbActionDB `liftM` getActionStateTCB+ guardWriteP p (databaseLabel db)+ setDatabaseLabelTCB l++-- | The collections label protects the collection-set of the database.+-- It is used to restrict who can name a collection in the database and+-- who can modify the underlying collection-set (e.g., by creating a new+-- collection). The policy module may change the default collections+-- label, which limits access to the policy module alone, using+-- @setCollectionSetLabel@.+--+-- The new label must be bounded by the current label and clearance as+-- checked by 'guardAlloc'. Additionally, the current label must flow to+-- the label of the database which protects the label of the+-- colleciton set. In most cases code should use 'setCollectionSetLabelP'.+setCollectionSetLabel :: DCLabel -> PMAction ()+setCollectionSetLabel = setCollectionSetLabelP noPriv++-- | Same as 'setCollectionSetLabel', but uses the supplied privileges+-- when performing label comparisons.+setCollectionSetLabelP :: DCPriv -- ^ Set of privileges+ -> DCLabel -- ^ New collections label+ -> PMAction ()+setCollectionSetLabelP p l = liftDB $ do+ guardAllocP p l+ db <- dbActionDB `liftM` getActionStateTCB+ guardWriteP p (databaseLabel db)+ setCollectionSetLabelTCB l++-- | This is the first action that any policy module should execute. It+-- is simply a wrapper for 'setDatabaseLabelP' and+-- 'setCollectionSetLabelP'. Given the policy module's privilges, label+-- for the database, and label for the collection-set @labelDatabaseP@+-- accordingly sets the labels.+labelDatabaseP :: DCPriv -- ^ Policy module privilges+ -> DCLabel -- ^ Database label+ -> DCLabel -- ^ Collections label+ -> PMAction ()+labelDatabaseP p ldb lcol = do+ setDatabaseLabelP p ldb+ setCollectionSetLabelP p lcol++--+-- Collections+--++{- $collection++As noted above a database consists of a set of collections. Each Hails+collection is a MongoDB collection with a set of labels and policies.+The main database \"work units\" are 'HsDocument's, which are stored+and retrieved from collections (see "Hails.Database"). ++Each collection has:++* A collection name, which is simply a string that can be used to name+ the collection. These names are protected by the collection-set+ label. Hence when performing @insert "myCollection" doc@, the name+ "myCollection" is always checked to actually be part of the+ databsae.++* A collection label. The collection label imposes a restriction on+ who can read and write to the collection.++* A collection clearance. The collection clearance imposes an upper+ bound on the sensitivity of data that can be stored in the+ collection.++* A collection policy (of type 'CollectionPolicy'). The collection+ policy specifies how collection documents and internal fields should+ be labeled . Specifically, a collection policy can be used to assign+ labeling policies to specific fields ('PolicyLabeled'), declares+ fields as 'SearchableField's (effectively readable by anybody that+ can read from the collection), and at a coarser level assign a label+ to each document.++The creation of collections, similar to setting database and+collection-set labels, is restricted to policy modules. Concretely, a+policy module may use 'createCollection' to create collections.++-}++-- | Create a 'Collection' given a name, label, clearance, and policy.+-- Several IFC rules must be respected for this function to succeed:+--+-- 1. The supplied collection label and clearance must be above the+-- current label and below the current clearance as enforced by+-- 'guardAlloc'.+--+-- 2. The current computation must be able to read the database+-- collection-set protected by the database label. The guard 'taint' is+-- used to guarantee this and raise the current label (to the+-- join of the current label and database label) appropriately.+-- +-- 3. The computation must be able to modify the database collection-set.+-- The guard 'guardWrite' is used to guarantee that the current label+-- is essentially equal to the collection-set label.+--+-- Note: the collection policy is modified to make the @_id@ field+-- explicitly a 'SearchableField'.+createCollection :: CollectionName -- ^ Collection name+ -> DCLabel -- ^ Collection label+ -> DCLabel -- ^ Collection clearance+ -> CollectionPolicy-- ^ Collection policy+ -> PMAction ()+createCollection = createCollectionP noPriv++-- | Same as 'createCollection', but uses privileges when performing+-- IFC checks.+createCollectionP :: DCPriv -- ^ Privileges+ -> CollectionName -- ^ Collection name+ -> DCLabel -- ^ Collection label+ -> DCLabel -- ^ Collection clearance+ -> CollectionPolicy -- ^ Collection policy+ -> PMAction ()+createCollectionP p n l c pol = liftDB $ do+ db <- dbActionDB `liftM` getActionStateTCB+ taintP p $ databaseLabel db+ guardWriteP p $ labelOf (databaseCollections db)+ guardAllocP p l+ guardAllocP p c+ associateCollectionTCB $ collectionTCB n l c newPol+ where newPol = let ps = fieldLabelPolicies pol+ ps' = Map.insert (T.pack "_id") SearchableField ps+ in pol { fieldLabelPolicies = ps' }++-- | Returns 'True' if the field policy is a 'SearchableField'.+isSearchableField :: FieldPolicy -> Bool+isSearchableField SearchableField = True+isSearchableField _ = False++-- | Get the list of names corresponding to 'SearchableField's.+searchableFields :: CollectionPolicy -> [FieldName]+searchableFields policy =+ Map.keys $ Map.filter isSearchableField fps+ where fps = fieldLabelPolicies policy++--+-- Managing databases+--++{- $withPM++Policy modules define a data model and security policies on the data.+Hence, in Hails, apps solely focus on implementing controllers and+viewers. Apps may use different policy modules to implement a rich+experience without focusing on how to specify and enforce security+policies. Moreover, Hails allows apps to use multiple policy modules+that may be in mutual distrust while guaranteeing that the policies of+each individual policy module are obeyed. Additionally, policy modules+may themselves rely on other policy modules to implement their duties.+A policy module's database is accessed using 'withPolicyModule'.++-}++-- | Policy type name. Has the form:+--+-- > <Policy module package>:<Fully qualified module>.<Policy module type>+type TypeName = String++-- | This contains a map of all the policy modules. Specifically, it+-- maps the policy moule types to a pair of the policy module+-- principal and database name.+--+-- /For the trusted programmer:/+-- The map itself is read from the file pointed to by the environment+-- variable @DATABASE_CONFIG_FILE@. Each line in the file corresponds+-- to a policy module. The format of a line is as follows+--+-- > ("<Policy module package>:<Fully qualified module>.<Policy module type>", "<Policy module database name>")+-- +-- Example of valid line is:+--+-- > ("my-policy-0.1.2.3:My.Policy.MyPolicyModule", "my_db")+--+-- The principal used by Hails is the first projection with a @\"_\"@+-- suffix. In the above, the principal assigned by Hails is:+--+-- > "_my-policy-0.1.2.3:My.Policy.MyPolicyModule"+availablePolicyModules :: Map TypeName (Principal, DatabaseName)+{-# NOINLINE availablePolicyModules #-}+availablePolicyModules = unsafePerformIO $ do+ conf <- getEnv "DATABASE_CONFIG_FILE"+ ls <- lines `liftM` readFile conf+ Map.fromList `liftM` mapM xfmLine ls+ where xfmLine l = do (tn, dn) <- readIO l+ return (tn,(principal (S8.pack $ '_':tn), dn))++-- | This function is the used to execute database queries on policy+-- module databases. The function firstly invokes the policy module,+-- determined from the type @pm@, and creates a pipe to the policy+-- module's database. The supplied database query function is then+-- applied to the policy module. In most cases, the value of type @pm@ is+-- opaque and the query is executed without additionally privileges.+--+-- > withPolicyModule $ \(_ :: SomePolicyModule) -> do+-- > -- Perform database operations: insert, save, find, delete, etc.+--+-- Trustworthy code (as deemed by the policy module) may, however, be+-- passed in additional privileges by encapsulating them in @pm@ (see+-- 'PolicyModule').+withPolicyModule :: forall a pm. PolicyModule pm => (pm -> DBAction a) -> DC a+withPolicyModule act = do+ case Map.lookup tn availablePolicyModules of+ Nothing -> throwLIO UnknownPolicyModule + Just (pmOwner, dbName) -> do+ env <- ioTCB $ getEnvironment+ let hostName = fromMaybe "localhost" $+ List.lookup "HAILS_MONGODB_SERVER" env+ mode = maybe master parseMode $+ List.lookup "HAILS_MONGODB_MODE" env+ pipe <- rethrowIoTCB $ Mongo.runIOE $ Mongo.connect (Mongo.host hostName)+ let priv = mintTCB (toComponent pmOwner)+ s0 = makeDBActionStateTCB priv dbName pipe mode+ -- Execute policy module entry function with raised clearance:+ (policy, s1) <- withClearanceP' priv $ runDBAction (pmAct priv) s0+ let s2 = s1 { dbActionDB = dbActionDB s1 }+ res <- evalDBAction (act policy) s2+ rethrowIoTCB $ Mongo.close pipe+ return res+ where tn = policyModuleTypeName (undefined :: pm)+ pmAct priv = unPMActionTCB $ initPolicyModule priv :: DBAction pm+ withClearanceP' priv io = do+ c <- getClearance+ let lpriv = dcLabel (privDesc priv) (privDesc priv) `lub` c+ bracketP priv+ -- Raise clearance:+ (setClearanceP priv lpriv)+ -- Lower clearance:+ (const $ do c' <- getClearance + setClearanceP priv (partDowngradeP priv c' c))+ -- Execute policy module entry point, in between:+ (const io)++-- | Get the name of a policy module.+policyModuleTypeName :: PolicyModule pm => pm -> TypeName+policyModuleTypeName x =+ tyConPackage tp ++ ":" ++ tyConModule tp ++ "." ++ tyConName tp+ where tp = typeRepTyCon $ typeOf x+ +--+-- Parser for getLastError+--++-- | Parse the access mode.+--+-- > slaveOk : slaveOk+-- > unconfirmedWrites : UnconfirmedWrites+-- > onfirmWrites <options> : ConfirmWrites [corresponding-options]+-- > _ : master+--+-- where @options@ can be:+--+-- > fsync | journal | writes=<N>+--+-- separated by \',\', and @N@ is an integer.+-- Example: +--+-- > HAILS_MONGODB_MODE = "slaveOk"+-- > HAILS_MONGODB_MODE = "confirmWrites: writes=3, journal"+-- > HAILS_MONGODB_MODE = "master"+--+parseMode :: String -> AccessMode+parseMode "slaveOk" = slaveOk+parseMode "unconfirmedWrites" = UnconfirmedWrites+parseMode xs = case parse wParser "" xs of+ Right le -> ConfirmWrites le+ Left _ -> master+ where wParser = do _ <- string "confirmWrites" + spaces+ _ <- char ':'+ spaces+ gle_opts++gle_opts :: Stream s m Char => ParsecT s u m GetLastError+gle_opts = do opt_first <- gle_opt+ opt_rest <- gle_opts'+ return $ opt_first ++ opt_rest+ where gle_opt = gle_opt_fsync <|> gle_opt_journal <|> gle_opt_write + gle_opts' :: Stream s m Char => ParsecT s u m GetLastError+ gle_opts' = (spaces >> char ',' >> spaces >> gle_opts) <|> (return [])++gle_opt_fsync :: Stream s m Char => ParsecT s u m GetLastError+gle_opt_fsync = string "fsync" >> return [ (T.pack "fsync") Bson.=: True ]++gle_opt_journal :: Stream s m Char => ParsecT s u m GetLastError+gle_opt_journal = string "journal" >> return [ (T.pack "j") Bson.=: True ]++gle_opt_write :: Stream s m Char => ParsecT s u m GetLastError+gle_opt_write = do _ <- string "write"+ spaces+ _ <- char '='+ spaces+ dgt <- many1 digit+ return [ (T.pack "w") Bson.=: (read dgt :: Integer) ]+
+ Hails/PolicyModule/DSL.hs view
@@ -0,0 +1,753 @@+{-# LANGUAGE Trustworthy #-}+{-# LANGUAGE FunctionalDependencies,+ FlexibleInstances,+ TypeSynonymInstances,+ GeneralizedNewtypeDeriving,+ DeriveDataTypeable #-}+{- |++This module exports a domain specific language for specifying policy+module policies. It is recommended that /all/ policy modules use this+code when specifying security policies as it simplifies auditing and+building trust in the authors. Policy modules are described in+"Hails.PolicyModule", which is a pre-required reading to this+module\'s documentation.++Consider creating a policy module where anybody can read and write+freely to the databse. In this databsae we wish to create a simple+user model collecting user names and passwords. This collection+\"users\" is also readable and writable by anybody. However, the+passwords must always belong to the named user. Specifically, only the+user (or policy module) may read and modify the password. This policy+is implemented below:++> data UsersPolicyModule = UsersPolicyModuleTCB DCPriv+> deriving Typeable+> +> instance PolicyModule UsersPolicyModule where+> initPolicyModule priv = do+> setPolicy priv $ do+> database $ do+> readers ==> anybody+> writers ==> anybody+> admins ==> this+> collection "users" $ do+> access $ do+> readers ==> anybody+> writers ==> anybody+> clearance $ do+> secrecy ==> this+> integrity ==> anybody+> document $ \doc -> do+> readers ==> anybody+> writers ==> anybody+> field "name" $ searchable+> field "password" $ labeled $ \doc -> do+> let user = "name" `at` doc :: String+> readers ==> this \/ user+> writers ==> this \/ user+> return $ UsersPolicyModuleTCB priv+> where this = privDesc priv+++Notice that the database is public, as described above, but only this+policy module may modify the internal collection names (as indicated+by the 'admin' keyword). Similarly the collection is publicly+accessible (as set with the 'access' keyword), and may contain data at+most as sensitve as the policy module can read (i.e., the+'clearance').++Documents retrieved from the \"users\" 'collection' are public (as+indicated by the 'document' data-dependent policy that sets the+'readers' and 'writers'). The 'field' \"name\" is 'searchable' (i.e.,+it is a 'SearchableField') and thus can be used in query predicates.+Conversely, the \"password\" 'field' is 'labeled' using a+data-dependent policy. Specifically the field is labed using the+\"name\" value contained in the document (i.e., the user\'s name):+hence only the user having the right privilege or the policy module+(@this@) may read and create such data.++-}+ ++module Hails.PolicyModule.DSL (+ setPolicy+ -- * Label components (or roles)+ , readers, secrecy+ , writers, integrity+ , admins+ , (==>), (<==)+ -- * Creating databases label policies+ , database+ -- * Creating collection policies+ , collection+ , access+ , clearance+ , document+ -- * Creating field policies+ , field, searchable, key, labeled+ ) where++import Data.Maybe+import Data.List (isPrefixOf)+import Data.Map (Map)+import Data.Traversable (forM)+import Data.Typeable+import qualified Data.Map as Map+import qualified Data.Text as T+import Control.Monad hiding (forM)+import Control.Monad.Trans+import Control.Monad.Trans.Reader hiding (ask)+import Control.Monad.Trans.State hiding (put, get)+import Control.Monad.Trans.Error+import Control.Monad.State.Class+import Control.Monad.Reader.Class+import Control.Exception+import LIO+import LIO.DCLabel+import Hails.PolicyModule+import Hails.Database++-- | Type denoting readers.+data Readers = Readers+instance Show Readers where show _ = "readers"++-- | Set secrecy component of the label, i.e., the principals that can+-- read.+readers, secrecy :: Readers+readers = Readers+secrecy = Readers++-- | Type denoting writers.+data Writers = Writers+instance Show Writers where show _ = "writers"++-- | Set integrity component of the label, i.e., the principals that can+-- write.+writers, integrity :: Writers +writers = Writers +integrity = Writers ++-- | Used when setting integrity component of the collection-set label, i.e.,+-- the principals/administrators that can modify a database's underlying collections.+data Admins = Admins+instance Show Admins where show _ = "admins"++-- | Synonym for 'Admins'.+admins :: Admins +admins = Admins ++infixl 5 ==>, <==++-- | Class used for creating micro policies.+class MonadState s m => Role r s m where+ -- | @r ==> c@ effectively states that role @r@ (i.e., 'readers',+ -- 'writers', 'admins' must imply label component @c@).+ (==>) :: (ToComponent c) => r -> c -> m ()+ -- | Inverse implication. Purely provided for readability. The+ -- direction is not relevant to the internal representation.+ (<==) :: (ToComponent c) => r -> c -> m ()+ (<==) = (==>)+++--+--+--++-- | Type representing a database expression. +--+-- > database $ do+-- > readers ==> "Alice" \/ "Bob"+-- > writers ==> "Alice"+-- > admins ==> "Alice"+--+data DBExp = DBExp Component Component Component+ deriving Show++-- | Database expression solely contains a list of components.+type DBExpS = Map String Component++-- | Database expression composition monad+newtype DBExpM a = DBExpM (ErrorT String (State DBExpS) a)+ deriving (Monad, MonadState DBExpS)++instance Role Readers DBExpS DBExpM where + _ ==> c = DBExpM $ do+ s <- get + case Map.lookup (show readers) s of+ Just _ -> fail "Database readers already specified."+ Nothing -> put $ Map.insert (show readers) (toComponent c) s++instance Role Writers DBExpS DBExpM where + _ ==> c = DBExpM $ do+ s <- get + case Map.lookup (show writers) s of+ Just _ -> fail "Database writers already specified."+ Nothing -> put $ Map.insert (show writers) (toComponent c) s++instance Role Admins DBExpS DBExpM where + _ ==> c = DBExpM $ do+ s <- get + case Map.lookup (show admins) s of+ Just _ -> fail "Database admins already specified."+ Nothing -> put $ Map.insert (show admins) (toComponent c) s+++-- | Create a database lebeling policy The policy must set the label+-- of the database, i.e., the 'readers' and 'writers'. Additionally it+-- must state the 'admins' that can modify the underlying collection-set +--+-- For example, the policy+-- +-- > database $ do+-- > readers ==> "Alice" \/ "Bob" \/ "Clarice"+-- > writers ==> "Alice" \/ "Bob"+-- > admins ==> "Alice"+--+-- states that Alice, Bob, and Clarice can read from the database,+-- including the collections in the database (the 'readers' is used as+-- the secrecy component in the collection-set label). Only Alice or+-- Bob may, however, write to the database. Finally, only Alice can+-- add additional collections in the policy module code.+--+database :: DBExpM () -> PolicyExpM ()+database (DBExpM e) = do+ s <- get+ case Map.lookup "database" s of+ Just _ -> fail "Database labels already set"+ Nothing -> case evalState (runErrorT e') Map.empty of+ Left err -> fail err+ Right dbExp -> put $ Map.insert "database"+ (PolicyDBExpT dbExp) s+ where e' = do e+ s <- get+ r <- lookup' (show readers) s+ w <- lookup' (show writers) s+ a <- lookup' (show admins ) s+ return $ DBExp r w a+ lookup' k s = maybe (fail $ "Missing " ++ show k)+ return $ Map.lookup k s++--------------------------------------------------------------++-- | Type representing a collection access label expression.+--+-- > access $ do+-- > readers ==> "Alice" \/ "Bob"+-- > writers ==> "Alice"+--+data ColAccExp = ColAccExp Component Component+ deriving Show++-- | Access expression solely contains a list of components.+type ColAccExpS = Map String Component++-- | Access expression composition monad+newtype ColAccExpM a =+ ColAccExpM (ErrorT String (StateT ColAccExpS (Reader CollectionName)) a)+ deriving (Monad, MonadState ColAccExpS, MonadReader CollectionName)++instance Role Readers ColAccExpS ColAccExpM where + _ ==> c = ColAccExpM $ do+ s <- get + cName <- ask+ case Map.lookup (show readers) s of+ Just _ -> fail $ "Collection " ++ show cName+ ++ " access readers already specified."+ Nothing -> put $ Map.insert (show readers) (toComponent c) s++instance Role Writers ColAccExpS ColAccExpM where + _ ==> c = ColAccExpM $ do+ s <- get + cName <- ask+ case Map.lookup (show writers) s of+ Just _ -> fail $ "Collection " ++ show cName+ ++ " access writers already specified."+ Nothing -> put $ Map.insert (show writers) (toComponent c) s+++--------------------------------------------------------------++-- | Type representing a collection clearance label expression.+--+-- > clearance $ do+-- > readers ==> "Alice" \/ "Bob"+-- > writers ==> "Alice"+--+data ColClrExp = ColClrExp Component Component+ deriving Show++-- | Clress expression solely contains a list of components.+type ColClrExpS = Map String Component++-- | Database expression composition monad+newtype ColClrExpM a =+ ColClrExpM (ErrorT String (StateT ColClrExpS (Reader CollectionName)) a)+ deriving (Monad, MonadState ColClrExpS, MonadReader CollectionName)++instance Role Readers ColClrExpS ColClrExpM where + _ ==> c = ColClrExpM $ do+ s <- get + cName <- ask+ case Map.lookup (show readers) s of+ Just _ -> fail $ "Collection " ++ show cName+ ++ " clearance readers already specified."+ Nothing -> lift . put $ Map.insert (show readers) (toComponent c) s++instance Role Writers ColClrExpS ColClrExpM where + _ ==> c = ColClrExpM $ do+ s <- get + cName <- ask+ case Map.lookup (show writers) s of+ Just _ -> fail $ "Collection " ++ show cName+ ++ " clearance writers already specified."+ Nothing -> put $ Map.insert (show writers) (toComponent c) s++++--------------------------------------------------------------++-- | Type representing a collection document label expression.+--+-- > document $ \doc -> do+-- > readers ==> "Alice" \/ "Bob"+-- > writers ==> "Alice"+--+data ColDocExp = ColDocExp (HsonDocument -> LabelExp)+instance Show ColDocExp where show _ = "ColDocExp {- function -}"++-- | A Label expression has two components.+data LabelExp = LabelExp Component Component++-- | Document expression solely contains a list of components.+type ColDocExpS = Map String Component++-- | Document expression composition monad+newtype ColDocExpM a =+ ColDocExpM (ErrorT String (StateT ColDocExpS (Reader CollectionName)) a)+ deriving (Monad, MonadState ColDocExpS, MonadReader CollectionName)++instance Role Readers ColDocExpS ColDocExpM where + _ ==> c = ColDocExpM $ do+ s <- get + cName <- ask+ case Map.lookup (show readers) s of+ Just _ -> fail $ "Collection " ++ show cName+ ++ " document readers already specified."+ Nothing -> lift . put $ Map.insert (show readers) (toComponent c) s++instance Role Writers ColDocExpS ColDocExpM where + _ ==> c = ColDocExpM $ do+ s <- get + cName <- ask+ case Map.lookup (show writers) s of+ Just _ -> fail $ "Collection " ++ show cName+ ++ " document writers already specified."+ Nothing -> put $ Map.insert (show writers) (toComponent c) s++++--------------------------------------------------------------++-- | Type representing a collection field policy expression.+--+-- > field "name" searchable+-- > field "password" $ labeled $ \doc -> do+-- > readers ==> (((T.pack "name") `at`doc) :: String)+-- > writers ==> (((T.pack "name") `at`doc) :: String)+--+data ColFieldExp = ColFieldSearchable+ | ColLabFieldExp (HsonDocument -> LabelExp)++instance Show ColFieldExp where+ show ColFieldSearchable = "ColFieldSearchable"+ show (ColLabFieldExp _) = "ColLabFieldExp {- function -}"++-- | Labeled field expression solely contains a list of components.+type ColLabFieldExpS = Map String Component++-- | Labeled field expression composition monad.+newtype ColLabFieldExpM a =+ ColLabFieldExpM (ErrorT String (StateT ColLabFieldExpS (Reader (FieldName, CollectionName))) a)+ deriving (Monad, MonadState ColLabFieldExpS, MonadReader (FieldName, CollectionName))++instance Role Readers ColLabFieldExpS ColLabFieldExpM where + _ ==> c = ColLabFieldExpM $ do+ s <- get + (fName, cName) <- ask+ case Map.lookup (show readers) s of+ Just _ -> fail $ "Collection " ++ show cName ++ " field " ++ show fName+ ++ " readers already specified."+ Nothing -> lift . put $ Map.insert (show readers) (toComponent c) s++instance Role Writers ColLabFieldExpS ColLabFieldExpM where + _ ==> c = ColLabFieldExpM $ do+ s <- get + (fName, cName) <- ask+ case Map.lookup (show writers) s of+ Just _ -> fail $ "Collection " ++ show cName ++ " field " ++ show fName+ ++ " writers already specified."+ Nothing -> put $ Map.insert (show writers) (toComponent c) s++-- | Field expression composition monad.+newtype ColFieldExpM a =+ ColFieldExpM (ErrorT String (StateT (Maybe ColFieldExp) (Reader (FieldName, CollectionName))) a)+ deriving (Monad, MonadState (Maybe ColFieldExp), MonadReader (FieldName, CollectionName))++-- | Set the underlying field to be a searchable key.+--+-- > field "name" searchable+searchable :: ColFieldExpM ()+searchable = do+ s <- get + (fName, cName) <- ask+ when (isJust s) $ fail $ "Collection " ++ show cName ++ " field " +++ show fName ++ " policy already specified."+ put (Just ColFieldSearchable)++-- | Synonym for 'searchable'+key :: ColFieldExpM ()+key = searchable++-- | Set data-dependent document label+--+-- > field "password" $ labeled $ \doc -> do+-- > readers ==> (("name" `at`doc) :: String)+-- > writers ==> (("name" `at`doc) :: String)+labeled :: (HsonDocument -> ColLabFieldExpM ()) -> ColFieldExpM ()+labeled fpol = do+ s <- get+ (fN, cN) <- ask+ when (isJust s) $ fail $ "Collection " ++ show cN ++ " field " +++ show fN ++ " policy already specified."+ case eval (act fN cN) fN cN of+ Left e -> fail e+ Right labFieldE -> put (Just labFieldE)+ where act fN cN = do fpol (undefined :: HsonDocument)+ s <- get+ _ <- lookup' fN cN (show readers) s+ _ <- lookup' fN cN (show writers) s+ return . ColLabFieldExp $ + \doc -> fromRight $ eval (fpol' doc fN cN) fN cN+ eval (ColLabFieldExpM e) fN cN =+ runReader (evalStateT (runErrorT e) Map.empty) (fN, cN)+ fpol' doc fN cN = do fpol doc+ s <- get+ r <- lookup' fN cN (show readers) s+ w <- lookup' fN cN (show writers) s+ return $ LabelExp r w+ lookup' fN cN k s = maybe (fail $ "Missing " ++ show k +++ " in field label " ++ show fN+ ++ " of collection " ++ show cN)+ return $ Map.lookup k s+++--------------------------------------------------------------++-- | Type representing a collection expression.+--+-- > collection "w00t" $ do+-- > access $ do+-- > readers ==> "Alice" \/ "Bob"+-- > writers ==> "Alice" +-- > clearance $ do+-- > secrecy ==> "Users"+-- > integrity ==> "Alice" +-- > document $ \doc -> do+-- > readers ==> anybody+-- > writers ==> "Alice" \/ (("name" `at`doc) :: String)+-- > field "name" searchable+-- > field "password" $ labeled $ \doc -> do+-- > readers ==> (("name" `at`doc) :: String)+-- > writers ==> (("name" `at`doc) :: String)+--+data ColExp = ColExp CollectionName ColAccExp+ ColClrExp+ ColDocExp+ (Map FieldName ColFieldExp)+ deriving Show++-- | Internal state of collection+data ColExpT = ColAccT ColAccExp+ | ColClrT ColClrExp+ | ColDocT ColDocExp+ | ColFldT ColFieldExp+ deriving Show+++-- | Collection expression may contain an access label expression,+-- a collection label expression, etc.+type ColExpS = Map String ColExpT++-- | Database expression composition monad+newtype ColExpM a =+ ColExpM (ErrorT String (StateT ColExpS (Reader CollectionName)) a)+ deriving (Monad, MonadState ColExpS, MonadReader CollectionName)+++--------------------------------------------------------------++-- | Type representing a policy+data PolicyExp = PolicyExp DBExp (Map CollectionName ColExp)+ deriving Show++-- | Internal state of policy+data PolicyExpT = PolicyDBExpT DBExp+ | PolicyColExpT ColExp+ deriving Show++-- | Policy expression may contain a databse expression, or+-- a number of collection expressions.+type PolicyExpS = Map String PolicyExpT++-- | Policy expression composition monad+newtype PolicyExpM a = PolicyExpM (ErrorT String (State PolicyExpS) a)+ deriving (Monad, MonadState PolicyExpS)+++--------------------------------------------------------------++-- | Set the collection access label. For example,+--+-- > collection "w00t" $ do+-- > ...+-- > access $ do+-- > readers ==> "Alice" \/ "Bob"+-- > writers ==> "Alice"+-- +-- states that Alice and Bob can read documents from the collection,+-- but only Alice can insert new documents or modify existing ones.+access :: ColAccExpM () -> ColExpM ()+access (ColAccExpM acc) = do+ s <- get+ cN <- ask+ case Map.lookup "access" s of+ Just _ -> fail $ "Collection " ++ show cN+ ++ " access label already specified."+ _ -> let r = runReader (evalStateT (runErrorT (acc' cN)) Map.empty) cN+ in case r of+ Left e -> fail e+ Right accT -> put (Map.insert "access" accT s)+ where acc' cN= do+ acc + s <- get+ r <- lookup' cN (show readers) s+ w <- lookup' cN (show writers) s+ return . ColAccT $ ColAccExp r w+ lookup' cN k s = maybe (fail $ "Missing " ++ show k +++ " in access of " ++ show cN)+ return $ Map.lookup k s++-- | Set the collection clearance. For example,+--+-- > collection "w00t" $ do+-- > ...+-- > clearance $ do+-- > secrecy ==> "Alice" \/ "Bob"+-- > integrity ==> "Alice"+-- +-- states that all data in the collection is always readable by Alice+-- and Bob, and no more trustworthy than data Alice can create.+clearance :: ColClrExpM () -> ColExpM ()+clearance (ColClrExpM acc) = do+ s <- get+ cN <- ask+ case Map.lookup "clearance" s of+ Just _ -> fail $ "Collection " ++ show cN+ ++ " clearance label already specified."+ _ -> let r = runReader (evalStateT (runErrorT (acc' cN)) Map.empty) cN+ in case r of+ Left e -> fail e+ Right accT -> put (Map.insert "clearance" accT s)+ where acc' cN = do+ acc + s <- get+ r <- lookup' cN (show readers) s+ w <- lookup' cN (show writers) s+ return . ColClrT $ ColClrExp r w+ lookup' cN k s = maybe (fail $ "Missing " ++ show k +++ " in clearance of " ++ show cN)+ return $ Map.lookup k s++-- | Set data-dependent document label. For example,+--+-- > collection "w00t" $ do+-- > ...+-- > document $ \doc -> do+-- > readers ==> anybody+-- > writers ==> "Alice" \/ (("name" `at`doc) :: String)+--+-- states that every document in the collection is resable by anybody,+-- and only Alice or the principal named by the @name@ value in the+-- document can modify or insert such data.+document :: (HsonDocument -> ColDocExpM ()) -> ColExpM ()+document fpol = do+ s <- get+ cN <- ask+ case Map.lookup "document" s of+ Just _ -> fail $ "Collection " ++ show cN+ ++ " document policy already specified."+ _ -> case eval (act cN) cN of+ Left e -> fail e+ Right docT -> put (Map.insert "document" docT s)+ where act cN = do fpol (undefined :: HsonDocument)+ s <- get+ _ <- lookup' cN (show readers) s+ _ <- lookup' cN (show writers) s+ return . ColDocT $ ColDocExp $ + \doc -> fromRight $ eval (fpol' doc cN) cN+ eval (ColDocExpM e) cN =+ runReader (evalStateT (runErrorT e) Map.empty) cN+ fpol' doc cN = do fpol doc+ s <- get+ r <- lookup' cN (show readers) s+ w <- lookup' cN (show writers) s+ return $ LabelExp r w+ lookup' cN k s = maybe (fail $ "Missing " ++ show k +++ " in document label of collection " + ++ show cN)+ return $ Map.lookup k s++-- | Set field policy. A field can be declared to be a 'searchable'+-- key or a 'labeled' value.+--+-- Declaring a field to be a 'searchable' key is straight forward:+--+-- > collection "w00t" $ do+-- > ...+-- > field "name" searchable+--+-- The 'labeled' field declaration is similar to the 'document' policy, but+-- sets the label of a specific field. For example+--+-- > collection "w00t" $ do+-- > ...+-- > field "password" $ labeled $ \doc -> do+-- > let user = "name" `at` doc :: String+-- > readers ==> user+-- > writers ==> user+--+-- states that every @password@ field in the is readable and writable+-- only by or the principal named by the @name@ value of the document can+-- modify or insert such data.+field :: FieldName -> ColFieldExpM () -> ColExpM ()+field fName (ColFieldExpM e) = do+ s <- get+ cN <- ask+ let _fName = "field." ++ T.unpack fName+ case Map.lookup _fName s of+ Just _ -> fail $ "Collection " ++ show cN ++ " field " ++ show fName+ ++ " policy already specified."+ _ -> case runReader (evalStateT (runErrorT e') Nothing) (fName, cN) of+ Left er -> fail er+ Right Nothing -> fail $ "Collection " ++ show cN ++ " field " +++ show fName ++ " policy not specified."+ Right (Just fieldE) -> put (Map.insert _fName (ColFldT fieldE) s)+ where e' = do e >> get+ ++-- | Set the collection labels and policies. Each @collection@, must +-- at least specify who can 'access' the collection, what the+-- 'clearance' of the data in the collection is, and how 'document's+-- are labeled. Below is an example that also labels the @password@+-- field and declares @name@ a searchable key.+--+-- > collection "w00t" $ do+-- > access $ do+-- > readers ==> "Alice" \/ "Bob"+-- > writers ==> "Alice" +-- > clearance $ do+-- > secrecy ==> "Users"+-- > integrity ==> "Alice" +-- > document $ \doc -> do+-- > readers ==> anybody+-- > writers ==> "Alice" \/ (("name" `at`doc) :: String)+-- > field "name" searchable+-- > field "password" $ labeled $ \doc -> do+-- > readers ==> (("name" `at`doc) :: String)+-- > writers ==> (("name" `at`doc) :: String)+--+collection :: CollectionName -> ColExpM () -> PolicyExpM ()+collection cN (ColExpM e) = do+ s <- get+ let _cN = "collection." ++ T.unpack cN+ case Map.lookup _cN s of+ Just _ -> fail $ "Collection " ++ show cN ++ " policy already set"+ Nothing -> case runReader (evalStateT (runErrorT e') Map.empty) cN of+ Left err -> fail err+ Right colExp -> put $ Map.insert _cN (PolicyColExpT colExp) s+ where e' = do+ e+ s <- get+ (ColAccT a) <- lookup' "access" s+ (ColClrT c) <- lookup' "clearance" s+ (ColDocT d) <- lookup' "document" s+ let fs = Map.mapKeys (T.pack . (drop (length "field."))) $+ Map.map (\(ColFldT f) -> f) $+ Map.filterWithKey (\k _ -> "field." `isPrefixOf` k) s+ return $ ColExp cN a c d fs+ lookup' k s = maybe (fail $ "Missing " ++ show k +++ " for collection " ++ show cN)+ return $ Map.lookup k s+++--------------------------------------------------------------++-- | Compile a policy.+runPolicy :: PolicyExpM () -> Either String PolicyExp+runPolicy (PolicyExpM e) = evalState (runErrorT e') Map.empty+ where e' = do+ e+ s <- get+ (PolicyDBExpT db) <- maybe (fail $ "Missing database policy")+ return $ Map.lookup "database" s+ let cs = Map.mapKeys (T.pack . (drop (length "collection."))) $+ Map.map (\(PolicyColExpT f) -> f) $+ Map.filterWithKey (\k _ -> "collection." `isPrefixOf` k) s+ return $ PolicyExp db cs++-- | High level function used to set the policy in a 'PolicyModule'.+-- This function takes the policy module's privileges and a policy+-- expression, and produces a 'PMAction' that sets the policy.+setPolicy :: DCPriv -> PolicyExpM () -> PMAction ()+setPolicy priv pol = + case runPolicy pol of+ Left err -> throwLIO $ PolicyCompilerError err+ Right policy -> execPolicy policy+ where execPolicy (PolicyExp db cs) = do+ execPolicyDB db + void $ forM cs execPolicyCol+ --+ execPolicyDB (DBExp r w a) = do+ setDatabaseLabelP priv (dcLabel r w)+ setCollectionSetLabelP priv (dcLabel r a)+ --+ execPolicyCol (ColExp n (ColAccExp lr lw) (ColClrExp cr cw) doc fs) =+ let cps = mkColPol doc fs+ in createCollectionP priv n (dcLabel lr lw) (dcLabel cr cw) cps+ --+ mkColPol (ColDocExp fdocE) cs = + let fdoc = unDataPolicy fdocE+ in CollectionPolicy { documentLabelPolicy = fdoc+ , fieldLabelPolicies = Map.map unFieldExp cs }+ --+ unDataPolicy fpolE = \doc -> + let (LabelExp s i) = fpolE doc+ in dcLabel s i+ --+ unFieldExp ColFieldSearchable = SearchableField+ unFieldExp (ColLabFieldExp f) = FieldPolicy (unDataPolicy f)++-- | Exception thrown if a policy cannot be compiled.+data PolicyCompilerError = PolicyCompilerError String+ deriving (Show, Typeable)++instance Exception PolicyCompilerError +++--+-- Helpers++fromRight :: Either a b -> b+fromRight (Right x) = x+fromRight _ = error "fromRight: unexpected value"
+ Hails/PolicyModule/TCB.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE Unsafe #-}+{-# LANGUAGE GeneralizedNewtypeDeriving,+ MultiParamTypeClasses,+ TypeFamilies #-}++{- |++This module exports a newtype wrapper for 'DBAction' that restricts+certain combinators solely to policy modules. Specifically, this+policy module monad ('PMAction') is used when setting labels,+specifing policies, creating collections, etc. The newtype is used to+restrict such functionality to policy modules; apps cannot and should+not be concerned with specifying data models and policies.++-}+++module Hails.PolicyModule.TCB (+ PMAction(..)+ ) where+++import Control.Applicative++import LIO+import LIO.DCLabel+import Hails.Database.Core++-- | A policy module action (@PMAction@) is simply a wrapper for+-- database action ('DBAction'). The wrapper is used to restrict /app/+-- code from specifying policies; only policy module may execute+-- @PMAction@s, and thus create collections, set a label on their+-- databases, etc.+newtype PMAction a = PMActionTCB { unPMActionTCB :: DBAction a }+ deriving (Monad, Functor, Applicative)++instance MonadLIO DCLabel PMAction where+ liftLIO = liftDB . liftLIO++instance MonadDB PMAction where+ liftDB = PMActionTCB
− Hails/TCB/Types.hs
@@ -1,44 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 704-{-# LANGUAGE Unsafe #-}-#endif-{-# LANGUAGE DeriveFunctor,- GeneralizedNewtypeDeriving #-}--module Hails.TCB.Types ( AppName- , AppConf(..)- , AppReqHandler- , AppRoute- ) where--import qualified Data.ByteString.Lazy as L-import Data.IterIO.Http-import Data.IterIO.HttpRoute--import DCLabel.TCB-import LIO.DCLabel--type L = L.ByteString---- | Application name-type AppName = String---- | Application configuration.-data AppConf = AppConf { appUser :: !Principal- -- ^ User the app is running on behalf of- , appName :: !AppName- -- ^ The app's name- , appPriv :: !TCBPriv- -- ^ The app's privileges.- , appReq :: HttpReq ()- -- ^ The request message- }---- | Application handler.-type AppReqHandler = HttpReq ()- -> DCLabeled L- -> DC (HttpResp DC)---- | Application route.-type AppRoute = HttpRoute DC ()-
+ Hails/Version.hs view
@@ -0,0 +1,9 @@+{-# LANGUAGE Trustworthy #-}+{- | ++This module solely exports the versoin of hails.++-}++module Hails.Version (version) where+import Paths_hails
− LIO/Data/Time.hs
@@ -1,33 +0,0 @@-{-# LANGUAGE CPP #-}-#if __GLASGOW_HASKELL__ >= 702-{-# LANGUAGE Trustworthy #-}-#endif--{- | This module re-exports "Data.Time" wrapped in 'LIO'. It is-important to note that this module is only safe with the latest-version of "LIO", where @toLabeled@ has been removed and timing-attacked have been addressed. In similar vain, when executing a-piece of code that you do not trust, it is important that the time-primitives not be directly available. -}-module LIO.Data.Time ( module Data.Time- , getCurrentTime- , getZonedTime- , utcToLocalZonedTime) where--import qualified Data.Time as T-import Data.Time hiding ( getCurrentTime- , getZonedTime- , utcToLocalZonedTime)-import LIO.TCB---- | Get the current UTC time from the system clock.-getCurrentTime :: (LabelState l p s) => LIO l p s UTCTime-getCurrentTime = rtioTCB T.getCurrentTime---- | Get the local time together with a TimeZone.-getZonedTime :: (LabelState l p s) => LIO l p s ZonedTime-getZonedTime = rtioTCB T.getZonedTime---- | Convert UTC time to local time with TimzeZone-utcToLocalZonedTime :: (LabelState l p s) => UTCTime -> LIO l p s ZonedTime-utcToLocalZonedTime = rtioTCB . T.utcToLocalZonedTime
+ examples/SimpleApp.hs view
@@ -0,0 +1,10 @@+{-# LANGUAGE Safe #-}+module SimpleApp (server) where++import Hails.HttpServer++import qualified Data.ByteString.Lazy.Char8 as L8++server :: Application+server _ _ = return $+ Response ok200 [] (L8.pack "w00t")
+ examples/httpClientExample.hs view
@@ -0,0 +1,41 @@+module Main (main) where+import LIO+import LIO.TCB (ioTCB)+import LIO.DCLabel+import LIO.Privs.TCB++import Hails.HttpClient++dcPutStrLn :: String -> DC ()+dcPutStrLn s = ioTCB $ putStrLn s++alicePriv :: DCPriv+alicePriv = mintTCB (dcPrivDesc "alice")++evalDC' :: DC () -> IO ()+evalDC' io = do+ (_, s) <- runDC io+ putStrLn $ show $ lioLabel s++main :: IO ()+main = evalDC' $ do+ case exNr of+ 1 {- OK -} -> exMap False "maps.googleapis.com" mapBase+ 2 {- OK SSL -} -> exMap True "maps.googleapis.com" mapBaseS+ 3 {- FAIL -} -> exMap False "maps.yahoo.com" mapBase+ 4 {- FAIL -} -> exMap False "maps.googleapis.com" "http://maps.google.com"+ 5 {- FAIL -} -> exMap True "maps.googleapis.com" mapBase+ _ -> return ()+ where exNr = 1 :: Int+ mapBase = "http://maps.googleapis.com/maps/api/geocode/json?sensor=false"+ mapBaseS = "https://maps.googleapis.com/maps/api/geocode/json?sensor=false"++exMap :: Bool -> String -> String -> DC ()+exMap sec domain mapBase = do+ let aliceLocL = dcLabel ("alice" /\ (scheme ++ domain ++ p)) dcTrue+ myLoc <- labelP alicePriv aliceLocL "3101 24th Street, San Francisco, CA"+ aliceLoc <- unlabelP alicePriv myLoc+ resp <- simpleGetHttp $ mapBase ++ "&address=" ++ aliceLoc+ dcPutStrLn (show resp)+ where scheme = (if sec then "https" else "http") ++ "://"+ p = if sec then ":443" else ":80"
+ examples/simpleDBExample.hs view
@@ -0,0 +1,108 @@+{-# LANGUAGE DeriveDataTypeable,+ ScopedTypeVariables,+ OverloadedStrings #-}++module Main (main) where++import Data.Typeable+import Data.Text ()++import Control.Monad++import LIO+import LIO.DCLabel+import Hails.Data.Hson+import Hails.Database+import Hails.PolicyModule+import Hails.PolicyModule.DSL++import LIO.TCB (ioTCB)+import LIO.Privs.TCB (mintTCB)+import LIO.DCLabel.Privs.TCB (allPrivTCB)+import System.Posix.Env (setEnv)++data UsersPolicyModule = UsersPolicyModuleTCB DCPriv+ deriving Typeable++instance PolicyModule UsersPolicyModule where+ initPolicyModule priv = do+ setPolicy priv $ do+ database $ do+ readers ==> anybody+ writers ==> anybody+ admins ==> this+ collection "users" $ do+ access $ do+ readers ==> anybody+ writers ==> anybody+ clearance $ do+ secrecy ==> this+ integrity ==> anybody+ document $ \_ -> do+ readers ==> anybody+ writers ==> anybody+ field "name" $ searchable+ field "password" $ labeled $ \doc -> do+ readers ==> this \/ ("name" `at` doc :: String)+ writers ==> this \/ ("name" `at` doc :: String)+ return $ UsersPolicyModuleTCB priv+ where this = privDesc priv++withUsersPolicyModule :: DBAction a -> DC a+withUsersPolicyModule act = withPolicyModule (\(_ :: UsersPolicyModule) -> act)+++-- | Create databse config file+mkDBConfFile :: IO ()+mkDBConfFile = do+ writeFile dbConfFile (unlines [show pm])+ setEnv "DATABASE_CONFIG_FILE" dbConfFile False+ where pm :: (String, String, String)+ pm = (mkName (UsersPolicyModuleTCB undefined), "_users", "users_db")+ dbConfFile = "/tmp/hails_example_database.conf"+ mkName x =+ let tp = typeRepTyCon $ typeOf x+ in tyConPackage tp ++ ":" ++ tyConModule tp ++ "." ++ tyConName tp++main :: IO ()+main = do+ mkDBConfFile+ withUser "alice" app1+ withUser "bob" (app2 False)+ withUser "bob" (app2 True)+ withUser "alice" (app2 True)+ where withUser :: String -> (String -> DCPriv -> DC ()) -> IO ()+ withUser u act = putStrLn . show =<< (paranoidDC $ do+ let prin = toComponent u+ setClearanceP allPrivTCB (dcLabel prin dcTrue)+ act u $ mintTCB prin)++app1 :: String -> DCPriv -> DC ()+app1 usr priv = do+ let p = toBsonValue ("w00tw00t" :: String)+ withUsersPolicyModule $ do+ let doc :: HsonDocument+ doc = [ "name" -: usr, "password" -: needPolicy p]+ insertP_ priv "users" doc++app2 :: Bool -> String -> DCPriv -> DC ()+app2 readPass _ priv = do+ ldocs <- withUsersPolicyModule $ do+ cur <-findP priv $ select [] "users"+ getAll [] cur+ --+ forM_ ldocs $ \ldoc -> do+ doc <- unlabelP priv ldoc+ putStrLn' $ "name = " ++ ("name" `at` doc)+ when readPass $ do+ lpass <- getPolicyLabeled ("password" `at` doc)+ pass <- unlabelP priv lpass+ putStrLn' $ "password = " ++ show pass+ where getAll acc cur = do+ mldoc <- nextP priv cur+ case mldoc of+ Nothing -> return acc+ Just ldoc -> getAll (ldoc:acc) cur++putStrLn' :: String -> DC ()+putStrLn' m = ioTCB $ putStrLn m
hails.cabal view
@@ -1,77 +1,200 @@ Name: hails-Version: 0.1.1+Version: 0.9.0.1 build-type: Simple License: GPL-2 License-File: LICENSE-Author: HAILS team-Maintainer: Amit Levy <levya at cs.stanford dot edu>, Deian Stefan <deian at cs dot stanford dot edu>-Stability: experimental-Synopsis: IFC enforcing web platform framework+Author: Hails team+Maintainer: Hails team <hails at scs dot stanford dot edu>+Synopsis: Multi-app web platform framework Category: Web-Cabal-Version: >= 1.6+Cabal-Version: >= 1.8 Description:- Hails is a framework for building multi-app web platforms.- This module exports a library for building Hails platforms.+ The rise of web platforms and their associated /apps/ represents a+ new way of developing and deploying software. Sites such as+ Facebook and Yammer are no longer written by a single entity, but+ rather are freely extended by third-party developers offering+ competing features to users. + .++ Allowing an app to access more user data allows developers to build+ more compelling products. It also opens the door to accidental or+ malicious breaches of user privacy. In the case of a website like+ Facebook, exposing access to a user's private messages would allow+ an external developer to build a search feature. Exciting! But,+ another developer can take advantage of this feature to build an app+ that mines private messages for credit card numbers, ad keywords, or+ other sensitive data.++ .++ Frameworks such as Ruby on Rails, Django, Yesod, etc. are geared+ towards building monolithic web sites. And, they are great for+ this! However, they are not designed for websites that integrate+ third-party code, and thus lack a good mechanism for building such+ multi-app platforms without sacrificing a user's security or an+ app's functionality.++ .++ Hails is explicitly designed for building web /platforms/, where it+ is expected that a site will comprise many mutually-distrustful+ components written by a variety of entities. We built Hails around+ two core design principles. ++ .++ * Separation of policy:+ Data access policies should be concisely specified alongside data+ structures and schemas, rather than strewn throughout the+ codebase in a series of conditionals. Code that implements this+ is called a /policy module/ in Hails (see "Hails.PolicyModule").++ .+++ * Mandatory access control (MAC):+ Data access policies should be mandatory even once code has+ obtained access to data. MAC lets platform components modules+ productively interact by sharing data, despite mutual distrust.+ Haskell lets us implement MAC at a fine grained level using the+ information flow control library "LIO".++ .++ A Hails platform hosts two types of code: /apps/ and /policy+ modules/. Apps encompass what would traditionally be considered+ controller and view logic. Policy modules are libraries that+ implement both the model and the data security policy. They are+ invoked directly by apps or other policy modules, but run with+ different privileges from the invoking code. Both apps and policy+ modules can be implemented by untrusted third parties, with the user+ only needing to trust the policy module governing the data in+ question. Separating of policy code from app code allows users to+ inspect and more easily unserstand the overall security provided by+ the system, while MAC guarantees that these policies are enforced+ in an end-to-end fashion.++Extra-source-files:+ examples/simpleDBExample.hs+ examples/SimpleApp.hs+ examples/httpClientExample.hs+ Source-repository head Type: git- Location: http://www.github.com/scslab/hails.git+ Location: http://www.gitstar.com/scs/hails.git + Library- Build-Depends: base >= 4.5 && < 5,- containers >= 0.4.2 && < 0.5,- base64-bytestring >= 0.1 && < 0.2,- bytestring >= 0.9 && < 1,- containers >= 0.4.2 && < 0.5,- lio >= 0.1.3 && < 0.2,- iterIO >= 0.2.2 && < 0.3,- iterio-server >= 0.3 && < 0.4,- dclabel >= 0.0.4 && < 0.1,- mongoDB >= 1.1.2 && < 1.3,- transformers-base >= 0.4.1 && < 0.5,- parsec >= 3.1.2 && < 3.2,- monad-control >= 0.3.1 && < 0.4,- bson >= 0.1 && < 0.2,- network >= 2.3 && < 2.4,- mtl >= 2.0 && < 2.1,- compact-string-fix >= 0.3.2 && < 0.4,- transformers >= 0.2.2.0 && < 0.3,- time >= 1.4 && < 2.0,- cereal >= 0.3.5.1 && < 0.4,- binary >= 0.5 && < 0.6,- HsOpenSSL >= 0.10 && < 2,- unix >= 2.5 && < 3,- MissingH >= 1.1.1 && < 2,- SHA >= 1.5 && < 2,- pureMD5 >= 2.1.0.3 && < 3,- SimpleAES >= 0.4.2 && < 0.5,- RSA >= 1.0.6.2 && < 2+ Build-Depends:+ base >= 4.5 && < 5.0+ ,transformers >= 0.2.2+ ,mtl >= 2.0+ ,containers >= 0.4.2+ ,bytestring >= 0.9+ ,text >= 0.11+ ,parsec >= 3.1.2+ ,binary >= 0.5+ ,time >= 1.2.0.5+ ,lio >= 0.9.0.0+ ,base64-bytestring >= 0.1+ ,bson >= 0.2+ ,mongoDB >= 1.3.0+ ,network >= 2.3+ ,conduit >= 0.5+ ,resourcet >= 0.3.3.1+ ,http-conduit >= 1.5+ ,wai >= 1.3+ ,wai-app-static >= 1.3.0.1+ ,wai-extra >= 1.3.0.1+ ,http-types >= 0.7+ ,authenticate >= 1.3+ ,cookie >= 0.4+ ,blaze-builder >= 0.3.1+ ,failure >= 0.2.0.1 && < 0.3 - ghc-options: -Wall -fno-warn-orphans+ GHC-options: -Wall -fno-warn-orphans Exposed-modules:- Hails.Data.LBson- Hails.Data.LBson.Rexports- Hails.Data.LBson.Rexports.Bson- Hails.Data.LBson.Safe- Hails.Data.LBson.TCB- Hails.App- Hails.Policy+ Hails.Data.Hson+ Hails.Data.Hson.TCB+ Hails.Database+ Hails.Database.Core+ Hails.Database.TCB+ Hails.Database.Query+ Hails.Database.Query.TCB+ Hails.Database.Structured Hails.HttpServer Hails.HttpServer.Auth- Hails.IterIO.Conversions- Hails.IterIO.HailsRoute- Hails.IterIO.Mime- Hails.IterIO.HttpClient- Hails.TCB.Types- Hails.Database- Hails.Database.MongoDB- Hails.Database.MongoDB.TCB.Access- Hails.Database.MongoDB.TCB.Convert- Hails.Database.MongoDB.TCB.Types- Hails.Database.MongoDB.TCB.Query- Hails.Database.MongoDB.TCB.DCAccess- Hails.Database.MongoDB.Structured- Hails.Crypto- LIO.Data.Time+ Hails.HttpServer.Types+ Hails.PolicyModule+ Hails.PolicyModule.DSL+ Hails.PolicyModule.TCB+ Hails.HttpClient+ Hails.Version+ Other-modules:+ Paths_hails++Executable hails+ Main-is: hails.hs+ ghc-options: -package ghc -Wall -fno-warn-orphans+ Build-Depends:+ base >= 4.5 && < 5.0+ ,transformers >= 0.2.2+ ,mtl >= 2.0+ ,containers >= 0.4.2+ ,bytestring >= 0.9+ ,text >= 0.11+ ,parsec >= 3.1.2+ ,binary >= 0.5+ ,time >= 1.2.0.5+ ,lio >= 0.9.1+ ,base64-bytestring >= 0.1+ ,bson >= 0.2+ ,mongoDB >= 1.3.0+ ,network >= 2.3+ ,conduit >= 0.5+ ,resourcet >= 0.3.3.1+ ,http-conduit >= 1.5+ ,wai >= 1.3+ ,wai-extra >= 1.3+ ,wai-app-static >= 1.3+ ,warp >= 1.3+ ,http-types >= 0.7+ ,authenticate >= 1.3+ ,cookie >= 0.4+ ,blaze-builder >= 0.3.1+ ,directory >= 1.1+ ,filepath >= 1.3+ ,unix >= 2.5.1+ ,ghc-paths >= 0.1.0.8+ ,hails++test-suite tests+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: Tests.hs++ ghc-options: -threaded -rtsopts -Wall -fno-warn-orphans++ build-depends:+ hails+ ,base >= 4.5+ ,containers >= 0.4.2+ ,unix >= 2.5+ ,time >= 1.2.0.5+ ,text >= 0.11+ ,QuickCheck >= 2.3+ ,HUnit >= 1.2.5+ ,quickcheck-instances >= 0.3.0+ ,test-framework >= 0.6+ ,test-framework-quickcheck2 >= 0.2.11+ ,test-framework-hunit >= 0.2.7+ ,lio >= 0.9.0.0+ ,quickcheck-lio-instances >= 0.9.0.0+ ,bson >= 0.2+ ,mongoDB >= 1.3.0+ ,wai >= 1.3+ ,wai-test >= 1.3+ ,http-types >= 0.7
+ hails.hs view
@@ -0,0 +1,363 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Main (main) where+import qualified Data.ByteString.Char8 as S8++import qualified Data.Text as T+import Data.List (isPrefixOf, isSuffixOf)+import Data.Maybe+import Data.Version+import Control.Monad++import Hails.HttpServer+import Hails.HttpServer.Auth+import Hails.Version++import Network.Wai.Handler.Warp+import Network.Wai.Middleware.MethodOverridePost+import Network.Wai.Middleware.RequestLogger++import System.Posix.Env (setEnv)+import System.Environment+import System.Console.GetOpt hiding (Option)+import qualified System.Console.GetOpt as GetOpt+import System.IO (stderr, hPutStrLn)+import System.FilePath+import System.Directory+import System.Exit+++import GHC+import GHC.Paths+import DynFlags+import Unsafe.Coerce++++about :: String -> String+about prog = prog ++ " " ++ showVersion version ++ "\n\n\+ \Simple tool for launching Hails apps. This tool can be used in \n\+ \both development and production mode. It allows you configure the \n\+ \environment your app runs in (e.g., the port number the Hails HTTP \n\+ \server should listen on, the MongoDB server it should connect to, \n\+ \etc.). In development mode (default), " ++ prog ++ " uses some default\n\+ \settings (e.g., port 8080). In production, mode all configuration \n\+ \settings must be specified. To simplify deployment, this tool \n\+ \checks the program environment for configuration settings (e.g., \n\+ \variable PORT is used for the port number), but you can override \n\+ \these with arguments. See \'" ++ prog ++ " --help\' for a list of \n\+ \configuration settings and corresponding environment variables. \n\n"+ ++ prog ++ " dynamically loads your app requst handler. Hence, the \n\+ \app name is the module name where your \'server\' function is \n\+ \defined."++--+--+--+++main :: IO ()+main = do+ args <- getArgs+ env <- getEnvironment+ opts <- do opts <- hailsOpts args env+ when (optAbout opts) $ printAbout+ opts' <- case optInFile opts of+ Nothing -> return opts+ Just file -> do envFromFile file+ env' <- getEnvironment+ print env'+ hailsOpts args env'+ cleanOpts opts'+ maybe (return ()) (optsToFile opts) $ optOutFile opts+ putStrLn $ "Working environment:\n\n" ++ optsToEnvStr opts+ forM_ (optsToEnv opts) $ \(k,v) -> setEnv k v True+ let port = fromJust $ optPort opts+ provider = T.pack . fromJust . optOpenID $ opts+ f = if optDev opts+ then logStdoutDev . devHailsApplication+ else logStdout . (openIdAuth provider) . hailsApplicationToWai + app <- loadApp (optSafe opts) (optPkgConf opts) (fromJust $ optName opts)+ runSettings (defaultSettings { settingsPort = port })+ (methodOverridePost $ f app)+++-- | Given an application module name, load the main controller named+-- @server@.+loadApp :: Bool -- -XSafe ?+ -> Maybe String -- -package-config+ -> String -- Application name+ -> IO Application+loadApp safe mpkgConf appName = runGhc (Just libdir) $ do+ dflags0 <- getSessionDynFlags+ let dflags1 = if safe+ then dopt_set (dflags0 { safeHaskell = Sf_Safe })+ Opt_PackageTrust+ else dflags0+ dflags2 = case mpkgConf of+ Just pkgConf ->+ dopt_unset (dflags1 { extraPkgConfs =+ pkgConf : extraPkgConfs dflags1 })+ Opt_ReadUserPackageConf+ _ -> dflags1+ void $ setSessionDynFlags dflags2+ target <- guessTarget appName Nothing+ addTarget target+ r <- load LoadAllTargets+ case r of+ Failed -> fail "Compilation failed."+ Succeeded -> do+ setContext [IIDecl $ simpleImportDecl (mkModuleName appName)]+ value <- compileExpr (appName ++ ".server") + return . unsafeCoerce $ value+++--+-- Parsing options+--++-- | Type used to encode hails options+data Options = Options+ { optName :: Maybe String -- ^ App name+ , optPort :: Maybe Int -- ^ App port number+ , optAbout :: Bool -- ^ About this program+ , optSafe :: Bool -- ^ Use @-XSafe@+ , optForce :: Bool -- ^ Force unsafe in production+ , optDev :: Bool -- ^ Development/Production+ , optOpenID :: Maybe String -- ^ OpenID provider+ , optDBConf :: Maybe String -- ^ Filepath of databases conf file+ , optPkgConf :: Maybe String -- ^ Filepath of package-conf+ , optMongoServer :: Maybe String -- ^ MongoDB server URL+ , optCabalDev :: Maybe String -- ^ Cabal-dev directory+ , optOutFile :: Maybe String -- ^ Write configurate to file+ , optInFile :: Maybe String -- ^ Read configurate from file+ } deriving Show++-- | Default options+defaultOpts :: Options+defaultOpts = Options { optName = Nothing+ , optPort = Nothing+ , optAbout = False+ , optSafe = True+ , optForce = False+ , optDev = True+ , optOpenID = Nothing+ , optDBConf = Nothing+ , optPkgConf = Nothing+ , optCabalDev = Nothing+ , optMongoServer = Nothing + , optOutFile = Nothing+ , optInFile = Nothing}++-- | Default development options. These options can be used +-- when in development mode, to avoid annoying the user.+defaultDevOpts :: Options+defaultDevOpts = Options { optName = Just "App"+ , optPort = Just 8080+ , optAbout = False+ , optSafe = True+ , optForce = False+ , optDev = True+ , optOpenID = Just "http://localhost"+ , optDBConf = Just "database.conf"+ , optPkgConf = Nothing+ , optCabalDev = Nothing+ , optMongoServer = Just "localhost"+ , optOutFile = Nothing+ , optInFile = Nothing}+++-- | Parser for options+options :: [ OptDescr (Options -> Options) ]+options = + [ GetOpt.Option ['a'] ["app"]+ (ReqArg (\n o -> o { optName = Just n }) "APP_NAME")+ "Start application APP_NAME."+ , GetOpt.Option ['p'] ["port"]+ (ReqArg (\p o -> o { optPort = Just $ read p }) "PORT")+ "Run application on port PORT."+ , GetOpt.Option [] ["dev", "development"]+ (NoArg (\opts -> opts { optDev = True }))+ "Development mode, default (no authentication)."+ , GetOpt.Option [] ["prod", "production"]+ (NoArg (\opts -> opts { optDev = False }))+ "Production mode (OpenID authentication). Must set OPENID_PROVIDER."+ , GetOpt.Option [] ["openid-provider"]+ (ReqArg (\u o -> o { optOpenID = Just u }) "OPENID_PROVIDER")+ "Set OPENID_PROVIDER as the OpenID provider."+ , GetOpt.Option [] ["unsafe"]+ (NoArg (\opts -> opts { optSafe = False }))+ "Turn the -XSafe flag off."+ , GetOpt.Option [] ["force"]+ (NoArg (\opts -> opts { optForce = True }))+ "Use with --unsafe to force the -XSafe flag off in production mode."+ , GetOpt.Option [] ["package-conf"]+ (ReqArg (\n o -> o { optPkgConf = Just n }) "PACKAGE_CONF")+ "Use PACKAGE_CONF for as the app specific package-conf file."+ , GetOpt.Option ['s'] ["cabal-dev"]+ (ReqArg (\n o -> o { optCabalDev = Just n }) "CABAL_DEV_SANDBOX")+ "The location ofthe cabal-dev sandbox (e.g., ./cabal-dev)."+ , GetOpt.Option [] ["db-conf", "database-conf"]+ (ReqArg (\n o -> o { optDBConf = Just n }) "DATABASE_CONFIG_FILE")+ "Use DATABASE_CONFIG_FILE as the specific database.conf file."+ , GetOpt.Option [] ["db", "mongodb-server"]+ (ReqArg (\n o -> o { optMongoServer = Just n }) "HAILS_MONGODB_SERVER")+ "Use HAILS_MONGODB_SERVER as the URL to the MongoDB server."+ , GetOpt.Option [] ["out"]+ (ReqArg (\n o -> o { optOutFile = Just n }) "OUT_FILE")+ "Write options to environment file OUT_FILE."+ , GetOpt.Option [] ["in", "env", "environment"]+ (ReqArg (\n o -> o { optInFile = Just n }) "IN_FILE")+ "Load environment variables from file IN_FILE."+ , GetOpt.Option ['?'] ["about"]+ (NoArg (\opts -> opts { optAbout = True }))+ "About this program."+ ]++-- | Do parse options+hailsOpts :: [String] -> [(String, String)] -> IO Options+hailsOpts args env =+ let opts = envOpts defaultOpts env+ in case getOpt Permute options args of+ (o,[], []) -> return $ foldl (flip id) opts o+ (_,_,errs) -> do prog <- getProgName+ hPutStrLn stderr $ concat errs +++ usageInfo (header prog) options+ exitFailure+ where header prog = "Usage: " ++ prog ++ " [OPTION...]"+++-- | Extracting options from the environment (prioritzed) over+-- arguments+envOpts :: Options -> [(String, String)] -> Options+envOpts opts env = + opts { optName = mFromEnvOrOpt "APP_NAME" optName+ , optPort = case readFromEnv "PORT" of+ p@(Just _) -> p+ _ -> optPort opts+ , optOpenID = mFromEnvOrOpt "OPENID_PROVIDER" optOpenID + , optDBConf = mFromEnvOrOpt "DATABASE_CONFIG_FILE" optDBConf+ , optPkgConf = mFromEnvOrOpt "PACKAGE_CONF" optPkgConf+ , optCabalDev = mFromEnvOrOpt "CABAL_DEV_SANDBOX" optCabalDev+ , optMongoServer = mFromEnvOrOpt "HAILS_MONGODB_SERVER" optMongoServer+ }+ where fromEnv n = lookup n env+ readFromEnv n = lookup n env >>= mRead+ mRead :: Read a => String -> Maybe a+ mRead s = fst `liftM` (listToMaybe $ reads s)+ mFromEnvOrOpt evar f = case fromEnv evar of+ x@(Just _) -> x+ _ -> f opts++cleanOpts :: Options -> IO Options+cleanOpts opts = do+ when (optAbout opts) $ printAbout+ if optDev opts + then cleanDevOpts opts+ else cleanProdOpts opts++-- | Clean options and use default development options when+-- non-existant.+cleanDevOpts :: Options -> IO Options+cleanDevOpts opts0 = do+ let opts1 = opts0 { optName = mergeMaybe optName+ , optPort = mergeMaybe optPort+ , optOpenID = mergeMaybe optOpenID+ , optDBConf = mergeMaybe optDBConf+ , optMongoServer = mergeMaybe optMongoServer }+ case (optPkgConf opts1, optCabalDev opts1) of+ (Just _, Just _) -> do+ hPutStrLn stderr "Flag package-conf supplied, ignoring cabal-dev sandbox"+ return $ opts1 { optCabalDev = Nothing }+ (_, Just cd) -> do+ pkgConf <- findPackageConfInCabalDev cd+ return $ opts1 { optCabalDev = Nothing, optPkgConf = Just pkgConf }+ _ -> return opts1+ where mergeMaybe f = f $ if isJust (f opts0)+ then opts0+ else defaultDevOpts++-- | Clean options and strictly check that all the necessary ones+-- exist.+cleanProdOpts :: Options -> IO Options+cleanProdOpts opts0 = do+ checkIsJust optName "APP_NAME"+ checkIsJust optPort "PORT"+ checkIsJust optOpenID "OPENID_PROVIDER"+ checkIsJust optDBConf "DATABASE_CONFIG_FILE"+ checkIsJust optMongoServer "HAILS_MONGODB_SERVER"+ unless (optSafe opts0 || optForce opts0) $ do+ hPutStrLn stderr "Production code must be Safe, use --force to override"+ exitFailure+ case (optPkgConf opts0, optCabalDev opts0) of+ (Just _, Just _) -> do+ hPutStrLn stderr "Both package-conf supplied and cabal-dev sandbox defined."+ exitFailure+ (_, Just cd) -> do+ pkgConf <- findPackageConfInCabalDev cd+ return $ opts0 { optCabalDev = Nothing, optPkgConf = Just pkgConf }+ _ -> return opts0+ where checkIsJust f msg =+ when (isNothing $ f opts0) $ do+ hPutStrLn stderr $ "Production mode is strict, missing " ++ msg+ exitFailure+++-- | Find the package-conf file in a cabal-dev directory (e.g.,+-- packages-7.4.2.conf)+findPackageConfInCabalDev :: FilePath -> IO FilePath+findPackageConfInCabalDev cdev = do+ fs <- getDirectoryContents cdev+ case filter f fs of+ [] -> do+ hPutStrLn stderr $ "Could not file package config file in " ++ show cdev+ exitFailure+ xs@(x:_) -> do + let path = cdev </> x+ when (length xs > 1) $ hPutStrLn stderr $ "Using " ++ show path +++ " for the package config file"+ return path+ where f d = "packages-" `isPrefixOf` d && ".conf" `isSuffixOf` d+ +-- | Print about message+printAbout :: IO ()+printAbout = do+ prog <- getProgName+ putStrLn $ about prog+ exitSuccess++-- | Write options to environment file+optsToFile :: Options -> FilePath -> IO ()+optsToFile opts file = writeFile file (optsToEnvStr opts) >> exitSuccess++-- | Options to envionment string+optsToEnv :: Options -> [(String,String)]+optsToEnv opts = map (\(k, mv) -> (k, fromJust mv)) $ + filter (isJust . snd) $+ [toLine optName "APP_NAME"+ ,("PORT", show `liftM` optPort opts)+ ,toLine optOpenID "OPENID_PROVIDER"+ ,toLine optDBConf "DATABASE_CONFIG_FILE"+ ,toLine optMongoServer "HAILS_MONGODB_SERVER"+ ,toLine optPkgConf "PACKAGE_CONF"+ ,toLine optCabalDev "CABAL_DEV_SANDBOX" ]+ where toLine f var = (var, f opts)++-- | Create environment list+optsToEnvStr :: Options -> String+optsToEnvStr opts = unlines $ map (\(k,v) -> k++"="++v) $ optsToEnv opts ++-- If an environment entry does not contain an @\'=\'@ character,+-- the @key@ is the whole entry and the @value@ is the empty string.+envFromFile :: FilePath -> IO ()+envFromFile file = do+ ls <- S8.lines `liftM` S8.readFile file+ forM_ ls $ \line ->+ let (key',val') = S8.span (/='=') line+ val = safeTail val'+ in case S8.words key' of+ [key] -> setEnv (S8.unpack key) (S8.unpack val) True+ _ -> do hPutStrLn stderr $ "Invalid environment line: " +++ show (S8.unpack line)+ exitFailure+ where safeTail s = if S8.null s then s else S8.tail s
+ tests/Tests.hs view
@@ -0,0 +1,15 @@+module Main (main) where++import Test.Framework++import qualified AuthTests+import qualified HsonTests+import qualified DatabaseTests++main :: IO ()+main = defaultMain tests++tests :: [Test]+tests = AuthTests.tests +++ HsonTests.tests +++ DatabaseTests.tests