From 59423832e6a3dafd64b4ce2e7e505e7c47c1567b Mon Sep 17 00:00:00 2001
From: SJost <jost@tcs.ifi.lmu.de>
Date: Fri, 25 May 2018 11:54:27 +0200
Subject: [PATCH] evalAccess is complete now

---
 src/Foundation.hs | 68 +++++++++++++++++++++++++++++++++--------------
 1 file changed, 48 insertions(+), 20 deletions(-)

diff --git a/src/Foundation.hs b/src/Foundation.hs
index 10cded5a3..5edc7f765 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -102,7 +102,6 @@ data AccessPredicate
   | APHandler  (Route UniWorX -> Handler UniWorX AuthResult)
   | APDB       (Route UniWorX -> YesodDB UniWorX AuthResult)
 
-
 orAR, andAR :: (forall msg. RenderMessage UniWorX msg => msg -> Text) ->  AuthResult -> AuthResult -> AuthResult
 orAR  _  Authorized _ = Authorized
 orAR  _  _ Authorized = Authorized
@@ -123,18 +122,37 @@ andAP = liftAR andAR
 
 liftAR :: ((forall msg. RenderMessage UniWorX msg => msg -> Text) ->  AuthResult -> AuthResult -> AuthResult)
           -> AccessPredicate -> AccessPredicate -> AccessPredicate
-liftAR op (APPure f)    (APPure g)    = APPure    $ \r -> op <$> ask              <*> f r <*> g r
-liftAR op (APHandler f) (APHandler g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r
-liftAR op (APDB  f)     (APDB  g)     = APDB      $ \r -> op <$> getMessageRender <*> f r <*> g r
-liftAR op apf@(APPure _)  apg@(APHandler _) = liftAR op apg apf
-liftAR op apf (APPure    g) = liftAR op apf (APHandler $ \r -> runReader (g r) <$> getMessageRender)
-liftAR op apf (APHandler g) = liftAR op apf (APDB      $ lift   . g)
-liftAR op apf apg = liftAR op apg apf
+-- Ensure to first evaluate Pure conditions, then Handler before DB
+liftAR op (APPure    f) (APPure     g) = APPure    $ \r -> op <$> ask              <*> f r <*> g r
+liftAR op (APHandler f) (APHandler  g) = APHandler $ \r -> op <$> getMessageRender <*> f r <*> g r
+liftAR op (APDB      f) (APDB       g) = APDB      $ \r -> op <$> getMessageRender <*> f r <*> g r
+liftAR op (APPure    f) apg  = liftAR op (APHandler $ \r -> runReader (f r) <$> getMessageRender) apg
+liftAR op apf           apg@(APPure _)    = liftAR op apg apf
+liftAR op (APHandler f) apdb = liftAR op (APDB      $ lift . f) apdb
+liftAR op apdb          apg@(APHandler _) = liftAR op apg apdb
 
 
 trueAP,falseAP :: AccessPredicate
 trueAP  = APPure . const $ return Authorized
 falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) <$> ask
+-- TODO: I believe falseAP := adminAP
+
+adminAP :: AccessPredicate
+adminAP = APDB $ \case
+    CourseR tid csh -> maybeT (unauthorizedI MsgUnauthorizedSchoolAdmin) $ do
+        authId <- lift requireAuthId
+        -- SQL JOIN:
+        Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
+        -- get schoolId for cid
+        -- check adminrights for schoolId
+        undefined -- CONTINUE HERE
+
+    _other -> do
+        authId <- lift requireAuthId
+        adrights <- selectFirst [UserAdminUser ==. authId]
+        case adright of
+          (Just _) -> return Authorized
+          Nothing  -> unauthorizedI $ MsgUnauthorized
 
 knownTags :: Map (CI Text) AccessPredicate
 knownTags =
@@ -160,22 +178,32 @@ knownTags =
    -- TODO: Continue here!!!
   ]
 
-declareWrapped [d|
-    newtype DNF a = DNF (Set (Set a)) -- disjunctive Normalform
-  |]
 
+tag2ap :: Text -> AccessPredicate
+tag2ap t = case Map.lookup t knownTags of
+    (Just ap) -> ap
+    Nothing   -> APHandler $ \r -> do --TODO: can this be pure like falseAP?
+      $logWarnS "AccessControl" ("route tag unknown for access control")
+      unauthorizedI $ MsgUnauthorized
 
-getAccess :: Route UniWorX -> DNF AccessPredicate
-getAccess r = DNF $ Set.map attrsAND attrsOR
- where
-    attrsOR  = routeAttrs r
-    attrsAND = Set.fromList . Map.elems . Map.restrictKeys knownTags . Set.fromList . splitOn "AND"
+route2ap :: Route UniWorX -> AccessPredicate
+route2ap r = Set.foldr orAP adminAP attrsAND
+  where
+    attrsAND = Set.map splitAnd $ routeAttrs r
+    splitAND = foldr1 andAP . map tag2access . splitOn "AND"
 
-evalAccess :: Route -> DB Authorized
-evalAccess = undefined -- TODO -- ^ uses `getAccess`
+evalAccessDB :: Route -> DB Authorized
+evalAccessDB r = case getAccess r of
+  (APPure    p) -> lift $ runReader (p r) <$> getMessageRender
+  (APHandler p) -> lift $ p r
+  (APDB      p) -> p r
+
+evalAccess :: Route -> Handler UniWorX Authorized
+evalAccess r = case getAccess r of
+  (APPure    p) -> runReader (p r) <$> getMessageRender
+  (APHandler p) -> p r
+  (APDB      p) -> runDB $ p r
 
-evalAccess' :: Route -> Handler UniWorX Authorized
-evalAccess = undefined -- TODO -- ^ uses `getAccess`
 
 -- TODO: isAuthorized = evalAccess'