Bugfix: Infinite Loop in Authorization Code; Stubs for Exercise Sheet; Fixed several compiler warnings

routes

@@ -4,10 +4,9 @@
 /favicon.ico FaviconR GET
 /robots.txt RobotsR GET
 
-/ HomeR GET POST
+/        HomeR    GET POST
 /profile ProfileR GET
 
-
 /term                       TermShowR         GET 
 /term/edit                  TermEditR         GET POST
 /term/#TermIdentifier/edit  TermEditExistR    GET
@@ -18,6 +17,12 @@
 /course/#TermIdentifier/#Text/edit CourseEditExistR GET
 /course/#TermIdentifier/#Text/show CourseShowR GET POST
 
+/course/#TermIdentifier/#Text/sheet/              SheetListR  GET
+/course/#TermIdentifier/#Text/sheet/new           SheetNewR   GET
+/course/#TermIdentifier/#Text/sheet/#SheetId/show SheetShowR  GET
+/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR  GET
+
+
 /submission                 SubmissionListR GET POST
 /submission/#CryptoUUIDSubmission SubmissionR GET POST
 /submissions.zip SubmissionDownloadMultiArchiveR POST

src/Application.hs

@@ -38,14 +38,16 @@ import System.Log.FastLogger                (defaultBufSize, newStdoutLoggerSet,
                                              toLogStr)
 
 -- Import all relevant handler modules here.
--- Don't forget to add new modules to your cabal file! 
+-- (HPack takes care to add new modules to our cabal file nowadays.)
 import Handler.Common
 import Handler.Home
 import Handler.Profile
 import Handler.Term
 import Handler.Course
+import Handler.Sheet
 import Handler.Submission
 
+
 -- This line actually creates our YesodDispatch instance. It is the second half
 -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
 -- comments there for more details.

src/Foundation.hs

@@ -135,6 +135,7 @@ instance Yesod UniWorX where
     isAuthorized (CourseShowR _ _)   _ = return Authorized
     isAuthorized  SubmissionListR    _ = isAuthenticated
     isAuthorized  SubmissionDownloadMultiArchiveR _ = isAuthenticated
+--     isAuthorized  TestR        _ = return Authorized
     isAuthorized route isWrite = runDB $ isAuthorizedDB route isWrite
 
     -- This function creates static content files in the static folder
@@ -188,7 +189,7 @@ isAuthorizedDB (CourseEditExistIDR cID) _ = do
   cIDKey <- getsYesod appCryptoIDKey
   courseId <- UUID.decrypt cIDKey cID
   courseLecturerAccess courseId
-isAuthorizedDB route isWrite = lift $ isAuthorized route isWrite
+isAuthorizedDB route isWrite = return  $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
 
 submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult
 submissionAccess cID = do
@@ -206,8 +207,8 @@ adminAccess :: Maybe SchoolId -- ^ If @Just@, matched exactly against 'userAdmin
             -> YesodDB UniWorX AuthResult
 adminAccess school = do    
   authId <- lift requireAuthId
-  rights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) []  
+  adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) []  
-  return $ if (not $ null rights) 
+  return $ if (not $ null adrights) 
     then Authorized
     else Unauthorized "No admin access"
 
@@ -215,8 +216,8 @@ lecturerAccess :: Maybe SchoolId
                -> YesodDB UniWorX AuthResult
 lecturerAccess school = do
   authId <- lift requireAuthId
-  rights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) []  
+  lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) []  
-  return $ if (not $ null rights)
+  return $ if (not $ null lecrights)
     then Authorized
     else Unauthorized "No lecturer access"
 

src/Handler/Course.hs

@@ -12,7 +12,7 @@ module Handler.Course where
 import Import 
 import Handler.Utils
 
-import Data.Time
+-- import Data.Time
 import qualified Data.Text as T
 import Data.Function ((&))
 import Yesod.Form.Bootstrap3 
@@ -121,6 +121,7 @@ postCourseShowR tid csh = do
           actTime <- liftIO $ getCurrentTime
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
           when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
+    (_other) -> return () -- TODO check this!
   -- redirect or not?! I guess not, since we want GET now
   getCourseShowR tid csh  
   

src/Handler/Home.hs

@@ -12,16 +12,16 @@ module Handler.Home where
 import Import 
 import Handler.Utils
 
-import Data.Time
+-- import Data.Time
-import qualified Data.Text as T
+-- import qualified Data.Text as T
-import Yesod.Form.Bootstrap3 
+-- import Yesod.Form.Bootstrap3 
  
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
-import Colonnade
+-- import Colonnade
-import Yesod.Colonnade
+-- import Yesod.Colonnade
 
-import qualified Data.UUID.Cryptographic as UUID
+-- import qualified Data.UUID.Cryptographic as UUID
 
 -- BEGIN - Buttons needed only here
 data CreateButton = CreateMath | CreateInf  -- Dummy for Example

src/Handler/Sheet.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module Handler.Sheet where
+
+import Import 
+import Handler.Utils
+
+-- import Data.Time
+-- import qualified Data.Text as T
+-- import Data.Function ((&))
+-- import Yesod.Form.Bootstrap3 
+-- 
+-- import Colonnade hiding (fromMaybe)
+-- import Yesod.Colonnade 
+-- 
+-- import qualified Data.UUID.Cryptographic as UUID
+
+
+{-
+  * Implement Handlers
+  * Implement Breadcrumbs in Foundation 
+  * Implement Access in Foundation
+-}
+
+
+getSheetListR :: TermIdentifier -> Text -> Handler Html
+getSheetListR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+
+getSheetNewR :: TermIdentifier -> Text -> Handler Html
+getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+
+getSheetShowR :: TermIdentifier -> Text -> SheetId -> Handler Html
+getSheetShowR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+
+getSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
+getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
+
+
+
+{-
+getCourseShowR :: TermIdentifier -> Text -> Handler Html
+getCourseShowR tid csh = do
+  mbAid <- maybeAuthId
+  (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
+      courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
+      dependent <- (,,) 
+          <$> get (courseSchoolId course)               -- join
+          <*> count [CourseParticipantCourseId ==. cid] -- join 
+          <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
+                Nothing -> return False
+                (Just aid) -> do
+                                regL <- getBy (UniqueCourseParticipant cid aid)
+                                return $ isJust regL)
+      return $ (courseEnt,dependent)
+  let course = entityVal courseEnt  
+  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered      
+  defaultLayout $ do
+    setTitle $ [shamlet| #{termToText tid} - #{csh}|]
+    $(widgetFile "course")
+-}    

src/Handler/Submission.hs

@@ -115,7 +115,7 @@ postSubmissionListR = do
                   
         runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= void sinkSubmissions
  
-  (submissionTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable
+  (subTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable
 
   defaultLayout $(widgetFile "submission-list")
 

src/Handler/Utils/Table.hs

@@ -54,26 +54,26 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
   externalIds <- mapM (lift . toExternal) tdata
 
   let
-    checkbox externalId = Field parse view UrlEncoded
+    checkbox extId = Field parse view UrlEncoded
       where
         parse [] _ = return $ Right Nothing
         parse optlist _ = runExceptT $ do
-          externalIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
+          extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
           case () of
-            _ | externalId `elem` externalIds
+            _ | extId `elem` extIds
-                -> Just <$> (lift $ fromExternal externalId)
+                -> Just <$> (lift $ fromExternal extId)
               | otherwise
                 -> return Nothing
 
-        view _ name attrs val _ = do
+        view _ name attributes val _ = do
           [whamlet|
             <label style="display: block">
-              <input type=checkbox name=#{name} value=#{toPathPiece externalId} *{attrs} :isRight val:checked>
+              <input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
           |]
 
   selectionIdent <- newFormIdent
 
-  (selectionResults, selectionBoxes) <- fmap unzip . forM externalIds $ \id -> mopt (checkbox id) ("" { fsName = Just selectionIdent }) Nothing
+  (selectionResults, selectionBoxes) <- fmap unzip . forM externalIds $ \ident -> mopt (checkbox ident) ("" { fsName = Just selectionIdent }) Nothing
   
   let
     selColonnade :: Colonnade Headed Int (Cell UniWorX)

templates/submission-list.hamlet

@@ -2,5 +2,5 @@
   ^{uploadWidget}
 
 <form method=POST enctype=#{selectEncoding} target=_blank action=@{SubmissionDownloadMultiArchiveR}>
-  ^{submissionTable}
+  ^{subTable}
   <button .btn .btn-default type=submit >Markierte herunterladen