diff --git a/Hails/App.hs b/Hails/App.hs deleted file mode 100644 --- a/Hails/App.hs +++ /dev/null @@ -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 diff --git a/Hails/Crypto.hs b/Hails/Crypto.hs deleted file mode 100644 --- a/Hails/Crypto.hs +++ /dev/null @@ -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 diff --git a/Hails/Data/Hson.hs b/Hails/Data/Hson.hs new file mode 100644 --- /dev/null +++ b/Hails/Data/Hson.hs @@ -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" + diff --git a/Hails/Data/Hson/TCB.hs b/Hails/Data/Hson/TCB.hs new file mode 100644 --- /dev/null +++ b/Hails/Data/Hson/TCB.hs @@ -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 diff --git a/Hails/Data/LBson.hs b/Hails/Data/LBson.hs deleted file mode 100644 --- a/Hails/Data/LBson.hs +++ /dev/null @@ -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 diff --git a/Hails/Data/LBson/Rexports.hs b/Hails/Data/LBson/Rexports.hs deleted file mode 100644 --- a/Hails/Data/LBson/Rexports.hs +++ /dev/null @@ -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 diff --git a/Hails/Data/LBson/Rexports/Bson.hs b/Hails/Data/LBson/Rexports/Bson.hs deleted file mode 100644 --- a/Hails/Data/LBson/Rexports/Bson.hs +++ /dev/null @@ -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 diff --git a/Hails/Data/LBson/Safe.hs b/Hails/Data/LBson/Safe.hs deleted file mode 100644 --- a/Hails/Data/LBson/Safe.hs +++ /dev/null @@ -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) diff --git a/Hails/Data/LBson/TCB.hs b/Hails/Data/LBson/TCB.hs deleted file mode 100644 --- a/Hails/Data/LBson/TCB.hs +++ /dev/null @@ -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 diff --git a/Hails/Database.hs b/Hails/Database.hs --- a/Hails/Database.hs +++ b/Hails/Database.hs @@ -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 diff --git a/Hails/Database/Core.hs b/Hails/Database/Core.hs new file mode 100644 --- /dev/null +++ b/Hails/Database/Core.hs @@ -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 diff --git a/Hails/Database/MongoDB.hs b/Hails/Database/MongoDB.hs deleted file mode 100644 --- a/Hails/Database/MongoDB.hs +++ /dev/null @@ -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 - diff --git a/Hails/Database/MongoDB/Structured.hs b/Hails/Database/MongoDB/Structured.hs deleted file mode 100644 --- a/Hails/Database/MongoDB/Structured.hs +++ /dev/null @@ -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 diff --git a/Hails/Database/MongoDB/TCB/Access.hs b/Hails/Database/MongoDB/TCB/Access.hs deleted file mode 100644 --- a/Hails/Database/MongoDB/TCB/Access.hs +++ /dev/null @@ -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) diff --git a/Hails/Database/MongoDB/TCB/Convert.hs b/Hails/Database/MongoDB/TCB/Convert.hs deleted file mode 100644 --- a/Hails/Database/MongoDB/TCB/Convert.hs +++ /dev/null @@ -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 - diff --git a/Hails/Database/MongoDB/TCB/DCAccess.hs b/Hails/Database/MongoDB/TCB/DCAccess.hs deleted file mode 100644 --- a/Hails/Database/MongoDB/TCB/DCAccess.hs +++ /dev/null @@ -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 : ConfirmWrites [corresponding-options] --- > _ : master --- --- where @options@ can be: --- --- > fsync | journal | writes= --- --- 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) diff --git a/Hails/Database/MongoDB/TCB/Query.hs b/Hails/Database/MongoDB/TCB/Query.hs deleted file mode 100644 --- a/Hails/Database/MongoDB/TCB/Query.hs +++ /dev/null @@ -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 - diff --git a/Hails/Database/MongoDB/TCB/Types.hs b/Hails/Database/MongoDB/TCB/Types.hs deleted file mode 100644 --- a/Hails/Database/MongoDB/TCB/Types.hs +++ /dev/null @@ -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 - } - diff --git a/Hails/Database/Query.hs b/Hails/Database/Query.hs new file mode 100644 --- /dev/null +++ b/Hails/Database/Query.hs @@ -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 diff --git a/Hails/Database/Query/TCB.hs b/Hails/Database/Query/TCB.hs new file mode 100644 --- /dev/null +++ b/Hails/Database/Query/TCB.hs @@ -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 + } diff --git a/Hails/Database/Structured.hs b/Hails/Database/Structured.hs new file mode 100644 --- /dev/null +++ b/Hails/Database/Structured.hs @@ -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 + diff --git a/Hails/Database/TCB.hs b/Hails/Database/TCB.hs new file mode 100644 --- /dev/null +++ b/Hails/Database/TCB.hs @@ -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 diff --git a/Hails/HttpClient.hs b/Hails/HttpClient.hs new file mode 100644 --- /dev/null +++ b/Hails/HttpClient.hs @@ -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 diff --git a/Hails/HttpServer.hs b/Hails/HttpServer.hs --- a/Hails/HttpServer.hs +++ b/Hails/HttpServer.hs @@ -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 } + + diff --git a/Hails/HttpServer/Auth.hs b/Hails/HttpServer/Auth.hs --- a/Hails/HttpServer/Auth.hs +++ b/Hails/HttpServer/Auth.hs @@ -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) diff --git a/Hails/HttpServer/Types.hs b/Hails/HttpServer/Types.hs new file mode 100644 --- /dev/null +++ b/Hails/HttpServer/Types.hs @@ -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 diff --git a/Hails/IterIO/Conversions.hs b/Hails/IterIO/Conversions.hs deleted file mode 100644 --- a/Hails/IterIO/Conversions.hs +++ /dev/null @@ -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 diff --git a/Hails/IterIO/HailsRoute.hs b/Hails/IterIO/HailsRoute.hs deleted file mode 100644 --- a/Hails/IterIO/HailsRoute.hs +++ /dev/null @@ -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 diff --git a/Hails/IterIO/HttpClient.hs b/Hails/IterIO/HttpClient.hs deleted file mode 100644 --- a/Hails/IterIO/HttpClient.hs +++ /dev/null @@ -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 - diff --git a/Hails/IterIO/Mime.hs b/Hails/IterIO/Mime.hs deleted file mode 100644 --- a/Hails/IterIO/Mime.hs +++ /dev/null @@ -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 diff --git a/Hails/Policy.hs b/Hails/Policy.hs deleted file mode 100644 --- a/Hails/Policy.hs +++ /dev/null @@ -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 diff --git a/Hails/PolicyModule.hs b/Hails/PolicyModule.hs new file mode 100644 --- /dev/null +++ b/Hails/PolicyModule.hs @@ -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: +-- +-- > :. +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 +-- +-- > (":.", "") +-- +-- 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 : ConfirmWrites [corresponding-options] +-- > _ : master +-- +-- where @options@ can be: +-- +-- > fsync | journal | writes= +-- +-- 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) ] + diff --git a/Hails/PolicyModule/DSL.hs b/Hails/PolicyModule/DSL.hs new file mode 100644 --- /dev/null +++ b/Hails/PolicyModule/DSL.hs @@ -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" diff --git a/Hails/PolicyModule/TCB.hs b/Hails/PolicyModule/TCB.hs new file mode 100644 --- /dev/null +++ b/Hails/PolicyModule/TCB.hs @@ -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 diff --git a/Hails/TCB/Types.hs b/Hails/TCB/Types.hs deleted file mode 100644 --- a/Hails/TCB/Types.hs +++ /dev/null @@ -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 () - diff --git a/Hails/Version.hs b/Hails/Version.hs new file mode 100644 --- /dev/null +++ b/Hails/Version.hs @@ -0,0 +1,9 @@ +{-# LANGUAGE Trustworthy #-} +{- | + +This module solely exports the versoin of hails. + +-} + +module Hails.Version (version) where +import Paths_hails diff --git a/LIO/Data/Time.hs b/LIO/Data/Time.hs deleted file mode 100644 --- a/LIO/Data/Time.hs +++ /dev/null @@ -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 diff --git a/examples/SimpleApp.hs b/examples/SimpleApp.hs new file mode 100644 --- /dev/null +++ b/examples/SimpleApp.hs @@ -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") diff --git a/examples/httpClientExample.hs b/examples/httpClientExample.hs new file mode 100644 --- /dev/null +++ b/examples/httpClientExample.hs @@ -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" diff --git a/examples/simpleDBExample.hs b/examples/simpleDBExample.hs new file mode 100644 --- /dev/null +++ b/examples/simpleDBExample.hs @@ -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 diff --git a/hails.cabal b/hails.cabal --- a/hails.cabal +++ b/hails.cabal @@ -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 , Deian Stefan -Stability: experimental -Synopsis: IFC enforcing web platform framework +Author: Hails team +Maintainer: Hails team +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 diff --git a/hails.hs b/hails.hs new file mode 100644 --- /dev/null +++ b/hails.hs @@ -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 diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Tests.hs @@ -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