convenience functions for authorisation

src/Foundation.hs

@@ -78,6 +78,8 @@ data UniWorX = UniWorX
 -- type Widget  = WidgetT  UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
+type DB a = YesodDB UniWorX a
+
 data MenuItem = MenuItem
     { menuItemLabel :: Text
     , menuItemRoute :: Route UniWorX
@@ -236,7 +238,7 @@ lecturerAccess :: Maybe SchoolId
                -> YesodDB UniWorX AuthResult
 lecturerAccess school = do
   authId <- lift requireAuthId
-  lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) []  
+  lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) []
   return $ if (not $ null lecrights)
     then Authorized
     else Unauthorized "No lecturer access"
@@ -244,10 +246,28 @@ lecturerAccess school = do
 courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult
 courseLecturerAccess courseId = do
   authId <- lift requireAuthId
-  users <- map (lecturerUserId . entityVal ) <$> selectList [ LecturerCourseId ==. courseId ] []
-  return $ case authId `elem` users of
-    True  -> Authorized
-    False -> Unauthorized "No lecturer access for this course"
+  lecturer <- getBy $ UniqueLecturer authId courseId
+  return $ case lecturer of
+    (Just _) -> Authorized
+    Nothing  -> Unauthorized "Not a lecturer for this course"
+
+courseCorrectorAccess :: CourseId -> YesodDB UniWorX AuthResult
+courseCorrectorAccess courseId = do
+  authId <- lift requireAuthId
+  participation <- getBy $ UniqueCorrector authId courseId
+  return $ case participation of
+    (Just _) -> Authorized
+    Nothing  -> Unauthorized "Not a corrector for this course"
+
+courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult
+courseParticipantAccess courseId = do
+  authId <- lift requireAuthId
+  participation <- getBy $ UniqueCourseParticipant courseId authId
+  return $ case participation of
+    (Just _) -> Authorized
+    Nothing  -> Unauthorized "Not a participant for this course"
+
+
 
 isAuthorizedDB' :: Route UniWorX -> Bool -> YesodDB UniWorX Bool
 isAuthorizedDB' route isWrite = (== Authorized) <$> isAuthorizedDB route isWrite

src/Handler/Sheet.hs

@@ -137,17 +137,25 @@ getSheetList courseEnt = do
         submissions <- count sheetsub
         rated       <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
         return (sid, sheet, (submissions, rated))
-  let colSheets = mconcat
+  let colBase = mconcat
         [ headed "Blatt"       $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ SheetShowR tid csh (sheetName sheet)
         , headed "Abgabe ab"   $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
         , headed "Abgabe bis"  $ toWgt . formatTimeGerWD . sheetActiveTo   . snd3
         , headed "Bewertung"   $ toWgt . show . sheetType . snd3
         , headed "Korrigiert"  $ toWgt . snd . trd3
         , headed "Eingereicht" $ toWgt . fst . trd3
-        -- TODO: only show edit button for allowed course assistants
-        , headed ""            $ \s -> linkButton "Edit"   BCLink $ SheetEditR tid csh $ sheetName $ snd3 s
+        ]
+  let colAdmin = mconcat -- only show edit button for allowed course assistants
+        [ headed ""            $ \s -> linkButton "Edit"   BCLink $ SheetEditR tid csh $ sheetName $ snd3 s
         , headed ""            $ \s -> linkButton "Delete" BCLink $ SheetDelR  tid csh $ sheetName $ snd3 s
         ]
+  showAdmin <- case sheets of
+    ((_,firstSheet,_):_) ->
+      (Authorized ==) <$> isAuthorized (SheetEditR tid csh $ sheetName firstSheet) False
+    _otherwise   -> return False
+  let colSheets = if showAdmin
+        then colBase `mappend` colAdmin
+        else colBase
   let pageActions =
         [ NavbarLeft $ MenuItem
           { menuItemLabel = "Neues Übungsblatt"

src/Handler/Utils/Form.hs

@@ -201,43 +201,7 @@ buttonForm csrf = do
     accResult' FormMissing _ = FormMissing
     accResult' (FormFailure errs) _ = FormFailure errs
 
-  
----------------------------------------
--- Buttons (old version, deprecated) --
----------------------------------------
 
-formBtnSave  :: (Text,Text,Text)
-formBtnSave   = ("save"  ,"Speichern"  ,"btn-primary")
-
-formBtnAbort :: (Text,Text,Text)
-formBtnAbort  = ("abort" ,"Abbrechen"  ,"btn-default")
-
-formBtnDelete ::(Text,Text,Text)
-formBtnDelete = ("delete","Löschen"    ,"btn-warning")
-
-formActionSave :: Maybe Text
-formActionSave   = Just $ fst3 formBtnSave
-
-formActionAbort :: Maybe Text
-formActionAbort  = Just $ fst3 formBtnAbort
-
-formActionDelete :: Maybe Text
-formActionDelete = Just $ fst3 formBtnDelete
-
-defaultFormActions :: [(Text,Text,Text)]
-defaultFormActions =  [ formBtnDelete
-                      , formBtnAbort
-                      , formBtnSave
-                      ]
-
--- Post-Buttons
-postButtonForm :: Text -> Form ()
-postButtonForm lblId = identifyForm lblId buttonF
-  where
-    buttonF = renderAForm FormStandard $ pure () <* bootstrapSubmit bProps
-    bProps :: BootstrapSubmit Text
-    bProps = fromString $ unpack lblId
-    
     
 ------------
 -- Fields --