Skip to content

Commit

Permalink
Moved addUsers to policy module
Browse files Browse the repository at this point in the history
  • Loading branch information
a-shen committed Jul 29, 2013
1 parent 3dfb359 commit 9d9d806
Show file tree
Hide file tree
Showing 2 changed files with 83 additions and 28 deletions.
44 changes: 24 additions & 20 deletions Task/Controllers.hs
Expand Up @@ -77,9 +77,13 @@ server = mkRouter $ do
, "tasks" -: (("tasks" `at` oldproj) :: [ObjectId]) ]
pdoc
liftLIO $ withTaskPolicyModule $ save "projects" project
alldocs <- liftLIO $ withTaskPolicyModule $ findAll $ select [] "users"
let memDocs = filter (\u -> ("name" `at` u) `elem` members) alldocs
alldocs <- liftLIO $ withTaskPolicyModule $ findAllL $ select [] "users"
memDocs <- liftLIO $ filterM (\ldoc -> do
doc <- liftLIO $ unlabel ldoc
return (("name" `at` doc) `elem` members) :: LIO DCLabel Bool)
alldocs
liftLIO $ withTaskPolicyModule $ addProjects memDocs pid
-- to do: remove project from the documents of users who were removed
respond $ redirectTo ("/projects/" ++ show pid)

-- Display the Project Page
Expand Down Expand Up @@ -116,8 +120,11 @@ server = mkRouter $ do
, "tasks" -: ([] :: [ObjectId])]
pdoc
pid <- liftLIO $ withTaskPolicyModule $ insert "projects" project
alldocs <- liftLIO $ withTaskPolicyModule $ findAll $ select [] "users"
let memDocs = filter (\doc -> ("name" `at` doc) `elem` members) alldocs
alldocs <- liftLIO $ withTaskPolicyModule $ findAllL $ select [] "users"
memDocs <- liftLIO $ filterM (\ldoc -> do
doc <- liftLIO $ unlabel ldoc
return (("name" `at` doc) `elem` members) :: LIO DCLabel Bool)
alldocs
liftLIO $ withTaskPolicyModule $ addProjects memDocs pid
modifieddocs <- liftLIO $ withTaskPolicyModule $ findAll $ select [] "users"
let modifiedMemDocs = filter (\doc -> ("name" `at` doc) `elem` members) modifieddocs
Expand Down Expand Up @@ -215,7 +222,7 @@ server = mkRouter $ do
taskdoc <- include ["name", "members", "project", "completed", "priority"] `liftM` (request >>= labeledRequestToHson >>= (liftLIO. unlabel))
let members = ("members" `at` taskdoc)
let task = merge ["members" -: (members :: [String])] taskdoc
tid <- liftLIO $ withTaskPolicyModule $ insert "tasks" task
tid <- liftLIO $ withTaskPolicyModule $ insert "tasks" task -- todo: move to policy
mlpdoc <- liftLIO $ withTaskPolicyModule $ findOne $ select [ "_id" -: pid ] "projects"
pdoc <- liftLIO $ unlabel $ fromJust mlpdoc
let curTasks = "tasks" `at` pdoc
Expand Down Expand Up @@ -353,21 +360,6 @@ addTasks memDocs taskId = do
save "users" newDoc
addTasks (tail memDocs) taskId

-- Modifies the database by adding the second argument pId to each user document's "projects" field
addProjects :: [HsonDocument] -> ObjectId -> DBAction ()
addProjects memDocs pId = do
if memDocs == []
then return ()
else do
let doc = head memDocs
let curProjects = "projects" `at` doc
if (pId `elem` curProjects) then addProjects (tail memDocs) pId
else do
let newProjects = pId:curProjects
let newDoc = merge ["projects" -: newProjects] doc
save "users" newDoc
addProjects (tail memDocs) pId

-- Modifies the database by removing the second argument proj from each uer document's "projects" field
removeProj :: [UserName] -> ObjectId -> DBAction ()
removeProj users proj = do
Expand All @@ -383,6 +375,18 @@ removeProj users proj = do
liftLIO $ withTaskPolicyModule $ save "users" newdoc
removeProj (tail users) proj

-- Returns a list of all labeled documents in the database satisfying the Query
findAllL :: Query -> DBAction [LabeledHsonDocument]
findAllL q = do
cur <- find q
getAll cur []
where getAll cur list = do
mldoc <- next cur
case mldoc of
Nothing -> return list
Just ldoc -> do
getAll cur (list ++ [ldoc])

-- Returns a list of all documents in the database satisfying the Query
findAll :: Query -> DBAction [HsonDocument]
findAll q = do
Expand Down
67 changes: 59 additions & 8 deletions Task/Policy.hs
Expand Up @@ -3,16 +3,18 @@
module Task.Policy (
TaskPolicyModule
, withTaskPolicyModule
, addProjects
) where

import Data.Typeable

import Debug.Trace
import LIO
import LIO.DCLabel
import Hails.Database
import Hails.PolicyModule
import Hails.PolicyModule.DSL
import Hails.Web.User
import Data.Maybe
import qualified Data.List as List
import qualified Data.Text as T

Expand All @@ -37,18 +39,22 @@ instance PolicyModule TaskPolicyModule where
readers ==> unrestricted
writers ==> unrestricted
field "name" key
field "_id" key
collection "tasks" $ do
access $ do
readers ==> unrestricted
writers ==> unrestricted
clearance $ do
secrecy ==> this
integrity ==> unrestricted
document $ \_ -> do
document $ \doc -> do
--let pid = "project" `at` doc
--mlpdoc <- findOne $ select ["_id" -: pid] "projects"
--let pdoc = unlabel $ fromJust mlpdoc
--let members = "members" `at` pdoc
--readers ==> List.foldl' (\/) this members
--writers ==> List.foldl' (\/) this members
readers ==> unrestricted
writers ==> unrestricted
field "_id" key
collection "projects" $ do
access $ do
readers ==> unrestricted
Expand All @@ -57,10 +63,11 @@ instance PolicyModule TaskPolicyModule where
secrecy ==> this
integrity ==> unrestricted
document $ \doc -> do
let members = map T.unpack ("members" `at` doc :: [UserName])
readers ==> List.foldl' (\/) this members
--let members = map T.unpack ("members" `at` doc :: [UserName])
--readers ==> List.foldl' (\/) this members
--writers ==> List.foldl' (\/) this members
readers ==> unrestricted
writers ==> unrestricted
field "_id" key
collection "comments" $ do
access $ do
readers ==> unrestricted
Expand All @@ -78,5 +85,49 @@ instance PolicyModule TaskPolicyModule where
withTaskPolicyModule :: DBAction a -> DC a
withTaskPolicyModule act = withPolicyModule (\(_ :: TaskPolicyModule) -> act)

-- Modifies the database by adding the second argument pId to each user document's "projects" field
addProjects :: [LabeledHsonDocument] -> ObjectId -> DBAction ()
addProjects lmemdocs pId = liftLIO $ withPolicyModule $ \(TaskPolicyModuleTCB mypriv) -> do
mlproj <- findOne $ select ["_id" -: pId] "projects"
let lproj = fromJust mlproj
if (length lmemdocs) == 0
then trace "97" $ return ()
else do
if (labelOf (head lmemdocs)) `canFlowTo` (labelOf lproj)
then trace "94" $ do
memDocs <- mapM (liftLIO . unlabel) lmemdocs
trace ("memDocs: " ++ show memDocs) $ do
let ldoc = head lmemdocs
let curProjects = trace "100" $ "projects" `at` (head memDocs)
if (pId `elem` curProjects) then trace "101" $ addProjects (tail lmemdocs) pId
else trace "102" $ do
let newProjects = pId:curProjects
doc <- liftLIO $ unlabel ldoc
let newDoc = merge ["projects" -: newProjects] doc
saveP mypriv "users" newDoc
addProjects (tail lmemdocs) pId
else trace "addProjects: label was not high enough" $ return ()


{-
-- Modifies the database by adding the second argument taskId to each user document's "tasks" field
addTasks :: [LabeledHsonDocument] -> ObjectId -> DBAction ()
addTasks lmemdocs tid = liftLIO $ withPolicyModule $ \(TaskPolicyModuleTCB mypriv) -> do
if (length lmemdocs == 0)
then return ()
else do
mltask <- findOne $ select ["_id" -: tid] "tasks"
task <- unlabel $ fromJust mltask
let pid = "project" `at` task
mlproj <- findOne $ select ["_id" -: pid] "projects"
let lproj = fromJust mlproj
if (labelOf (head lmemdocs)) `canFlowTo` (labelOf lproj)
then do
memDocs <- mapM (liftLIO . unlabel) lmemdocs
let doc = head memDocs
let curTasks = "tasks" `at` doc
let newTasks = taskId:curTasks
let newDoc = merge ["tasks" -: newTasks] doc
saveP mypriv "users" newDoc
addTasks (tail memDocs) taskId
else trace "addProjects: label was not high enough" $ return ()
-}

0 comments on commit 9d9d806

Please sign in to comment.