hails (empty) → 0.1
raw patch · 26 files changed
+3020/−0 lines, 26 filesdep +HsOpenSSLdep +MissingHdep +RSAsetup-changed
Dependencies added: HsOpenSSL, MissingH, RSA, SHA, SimpleAES, base, base64-bytestring, binary, bson, bytestring, cereal, compact-string-fix, containers, dclabel, iterIO, iterio-server, lio, monad-control, mongoDB, mtl, network, parsec, pureMD5, time, transformers, transformers-base, unix
Files
- Hails/App.hs +30/−0
- Hails/Crypto.hs +17/−0
- Hails/Data/LBson.hs +7/−0
- Hails/Data/LBson/Rexports/Bson.hs +9/−0
- Hails/Data/LBson/Safe.hs +51/−0
- Hails/Data/LBson/TCB.hs +493/−0
- Hails/Database.hs +73/−0
- Hails/Database/MongoDB.hs +52/−0
- Hails/Database/MongoDB/Structured.hs +193/−0
- Hails/Database/MongoDB/TCB/Access.hs +127/−0
- Hails/Database/MongoDB/TCB/Convert.hs +69/−0
- Hails/Database/MongoDB/TCB/DCAccess.hs +249/−0
- Hails/Database/MongoDB/TCB/Query.hs +417/−0
- Hails/Database/MongoDB/TCB/Types.hs +374/−0
- Hails/HttpServer.hs +111/−0
- Hails/HttpServer/Auth.hs +104/−0
- Hails/IterIO/Conversions.hs +79/−0
- Hails/IterIO/HailsRoute.hs +47/−0
- Hails/IterIO/HttpClient.hs +302/−0
- Hails/IterIO/Mime.hs +25/−0
- Hails/Policy.hs +19/−0
- Hails/TCB/Types.hs +44/−0
- LICENSE +17/−0
- LIO/Data/Time.hs +33/−0
- Setup.hs +2/−0
- hails.cabal +76/−0
+ Hails/App.hs view
@@ -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
+ Hails/Crypto.hs view
@@ -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
+ Hails/Data/LBson.hs view
@@ -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
+ Hails/Data/LBson/Rexports/Bson.hs view
@@ -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
+ Hails/Data/LBson/Safe.hs view
@@ -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)
+ Hails/Data/LBson/TCB.hs view
@@ -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
+ Hails/Database.hs view
@@ -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+
+ Hails/Database/MongoDB.hs view
@@ -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+
+ Hails/Database/MongoDB/Structured.hs view
@@ -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
+ Hails/Database/MongoDB/TCB/Access.hs view
@@ -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)
+ Hails/Database/MongoDB/TCB/Convert.hs view
@@ -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+
+ Hails/Database/MongoDB/TCB/DCAccess.hs view
@@ -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 <options> : ConfirmWrites [corresponding-options]+-- > _ : master+--+-- where @options@ can be:+--+-- > fsync | journal | writes=<N>+--+-- separated by \',\', and @N@ is an integer.+-- Example: +--+-- > HAILS_MONGODB_MODE = "slaveOk"+-- > HAILS_MONGODB_MODE = "confirmWrites: writes=3, journal"+-- > HAILS_MONGODB_MODE = "master"+--+parseMode :: String -> AccessMode+parseMode "slaveOk" = slaveOk+parseMode "unconfirmedWrites" = UnconfirmedWrites+parseMode xs = case parse wParser "" xs of+ Right le -> ConfirmWrites le+ Left _ -> master+ where wParser = do _ <- string "confirmWrites" + spaces+ _ <- char ':'+ spaces+ gle_opts++gle_opts :: Stream s m Char => ParsecT s u m GetLastError+gle_opts = do opt_first <- gle_opt+ opt_rest <- gle_opts'+ return $ opt_first ++ opt_rest+ where gle_opt = gle_opt_fsync <|> gle_opt_journal <|> gle_opt_write + gle_opts' :: Stream s m Char => ParsecT s u m GetLastError+ gle_opts' = (spaces >> char ',' >> spaces >> gle_opts) <|> (return [])++gle_opt_fsync :: Stream s m Char => ParsecT s u m GetLastError+gle_opt_fsync = string "fsync" >> return [ (u "fsync") Bson.=: True ]++gle_opt_journal :: Stream s m Char => ParsecT s u m GetLastError+gle_opt_journal = string "journal" >> return [ (u "j") Bson.=: True ]++gle_opt_write :: Stream s m Char => ParsecT s u m GetLastError+gle_opt_write = do _ <- string "write"+ spaces+ _ <- char '='+ spaces+ dgt <- many1 digit+ return [ (u "w") Bson.=: (read dgt :: Integer) ]+++-- | Given a set of privileges, a labeled document and computaiton on+-- the (unlabeled version of the) documnet, downgrade the current label with+-- the supplied privileges execute (only integrity), unlabel the document+-- and apply the computation to it. The result is then labeled with the current+-- label and the current label is reset to the original (if possible).+gateToLabeled :: DCPrivTCB+ -> DCLabeled (Document DCLabel)+ -> (Document DCLabel -> DC a) -> DC (DCLabeled a)+gateToLabeled privs ldoc act = do+ l <- getLabel+ withLabel privs (newDC (secrecy l) (><)) $ do+ doc <- unlabel ldoc+ res <- act doc+ lr <- getLabel+ label lr res+++-- | Given a set of privileges, a desired label and action. Lower the+-- current label as close tothe desired label as possible, execute the+-- action and raise the current label.+withLabel :: DCPrivTCB -> DCLabel -> DC a -> DC a+withLabel privs l act = do+ -- Lower the current label:+ l0 <- getLabel+ setLabelP privs $ lostar privs l0 l+ -- Execute action+ act `finally` do l1 <- getLabel+ -- Raise current label:+ setLabelP privs (lostar privs l1 l0)
+ Hails/Database/MongoDB/TCB/Query.hs view
@@ -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+
+ Hails/Database/MongoDB/TCB/Types.hs view
@@ -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+ } +
+ Hails/HttpServer.hs view
@@ -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 = [] }
+ Hails/HttpServer/Auth.hs view
@@ -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"
+ Hails/IterIO/Conversions.hs view
@@ -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
+ Hails/IterIO/HailsRoute.hs view
@@ -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
+ Hails/IterIO/HttpClient.hs view
@@ -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+
+ Hails/IterIO/Mime.hs view
@@ -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
+ Hails/Policy.hs view
@@ -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
+ Hails/TCB/Types.hs view
@@ -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 ()+
+ LICENSE view
@@ -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
+ LIO/Data/Time.hs view
@@ -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
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ hails.cabal view
@@ -0,0 +1,76 @@+Name: hails+Version: 0.1+build-type: Simple+License: GPL-2+License-File: LICENSE+Author: HAILS team+Maintainer: Amit Levy <levya at cs.stanford dot edu>, Deian Stefan <deian at cs dot stanford dot edu>+Stability: experimental+Synopsis: IFC enforcing web platform framework+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