From 8d221600d3565a315c01123143b75dde7a5a9586 Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 19 Feb 2018 17:58:55 +0100 Subject: [PATCH] TermIdentifier -> TermId in routes --- .gitignore | 3 +- models | 4 +- routes | 20 ++-- src/Foundation.hs | 20 +++- src/Handler/Course.hs | 42 ++++---- src/Handler/Sheet.hs | 215 +++++++++++++++++++++++++++++++++++--- src/Handler/Submission.hs | 2 +- src/Handler/Term.hs | 14 +-- src/Handler/Utils/Term.hs | 7 +- 9 files changed, 266 insertions(+), 61 deletions(-) diff --git a/.gitignore b/.gitignore index f4c2d62c0..6338c36b4 100644 --- a/.gitignore +++ b/.gitignore @@ -26,4 +26,5 @@ uniworx.nix .dbsettings.yml *.kate-swp src/Handler/Assist.bak -src/Handler/Course.SnapCustom.hs \ No newline at end of file +src/Handler/Course.SnapCustom.hs +*.orig diff --git a/models b/models index fa564bc26..bb40183d3 100644 --- a/models +++ b/models @@ -37,8 +37,8 @@ Term json lectureStart Day lectureEnd Day active Bool - Primary name - deriving Show + Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier } + deriving Show -- type TermId = Key Term School json name Text shorthand Text diff --git a/routes b/routes index 835f50270..8c074546b 100644 --- a/routes +++ b/routes @@ -6,22 +6,24 @@ / HomeR GET POST /profile ProfileR GET +/users UsersR GET /term TermShowR GET /term/edit TermEditR GET POST -/term/#TermIdentifier/edit TermEditExistR GET +/term/#TermId/edit TermEditExistR GET /course/ CourseListR GET !/course/new CourseEditR GET POST -!/course/#TermIdentifier CourseListTermR GET -/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 +!/course/#TermId CourseListTermR GET +/course/#TermId/#Text/edit CourseEditExistR GET +/course/#TermId/#Text/show CourseShowR GET POST +/course/#TermId/#Text/sheet/ SheetListR GET +/course/#TermId/#Text/sheet/#Text/show SheetShowR GET +/course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR GET +/course/#TermId/#Text/sheet/new SheetNewR GET POST +/course/#TermId/#Text/sheet/#SheetId/edit SheetEditR GET POST +/course/#TermId/#Text/sheet/#SheetId/delete SheetDelR GET POST /submission SubmissionListR GET POST /submission/#CryptoUUIDSubmission SubmissionR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index fde407991..edd590f15 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -75,7 +75,7 @@ data UniWorX = UniWorX -- -- This function also generates the following type synonyms: -- type Handler = HandlerT UniWorX IO --- type Widget = WidgetT UniWorX IO () +-- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") data MenuItem = MenuItem @@ -178,17 +178,19 @@ instance Yesod UniWorX where makeLogger = return . appLogger isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult +isAuthorizedDB UsersR _ = adminAccess Nothing isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseEditR _ = lecturerAccess Nothing -isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c) +isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseEditExistIDR cID) _ = do courseId <- decrypt cID courseLecturerAccess courseId -isAuthorizedDB route isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop! +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 @@ -240,11 +242,14 @@ instance YesodBreadcrumbs UniWorX where breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb CourseListR = return ("Kurs", Just HomeR) - breadcrumb (CourseListTermR term) = return (termToText term, Just TermShowR) + breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term) breadcrumb CourseEditR = return ("Neu", Just CourseListR) breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR) + breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh) + breadcrumb (SheetShowR tid csh _shn) = return ("Übungen", Just $ SheetListR tid csh) + breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) @@ -266,6 +271,11 @@ defaultLinks = -- Define the menu items of the header. , menuItemRoute = CourseListR , menuItemAccessCallback = return True } + , NavbarRight $ MenuItem + { menuItemLabel = "Users" + , menuItemRoute = UsersR + , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False + } , NavbarRight $ MenuItem { menuItemLabel = "Profile" , menuItemRoute = ProfileR @@ -384,7 +394,7 @@ instance YesodAuth UniWorX where authHttpManager = getHttpManager ldapConfig :: UniWorX -> LDAPConfig -ldapConfig app@(appSettings -> settings) = LDAPConfig +ldapConfig _app@(appSettings -> settings) = LDAPConfig { usernameFilter = \u -> principalName <> "=" <> u , identifierModifier , ldapUri = appLDAPURI settings diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index aaf4f97c5..e54e65178 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -26,20 +26,20 @@ import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent getCourseListR = redirect TermShowR -getCourseListTermR :: TermIdentifier -> Handler Html +getCourseListTermR :: TermId -> Handler Html getCourseListTermR tidini = do (term,courses) <- runDB $ (,) - <$> get (TermKey tidini) - <*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand] + <$> get tidini + <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand] when (isNothing term) $ do - addMessage "warning" [shamlet| Semester #{termToText tidini} nicht gefunden. |] + addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |] redirect TermShowR -- TODO: several runDBs per TableRow are probably too inefficient! let colonnadeTerms = mconcat [ headed "Kürzel" $ (\ckv -> let c = entityVal ckv shd = courseShorthand c - tid = unTermKey $ courseTermId c + tid = courseTermId c in [whamlet| #{shd} |] ) -- , headed "Institut" $ [shamlet| #{course} |] , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal @@ -52,7 +52,7 @@ getCourseListTermR tidini = do , headed " " $ (\ckv -> let c = entityVal ckv shd = courseShorthand c - tid = unTermKey $ courseTermId c + tid = courseTermId c in do adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else "" @@ -76,11 +76,11 @@ getCourseListTermR tidini = do linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) -getCourseShowR :: TermIdentifier -> Text -> Handler Html +getCourseShowR :: TermId -> Text -> Handler Html getCourseShowR tid csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do - courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh + courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh dependent <- (,,) <$> get (courseSchoolId course) -- join <*> count [CourseParticipantCourseId ==. cid] -- join @@ -93,7 +93,7 @@ getCourseShowR tid csh = do let course = entityVal courseEnt (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered defaultLayout $ do - setTitle $ [shamlet| #{termToText tid} - #{csh}|] + setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") registerButton :: Bool -> Form () @@ -104,11 +104,11 @@ registerButton registered = msg = if registered then "Abmelden" else "Anmelden" regMsg = msg :: BootstrapSubmit Text -postCourseShowR :: TermIdentifier -> Text -> Handler Html +postCourseShowR :: TermId -> Text -> Handler Html postCourseShowR tid csh = do aid <- requireAuthId (cid, registered) <- runDB $ do - (Entity cid _) <- getBy404 $ CourseTermShort (TermKey tid) csh + (Entity cid _) <- getBy404 $ CourseTermShort tid csh registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid) return (cid, registered) ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered @@ -133,9 +133,9 @@ getCourseEditR = do postCourseEditR :: Handler Html postCourseEditR = courseEditHandler Nothing -getCourseEditExistR :: TermIdentifier -> Text -> Handler Html +getCourseEditExistR :: TermId -> Text -> Handler Html getCourseEditExistR tid csh = do - course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh + course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html @@ -155,12 +155,12 @@ courseEditHandler course = do | fAct == formActionDelete , Just cid <- cfCourseId res -> do runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|] redirect $ CourseListTermR $ cfTerm res | fAct == formActionSave , Just cid <- cfCourseId res -> do - let tid = TermKey $ cfTerm res + let tid = cfTerm res actTime <- liftIO getCurrentTime updateokay <- runDB $ do exists <- getBy $ CourseTermShort tid $ cfShort res @@ -179,7 +179,7 @@ courseEditHandler course = do , CourseChanged =. actTime ] return upokay - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res if updateokay then do addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] @@ -195,7 +195,7 @@ courseEditHandler course = do , courseDescription = cfDesc res , courseLinkExternal = cfLink res , courseShorthand = cfShort res - , courseTermId = TermKey $ cfTerm res + , courseTermId = cfTerm res , courseSchoolId = cfSchool res , courseCapacity = cfCapacity res , courseHasRegistration = cfHasReg res @@ -209,11 +209,11 @@ courseEditHandler course = do case insertOkay of (Just cid) -> do runDB $ insert_ $ Lecturer aid cid - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|] redirect $ CourseListTermR $ cfTerm res Nothing -> do - let cti = termToText $ cfTerm res + let cti = toPathPiece $ cfTerm res addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|] (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." _other -> return () @@ -231,7 +231,7 @@ data CourseForm = CourseForm , cfDesc :: Maybe Html , cfLink :: Maybe Text , cfShort :: Text - , cfTerm :: TermIdentifier + , cfTerm :: TermId , cfSchool :: SchoolId , cfCapacity :: Maybe Int , cfHasReg :: Bool @@ -250,7 +250,7 @@ courseToForm cEntity = CourseForm , cfDesc = courseDescription course , cfLink = courseLinkExternal course , cfShort = courseShorthand course - , cfTerm = unTermKey $ courseTermId course + , cfTerm = courseTermId course , cfSchool = courseSchoolId course , cfCapacity = courseCapacity course , cfHasReg = courseHasRegistration course diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index a3f3afa4d..28bacf0b3 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -1,3 +1,6 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -8,17 +11,23 @@ module Handler.Sheet where import Import import Handler.Utils +import Handler.Utils.Zip + -- import Data.Time --- import qualified Data.Text as T +import qualified Data.Text as T -- import Data.Function ((&)) --- import Yesod.Form.Bootstrap3 +import Yesod.Form.Bootstrap3 -- --- import Colonnade hiding (fromMaybe) --- import Yesod.Colonnade +import Colonnade -- hiding (fromMaybe) +import Yesod.Colonnade -- --- import qualified Data.UUID.Cryptographic as UUID +import qualified Data.UUID.Cryptographic as UUID +import qualified Data.Conduit.List as C +import qualified Database.Esqueleto as E + +import Network.Mime {- * Implement Handlers @@ -26,23 +35,203 @@ import Handler.Utils * Implement Access in Foundation -} +data SheetForm = SheetForm + { sfName :: Text + , sfComment :: Maybe Html + , sfType :: SheetType + , sfMarkingText :: Maybe Html + , sfActiveFrom :: UTCTime + , sfActiveTo :: UTCTime + , sfSheetF :: Maybe FileInfo + , sfHintFrom :: Maybe UTCTime + , sfHintF :: Maybe FileInfo + , sfSolutionFrom :: Maybe UTCTime + , sfSolutionF :: Maybe FileInfo + } -getSheetListR :: TermIdentifier -> Text -> Handler Html -getSheetListR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO -getSheetNewR :: TermIdentifier -> Text -> Handler Html -getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO +makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm +makeSheetForm cid template = identForm FIDsheet $ \html -> do + -- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :( + -- Erstmal nur mit ZIP arbeiten + (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm + <$> areq textField (fsb "Name") (sfName <$> template) + <*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template) + <*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template) + --TODO: SICHTBARKEIT hinzunehmen + <*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template) + <*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template) + <*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template) + <*> fileAFormOpt (fsb "Aufgaben") + <*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template) + <*> fileAFormOpt (fsb "Hinweis") + <*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template) + <*> fileAFormOpt (fsb "Lösung") + return $ case result of + FormSuccess sheetResult + | errorMsgs <- validateSheet sheetResult + , not $ null errorMsgs -> + (FormFailure errorMsgs, + [whamlet| +
+

Fehler: +