Skip to content

Commit 9d9d806

Browse files
a-shena-shen
committed
Moved addUsers to policy module
1 parent 3dfb359 commit 9d9d806

File tree

2 files changed

+83
-28
lines changed

2 files changed

+83
-28
lines changed

‎Task/Controllers.hs‎

Lines changed: 24 additions & 20 deletions
Original file line numberDiff line numberDiff line change
@@ -77,9 +77,13 @@ server = mkRouter $ do
7777
, "tasks" -: (("tasks" `at` oldproj) :: [ObjectId]) ]
7878
pdoc
7979
liftLIO $ withTaskPolicyModule $ save "projects" project
80-
alldocs <- liftLIO $ withTaskPolicyModule $ findAll $ select [] "users"
81-
let memDocs = filter (\u -> ("name" `at` u) `elem` members) alldocs
80+
alldocs <- liftLIO $ withTaskPolicyModule $ findAllL $ select [] "users"
81+
memDocs <- liftLIO $ filterM (\ldoc -> do
82+
doc <- liftLIO $ unlabel ldoc
83+
return (("name" `at` doc) `elem` members) :: LIO DCLabel Bool)
84+
alldocs
8285
liftLIO $ withTaskPolicyModule $ addProjects memDocs pid
86+
-- to do: remove project from the documents of users who were removed
8387
respond $ redirectTo ("/projects/" ++ show pid)
8488

8589
-- Display the Project Page
@@ -116,8 +120,11 @@ server = mkRouter $ do
116120
, "tasks" -: ([] :: [ObjectId])]
117121
pdoc
118122
pid <- liftLIO $ withTaskPolicyModule $ insert "projects" project
119-
alldocs <- liftLIO $ withTaskPolicyModule $ findAll $ select [] "users"
120-
let memDocs = filter (\doc -> ("name" `at` doc) `elem` members) alldocs
123+
alldocs <- liftLIO $ withTaskPolicyModule $ findAllL $ select [] "users"
124+
memDocs <- liftLIO $ filterM (\ldoc -> do
125+
doc <- liftLIO $ unlabel ldoc
126+
return (("name" `at` doc) `elem` members) :: LIO DCLabel Bool)
127+
alldocs
121128
liftLIO $ withTaskPolicyModule $ addProjects memDocs pid
122129
modifieddocs <- liftLIO $ withTaskPolicyModule $ findAll $ select [] "users"
123130
let modifiedMemDocs = filter (\doc -> ("name" `at` doc) `elem` members) modifieddocs
@@ -215,7 +222,7 @@ server = mkRouter $ do
215222
taskdoc <- include ["name", "members", "project", "completed", "priority"] `liftM` (request >>= labeledRequestToHson >>= (liftLIO. unlabel))
216223
let members = ("members" `at` taskdoc)
217224
let task = merge ["members" -: (members :: [String])] taskdoc
218-
tid <- liftLIO $ withTaskPolicyModule $ insert "tasks" task
225+
tid <- liftLIO $ withTaskPolicyModule $ insert "tasks" task -- todo: move to policy
219226
mlpdoc <- liftLIO $ withTaskPolicyModule $ findOne $ select [ "_id" -: pid ] "projects"
220227
pdoc <- liftLIO $ unlabel $ fromJust mlpdoc
221228
let curTasks = "tasks" `at` pdoc
@@ -353,21 +360,6 @@ addTasks memDocs taskId = do
353360
save "users" newDoc
354361
addTasks (tail memDocs) taskId
355362

356-
-- Modifies the database by adding the second argument pId to each user document's "projects" field
357-
addProjects :: [HsonDocument] -> ObjectId -> DBAction ()
358-
addProjects memDocs pId = do
359-
if memDocs == []
360-
then return ()
361-
else do
362-
let doc = head memDocs
363-
let curProjects = "projects" `at` doc
364-
if (pId `elem` curProjects) then addProjects (tail memDocs) pId
365-
else do
366-
let newProjects = pId:curProjects
367-
let newDoc = merge ["projects" -: newProjects] doc
368-
save "users" newDoc
369-
addProjects (tail memDocs) pId
370-
371363
-- Modifies the database by removing the second argument proj from each uer document's "projects" field
372364
removeProj :: [UserName] -> ObjectId -> DBAction ()
373365
removeProj users proj = do
@@ -383,6 +375,18 @@ removeProj users proj = do
383375
liftLIO $ withTaskPolicyModule $ save "users" newdoc
384376
removeProj (tail users) proj
385377

378+
-- Returns a list of all labeled documents in the database satisfying the Query
379+
findAllL :: Query -> DBAction [LabeledHsonDocument]
380+
findAllL q = do
381+
cur <- find q
382+
getAll cur []
383+
where getAll cur list = do
384+
mldoc <- next cur
385+
case mldoc of
386+
Nothing -> return list
387+
Just ldoc -> do
388+
getAll cur (list ++ [ldoc])
389+
386390
-- Returns a list of all documents in the database satisfying the Query
387391
findAll :: Query -> DBAction [HsonDocument]
388392
findAll q = do

‎Task/Policy.hs‎

Lines changed: 59 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -3,16 +3,18 @@
33
module Task.Policy (
44
TaskPolicyModule
55
, withTaskPolicyModule
6+
, addProjects
67
) where
78

89
import Data.Typeable
9-
10+
import Debug.Trace
1011
import LIO
1112
import LIO.DCLabel
1213
import Hails.Database
1314
import Hails.PolicyModule
1415
import Hails.PolicyModule.DSL
1516
import Hails.Web.User
17+
import Data.Maybe
1618
import qualified Data.List as List
1719
import qualified Data.Text as T
1820

@@ -37,18 +39,22 @@ instance PolicyModule TaskPolicyModule where
3739
readers ==> unrestricted
3840
writers ==> unrestricted
3941
field "name" key
40-
field "_id" key
4142
collection "tasks" $ do
4243
access $ do
4344
readers ==> unrestricted
4445
writers ==> unrestricted
4546
clearance $ do
4647
secrecy ==> this
4748
integrity ==> unrestricted
48-
document $ \_ -> do
49+
document $ \doc -> do
50+
--let pid = "project" `at` doc
51+
--mlpdoc <- findOne $ select ["_id" -: pid] "projects"
52+
--let pdoc = unlabel $ fromJust mlpdoc
53+
--let members = "members" `at` pdoc
54+
--readers ==> List.foldl' (\/) this members
55+
--writers ==> List.foldl' (\/) this members
4956
readers ==> unrestricted
5057
writers ==> unrestricted
51-
field "_id" key
5258
collection "projects" $ do
5359
access $ do
5460
readers ==> unrestricted
@@ -57,10 +63,11 @@ instance PolicyModule TaskPolicyModule where
5763
secrecy ==> this
5864
integrity ==> unrestricted
5965
document $ \doc -> do
60-
let members = map T.unpack ("members" `at` doc :: [UserName])
61-
readers ==> List.foldl' (\/) this members
66+
--let members = map T.unpack ("members" `at` doc :: [UserName])
67+
--readers ==> List.foldl' (\/) this members
68+
--writers ==> List.foldl' (\/) this members
69+
readers ==> unrestricted
6270
writers ==> unrestricted
63-
field "_id" key
6471
collection "comments" $ do
6572
access $ do
6673
readers ==> unrestricted
@@ -78,5 +85,49 @@ instance PolicyModule TaskPolicyModule where
7885
withTaskPolicyModule :: DBAction a -> DC a
7986
withTaskPolicyModule act = withPolicyModule (\(_ :: TaskPolicyModule) -> act)
8087

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

82-
111+
{-
112+
-- Modifies the database by adding the second argument taskId to each user document's "tasks" field
113+
addTasks :: [LabeledHsonDocument] -> ObjectId -> DBAction ()
114+
addTasks lmemdocs tid = liftLIO $ withPolicyModule $ \(TaskPolicyModuleTCB mypriv) -> do
115+
if (length lmemdocs == 0)
116+
then return ()
117+
else do
118+
mltask <- findOne $ select ["_id" -: tid] "tasks"
119+
task <- unlabel $ fromJust mltask
120+
let pid = "project" `at` task
121+
mlproj <- findOne $ select ["_id" -: pid] "projects"
122+
let lproj = fromJust mlproj
123+
if (labelOf (head lmemdocs)) `canFlowTo` (labelOf lproj)
124+
then do
125+
memDocs <- mapM (liftLIO . unlabel) lmemdocs
126+
let doc = head memDocs
127+
let curTasks = "tasks" `at` doc
128+
let newTasks = taskId:curTasks
129+
let newDoc = merge ["tasks" -: newTasks] doc
130+
saveP mypriv "users" newDoc
131+
addTasks (tail memDocs) taskId
132+
else trace "addProjects: label was not high enough" $ return ()
133+
-}

0 commit comments

Comments
 (0)