hails 0.9.2.2 → 0.11.0.0

raw patch · 18 files changed

+436/−360 lines, 18 filesdep ~HUnitdep ~QuickCheckdep ~SHAPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: HUnit, QuickCheck, SHA, authenticate, base, base64-bytestring, binary, blaze-builder, bson, bytestring, conduit, containers, cookie, directory, failure, filepath, ghc-paths, http-conduit, http-types, lio, mongoDB, mtl, network, parsec, quickcheck-instances, quickcheck-lio-instances, resourcet, test-framework, test-framework-hunit, test-framework-quickcheck2, text, time, transformers, unix, wai, wai-app-static, wai-extra, wai-test, warp

API changes (from Hackage documentation)

Files

• Hails/Data/Hson.hs +6/−8
• Hails/Data/Hson/TCB.hs +4/−3
• Hails/Database/Core.hs +3/−2
• Hails/Database/Query.hs +51/−49
• Hails/Database/Structured.hs +38/−28
• Hails/Database/TCB.hs +9/−10
• Hails/HttpClient.hs +13/−10
• Hails/HttpServer.hs +48/−48
• Hails/HttpServer/Auth.hs +36/−0
• Hails/HttpServer/Types.hs +14/−14
• Hails/PolicyModule.hs +22/−21
• Hails/PolicyModule/DSL.hs +41/−37
• Hails/PolicyModule/Groups.hs +26/−19
• Hails/Web/Controller.hs +12/−6
• Hails/Web/REST.hs +2/−2
• Hails/Web/Router.hs +27/−28
• hails.cabal +74/−74
• hails.hs +10/−1

@@ -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  --

@@ -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

@@ -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.

@@ -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

@@ -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 

@@ -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

@@ -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'. --

@@ -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 }  

@@ -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 . (:[])+

@@ -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 

@@ -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) 

@@ -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

@@ -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+

@@ -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 

@@ -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 \/

@@ -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#

@@ -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

@@ -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")]