From 14ccdb1e3512d570351ae909c098834e9c0fd81f Mon Sep 17 00:00:00 2001 From: SJost Date: Wed, 29 Nov 2017 17:26:32 +0100 Subject: [PATCH] Bugfix: Infinite Loop in Authorization Code; Stubs for Exercise Sheet; Fixed several compiler warnings --- routes | 9 ++++- src/Application.hs | 4 +- src/Foundation.hs | 11 +++--- src/Handler/Course.hs | 3 +- src/Handler/Home.hs | 12 +++--- src/Handler/Sheet.hs | 64 ++++++++++++++++++++++++++++++++ src/Handler/Submission.hs | 2 +- src/Handler/Utils/Table.hs | 14 +++---- templates/submission-list.hamlet | 2 +- 9 files changed, 97 insertions(+), 24 deletions(-) create mode 100644 src/Handler/Sheet.hs diff --git a/routes b/routes index de7b39e66..4085fd935 100644 --- a/routes +++ b/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 diff --git a/src/Application.hs b/src/Application.hs index 3ab73b289..403bf072c 100644 --- a/src/Application.hs +++ b/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. diff --git a/src/Foundation.hs b/src/Foundation.hs index 14a30a7af..ae0b849bb 100644 --- a/src/Foundation.hs +++ b/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) [] - return $ if (not $ null rights) + adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] + 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) [] - return $ if (not $ null rights) + lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) [] + return $ if (not $ null lecrights) then Authorized else Unauthorized "No lecturer access" diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 57e740a7f..56190ce78 100644 --- a/src/Handler/Course.hs +++ b/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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index d0b97fca0..9054a0726 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -12,16 +12,16 @@ module Handler.Home where import Import import Handler.Utils -import Data.Time -import qualified Data.Text as T -import Yesod.Form.Bootstrap3 +-- import Data.Time +-- import qualified Data.Text as T +-- import Yesod.Form.Bootstrap3 import Web.PathPieces (showToPathPiece, readFromPathPiece) -import Colonnade -import Yesod.Colonnade +-- import 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 diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs new file mode 100644 index 000000000..a3f3afa4d --- /dev/null +++ b/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") +-} diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index f9aec1702..87e760998 100644 --- a/src/Handler/Submission.hs +++ b/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") diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index 6679f2f8b..786bb6357 100644 --- a/src/Handler/Utils/Table.hs +++ b/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 - -> Just <$> (lift $ fromExternal externalId) + _ | extId `elem` extIds + -> Just <$> (lift $ fromExternal extId) | otherwise -> return Nothing - view _ name attrs val _ = do + view _ name attributes val _ = do [whamlet|