diff --git a/Hails/App.hs b/Hails/App.hs new file mode 100644 --- /dev/null +++ b/Hails/App.hs @@ -0,0 +1,30 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Crypto.hs @@ -0,0 +1,17 @@ +{-# 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/LBson.hs b/Hails/Data/LBson.hs new file mode 100644 --- /dev/null +++ b/Hails/Data/LBson.hs @@ -0,0 +1,7 @@ +{-# 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/Bson.hs b/Hails/Data/LBson/Rexports/Bson.hs new file mode 100644 --- /dev/null +++ b/Hails/Data/LBson/Rexports/Bson.hs @@ -0,0 +1,9 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Data/LBson/Safe.hs @@ -0,0 +1,51 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Data/LBson/TCB.hs @@ -0,0 +1,493 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Database.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE Trustworthy, ScopedTypeVariables #-} + +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 + +-- | 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 + +-- | 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 + +-- | 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)) + +-- | 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 + +-- | 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 + diff --git a/Hails/Database/MongoDB.hs b/Hails/Database/MongoDB.hs new file mode 100644 --- /dev/null +++ b/Hails/Database/MongoDB.hs @@ -0,0 +1,52 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Database/MongoDB/Structured.hs @@ -0,0 +1,193 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Database/MongoDB/TCB/Access.hs @@ -0,0 +1,127 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Database/MongoDB/TCB/Convert.hs @@ -0,0 +1,69 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Database/MongoDB/TCB/DCAccess.hs @@ -0,0 +1,249 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Database/MongoDB/TCB/Query.hs @@ -0,0 +1,417 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Database/MongoDB/TCB/Types.hs @@ -0,0 +1,374 @@ +{-# 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/HttpServer.hs b/Hails/HttpServer.hs new file mode 100644 --- /dev/null +++ b/Hails/HttpServer.hs @@ -0,0 +1,111 @@ +{-# LANGUAGE CPP #-} +#if __GLASGOW_HASKELL__ >= 704 +{-# LANGUAGE Unsafe #-} +#endif + +{-# LANGUAGE OverloadedStrings #-} + +module Hails.HttpServer ( secureHttpServer ) where + +import qualified Data.ByteString.Lazy.Char8 as L8 +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 Hails.TCB.Types + +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 + +type L = L8.ByteString + +-- | 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 + +-- | 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 + +-- | 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) + +-- +-- 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 = [] } diff --git a/Hails/HttpServer/Auth.hs b/Hails/HttpServer/Auth.hs new file mode 100644 --- /dev/null +++ b/Hails/HttpServer/Auth.hs @@ -0,0 +1,104 @@ +{-# 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 ((<$>)) + +import Hails.Crypto + +import LIO.DCLabel + +type S = S8.ByteString +type L = L8.ByteString + +-- |Authentication function +type AuthFunction m s = HttpReq s -- ^ Request + -> m (Either (HttpResp m) (HttpReq s)) + +-- +-- 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 + +-- | 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 + +-- +-- Cookie authentication +-- + +-- | 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" + +-- | Cookie user HMAC token +_hails_cookie_hmac :: S +_hails_cookie_hmac = "_hails_user_hmac" diff --git a/Hails/IterIO/Conversions.hs b/Hails/IterIO/Conversions.hs new file mode 100644 --- /dev/null +++ b/Hails/IterIO/Conversions.hs @@ -0,0 +1,79 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/IterIO/HailsRoute.hs @@ -0,0 +1,47 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/IterIO/HttpClient.hs @@ -0,0 +1,302 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/IterIO/Mime.hs @@ -0,0 +1,25 @@ +{-# 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 new file mode 100644 --- /dev/null +++ b/Hails/Policy.hs @@ -0,0 +1,19 @@ +{-# 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/TCB/Types.hs b/Hails/TCB/Types.hs new file mode 100644 --- /dev/null +++ b/Hails/TCB/Types.hs @@ -0,0 +1,44 @@ +{-# 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/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,17 @@ +This program is free software; you can redistribute it and/or +modify it under the terms of the GNU General Public License as +published by the Free Software Foundation; either version 2, or (at +your option) any later version. + +This program is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You can obtain copies of permitted licenses from these URLs: + + http://www.gnu.org/licenses/old-licenses/gpl-2.0.txt + http://www.gnu.org/licenses/gpl-3.0.txt + +or by writing to the Free Software Foundation, Inc., 59 Temple Place, +Suite 330, Boston, MA 02111-1307 USA diff --git a/LIO/Data/Time.hs b/LIO/Data/Time.hs new file mode 100644 --- /dev/null +++ b/LIO/Data/Time.hs @@ -0,0 +1,33 @@ +{-# 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hails.cabal b/hails.cabal new file mode 100644 --- /dev/null +++ b/hails.cabal @@ -0,0 +1,76 @@ +Name: hails +Version: 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 +Category: Web +Cabal-Version: >= 1.6 + +Description: + Hails is a framework for building multi-app web platforms. + This module exports a library for building Hails platforms. + +Source-repository head + Type: git + Location: http://www.github.com/scslab/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 + + ghc-options: -Wall -fno-warn-orphans + + Exposed-modules: + Hails.Data.LBson + Hails.Data.LBson.Rexports.Bson + Hails.Data.LBson.Safe + Hails.Data.LBson.TCB + Hails.App + Hails.Policy + 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