diff --git a/Hails/Data/Hson.hs b/Hails/Data/Hson.hs --- a/Hails/Data/Hson.hs +++ b/Hails/Data/Hson.hs @@ -109,8 +109,7 @@ import LIO import LIO.DCLabel -import LIO.Labeled.TCB -import LIO.TCB (ioTCB, ShowTCB(..)) +import LIO.TCB import Network.Wai.Parse ( FileInfo(..) , sinkRequestBody @@ -321,17 +320,16 @@ -- | Convert a labeled request to a labeled document. Values of fields that -- have a name that ends with @[]@ are converted to arrays and the -- suffix @[]@ is stripped from the name. -labeledRequestToHson :: MonadDC m +labeledRequestToHson :: MonadLIO DCLabel m => DCLabeled Request -> m (DCLabeled HsonDocument) -labeledRequestToHson lreq = do - let origLabel = labelOf lreq - req = unlabelTCB lreq +labeledRequestToHson lreq = liftLIO $ do + let (LabeledTCB origLabel req) = lreq btype = fromMaybe UrlEncoded $ getRequestBodyType req (ps, fs) <- liftLIO . ioTCB $ runResourceT $ sourceLbs (requestBody req) $$ sinkRequestBody lbsBackEnd btype let psDoc = map convertPS ps fsDoc = map convertFS fs - return $ labelTCB origLabel $ arrayify $ psDoc ++ fsDoc + return $ LabeledTCB origLabel $ arrayify $ psDoc ++ fsDoc where convertPS (k,v) = HsonField (T.pack . S8.unpack $ k) (toHsonValue . S8.unpack $ v) @@ -643,7 +641,7 @@ -- -- | Create a fresh ObjectId. -genObjectId :: MonadDC m => m ObjectId +genObjectId :: MonadLIO DCLabel m => m ObjectId genObjectId = liftLIO $ ioTCB Bson.genObjectId -- diff --git a/Hails/Data/Hson/TCB.hs b/Hails/Data/Hson/TCB.hs --- a/Hails/Data/Hson/TCB.hs +++ b/Hails/Data/Hson/TCB.hs @@ -60,8 +60,8 @@ import qualified Data.Binary.Put as Binary import qualified Data.Binary.Get as Binary -import LIO.Labeled.TCB (unlabelTCB) import LIO.DCLabel +import LIO.TCB -- | Strict ByeString type S8 = S8.ByteString @@ -171,9 +171,10 @@ -- applied to label the field. hsonToDataBsonTCB :: HsonValue -> Bson.Value hsonToDataBsonTCB (HsonValue b) = bsonToDataBsonTCB b -hsonToDataBsonTCB (HsonLabeled (HasPolicyTCB lv)) = +hsonToDataBsonTCB (HsonLabeled (HasPolicyTCB (LabeledTCB _ lv))) = toUserDef . hsonDocToDataBsonDocTCB $ - [ HsonField __hails_HsonLabeled_value $ HsonValue (unlabelTCB lv) ] + [ HsonField __hails_HsonLabeled_value $ + HsonValue lv ] where toUserDef = Bson.UserDef . Bson.UserDefined . strictify diff --git a/Hails/Database/Core.hs b/Hails/Database/Core.hs --- a/Hails/Database/Core.hs +++ b/Hails/Database/Core.hs @@ -29,6 +29,7 @@ , Pipe, AccessMode(..), master, slaveOk ) where +import Data.Monoid import Control.Monad import Control.Monad.Trans.State @@ -66,14 +67,14 @@ -- label on collections which can be projected given a 'Database' -- value. getDatabase :: DBAction Database -getDatabase = getDatabaseP noPriv +getDatabase = getDatabaseP mempty -- | Same as 'getDatabase', but uses privileges when raising the -- current label. getDatabaseP :: DCPriv -> DBAction Database getDatabaseP p = do db <- dbActionDB `liftM` getActionStateTCB - taintP p (databaseLabel db) + liftLIO $ taintP p (databaseLabel db) return db -- | Arbitrary monad that can perform database actions. diff --git a/Hails/Database/Query.hs b/Hails/Database/Query.hs --- a/Hails/Database/Query.hs +++ b/Hails/Database/Query.hs @@ -54,6 +54,7 @@ import Prelude hiding (lookup) import Data.Maybe +import Data.Monoid import Data.List (sortBy) import qualified Data.List as List import Data.Map (Map) @@ -65,7 +66,6 @@ import qualified Data.Traversable as T import Control.Monad -import Control.Exception (Exception) import qualified Data.Bson as Bson import qualified Database.MongoDB as Mongo @@ -74,8 +74,9 @@ , BatchSize) import LIO +import LIO.Error import LIO.DCLabel -import LIO.Labeled.TCB (unlabelTCB, labelTCB) +import LIO.TCB import Hails.Data.Hson import Hails.Data.Hson.TCB @@ -202,7 +203,7 @@ insert :: CollectionName -> doc -> DBAction ObjectId - insert = insertP noPriv + insert = insertP mempty -- | Same as 'insert' except it does not return @_id@ insert_ :: CollectionName @@ -233,7 +234,7 @@ save :: CollectionName -> doc -> DBAction () - save = saveP noPriv + save = saveP mempty -- | Same as 'save', but uses privileges when applying the -- policies and performing label comparisons. @@ -252,9 +253,9 @@ withCollection priv True cName $ \col -> do -- Already checked that we can write to DB and collection, -- apply policies: - ldoc <- applyCollectionPolicyP priv col doc + (LabeledTCB _ ndoc) <- applyCollectionPolicyP priv col doc -- No IFC violation, perform insert: - let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc + let bsonDoc = hsonDocToDataBsonDocTCB ndoc _id `liftM` (execMongoActionTCB $ Mongo.insert cName bsonDoc) where _id i = let HsonValue (BsonObjId i') = dataBsonValueToHsonValueTCB i in i' @@ -269,11 +270,11 @@ Just (_id :: ObjectId) -> do mdoc <- findOneP priv $ select [_id_n -: _id] cName -- If document exists, check that we can overwrite it: - maybe (return ()) (guardWriteP priv . labelOf) mdoc + maybe (return ()) (liftLIO . guardWriteP priv . labelOf) mdoc -- Okay, save document: saveIt ldoc - where saveIt ldoc = - let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc + where saveIt (LabeledTCB _ nd) = + let bsonDoc = hsonDocToDataBsonDocTCB nd in execMongoActionTCB $ Mongo.save cName bsonDoc instance InsertLike LabeledHsonDocument where @@ -284,9 +285,10 @@ -- current computation may insert a document it could otherwise not -- have created. insertP priv cName ldoc' = do - guardInsertOrSaveLabeledHsonDocument priv cName ldoc' $ \ldoc -> + guardInsertOrSaveLabeledHsonDocument priv cName ldoc' $ + \(LabeledTCB _ doc) -> -- No IFC violation, perform insert: - let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc + let bsonDoc = hsonDocToDataBsonDocTCB doc in _id `liftM` (execMongoActionTCB $ Mongo.insert cName bsonDoc) where _id i = let HsonValue (BsonObjId i') = dataBsonValueToHsonValueTCB i in i' @@ -299,23 +301,21 @@ -- document it could otherwise not have created. saveP priv cName ldoc' = do guardInsertOrSaveLabeledHsonDocument priv cName ldoc' $ \ldoc -> - let doc = unlabelTCB ldoc + let (LabeledTCB ld doc) = ldoc _id_n = Text.pack "_id" in case lookup _id_n doc of Nothing -> saveIt ldoc Just (_id :: ObjectId) -> do mdoc <- findOneP priv $ select [_id_n -: _id] cName -- If document exists, check that we can overwrite it: - maybe (return ()) (guardWriteP' (labelOf ldoc) . labelOf) mdoc + maybe (return ()) (liftLIO . guardWriteP' ld . labelOf) mdoc -- Okay, save document: saveIt ldoc where guardWriteP' lnew lold = - unless (canFlowToP priv lnew lold) $ throwLIO $ - VMonitorFailure { - monitorFailure = CanFlowToViolation - , monitorMessage = "New document label doesn't flow to the old" } - saveIt ldoc = - let bsonDoc = hsonDocToDataBsonDocTCB . unlabelTCB $ ldoc + unless (canFlowToP priv lnew lold) $ labelErrorP + "New document label doesn't flow to the old" priv [lnew, lold] + saveIt (LabeledTCB _ doc) = + let bsonDoc = hsonDocToDataBsonDocTCB doc in execMongoActionTCB $ Mongo.save cName bsonDoc -- @@ -346,22 +346,23 @@ withCollection priv True cName $ \col -> do -- Already checked that we can write to DB and collection -- Document is labeled, remove label: - let doc = unlabelTCB ldoc + let (LabeledTCB ld doc) = ldoc -- Check that labels are same as if we had applied them -- Apply policies to the unlabeled document, -- asserts that labeled values are below collection clearance: dbPriv <- dbActionPriv `liftM` getActionStateTCB - ldocTCB <- applyCollectionPolicyP dbPriv col doc + (LabeledTCB ltcb docTCB) <- applyCollectionPolicyP dbPriv col doc -- Check that all the fields are the same (i.e., if there was a -- unlabeled PolicyLabeled value an this will fail): - let same = compareDoc doc (unlabelTCB ldocTCB) - unless same $ throwLIO PolicyViolation - -- Check that label of the passed in document `canFlowToP` - -- the label of document created by the policy: - unless (canFlowToP priv (labelOf ldoc) (labelOf ldocTCB)) $ - throwLIO PolicyViolation + let same = compareDoc doc docTCB + liftLIO $ do + unless same $ throwLIO PolicyViolation + -- Check that label of the passed in document `canFlowToP` + -- the label of document created by the policy: + unless (canFlowToP priv ld ltcb) $ + throwLIO PolicyViolation -- Perform action on policy-labeled document: - act ldocTCB + act $ LabeledTCB ltcb docTCB where compareDoc d1' d2' = let d1 = sortDoc d1' d2 = sortDoc d2' @@ -395,7 +396,7 @@ -- 'order', or 'hint' are /ignored/ (as opposed to throwing an -- exception). find :: Query -> DBAction Cursor -find = findP noPriv +find = findP mempty -- | Same as 'find', but uses privileges when reading from the -- collection and database. @@ -436,13 +437,13 @@ -- The returned document is labeled according to the underlying -- 'Collection' policy. next :: Cursor -> DBAction (Maybe LabeledHsonDocument) -next = nextP noPriv +next = nextP mempty -- | Same as 'next', but usess privileges when raising the current label. nextP :: DCPriv -> Cursor -> DBAction (Maybe LabeledHsonDocument) nextP p cur = do -- Raise current label, can read from DB+collection: - taintP p $ curLabel cur + liftLIO $ taintP p $ curLabel cur -- Read the document: mMongoDoc <- execMongoActionTCB $ Mongo.next $ curInternal cur case mMongoDoc of @@ -451,17 +452,16 @@ let doc0 = dataBsonDocToHsonDocTCB mongoDoc dbPriv <- dbActionPriv `liftM` getActionStateTCB ldoc <- applyCollectionPolicyP dbPriv (curCollection cur) doc0 - let doc = unlabelTCB ldoc - l = labelOf ldoc + let (LabeledTCB l doc) = ldoc proj = case curProject cur of [] -> id xs -> include xs - return . Just . labelTCB l . proj $ doc + return . Just . LabeledTCB l . proj $ doc -- | Fetch the first document satisfying query, or 'Nothing' if not -- documents matched the query. findOne :: Query -> DBAction (Maybe LabeledHsonDocument) -findOne = findOneP noPriv +findOne = findOneP mempty -- | Same as 'findOne', but uses privileges when performing label -- comparisons. @@ -477,18 +477,18 @@ -- existing documents. That is, the current label must flow -- to the label of each document that matches the selection. delete :: Selection -> DBAction () -delete = deleteP noPriv +delete = deleteP mempty -- | Same as 'delete', but uses privileges. deleteP :: DCPriv -> Selection -> DBAction () deleteP p sel = do let qry = select (selectionSelector sel) (selectionCollection sel) cur <- findP p qry - forAll cur $ \ld -> do + forAll cur $ \(LabeledTCB l ld) -> do -- Can write to the document? - guardWriteP p (labelOf ld) + liftLIO $ guardWriteP p l -- Delete only _this_ document, avoid TOCTTOU - let doc' = hsonDocToDataBsonDocTCB $ ["_id"] `include` (unlabelTCB ld) + let doc' = hsonDocToDataBsonDocTCB $ ["_id"] `include` ld -- Remove this document execMongoActionTCB $ Mongo.deleteOne $ Mongo.select doc' (selectionCollection sel) @@ -540,14 +540,16 @@ -> DBAction a withCollection priv isWrite cName act = do db <- getDatabaseP priv - -- If this is a write: check that we can write to database: - when isWrite $ guardWriteP priv (databaseLabel db) - -- Check that we can read collection names associated with DB: - cs <- unlabelP priv $ databaseCollections db - -- Lookup collection name in the collection set associated with DB: - col <- maybe (throwLIO UnknownCollection) return $ getCol cs - -- If this is a write: check that we can write to collection: - when isWrite $ guardWriteP priv (colLabel col) + col <- liftLIO $ do + -- If this is a write: check that we can write to database: + when isWrite $ guardWriteP priv (databaseLabel db) + -- Check that we can read collection names associated with DB: + cs <- unlabelP priv $ databaseCollections db + -- Lookup collection name in the collection set associated with DB: + col0 <- maybe (throwLIO UnknownCollection) return $ getCol cs + -- If this is a write: check that we can write to collection: + when isWrite $ guardWriteP priv (colLabel col0) + return col0 -- Execute action on collection: act col where getCol = listToMaybe . Set.toList . Set.filter ((==cName) . colName) @@ -585,7 +587,7 @@ -- Additionally, these labels must flow to the label of the collection -- clearance. (Of course, in both cases privileges are used to allow for -- more permissive flows.) -applyCollectionPolicyP :: MonadDC m +applyCollectionPolicyP :: MonadLIO DCLabel m => DCPriv -- ^ Privileges -> Collection -- ^ Collection and policies -> HsonDocument -- ^ Document to apply policies to @@ -594,7 +596,7 @@ let doc1 = List.nubBy (\f1 f2 -> fieldName f1 == fieldName f2) doc0 typeCheckDocument fieldPolicies doc1 c <- getClearance - withClearanceP p ((colClearance col) `lowerBound` c) $ do + withClearanceP p ((colClearance col) `glb` c) $ do -- Apply fied policies: doc2 <- T.for doc1 $ \f@(HsonField n v) -> case v of diff --git a/Hails/Database/Structured.hs b/Hails/Database/Structured.hs --- a/Hails/Database/Structured.hs +++ b/Hails/Database/Structured.hs @@ -21,10 +21,9 @@ , toLabeledDocumentP, fromLabeledDocumentP ) where -import Data.Monoid (mappend) +import Data.Monoid (mappend, mempty) import Control.Monad (liftM) -import Control.Exception (SomeException) - + import LIO import LIO.DCLabel @@ -71,13 +70,13 @@ -- -- - findBy = findByP noPriv + findBy = findByP mempty -- - findWhere = findWhereP noPriv + findWhere = findWhereP mempty -- - insertRecord = insertRecordP noPriv + insertRecord = insertRecordP mempty -- - saveRecord = saveRecordP noPriv + saveRecord = saveRecordP mempty -- insertRecordP p r = liftDB $ do insertP p (recordCollection r) $ toDocument r @@ -90,7 +89,7 @@ -- findWhereP p query = liftDB $ do mldoc <- findOneP p query - c <- getClearance + c <- liftLIO $ getClearance case mldoc of Just ldoc | canFlowToP p (labelOf ldoc) c -> fromDocument `liftM` (liftLIO $ unlabelP p ldoc) @@ -114,7 +113,7 @@ -- | Find all records that satisfy the query and can be read, subject -- to the current clearance. findAll :: (DCRecord a, MonadDB m) => Query -> m [a] -findAll = findAllP noPriv +findAll = findAllP mempty -- | Same as 'findAll', but uses privileges. findAllP :: (DCRecord a, MonadDB m) @@ -126,7 +125,7 @@ mldoc <- nextP p cur case mldoc of Just ldoc -> do - c <- getClearance + c <- liftLIO getClearance if canFlowTo (labelOf ldoc) c then do md <- fromDocument `liftM` (liftLIO $ unlabelP p ldoc) cursorToRecords cur $ maybe docs (:docs) md @@ -165,9 +164,9 @@ -- -- - insertLabeledRecord lrec = insertLabeledRecordP noPriv lrec + insertLabeledRecord lrec = insertLabeledRecordP mempty lrec -- - saveLabeledRecord lrec = saveLabeledRecordP noPriv lrec + saveLabeledRecord lrec = saveLabeledRecordP mempty lrec -- insertLabeledRecordP p lrec = liftDB $ do let cName = recordCollection (forceType lrec) @@ -184,7 +183,7 @@ toLabeledDocument :: (MonadDB m, DCLabeledRecord pm a) => DCLabeled a -> m (DCLabeled Document) -toLabeledDocument = toLabeledDocumentP noPriv +toLabeledDocument = toLabeledDocumentP mempty -- | Uses the policy modules\'s privileges to convert a labeled record -- to a labeled document, if the policy module created an instance of @@ -195,20 +194,26 @@ -> m (DCLabeled Document) toLabeledDocumentP p' lr = liftDB $ do pmPriv' <- dbActionPriv `liftM` getActionStateTCB - -- Fail if not endorsed: - pmPriv <- liftLIO $ (evaluate . endorseInstance $ lr) >> return pmPriv' - `catchLIO` (\(_ :: SomeException) -> return noPriv) - let p = p' `mappend` pmPriv - r <- unlabelP p lr - lcur <- getLabel - let lres = partDowngradeP p lcur (labelOf lr) - labelP p lres $ toDocument r + liftLIO $ do + -- Fail if not endorsed: + pmPriv <- (evaluate . endorseInstance $ lr) >> return pmPriv' + `catch` (\(_ :: SomeException) -> return mempty) + let p = p' `mappend` pmPriv + scopeClearance $ do + -- raise clearance: + clr <- getClearance + setClearanceP p $ clr `lub` (p %% True) + -- + r <- unlabelP p lr + lcur <- getLabel + let lres = downgradeP p lcur `lub` (labelOf lr) + labelP p lres $ toDocument r -- | Convert labeled document to labeled record fromLabeledDocument :: forall m pm a. (MonadDB m, DCLabeledRecord pm a) => DCLabeled Document -> m (DCLabeled a) -fromLabeledDocument = fromLabeledDocumentP noPriv +fromLabeledDocument = fromLabeledDocumentP mempty -- | Uses the policy modules\'s privileges to convert a labeled document -- to a labeled record, if the policy module created an instance of @@ -221,13 +226,18 @@ pmPriv' <- dbActionPriv `liftM` getActionStateTCB -- Fail if not endorsed: pmPriv <- liftLIO $ (evaluate . endorseInstance $ fake) >> return pmPriv' - `catchLIO` (\(_ :: SomeException) -> return noPriv) + `catch` (\(_ :: SomeException) -> return mempty) let p = p' `mappend` pmPriv - doc <- unlabelP p ldoc - lcur <- getLabel - let lres = partDowngradeP p lcur (labelOf ldoc) - rec <- fromDocument doc - labelP p lres rec + liftLIO $ scopeClearance $ do + -- raise clearance: + clr <- getClearance + setClearanceP p $ clr `lub` (p %% True) + -- get at the document + doc <- liftLIO $ unlabelP p ldoc + lcur <- liftLIO $ getLabel + let lres = downgradeP p lcur `lub` (labelOf ldoc) + rec <- fromDocument doc + labelP p lres rec where fake :: DCLabeled a fake = undefined diff --git a/Hails/Database/TCB.hs b/Hails/Database/TCB.hs --- a/Hails/Database/TCB.hs +++ b/Hails/Database/TCB.hs @@ -61,8 +61,7 @@ ) import LIO -import LIO.TCB (rethrowIoTCB) -import LIO.Labeled.TCB (labelTCB, unlabelTCB) +import LIO.TCB import LIO.DCLabel import Hails.Data.Hson @@ -237,8 +236,8 @@ , dbActionPriv = priv } where db = DatabaseTCB { databaseName = dbName , databaseLabel = l - , databaseCollections = labelTCB l Set.empty } - l = dcLabel prin prin + , databaseCollections = LabeledTCB l Set.empty } + l = prin %% prin prin = privDesc priv -- | Set the label of the underlying database to the supplied label, @@ -253,8 +252,8 @@ setCollectionSetLabelTCB :: DCLabel -> DBAction () setCollectionSetLabelTCB l = updateActionStateTCB $ \s -> let db = dbActionDB s - cs = databaseCollections db - cs' = labelTCB l $! unlabelTCB cs + (LabeledTCB _ cs) = databaseCollections db + cs' = LabeledTCB l $! cs in s { dbActionDB = db { databaseCollections = cs' } } -- | Associate a collection with underlying database, ignoring IFC. @@ -264,9 +263,9 @@ let db = dbActionDB s in s { dbActionDB = doUpdate db } where doUpdate db = - let cs = databaseCollections db - in db { databaseCollections = labelTCB (labelOf cs) $ - Set.insert col $ unlabelTCB cs } + let (LabeledTCB l cs) = databaseCollections db + in db { databaseCollections = LabeledTCB l $ + Set.insert col cs } -- | Lift a mongoDB action into the 'DBAction' monad. This function -- always executes the action with "Database.MongoDB"\'s @access@. If @@ -277,7 +276,7 @@ let pipe = dbActionPipe s mode = dbActionMode s db = databaseName . dbActionDB $ s - liftLIO $ rethrowIoTCB $ do + liftLIO $ ioTCB $ do res <- Mongo.access pipe mode db act case res of Left err -> throwIO $ ExecFailure err diff --git a/Hails/HttpClient.hs b/Hails/HttpClient.hs --- a/Hails/HttpClient.hs +++ b/Hails/HttpClient.hs @@ -1,6 +1,7 @@ {-# LANGUAGE Trustworthy #-} {-# LANGUAGE FlexibleInstances, - MultiParamTypeClasses #-} + MultiParamTypeClasses, + FlexibleContexts #-} {- | Exports basic HTTP client functions inside the 'DC' Monad. @@ -95,6 +96,7 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.Conduit as C +import Data.Monoid import Control.Failure import Control.Exception @@ -128,16 +130,17 @@ -- | Perform a simple HTTP(S) request. simpleHttp :: Request -- ^ Request -> DC Response -simpleHttp = simpleHttpP noPriv +simpleHttp = simpleHttpP noPrivs -- | Same as 'simpleHttp', but uses privileges. -simpleHttpP :: DCPriv -- ^ Privilege +simpleHttpP :: PrivDesc DCLabel p + => Priv p -- ^ Privilege -> Request -- ^ Request -> DC Response simpleHttpP p req' = do let req = req' { proxy = Nothing, socksProxy = Nothing } guardWriteURLP p req - resp <- rethrowIoTCB $ C.withManager $ C.httpLbs req + resp <- ioTCB $ C.withManager $ C.httpLbs req return $ Response { respStatus = C.responseStatus resp , respHeaders = C.responseHeaders resp , respBody = C.responseBody resp @@ -157,7 +160,7 @@ -- | Simple HTTP GET request. simpleGetHttp :: String -> DC Response -simpleGetHttp = simpleGetHttpP noPriv +simpleGetHttp = simpleGetHttpP mempty -- | Simple HTTP HEAD request. simpleHeadHttpP :: DCPriv -- ^ Privilege @@ -169,7 +172,7 @@ -- | Simple HTTP HEAD request. simpleHeadHttp :: String -> DC Response -simpleHeadHttp = simpleHeadHttpP noPriv +simpleHeadHttp = simpleHeadHttpP mempty -- @@ -177,7 +180,7 @@ -- -- | Check that current label can flow to label of request. -guardWriteURLP :: DCPriv -> Request -> DC () +guardWriteURLP :: PrivDesc DCLabel p => Priv p -> Request -> DC () guardWriteURLP p req = do let (lr, lw) = labelOfReq req guardAllocP p lr @@ -203,9 +206,9 @@ -- absolute URL makes senes. labelOfReq :: Request -> (DCLabel, DCLabel) labelOfReq req = - let scheme = if secure req then "https://" else "http://" - prin = concat [scheme, S8.unpack (host req), ':' : show (port req)] - in (dcLabel (toComponent prin) dcTrue, dcLabel dcTrue (toComponent prin)) + let scheme = if secure req then (S8.pack "https://") else (S8.pack "http://") + prin = principalBS $ S8.concat [scheme, host req, S8.pack ":", S8.pack $ show (port req)] + in (prin %% True, True %% prin) -- | Convert a URL into a 'Request'. -- diff --git a/Hails/HttpServer.hs b/Hails/HttpServer.hs --- a/Hails/HttpServer.hs +++ b/Hails/HttpServer.hs @@ -31,17 +31,20 @@ ) where import qualified Data.List as List +import qualified Data.Set as Set import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import Data.Conduit -import Data.Conduit.List +import Data.Conduit.List hiding (head) +import Data.Monoid +import Control.Monad (liftM) import Control.Monad.IO.Class (liftIO) import Control.Monad.Error.Class -import Control.Exception (fromException) import Network.HTTP.Types +import Network.URI (isURI) import qualified Network.Wai as W import qualified Network.Wai.Application.Static as W import Network.Wai.Middleware.MethodOverridePost @@ -49,8 +52,6 @@ import LIO import LIO.TCB import LIO.DCLabel -import LIO.DCLabel.Privs.TCB -import LIO.Labeled.TCB import Hails.HttpServer.Types @@ -101,35 +102,35 @@ then response else Response status403 [] "" --- | Adds the header @X-Hails-Label@ to the response. If the +-- | Adds the header @Content-Security-Policy@ to the response, if the -- label of the computation does not flow to the public label, --- 'dcPub', the JSON field @isPublic@ is set to @true@, otherwise --- it is set to @true@ and the JSON @label@ is set to the secrecy +-- 'dcPublic'. The @default-src@ directive is set to the secrecy -- component of the response label (if it is a disjunction --- of principals is added). An example may be: --- --- > X-Hails-Label = { isPublic: true } --- --- or +-- of principals). Currently, @'self'@ is always added to the +-- whitelist. An example may be: -- --- > X-Hails-Label = { isPublic: false, label : ["http://google.com:80", "alice"] } +-- > Content-Security-Policy: default-src 'self' http://google.com:80 https://a.lvh.me:3000; -- guardSensitiveResp :: Middleware -guardSensitiveResp happ p req = do - response <- happ p req +guardSensitiveResp app config req = do + response <- (flip removeResponseHeader) csp `liftM` app config req resultLabel <- getLabel - return $ addResponseHeader response $ - ("X-Hails-Label", S8.pack $ - if resultLabel `canFlowTo` dcPub - then "{\"isPublic\": true}" - else "{\"isPublic\": false, \"label\": [" ++ mkClientLabel resultLabel ++ "]}") - where mkClientLabel l = let s = dcSecrecy l - cs = toList s - in if s == dcFalse || length cs /= 1 - then "" - else List.intercalate ", " $ - List.map (show . S8.unpack . principalName) $ - List.head cs + return $ if resultLabel `canFlowTo` dcPublic + then response + else addResponseHeader response $ + ( csp + , "default-src " <> headerVal resultLabel <> ";") + where csp = "Content-Security-Policy" + headerVal l = + let secrecy = dcSecrecy l + secrecySet = cToSet secrecy + uriList = Set.filter (isURI . S8.unpack) $ + Set.map principalName $ + dToSet $ head $ Set.elems secrecySet + in if secrecy == cFalse || Set.size secrecySet > 1 + then "\'none\'" -- false/conjunction + else S8.unwords $ + "\'self\'":"\'unsafe-inline\'":(Set.toList uriList) -- | Remove anything from the response that could cause inadvertant -- declasification. Currently this only removes the @Set-Cookie@ @@ -138,7 +139,7 @@ sanitizeResp hailsApp conf req = do response <- hailsApp conf req return $ foldr (\h r -> removeResponseHeader r h) response unsafeHeaders - where unsafeHeaders = ["Set-Cookie", "X-Hails-Label"] + where unsafeHeaders = ["Set-Cookie"] @@ -147,12 +148,12 @@ -- straight forward from other middleware: -- -- > secureApplication = 'browserLabelGuard' -- Return 403, if user should not read --- > . 'guardSensitiveResp' -- Add X-Hails-Sensitive if not public --- > . 'sanitizeResp' -- Remove Cookies +-- > . 'sanitizeResp' -- Remove Cookies/CSP +-- > . 'guardSensitiveResp' -- Add CSP if not public secureApplication :: Middleware secureApplication = browserLabelGuard -- Return 403, if user should not read . sanitizeResp -- Remove Cookies and X-Hails-Sensitive - . guardSensitiveResp -- Add X-Hails-Sensitive if not public + . guardSensitiveResp -- Add CSP if not public -- | Catch all exceptions thrown by middleware and return 500. catchAllExceptions :: W.Middleware @@ -195,28 +196,27 @@ hailsRequest <- waiToHailsReq req0 -- Extract browser/request configuration let conf = getRequestConf hailsRequest - result <- liftIO $ paranoidDC' conf $ do - let lreq = labelTCB (requestLabel conf) hailsRequest + (result, dcState) <- liftIO $ tryDCDef conf $ do + let lreq = LabeledTCB (requestLabel conf) hailsRequest app conf lreq case result of - Right (response,_) -> return $ hailsToWaiResponse response + Right response -> return $ hailsToWaiResponse response Left err -> do liftIO $ hPutStrLn stderr $ "App threw exception: " ++ show err - return $ case fromException err of - Just (LabeledExceptionTCB l _) -> - -- as in browserLabelGuard : - if l `canFlowTo` (browserLabel conf) - then resp500 else resp403 - _ -> resp500 + return $ + if lioLabel dcState `canFlowTo` (browserLabel conf) then + resp500 + else resp403 where app = secureApplication app0 isStatic req = case W.pathInfo req of ("static":_) -> True _ -> False resp403 = W.responseLBS status403 [] "" resp500 = W.responseLBS status500 [] "" - paranoidDC' conf act = - paranoidLIO act $ LIOState { lioLabel = dcPub - , lioClearance = browserLabel conf} + tryDCDef conf act = tryDC $ do + putLIOStateTCB $ LIOState { lioLabel = dcPublic + , lioClearance = browserLabel conf} + act -- @@ -228,12 +228,12 @@ getRequestConf :: Request -> RequestConfig getRequestConf req = let headers = requestHeaders req - userName = toComponent `fmap` lookup "x-hails-user" headers - appName = '@' : (S8.unpack . S8.takeWhile (/= '.') $ serverName req) - appPriv = DCPrivTCB $ toComponent appName + muserName = principalBS `fmap` lookup "x-hails-user" headers + appName = "@" `S8.append` (S8.takeWhile (/= '.') $ serverName req) + appPriv = PrivTCB $ toCNF $ principalBS appName in RequestConfig - { browserLabel = maybe dcPub (\un -> dcLabel un anybody) userName - , requestLabel = maybe dcPub (\un -> dcLabel anybody un) userName + { browserLabel = maybe dcPublic (\userName -> userName %% True) muserName + , requestLabel = maybe dcPublic (\userName -> True %% userName) muserName , appPrivilege = appPriv } diff --git a/Hails/HttpServer/Auth.hs b/Hails/HttpServer/Auth.hs --- a/Hails/HttpServer/Auth.hs +++ b/Hails/HttpServer/Auth.hs @@ -23,6 +23,8 @@ , personaAuth -- ** OpenID , openIdAuth + -- ** Authenticate with external app + , externalAuth -- * Development: basic authentication , devBasicAuth ) where @@ -227,3 +229,37 @@ , if serverPort req `notElem` [80, 443] then portBS else "" , path ] where portBS = S8.pack $ ":" ++ show (serverPort req) + + +-- Cookie authentication +-- + +-- | Use an external authentication service that sets cookies. +-- The cookie names are @_hails_user@, whose contents contains the +-- @user-name@, and @_hails_user_hmac@, whose contents contains +-- @HMAC-SHA1(user-name)@. This function simply checks that the cookie +-- exists and the MAC'd user name is correct. If this is the case, it +-- returns a request with the cookie removed and @x-hails-user@ header +-- set. Otherwies the original request is returned. +-- The login service retuns a redirect (to the provided url). +-- Additionally, cookie @_hails_refer$ is set to the current +-- URL (@scheme://domain:port/path@). +externalAuth :: L8.ByteString -> String -> Middleware +externalAuth key url app req = do + let mreqAuth = do + cookieHeaders <- lookup hCookie $ requestHeaders req + let cookies = parseCookies cookieHeaders + mac0 <- fmap (S8.takeWhile (/= '"') . S8.dropWhile (== '"')) $ lookup "_hails_user_hmac" cookies + user <- fmap (S8.takeWhile (/= '"') . S8.dropWhile (== '"')) $ lookup "_hails_user" cookies + let mac1 = showDigest $ hmacSha1 key (lazyfy user) + if S8.unpack mac0 == mac1 + then Just $ req { requestHeaders = ("X-Hails-User", user) + : requestHeaders req } + else Nothing + req0 = maybe req id mreqAuth + requireLoginMiddleware redirectResp app req0 + where redirectResp = return $ responseLBS status302 + [(hLocation, S8.pack url)] "" + -- + lazyfy = L8.fromChunks . (:[]) + diff --git a/Hails/HttpServer/Types.hs b/Hails/HttpServer/Types.hs --- a/Hails/HttpServer/Types.hs +++ b/Hails/HttpServer/Types.hs @@ -7,6 +7,7 @@ , addRequestHeader, removeRequestHeader -- * Responses , Response(..) + , module Network.HTTP.Types , addResponseHeader, removeResponseHeader -- * Applications and middleware , Application, RequestConfig(..) @@ -20,8 +21,7 @@ import qualified Data.ByteString.Lazy as L import Network.Socket (SockAddr) -import qualified Network.HTTP.Types as H -import qualified Network.HTTP.Types.Header as H +import Network.HTTP.Types import Network.Wai.Parse (RequestBodyType(..)) import Data.Time (UTCTime) @@ -35,9 +35,9 @@ -- | A request sent by the end-user. data Request = Request { -- | HTTP Request (e.g., @GET@, @POST@, etc.). - requestMethod :: H.Method + requestMethod :: Method -- | HTTP version (e.g., 1.1 or 1.0). - , httpVersion :: H.HttpVersion + , httpVersion :: HttpVersion -- | Extra path information sent by the client. , rawPathInfo :: S.ByteString -- | If no query string was specified, this should be empty. This value @@ -54,7 +54,7 @@ -- this value should not be used in URL construction. , serverPort :: Int -- | The request headers. - , requestHeaders :: H.RequestHeaders + , requestHeaders :: RequestHeaders -- | Was this request made over an SSL connection? , isSecure :: Bool -- | The client\'s host information. @@ -63,7 +63,7 @@ -- and without a query string, split on forward slashes, , pathInfo :: [Text] -- | Parsed query string information - , queryString :: H.Query + , queryString :: Query -- | Lazy ByteString containing the request body. , requestBody :: L.ByteString -- | Time request was received. @@ -92,13 +92,13 @@ else Nothing else Nothing --- | Add/replace a 'H.Header' to the 'Request' -addRequestHeader :: Request -> H.Header -> Request +-- | Add/replace a 'Header' to the 'Request' +addRequestHeader :: Request -> Header -> Request addRequestHeader req hdr@(hname, _) = req { requestHeaders = hdr:headers } where headers = List.filter ((/= hname) . fst) $ requestHeaders req -- | Remove a header (if it exists) from the 'Request' -removeRequestHeader :: Request -> H.HeaderName -> Request +removeRequestHeader :: Request -> HeaderName -> Request removeRequestHeader req hname = req { requestHeaders = headers } where headers = List.filter ((/= hname) . fst) $ requestHeaders req @@ -110,20 +110,20 @@ -- | A response sent by the app. data Response = Response { -- | Response status - respStatus :: H.Status + respStatus :: Status -- | Response headers - , respHeaders :: H.ResponseHeaders + , respHeaders :: ResponseHeaders -- | Response body , respBody :: L.ByteString } deriving Show --- | Add/replace a 'H.Header' to the 'Response' -addResponseHeader :: Response -> H.Header -> Response +-- | Add/replace a 'Header' to the 'Response' +addResponseHeader :: Response -> Header -> Response addResponseHeader resp hdr@(hname, _) = resp { respHeaders = hdr:headers } where headers = List.filter ((/= hname) . fst) $ respHeaders resp -- | Remove a header (if it exists) from the 'Response' -removeResponseHeader :: Response -> H.HeaderName -> Response +removeResponseHeader :: Response -> HeaderName -> Response removeResponseHeader resp hname = resp { respHeaders = headers } where headers = List.filter ((/= hname) . fst) $ respHeaders resp diff --git a/Hails/PolicyModule.hs b/Hails/PolicyModule.hs --- a/Hails/PolicyModule.hs +++ b/Hails/PolicyModule.hs @@ -55,11 +55,11 @@ import Data.Maybe +import Data.Monoid import qualified Data.List as List import Data.Map (Map) import qualified Data.Map as Map import Data.Typeable -import qualified Data.ByteString.Char8 as S8 import qualified Data.Text as T import qualified Data.Bson as Bson @@ -69,8 +69,7 @@ import Database.MongoDB (GetLastError) import LIO -import LIO.Privs.TCB (mintTCB) -import LIO.TCB (ioTCB, rethrowIoTCB) +import LIO.TCB import LIO.DCLabel import Hails.Data.Hson import Hails.Database.Core @@ -207,7 +206,7 @@ -- database label. The latter requirement suggests that every policy -- module use 'setDatabaseLabelP' when first changing the label. setDatabaseLabel :: DCLabel -> PMAction () -setDatabaseLabel = setDatabaseLabelP noPriv +setDatabaseLabel = setDatabaseLabelP mempty -- | Same as 'setDatabaseLabel', but uses privileges when performing -- label comparisons. If a policy module wishes to allow other policy @@ -219,9 +218,9 @@ -> DCLabel -- ^ New database label -> PMAction () setDatabaseLabelP p l = liftDB $ do - guardAllocP p l + liftLIO $ guardAllocP p l db <- dbActionDB `liftM` getActionStateTCB - guardWriteP p (databaseLabel db) + liftLIO $ guardWriteP p (databaseLabel db) setDatabaseLabelTCB l -- | The collections label protects the collection-set of the database. @@ -236,7 +235,7 @@ -- the label of the database which protects the label of the -- colleciton set. In most cases code should use 'setCollectionSetLabelP'. setCollectionSetLabel :: DCLabel -> PMAction () -setCollectionSetLabel = setCollectionSetLabelP noPriv +setCollectionSetLabel = setCollectionSetLabelP mempty -- | Same as 'setCollectionSetLabel', but uses the supplied privileges -- when performing label comparisons. @@ -244,9 +243,9 @@ -> DCLabel -- ^ New collections label -> PMAction () setCollectionSetLabelP p l = liftDB $ do - guardAllocP p l + liftLIO $ guardAllocP p l db <- dbActionDB `liftM` getActionStateTCB - guardWriteP p (databaseLabel db) + liftLIO $ guardWriteP p (databaseLabel db) setCollectionSetLabelTCB l -- | This is the first action that any policy module should execute. It @@ -325,7 +324,7 @@ -> DCLabel -- ^ Collection clearance -> CollectionPolicy-- ^ Collection policy -> PMAction () -createCollection = createCollectionP noPriv +createCollection = createCollectionP mempty -- | Same as 'createCollection', but uses privileges when performing -- IFC checks. @@ -337,10 +336,11 @@ -> PMAction () createCollectionP p n l c pol = liftDB $ do db <- dbActionDB `liftM` getActionStateTCB - taintP p $ databaseLabel db - guardWriteP p $ labelOf (databaseCollections db) - guardAllocP p l - guardAllocP p c + liftLIO $ do + taintP p $ databaseLabel db + guardWriteP p $ labelOf (databaseCollections db) + guardAllocP p l + guardAllocP p c associateCollectionTCB $ collectionTCB n l c newPol where newPol = let ps = fieldLabelPolicies pol ps' = Map.insert (T.pack "_id") SearchableField ps @@ -406,7 +406,7 @@ ls <- lines `liftM` readFile conf Map.fromList `liftM` mapM xfmLine ls where xfmLine l = do (tn, dn) <- readIO l - return (tn,(principal (S8.pack $ '_':tn), dn)) + return (tn,(principal ('_':tn), dn)) -- | This function is the used to execute database queries on policy -- module databases. The function firstly invokes the policy module, @@ -431,26 +431,27 @@ List.lookup "HAILS_MONGODB_SERVER" env mode = maybe master parseMode $ List.lookup "HAILS_MONGODB_MODE" env - pipe <- rethrowIoTCB $ Mongo.runIOE $ Mongo.connect (Mongo.host hostName) - let priv = mintTCB (toComponent pmOwner) + pipe <- ioTCB $ Mongo.runIOE $ Mongo.connect (Mongo.host hostName) + let priv = PrivTCB (toCNF pmOwner) s0 = makeDBActionStateTCB priv dbName pipe mode -- Execute policy module entry function with raised clearance: (policy, s1) <- withClearanceP' priv $ runDBAction (pmAct priv) s0 let s2 = s1 { dbActionDB = dbActionDB s1 } res <- evalDBAction (act policy) s2 - rethrowIoTCB $ Mongo.close pipe + ioTCB $ Mongo.close pipe return res where tn = policyModuleTypeName (undefined :: pm) pmAct priv = unPMActionTCB $ initPolicyModule priv :: DBAction pm withClearanceP' priv io = do c <- getClearance - let lpriv = dcLabel (privDesc priv) (privDesc priv) `lub` c - bracketP priv + let lpriv = (priv %% priv) `lub` c + -- XXX: does this actually work? Used to be bracketP + bracket -- Raise clearance: (setClearanceP priv lpriv) -- Lower clearance: (const $ do c' <- getClearance - setClearanceP priv (partDowngradeP priv c' c)) + setClearanceP priv (downgradeP priv c' `lub` c)) -- Execute policy module entry point, in between: (const io) diff --git a/Hails/PolicyModule/DSL.hs b/Hails/PolicyModule/DSL.hs --- a/Hails/PolicyModule/DSL.hs +++ b/Hails/PolicyModule/DSL.hs @@ -29,19 +29,19 @@ 'initPolicyModule' priv = do 'setPolicy' priv $ do 'database' $ do - 'readers' '==>' 'anybody' - 'writers' '==>' 'anybody' + 'readers' '==>' 'unrestricted' + 'writers' '==>' 'unrestricted' 'admins' '==>' this 'collection' \"users\" $ do 'access' $ do - 'readers' '==>' 'anybody' - 'writers' '==>' 'anybody' + 'readers' '==>' 'unrestricted' + 'writers' '==>' 'unrestricted' 'clearance' $ do 'secrecy' '==>' this - 'integrity' '==>' 'anybody' + 'integrity' '==>' 'unrestricted' 'document' $ \doc -> do - 'readers' '==>' 'anybody' - 'writers' '==>' 'anybody' + 'readers' '==>' 'unrestricted' + 'writers' '==>' 'unrestricted' 'field' \"name\" $ 'searchable' 'field' \"password\" $ 'labeled' $ \doc -> do let user = \"name\" ``at`` doc :: String @@ -77,6 +77,7 @@ -- * Label components (or roles) , readers, secrecy , writers, integrity + , unrestricted , admins , (==>), (<==) -- * Creating databases label policies @@ -146,10 +147,10 @@ class MonadState s m => Role r s m where -- | @r ==> c@ effectively states that role @r@ (i.e., 'readers', -- 'writers', 'admins' must imply label component @c@). - (==>) :: (ToComponent c) => r -> c -> m () + (==>) :: (ToCNF c) => r -> c -> m () -- | Inverse implication. Purely provided for readability. The -- direction is not relevant to the internal representation. - (<==) :: (ToComponent c) => r -> c -> m () + (<==) :: (ToCNF c) => r -> c -> m () (<==) = (==>) @@ -164,11 +165,11 @@ -- > writers ==> "Alice" -- > admins ==> "Alice" -- -data DBExp = DBExp Component Component Component +data DBExp = DBExp CNF CNF CNF deriving Show -- | Database expression solely contains a list of components. -type DBExpS = Map String Component +type DBExpS = Map String CNF -- | Database expression composition monad newtype DBExpM a = DBExpM (ErrorT String (State DBExpS) a) @@ -179,21 +180,21 @@ s <- get case Map.lookup (show readers) s of Just _ -> fail "Database readers already specified." - Nothing -> put $ Map.insert (show readers) (toComponent c) s + Nothing -> put $ Map.insert (show readers) (toCNF c) s instance Role Writers DBExpS DBExpM where _ ==> c = DBExpM $ do s <- get case Map.lookup (show writers) s of Just _ -> fail "Database writers already specified." - Nothing -> put $ Map.insert (show writers) (toComponent c) s + Nothing -> put $ Map.insert (show writers) (toCNF c) s instance Role Admins DBExpS DBExpM where _ ==> c = DBExpM $ do s <- get case Map.lookup (show admins) s of Just _ -> fail "Database admins already specified." - Nothing -> put $ Map.insert (show admins) (toComponent c) s + Nothing -> put $ Map.insert (show admins) (toCNF c) s -- | Create a database lebeling policy The policy must set the label @@ -239,11 +240,11 @@ -- > readers ==> "Alice" \/ "Bob" -- > writers ==> "Alice" -- -data ColAccExp = ColAccExp Component Component +data ColAccExp = ColAccExp CNF CNF deriving Show -- | Access expression solely contains a list of components. -type ColAccExpS = Map String Component +type ColAccExpS = Map String CNF -- | Access expression composition monad newtype ColAccExpM a = @@ -257,7 +258,7 @@ case Map.lookup (show readers) s of Just _ -> fail $ "Collection " ++ show cName ++ " access readers already specified." - Nothing -> put $ Map.insert (show readers) (toComponent c) s + Nothing -> put $ Map.insert (show readers) (toCNF c) s instance Role Writers ColAccExpS ColAccExpM where _ ==> c = ColAccExpM $ do @@ -266,7 +267,7 @@ case Map.lookup (show writers) s of Just _ -> fail $ "Collection " ++ show cName ++ " access writers already specified." - Nothing -> put $ Map.insert (show writers) (toComponent c) s + Nothing -> put $ Map.insert (show writers) (toCNF c) s -------------------------------------------------------------- @@ -277,11 +278,11 @@ -- > readers ==> "Alice" \/ "Bob" -- > writers ==> "Alice" -- -data ColClrExp = ColClrExp Component Component +data ColClrExp = ColClrExp CNF CNF deriving Show -- | Clress expression solely contains a list of components. -type ColClrExpS = Map String Component +type ColClrExpS = Map String CNF -- | Database expression composition monad newtype ColClrExpM a = @@ -295,7 +296,7 @@ case Map.lookup (show readers) s of Just _ -> fail $ "Collection " ++ show cName ++ " clearance readers already specified." - Nothing -> lift . put $ Map.insert (show readers) (toComponent c) s + Nothing -> lift . put $ Map.insert (show readers) (toCNF c) s instance Role Writers ColClrExpS ColClrExpM where _ ==> c = ColClrExpM $ do @@ -304,7 +305,7 @@ case Map.lookup (show writers) s of Just _ -> fail $ "Collection " ++ show cName ++ " clearance writers already specified." - Nothing -> put $ Map.insert (show writers) (toComponent c) s + Nothing -> put $ Map.insert (show writers) (toCNF c) s @@ -320,10 +321,10 @@ instance Show ColDocExp where show _ = "ColDocExp {- function -}" -- | A Label expression has two components. -data LabelExp = LabelExp Component Component +data LabelExp = LabelExp CNF CNF -- | Document expression solely contains a list of components. -type ColDocExpS = Map String Component +type ColDocExpS = Map String CNF -- | Document expression composition monad newtype ColDocExpM a = @@ -337,7 +338,7 @@ case Map.lookup (show readers) s of Just _ -> fail $ "Collection " ++ show cName ++ " document readers already specified." - Nothing -> lift . put $ Map.insert (show readers) (toComponent c) s + Nothing -> lift . put $ Map.insert (show readers) (toCNF c) s instance Role Writers ColDocExpS ColDocExpM where _ ==> c = ColDocExpM $ do @@ -346,7 +347,7 @@ case Map.lookup (show writers) s of Just _ -> fail $ "Collection " ++ show cName ++ " document writers already specified." - Nothing -> put $ Map.insert (show writers) (toComponent c) s + Nothing -> put $ Map.insert (show writers) (toCNF c) s @@ -367,7 +368,7 @@ show (ColLabFieldExp _) = "ColLabFieldExp {- function -}" -- | Labeled field expression solely contains a list of components. -type ColLabFieldExpS = Map String Component +type ColLabFieldExpS = Map String CNF -- | Labeled field expression composition monad. newtype ColLabFieldExpM a = @@ -381,7 +382,7 @@ case Map.lookup (show readers) s of Just _ -> fail $ "Collection " ++ show cName ++ " field " ++ show fName ++ " readers already specified." - Nothing -> lift . put $ Map.insert (show readers) (toComponent c) s + Nothing -> lift . put $ Map.insert (show readers) (toCNF c) s instance Role Writers ColLabFieldExpS ColLabFieldExpM where _ ==> c = ColLabFieldExpM $ do @@ -390,7 +391,7 @@ case Map.lookup (show writers) s of Just _ -> fail $ "Collection " ++ show cName ++ " field " ++ show fName ++ " writers already specified." - Nothing -> put $ Map.insert (show writers) (toComponent c) s + Nothing -> put $ Map.insert (show writers) (toCNF c) s -- | Field expression composition monad. newtype ColFieldExpM a = @@ -451,7 +452,7 @@ -- > secrecy ==> "Users" -- > integrity ==> "Alice" -- > document $ \doc -> do --- > readers ==> anybody +-- > readers ==> unrestricted -- > writers ==> "Alice" \/ (("name" `at`doc) :: String) -- > field "name" searchable -- > field "password" $ labeled $ \doc -> do @@ -571,7 +572,7 @@ -- > collection "w00t" $ do -- > ... -- > document $ \doc -> do --- > readers ==> anybody +-- > readers ==> 'unrestricted' -- > writers ==> "Alice" \/ (("name" `at`doc) :: String) -- -- states that every document in the collection is readable by anybody, @@ -651,7 +652,7 @@ -- > secrecy ==> "Users" -- > integrity ==> "Alice" -- > document $ \doc -> do --- > readers ==> anybody +-- > readers ==> 'unrestricted' -- > writers ==> "Alice" \/ (("name" `at`doc) :: String) -- > field "name" searchable -- > field "password" $ labeled $ \doc -> do @@ -703,19 +704,19 @@ setPolicy :: DCPriv -> PolicyExpM () -> PMAction () setPolicy priv pol = case runPolicy pol of - Left err -> throwLIO $ PolicyCompileError err + Left err -> liftLIO $ throwLIO $ PolicyCompileError err Right policy -> execPolicy policy where execPolicy (PolicyExp db cs) = do execPolicyDB db void $ forM cs execPolicyCol -- execPolicyDB (DBExp r w a) = do - setDatabaseLabelP priv (dcLabel r w) - setCollectionSetLabelP priv (dcLabel r a) + setDatabaseLabelP priv (r %% w) + setCollectionSetLabelP priv (r %% a) -- execPolicyCol (ColExp n (ColAccExp lr lw) (ColClrExp cr cw) doc fs) = let cps = mkColPol doc fs - in createCollectionP priv n (dcLabel lr lw) (dcLabel cr cw) cps + in createCollectionP priv n (lr %% lw) (cr %% cw) cps -- mkColPol (ColDocExp fdocE) cs = let fdoc = unDataPolicy fdocE @@ -724,7 +725,7 @@ -- unDataPolicy fpolE = \doc -> let (LabelExp s i) = fpolE doc - in dcLabel s i + in s %% i -- unFieldExp ColFieldSearchable = SearchableField unFieldExp (ColLabFieldExp f) = FieldPolicy (unDataPolicy f) @@ -744,3 +745,6 @@ fromRight :: Either String b -> b fromRight (Right x) = x fromRight (Left e) = throw . PolicyRuntimeError $ e + +unrestricted :: CNF +unrestricted = cTrue diff --git a/Hails/PolicyModule/Groups.hs b/Hails/PolicyModule/Groups.hs --- a/Hails/PolicyModule/Groups.hs +++ b/Hails/PolicyModule/Groups.hs @@ -11,8 +11,8 @@ module Hails.PolicyModule.Groups ( Groups(..) , labelRewrite ) where -import Data.Maybe -import qualified Data.List as List +import Data.Monoid +import qualified Data.Set as Set import qualified Data.Map as Map import Control.Monad @@ -53,36 +53,43 @@ labelRewrite pm lx = do -- Make sure that 'groupsInstanceEndorse' is not bottom _ <- liftLIO $ evaluate (groupsInstanceEndorse :: unused_pm) - -- Get underlying privileges if they corresponds to the named (by - -- the first argument) policy module pmPriv <- getPMPriv + -- Build map from principals to list of princpals - pmap <- forM principals $ \p -> groups pm pmPriv p >>= \ps -> return (p, ps) + pMap <- Set.fold (\p act -> act >>= \m -> do + ps <- groups pm pmPriv p + return (Map.insert p ps m)) (return Map.empty) principals -- Apply map to all principals in the label - let lnew = dcLabel (mk pmap s) (mk pmap i) + let lnew = (expandPrincipals pMap s) %% (expandPrincipals pMap i) -- Relabel labeled value - relabelLabeledP pmPriv lnew lx + liftLIO $ relabelLabeledP pmPriv lnew lx where getPMPriv = do pmPriv <- dbActionPriv `liftM` getActionStateTCB -- Make sure that the underlying policy module -- and one named in the first parameter are the same case Map.lookup (policyModuleTypeName pm) availablePolicyModules of - Nothing -> return noPriv - Just (p,_) -> return $ if toComponent p == privDesc pmPriv + Nothing -> return mempty + Just (p,_) -> return $ if toCNF p == privDesc pmPriv then pmPriv - else noPriv + else mempty -- Modify label by expanding principals according to the map - mk pmap lc = - let f = map (concatMap (\x -> fromJust $ List.lookup x pmap)) - in if lc == dcFalse - then lc - else fromList . f . toList $ lc + expandPrincipals pMap origPrincipals = + -- Function to fold over disjunctions in a CNF, expanding each + -- principal with the groups map + let cFoldF :: Disjunction -> CNF -> CNF + cFoldF disj accm = + (Set.foldr expandOne cFalse $ dToSet disj) /\ accm + -- Inner fold function, expands a single principal and adds + -- to a CNF (that represents a Disjunction + expandOne :: Principal -> CNF -> CNF + expandOne princ accm = + (dFromList $ pMap Map.! princ) \/ accm + in Set.foldr cFoldF cTrue $ cToSet origPrincipals -- Label components s = dcSecrecy $ labelOf lx i = dcIntegrity $ labelOf lx -- All unique principals in the labe - principals = List.nub $ getPrincipals s ++ getPrincipals i + principals = getPrincipals s <> getPrincipals i -- Get principals form component - getPrincipals lc = if lc == dcFalse - then [] - else List.nub . concat . toList $ lc + getPrincipals = mconcat . (map dToSet) . Set.elems . cToSet + diff --git a/Hails/Web/Controller.hs b/Hails/Web/Controller.hs --- a/Hails/Web/Controller.hs +++ b/Hails/Web/Controller.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE OverloadedStrings , TypeSynonymInstances , FlexibleInstances @@ -31,12 +31,13 @@ import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy.Char8 as L8 -import Network.HTTP.Types.Header import Hails.HttpServer import Hails.Web.Router import Hails.Web.Responses -data ControllerState = ControllerState { csRequest :: DCLabeled Request } +data ControllerState = ControllerState + { csRequest :: DCLabeled Request + , csPathParams :: Query } -- | A controller is simply a reader monad atop 'DC' with the 'Labeled' -- 'Request' as the environment. @@ -46,19 +47,24 @@ liftLIO = lift instance Routeable (Controller Response) where - runRoute controller _ _ req = fmap Just $ - runReaderT controller $ ControllerState req + runRoute controller _ eq _ req = fmap Just $ + runReaderT controller $ ControllerState req eq -- | Get the underlying request. request :: Controller (DCLabeled Request) request = fmap csRequest ask +-- | Get the underlying request. +pathParams :: Controller [(S8.ByteString, Maybe S8.ByteString)] +pathParams = fmap csPathParams ask + -- | Get the query parameter mathing the supplied variable name. queryParam :: S8.ByteString -> Controller (Maybe S8.ByteString) queryParam varName = do req <- request >>= liftLIO . unlabel + params <- pathParams let qr = queryString req - case lookup varName qr of + case lookup varName (params ++ qr) of Just n -> return n _ -> return Nothing diff --git a/Hails/Web/REST.hs b/Hails/Web/REST.hs --- a/Hails/Web/REST.hs +++ b/Hails/Web/REST.hs @@ -109,9 +109,9 @@ instance Routeable (RESTControllerM a) where runRoute controller = rt - where rt pi conf req = do + where rt pi eq conf req = do (_, st) <- runStateT controller defaultRESTControllerState - runRoute st pi conf req + runRoute st pi eq conf req -- |GET \/ diff --git a/Hails/Web/Router.hs b/Hails/Web/Router.hs --- a/Hails/Web/Router.hs +++ b/Hails/Web/Router.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} {-# LANGUAGE FlexibleInstances #-} {- | @@ -37,13 +37,13 @@ import Data.Monoid import Data.Text (Text) import qualified Data.Text as T -import Network.HTTP.Types import Hails.HttpServer import Hails.Web.Responses -- | Route handler is a fucntion from the path info, request -- configuration, and labeled request to a response. -type RouteHandler = [Text] -- ^ Path info +type RouteHandler = [Text] -- ^ Path info + -> [(S8.ByteString, Maybe S8.ByteString)] -- ^ Extra query params -> RequestConfig -- ^ Request configuration -> DCLabeled Request -- ^ Labeled request -> DC (Maybe Response) @@ -72,17 +72,17 @@ mkRouter route conf lreq = do req <- liftLIO $ unlabel lreq let pi = pathInfo req - mapp <- runRoute route pi conf lreq + mapp <- runRoute route pi [] conf lreq case mapp of Just resp -> return resp Nothing -> return notFound instance Routeable Application where - runRoute app _ conf req = fmap Just $ app conf req + runRoute app _ _ conf req = fmap Just $ app conf req instance Routeable Response where - runRoute resp _ _ _ = return . Just $ resp + runRoute resp _ _ _ _ = return . Just $ resp {- | The 'RouteM' type is a basic instance of 'Routeable' that simply holds @@ -136,25 +136,25 @@ mroute handler = Route handler () instance Monad RouteM where - return a = Route (const . const . const $ return Nothing) a + return a = Route (const . const . const . const $ return Nothing) a (Route rtA valA) >>= fn = let (Route rtB valB) = fn valA - in Route (\pi conf req -> do - resA <- rtA pi conf req + in Route (\pi eq conf req -> do + resA <- rtA pi eq conf req case resA of - Nothing -> rtB pi conf req + Nothing -> rtB pi eq conf req Just _ -> return resA) valB instance Monoid Route where - mempty = mroute $ const . const . const $ return Nothing - mappend (Route a _) (Route b _) = mroute $ \pi conf req -> do - c <- a pi conf req + mempty = mroute $ const . const . const . const $ return Nothing + mappend (Route a _) (Route b _) = mroute $ \pi eq conf req -> do + c <- a pi eq conf req case c of - Nothing -> b pi conf req + Nothing -> b pi eq conf req Just _ -> return c instance Routeable (RouteM a) where - runRoute (Route rtr _) pi conf req = rtr pi conf req + runRoute (Route rtr _) pi eq conf req = rtr pi eq conf req -- | A route that always matches (useful for converting a 'Routeable' into a -- 'Route'). @@ -164,27 +164,27 @@ -- | Matches on the hostname from the 'Request'. The route only successeds on -- exact matches. routeHost :: Routeable r => S.ByteString -> r -> Route -routeHost host route = mroute $ \pi conf lreq -> do +routeHost host route = mroute $ \pi eq conf lreq -> do req <- unlabel lreq if host == serverName req - then runRoute route pi conf lreq + then runRoute route pi eq conf lreq else return Nothing -- | Matches if the path is empty. Note that this route checks that 'pathInfo' -- is empty, so it works as expected when nested under namespaces or other -- routes that pop the 'pathInfo' list. routeTop :: Routeable r => r -> Route -routeTop route = mroute $ \pi conf lreq -> do +routeTop route = mroute $ \pi eq conf lreq -> do if null pi || (T.null . head $ pi) - then runRoute route pi conf lreq + then runRoute route pi eq conf lreq else return Nothing -- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT') routeMethod :: Routeable r => StdMethod -> r -> Route -routeMethod method route = mroute $ \pi conf lreq -> do +routeMethod method route = mroute $ \pi eq conf lreq -> do req <- unlabel lreq if renderStdMethod method == requestMethod req then - runRoute route pi conf lreq + runRoute route pi eq conf lreq else return Nothing -- | Routes the given URL pattern. Patterns can include @@ -206,22 +206,21 @@ -- | Matches if the first directory in the path matches the given 'ByteString' routeName :: Routeable r => S.ByteString -> r -> Route -routeName name route = mroute $ \pi conf lreq -> do +routeName name route = mroute $ \pi eq conf lreq -> do if (not . null $ pi) && S8.unpack name == (T.unpack . head $ pi) - then runRoute route (tail pi) conf lreq + then runRoute route (tail pi) eq conf lreq else return Nothing -- | Always matches if there is at least one directory in 'pathInfo' but and -- adds a parameter to 'queryString' where the key is the supplied -- variable name and the value is the directory consumed from the path. routeVar :: Routeable r => S.ByteString -> r -> Route -routeVar varName route = mroute $ \pi conf lreq -> do +routeVar varName route = mroute $ \pi eq conf lreq -> if null pi then return Nothing - else do lreqNext <- liftLIO $ lFmap lreq $ \req -> - let varVal = S8.pack . T.unpack . head $ pi - in req {queryString = (varName, Just varVal):(queryString req)} - runRoute route (tail pi) conf lreqNext + else let varVal = S8.pack . T.unpack . head $ pi + neqp = (varName, Just varVal):eq + in runRoute route (tail pi) neqp conf lreq {- $Example #example# diff --git a/hails.cabal b/hails.cabal --- a/hails.cabal +++ b/hails.cabal @@ -1,5 +1,5 @@ Name: hails -Version: 0.9.2.2 +Version: 0.11.0.0 build-type: Simple License: GPL-2 License-File: LICENSE @@ -83,37 +83,37 @@ Source-repository head Type: git - Location: ssh://anonymous@gitstar.com/scs/hails.git + Location: ssh://git@github.com.com/scslab/hails.git Library Build-Depends: base >= 4.5 && < 5.0 - ,transformers >= 0.2.2 - ,mtl >= 2.0 - ,containers >= 0.4.2 - ,bytestring >= 0.10 - ,text >= 0.11 - ,parsec >= 3.1.2 - ,binary >= 0.5 - ,time >= 1.2.0.5 - ,lio >= 0.9.1.1 - ,base64-bytestring >= 0.1 - ,bson >= 0.2 - ,mongoDB >= 1.3.0 - ,network >= 2.3 - ,conduit >= 0.5 - ,resourcet >= 0.3.3.1 - ,http-conduit >= 1.5 - ,wai >= 1.3 - ,wai-app-static >= 1.3.0.1 - ,wai-extra >= 1.3.0.1 - ,http-types >= 0.7 - ,authenticate >= 1.3 - ,cookie >= 0.4 - ,blaze-builder >= 0.3.1 - ,failure >= 0.2.0.1 - ,SHA >= 1.5.0.0 + ,transformers + ,mtl + ,containers + ,bytestring + ,text >= 0.11.3.0 + ,parsec + ,binary + ,time + ,lio + ,base64-bytestring + ,bson + ,mongoDB + ,network + ,conduit + ,resourcet + ,http-conduit + ,wai + ,wai-app-static + ,wai-extra + ,http-types + ,authenticate + ,cookie + ,blaze-builder + ,failure + ,SHA GHC-options: -Wall -fno-warn-orphans @@ -150,35 +150,35 @@ ghc-options: -package ghc -Wall -fno-warn-orphans Build-Depends: base >= 4.5 && < 5.0 - ,transformers >= 0.2.2 - ,mtl >= 2.0 - ,containers >= 0.4.2 - ,bytestring >= 0.9 - ,text >= 0.11 - ,parsec >= 3.1.2 - ,binary >= 0.5 - ,time >= 1.2.0.5 - ,lio >= 0.9.1 - ,base64-bytestring >= 0.1 - ,bson >= 0.2 - ,mongoDB >= 1.3.0 - ,network >= 2.3 - ,conduit >= 0.5 - ,resourcet >= 0.3.3.1 - ,http-conduit >= 1.5 - ,wai >= 1.3 - ,wai-extra >= 1.3 - ,wai-app-static >= 1.3 - ,warp >= 1.3 - ,http-types >= 0.7 - ,authenticate >= 1.3 - ,cookie >= 0.4 - ,blaze-builder >= 0.3.1 - ,directory >= 1.1 - ,filepath >= 1.3 - ,unix >= 2.5.1 - ,ghc-paths >= 0.1.0.8 - ,SHA >= 1.5.0.0 + ,transformers + ,mtl + ,containers + ,bytestring + ,text + ,parsec + ,binary + ,time + ,lio + ,base64-bytestring + ,bson + ,mongoDB + ,network + ,conduit + ,resourcet + ,http-conduit + ,wai + ,wai-extra + ,wai-app-static + ,warp + ,http-types + ,authenticate + ,cookie + ,blaze-builder + ,directory + ,filepath + ,unix + ,ghc-paths + ,SHA ,hails test-suite tests @@ -190,21 +190,21 @@ build-depends: hails - ,base >= 4.5 - ,containers >= 0.4.2 - ,unix >= 2.5 - ,time >= 1.2.0.5 - ,text >= 0.11 - ,QuickCheck >= 2.3 - ,HUnit >= 1.2.5 - ,quickcheck-instances >= 0.3.0 - ,test-framework >= 0.6 - ,test-framework-quickcheck2 >= 0.2.11 - ,test-framework-hunit >= 0.2.7 - ,lio >= 0.9.0.0 - ,quickcheck-lio-instances >= 0.9.0.0 - ,bson >= 0.2 - ,mongoDB >= 1.3.0 - ,wai >= 1.3 - ,wai-test >= 1.3 - ,http-types >= 0.7 + ,base + ,containers + ,unix + ,time + ,text + ,QuickCheck + ,HUnit + ,quickcheck-instances + ,test-framework + ,test-framework-quickcheck2 + ,test-framework-hunit + ,lio + ,quickcheck-lio-instances + ,bson + ,mongoDB + ,wai + ,wai-test + ,http-types diff --git a/hails.hs b/hails.hs --- a/hails.hs +++ b/hails.hs @@ -82,12 +82,15 @@ hmac_key = L8.pack . fromJust $ optHmacKey opts persona = personaAuth hmac_key $ T.pack . fromJust . optPersonaAud $ opts openid = openIdAuth $ T.pack . fromJust . optOpenID $ opts + external = externalAuth hmac_key + (fromJust $ optExternal $ opts) logMiddleware = if optDev opts then logStdoutDev else logStdout authMiddleware = case () of -- dev/production mode with persona: _ | isJust (optPersonaAud opts) -> persona -- dev/productoin mode with openid: _ | isJust (optOpenID opts) -> openid + _ | isJust (optExternal opts) -> external -- dev mode: _ -> devBasicAuth app <- loadApp (optSafe opts) (optPkgConf opts) (fromJust $ optName opts) @@ -142,6 +145,7 @@ , optSafe :: Bool -- ^ Use @-XSafe@ , optForce :: Bool -- ^ Force unsafe in production , optDev :: Bool -- ^ Development/Production + , optExternal :: Maybe String -- ^ External Auth URL , optOpenID :: Maybe String -- ^ OpenID provider , optHmacKey :: Maybe String -- ^ HMAC cookie key , optPersonaAud :: Maybe String -- ^ Persona audience @@ -161,6 +165,7 @@ , optSafe = True , optForce = False , optDev = True + , optExternal = Nothing , optOpenID = Nothing , optHmacKey = Nothing , optPersonaAud = Nothing @@ -180,6 +185,7 @@ , optSafe = True , optForce = False , optDev = True + , optExternal = Nothing , optOpenID = Nothing , optHmacKey = Just "hails-d34adb33f-key" , optPersonaAud = Nothing @@ -267,6 +273,7 @@ _ -> optPort opts , optOpenID = mFromEnvOrOpt "OPENID_PROVIDER" optOpenID , optPersonaAud = mFromEnvOrOpt "PERSONA_AUDIENCE" optPersonaAud + , optExternal = mFromEnvOrOpt "AUTH_URL" optPersonaAud , optHmacKey = mFromEnvOrOpt "HMAC_KEY" optHmacKey , optDBConf = mFromEnvOrOpt "DATABASE_CONFIG_FILE" optDBConf , optPkgConf = mFromEnvOrOpt "PACKAGE_CONF" optPkgConf @@ -296,6 +303,7 @@ , optPort = mergeMaybe optPort , optOpenID = mergeMaybe optOpenID , optPersonaAud = mergeMaybe optPersonaAud + , optExternal = mergeMaybe optExternal , optHmacKey = mergeMaybe optHmacKey , optDBConf = mergeMaybe optDBConf , optMongoServer = mergeMaybe optMongoServer } @@ -318,7 +326,8 @@ checkIsJust [(optName ,"APP_NAME" )] checkIsJust [(optPort ,"PORT" )] checkIsJust [(optOpenID ,"OPENID_PROVIDER" ) {- or -} - ,(optPersonaAud ,"PERSONA_AUDIENCE" )] + ,(optPersonaAud ,"PERSONA_AUDIENCE" ) {- or -} + ,(optExternal ,"AUTH_URL")] when (isJust $ optPersonaAud opts0) $ checkIsJust [(optHmacKey ,"HMAC_KEY")] checkIsJust [(optDBConf ,"DATABASE_CONFIG_FILE")] checkIsJust [(optMongoServer ,"HAILS_MONGODB_SERVER")]