diff --git a/FragenSJ.txt b/FragenSJ.txt index 974d52943..c2219f2c1 100644 --- a/FragenSJ.txt +++ b/FragenSJ.txt @@ -18,11 +18,10 @@ - i18n der Links -> MenuItems verwenden wie bisher Page Titles -> setTitleI - Buttons? + Buttons? -> Kann leicht geändert werden! Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel? -** Page pageActions - - Berechtigungen prüfen? +** Page pageActions - Berechtigungen prüfen? => Eigener Constructor statt NavbarLeft/Right?! diff --git a/fill-db.hs b/fill-db.hs index d90c8af28..dd8f42c62 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -87,19 +87,17 @@ main = db $ do , courseTermId = TermKey summer2018 , courseSchoolId = ifi , courseCapacity = Just 20 - , courseCreated = now - , courseChanged = now - , courseCreatedBy = gkleen - , courseChangedBy = gkleen , courseHasRegistration = True , courseRegisterFrom = Just now , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) } + insert_ $ CourseEdit jost now ffp void . insert $ DegreeCourse ifiBsc ffp void . insert $ DegreeCourse ifiMsc ffp void . insert $ Lecturer gkleen ffp - void . insert $ Corrector gkleen ffp (ByProportion 1) - void . insert $ Sheet ffp "Blatt 1" Nothing NotGraded Nothing now now Nothing Nothing now now gkleen gkleen + insert_ $ Corrector gkleen ffp (ByProportion 1) + sheetkey <- insert $ Sheet ffp "Blatt 1" Nothing NotGraded NoGroups Nothing Nothing now now Nothing Nothing + insert_ $ SheetEdit gkleen now sheetkey -- EIP eip <- insert Course { courseName = "Einführung in die Programmierung" @@ -109,14 +107,11 @@ main = db $ do , courseTermId = TermKey summer2017 , courseSchoolId = ifi , courseCapacity = Just 20 - , courseCreated = now - , courseChanged = now - , courseCreatedBy = fhamann - , courseChangedBy = fhamann , courseHasRegistration = False , courseRegisterFrom = Nothing , courseRegisterTo = Nothing } + insert_ $ CourseEdit fhamann now eip void . insert $ DegreeCourse ifiBsc eip void . insert $ DegreeCourse ifiMsc eip void . insert $ Lecturer fhamann eip @@ -129,14 +124,11 @@ main = db $ do , courseTermId = TermKey summer2018 , courseSchoolId = ifi , courseCapacity = Just 20 - , courseCreated = now - , courseChanged = now - , courseCreatedBy = fhamann - , courseChangedBy = fhamann , courseHasRegistration = True , courseRegisterFrom = Just now , courseRegisterTo = Just ((3600 * 24 * 60) `addUTCTime` now ) } + insert_ $ CourseEdit fhamann now ixd void . insert $ DegreeCourse ifiBsc ixd void . insert $ Lecturer fhamann ixd -- concept development @@ -148,14 +140,11 @@ main = db $ do , courseTermId = TermKey winter2017 , courseSchoolId = ifi , courseCapacity = Just 30 - , courseCreated = now - , courseChanged = now - , courseCreatedBy = fhamann - , courseChangedBy = fhamann , courseHasRegistration = False , courseRegisterFrom = Nothing , courseRegisterTo = Nothing } + insert_ $ CourseEdit fhamann now ux3 void . insert $ DegreeCourse ifiBsc ux3 void . insert $ Lecturer fhamann ux3 -- promo @@ -167,14 +156,11 @@ main = db $ do , courseTermId = TermKey summer2017 , courseSchoolId = ifi , courseCapacity = Just 50 - , courseCreated = now - , courseChanged = now - , courseCreatedBy = jost - , courseChangedBy = jost , courseHasRegistration = False , courseRegisterFrom = Nothing , courseRegisterTo = Nothing } + insert_ $ CourseEdit jost now pmo void . insert $ DegreeCourse ifiBsc pmo void . insert $ Lecturer jost pmo -- datenbanksysteme @@ -186,13 +172,11 @@ main = db $ do , courseTermId = TermKey summer2018 , courseSchoolId = ifi , courseCapacity = Just 50 - , courseCreated = now - , courseChanged = now - , courseCreatedBy = jost - , courseChangedBy = jost , courseHasRegistration = False , courseRegisterFrom = Nothing , courseRegisterTo = Nothing } + insert_ $ CourseEdit gkleen now dbs void . insert $ DegreeCourse ifiBsc dbs - void . insert $ Lecturer jost dbs + void . insert $ Lecturer gkleen dbs + void . insert $ Lecturer jost dbs diff --git a/models b/models index 5c73fe32e..ea24256b9 100644 --- a/models +++ b/models @@ -61,14 +61,14 @@ Course termId TermId schoolId SchoolId capacity Int Maybe - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId hasRegistration Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo registerFrom UTCTime Maybe registerTo UTCTime Maybe CourseTermShort termId shorthand +CourseEdit + user UserId + time UTCTime + course CourseId Lecturer userId UserId courseId CourseId @@ -103,15 +103,11 @@ Sheet activeTo UTCTime hintFrom UTCTime Maybe solutionFrom UTCTime Maybe - created UTCTime -- delete - changed UTCTime -- delete - createdBy UserId -- delete - changedBy UserId -- delete CourseSheet courseId name SheetEdit - sheet SheetId user UserId time UTCTime + sheet SheetId SheetFile sheetId SheetId fileId FileId @@ -128,11 +124,11 @@ Submission ratingComment Text Maybe ratingBy UserId Maybe ratingTime UTCTime Maybe - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId deriving Show +SubmissionEdit + user UserId + time UTCTime + submission SubmissionId SubmissionFile submissionId SubmissionId fileId FileId @@ -147,10 +143,10 @@ SubmissionUser SubmissionGroup courseId CourseId name Text - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId +SubmissionGroupEdit + user UserId + time UTCTime + submissionGroup SubmissionGroupId SubmissionGroupUser submissionGroupId SubmissionGroupId userId UserId @@ -169,13 +165,12 @@ Booking end UTCTime weekly Bool exceptions [Day] -- only if weekly, begin in exception - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId - bookedFor RoomForId room RoomId +BookingEdit + user UserId + time UTCTime + boooking BookingId Room name Text capacity Int Maybe @@ -201,10 +196,10 @@ Exam deregistrationEnd UTCTime ratingVisible Bool statisticsVisible Bool - created UTCTime - changed UTCTime - createdBy UserId - changedBy UserId +ExamEdit + user UserId + time UTCTime + exam ExamId ExamUser userId UserId examId ExamId diff --git a/routes b/routes index 33692ba6f..d8d4010e7 100644 --- a/routes +++ b/routes @@ -6,36 +6,29 @@ / HomeR GET POST /profile ProfileR GET -/users UsersR GET +/users UsersR GET !adminAny -/term TermShowR GET -/term/edit TermEditR GET POST -/term/#TermId/edit TermEditExistR GET +/term TermShowR GET +/term/edit TermEditR GET POST !adminAny +/term/#TermId/edit TermEditExistR GET !adminAny /course/ CourseListR GET -!/course/new CourseNewR GET POST +!/course/new CourseNewR GET POST !lecturerAny !/course/#TermId CourseListTermR GET +/course/#TermId/#Text CourseR: + /show CourseShowR GET POST + /edit CourseEditR GET POST !lecturer --- /course/#TermId/#Text CourseR !tag: --- /edit CourseEditR GET POST --- /show CourseShowR GET POST -- CourseR tid csh CourseShowR --- /ex/#Text SheetR: !registered --- /show --- /edit -- CourseR tid csg (SheetR csh SheetEditR) --- /delete - -/course/#TermId/#Text/edit CourseEditR GET -/course/#TermId/#Text/show CourseShowR GET POST + /ex SheetR !registered: + / SheetListR GET + /#Text/show SheetShowR GET !time + /#Text/#SheetFileType/#FilePath SheetFileR GET !time + /new SheetNewR GET POST !lecturer + /#Text/edit SheetEditR GET POST !lecturer + /#Text/delete SheetDelR GET POST !lecturer - -/course/#TermId/#Text/ex/ SheetListR GET -/course/#TermId/#Text/ex/#Text/show SheetShowR GET -/course/#TermId/#Text/ex/#Text/#SheetFileType/#FilePath SheetFileR GET -/course/#TermId/#Text/ex/new SheetNewR GET POST -/course/#TermId/#Text/ex/#Text/edit SheetEditR GET POST -/course/#TermId/#Text/ex/#Text/delete SheetDelR GET POST - +-- TODO below /submission SubmissionListR GET POST /submission/#CryptoUUIDSubmission SubmissionR GET POST /submissions.zip SubmissionDownloadMultiArchiveR POST diff --git a/src/Foundation.hs b/src/Foundation.hs index a3d7d7e4c..e10d1c515 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -4,6 +4,7 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NamedFieldPuns #-} @@ -53,6 +54,9 @@ import System.FilePath import Handler.Utils.Templates +-- infixl 9 :$: +-- pattern a :$: b = a b + -- | The foundation datatype for your application. This can be a good place to -- keep settings and values requiring initialization before your application -- starts running, such as database connections. Every handler will have @@ -80,7 +84,9 @@ data UniWorX = UniWorX -- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") -type DB a = YesodDB UniWorX a +-- Pattern Synonyms for convenience +pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn) + data MenuItem = MenuItem { menuItemLabel :: Text @@ -89,13 +95,16 @@ data MenuItem = MenuItem , menuItemAccessCallback :: Handler Bool } -data MenuTypes - = NavbarAside { menuItem :: MenuItem } - | NavbarRight { menuItem :: MenuItem } - | NavbarExtra { menuItem :: MenuItem } - | NavbarSecondary { menuItem :: MenuItem } +data MenuTypes -- Semantische Rolle: + = NavbarAside { menuItem :: MenuItem } -- TODO + | NavbarExtra { menuItem :: MenuItem } -- TODO + | NavbarRight { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar + | NavbarSecondary { menuItem :: MenuItem } -- Generell, nahezu immer sichtbar + | PageActionPrime { menuItem :: MenuItem } -- Seitenspezifische Aktion, häufig + | PageActionSecondary { menuItem :: MenuItem } -- Seitenspezifische Aktion, selten --- | A convenient synonym for creating forms. +-- | Convenient Type Synonyms: +type DB a = YesodDB UniWorX a type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) mkMessage "UniWorX" "messages" "de" @@ -151,7 +160,7 @@ instance Yesod UniWorX where isAuthorized TermShowR _ = return Authorized isAuthorized CourseListR _ = return Authorized isAuthorized (CourseListTermR _) _ = return Authorized - isAuthorized (CourseShowR _ _) _ = return Authorized + isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized isAuthorized SubmissionListR _ = isAuthenticated isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated @@ -198,6 +207,12 @@ instance Yesod UniWorX where makeLogger = return . appLogger isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult +isAuthorizedDB route@(routeAttrs -> attrs) writeable + | "adminAny" `member` attrs = adminAccess Nothing + | "lecturerAny" `member` attrs = lecturerAccess Nothing + + + isAuthorizedDB UsersR _ = adminAccess Nothing isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID @@ -205,14 +220,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB CourseNewR _ = lecturerAccess Nothing -isAuthorizedDB (CourseEditR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (SheetListR t c) False = return Authorized -- -isAuthorizedDB (SheetShowR t c s) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor -isAuthorizedDB (SheetFileR t c s _ _) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor -isAuthorizedDB (SheetListR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (SheetEditR t c s) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) -isAuthorizedDB (SheetDelR t c s) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized -- +isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor +isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor +isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) +isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c) isAuthorizedDB (CourseEditIDR cID) _ = do courseId <- decrypt cID courseLecturerAccess courseId @@ -285,15 +300,15 @@ instance YesodBreadcrumbs UniWorX where breadcrumb CourseListR = return ("Kurs", Just HomeR) breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) - breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term) + breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term) breadcrumb CourseNewR = return ("Neu", Just CourseListR) - breadcrumb (CourseEditR _ _) = return ("Editieren", Just CourseListR) + breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR) - breadcrumb (SheetListR tid csh) = return ("Übungen",Just $ CourseShowR tid csh) - breadcrumb (SheetNewR tid csh) = return ("Neu", Just $ SheetListR tid csh) - breadcrumb (SheetShowR tid csh shn) = return (shn, Just $ SheetListR tid csh) - breadcrumb (SheetEditR tid csh shn) = return ("Edit", Just $ SheetShowR tid csh shn) - breadcrumb (SheetDelR tid csh shn) = return ("DELETE", Just $ SheetShowR tid csh shn) + breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR) + breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR) + breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR) + breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) + breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn) breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) @@ -384,6 +399,14 @@ defaultMenuLayout menu widget = do asidenav = $(widgetFile "widgets/asidenav") breadcrumbs :: Widget breadcrumbs = $(widgetFile "widgets/breadcrumbs") + pageactionprime :: Widget + pageactionprime = $(widgetFile "widgets/pageactionprime") + -- functions to determine if there are page-actions + isPageActionPrime :: MenuTypes -> Bool + isPageActionPrime (PageActionPrime _) = True + isPageActionPrime _ = False + hasPageActions :: Bool + hasPageActions = any isPageActionPrime menuTypes pc <- widgetToPageContent $ do addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900" @@ -391,6 +414,7 @@ defaultMenuLayout menu widget = do addStylesheet $ StaticR css_fonts_css addStylesheet $ StaticR css_icons_css $(widgetFile "default-layout") + $(widgetFile "standalone/modal") $(widgetFile "standalone/showHide") $(widgetFile "standalone/sortable") $(widgetFile "standalone/inputs") diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 07597838c..c12cc46af 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -40,7 +40,7 @@ getCourseListTermR tidini = do let c = entityVal ckv shd = courseShorthand c tid = courseTermId c - in [whamlet| #{shd} |] ) + in [whamlet| #{shd} |] ) -- , headed "Institut" $ [shamlet| #{course} |] , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal , headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal @@ -54,17 +54,17 @@ getCourseListTermR tidini = do shd = courseShorthand c tid = courseTermId c in do - adminLink <- handlerToWidget $ isAuthorized (CourseEditR tid shd ) False + adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else "" [whamlet| $if adminLink == Authorized - + editieren |] ) ] let pageLinks = - [ NavbarAside $ MenuItem + [ PageActionPrime $ MenuItem { menuItemLabel = "Neuer Kurs" , menuItemIcon = Just "book" , menuItemRoute = CourseNewR @@ -93,11 +93,11 @@ getCourseShowR tid csh = do let course = entityVal courseEnt (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered let pageActions = - [ NavbarAside $ MenuItem + [ PageActionPrime $ MenuItem { menuItemLabel = "Übungsblätter" , menuItemIcon = Nothing - , menuItemRoute = SheetListR tid csh - , menuItemAccessCallback = (== Authorized) <$> isAuthorized (SheetListR tid csh) False + , menuItemRoute = CSheetR tid csh SheetListR + , menuItemAccessCallback = (== Authorized) <$> isAuthorized (CSheetR tid csh SheetListR) False } ] defaultLinkLayout pageActions $ do @@ -145,6 +145,9 @@ getCourseEditR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course +postCourseEditR :: TermId -> Text -> Handler Html +postCourseEditR = getCourseEditR + getCourseEditIDR :: CryptoUUIDCourse -> Handler Html getCourseEditIDR cID = do cIDKey <- getsYesod appCryptoIDKey @@ -174,7 +177,7 @@ courseEditHandler course = do , cfTerm = tid })) -> do -- create new course let tident = unTermKey tid - actTime <- liftIO getCurrentTime + now <- liftIO getCurrentTime insertOkay <- runDB $ insertUnique $ Course { courseName = cfName res , courseDescription = cfDesc res @@ -186,14 +189,12 @@ courseEditHandler course = do , courseHasRegistration = cfHasReg res , courseRegisterFrom = cfRegFrom res , courseRegisterTo = cfRegTo res - , courseCreated = actTime - , courseChanged = actTime - , courseCreatedBy = aid - , courseChangedBy = aid - } + } case insertOkay of (Just cid) -> do - runDB $ insert_ $ Lecturer aid cid + runDB $ do + insert_ $ CourseEdit aid now cid + insert_ $ Lecturer aid cid addMessageI "info" $ MsgCourseNewOk tident csh redirect $ CourseListTermR tid Nothing -> @@ -205,7 +206,7 @@ courseEditHandler course = do , cfTerm = tid })) -> do -- edit existing course let tident = unTermKey tid - actTime <- liftIO getCurrentTime + now <- liftIO getCurrentTime -- addMessage "debug" [shamlet| #{show res}|] runDB $ do old <- get cid @@ -228,9 +229,9 @@ courseEditHandler course = do -- , CourseRegisterFrom =. cfRegFrom res -- , CourseRegisterTo =. cfRegTo res -- , CourseChangedBy =. aid --- , CourseChanged =. actTime +-- , CourseChanged =. now -- ] - updOkay <- replace cid ( -- TODO replaceUnique requires Eq?! + _updOkay <- replace cid ( -- TODO replaceUnique requires Eq?! Course { courseName = cfName res , courseDescription = cfDesc res , courseLinkExternal = cfLink res @@ -238,15 +239,12 @@ courseEditHandler course = do , courseTermId = cfTerm res , courseSchoolId = cfSchool res , courseCapacity = cfCapacity res - , courseChanged = actTime - , courseChangedBy = aid - , courseCreated = courseCreated oldCourse - , courseCreatedBy = courseCreatedBy oldCourse , courseHasRegistration = cfHasReg res , courseRegisterFrom = cfRegFrom res , courseRegisterTo = cfRegTo res } ) + insert_ $ CourseEdit aid now cid -- if (isNothing updOkay) -- then do addMessageI "info" $ MsgCourseEditOk tident csh @@ -256,7 +254,7 @@ courseEditHandler course = do (FormFailure _) -> addMessageI "warning" MsgInvalidInput other -> addMessage "error" $ [shamlet| Error: #{show other}|] let formTitle = "Kurs editieren/anlegen" :: Text - let actionUrl = CourseNewR -- CourseEditR -- TODO + actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute defaultLayout $ do setTitle [shamlet| #{formTitle} |] $(widgetFile "formPage") diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs index b3fabdceb..a7f672cc7 100644 --- a/src/Handler/Sheet.hs +++ b/src/Handler/Sheet.hs @@ -172,30 +172,30 @@ getSheetList courseEnt = do rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub return (sid, sheet, (submissions, rated)) let colBase = mconcat - [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ SheetShowR tid csh (sheetName sheet) + [ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ 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 ] 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 + [ headed "Korrigiert" $ toWgt . snd . trd3 + , headed "Eingereicht" $ toWgt . fst . trd3 + , headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s + , headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s ] showAdmin <- case sheets of ((_,firstSheet,_):_) -> do setUltDestCurrent - (Authorized ==) <$> isAuthorized (SheetEditR tid csh $ sheetName firstSheet) False + (Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False _otherwise -> return False let colSheets = if showAdmin then colBase `mappend` colAdmin else colBase let pageActions = - [ NavbarAside $ MenuItem + [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Übungsblatt" , menuItemIcon = Nothing - , menuItemRoute = SheetNewR tid csh + , menuItemRoute = CSheetR tid csh SheetNewR , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False } ] @@ -221,7 +221,7 @@ getSheetShowR tid csh shn = do E.where_ (sheet E.^. SheetId E.==. E.val sid ) -- return desired columns return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType) - let fileLinks = map (\(E.Value fName, E.Value fType) -> SheetFileR tid csh shn fType fName) fileNameTypes + let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes defaultLayout $ do setTitle $ toHtml $ T.append "Übung " $ sheetName sheet @@ -295,8 +295,6 @@ getSheetEditR tid csh shn = do } let action newSheet = do replaceRes <- myReplaceUnique sid $ newSheet - { sheetCreated = sheetCreated - , sheetCreatedBy = sheetChangedBy } case replaceRes of Nothing -> return $ Just sid (Just _err) -> return $ Nothing -- More specific error message for edit old sheet could go here @@ -314,8 +312,8 @@ handleSheetEdit tid csh msId template dbAction = do case res of (FormSuccess SheetForm{..}) -> do saveOkay <- runDB $ do - cid <- getKeyBy404 $ CourseTermShort tid csh actTime <- liftIO getCurrentTime + cid <- getKeyBy404 $ CourseTermShort tid csh let newSheet = Sheet { sheetCourseId = cid , sheetName = sfName @@ -328,10 +326,6 @@ handleSheetEdit tid csh msId template dbAction = do , sheetActiveTo = sfActiveTo , sheetHintFrom = sfHintFrom , sheetSolutionFrom = sfSolutionFrom - , sheetCreated = actTime -- dbAction adjusts this for replacement, TODO: eigene Tabelle für changedBy - , sheetChanged = actTime - , sheetCreatedBy = aid -- dbAction adjusts this for replacement - , sheetChangedBy = aid } mbsid <- dbAction newSheet case mbsid of @@ -340,16 +334,17 @@ handleSheetEdit tid csh msId template dbAction = do whenIsJust sfSheetF $ insertSheetFile' sid SheetExercise whenIsJust sfHintF $ insertSheetFile sid SheetHint whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution + insert_ $ SheetEdit aid actTime sid addMessageI "info" $ MsgSheetEditOk tident csh sfName return True - when saveOkay $ redirect $ SheetShowR tid csh sfName -- redirect must happen outside of runDB + when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB (FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml _ -> return () let pageTitle = maybe (MsgSheetTitleNew tident csh) (MsgSheetTitle tident csh) mbshn let formTitle = pageTitle let formText = Nothing :: Maybe UniWorXMessage - actionUrl <- fromMaybe (SheetNewR tid csh) <$> getCurrentRoute + actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute defaultLayout $ do setTitleI pageTitle $(widgetFile "formPageI18n") @@ -361,19 +356,19 @@ getSheetDelR tid csh shn = do let tident = unTermKey tid ((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete) case result of - (FormSuccess BtnAbort) -> redirectUltDest $ SheetShowR tid csh shn + (FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn (FormSuccess BtnDelete) -> do runDB $ fetchSheetId tid csh shn >>= deleteCascade -- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!! setMessageI $ MsgSheetDelOk tident csh shn - redirect $ SheetListR tid csh + redirect $ CSheetR tid csh SheetListR _other -> do submissionno <- runDB $ do sid <- fetchSheetId tid csh shn count [SubmissionSheetId ==. sid] let formTitle = MsgSheetDelTitle tident csh shn let formText = Just $ MsgSheetDelText submissionno - let actionUrl = SheetDelR tid csh shn + let actionUrl = CSheetR tid csh $ SheetDelR shn defaultLayout $ do setTitleI $ MsgSheetTitle tident csh shn $(widgetFile "formPageI18n") diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs index 3fb482691..3e2160d28 100644 --- a/src/Handler/Submission.hs +++ b/src/Handler/Submission.hs @@ -8,6 +8,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE ViewPatterns #-} module Handler.Submission where @@ -53,7 +54,7 @@ submissionTable = do (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s let - anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR courseTermId courseShorthand + anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName anchorSubmission (_, cUUID, _) = SubmissionR cUUID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID @@ -177,8 +178,12 @@ postSubmissionDownloadMultiArchiveR = do withinDirectory f@File{..} = f { fileTitle = directoryName fileTitle } + lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1] + lastEditTime <- case lastEditMb of + [(submissionEditTime.entityVal -> time)] -> return time + _other -> liftIO getCurrentTime yield $ File - { fileModified = submissionChanged + { fileModified = lastEditTime , fileTitle = directoryName , fileContent = Nothing } diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 7093e5ce8..f8155da8c 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -76,7 +76,7 @@ getTermShowR = do , dbtIdent = "terms" :: Text } let pageActions = - [ NavbarAside $ MenuItem + [ PageActionPrime $ MenuItem { menuItemLabel = "Neues Semester" , menuItemIcon = Nothing , menuItemRoute = TermEditR diff --git a/src/Handler/Utils/Submission.hs b/src/Handler/Utils/Submission.hs index fad44f370..6a100ab98 100644 --- a/src/Handler/Utils/Submission.hs +++ b/src/Handler/Utils/Submission.hs @@ -70,12 +70,9 @@ sinkSubmission sheetId userId mExists = do submissionRatingComment = Nothing submissionRatingBy = Nothing submissionRatingTime = Nothing - submissionCreated = now - submissionChanged = now - submissionCreatedBy = userId - submissionChangedBy = userId - (sId, isUpdate) <- lift $ maybe ((, False) <$> insert Submission{..}) return mExists + (sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists + sId <$ sinkSubmission' sId isUpdate where @@ -184,9 +181,9 @@ sinkSubmission sheetId userId mExists = do alreadyTouched <- gets $ getAny . sinkSubmissionTouched when (not alreadyTouched) $ do now <- liftIO getCurrentTime - lift . update submissionId $ case isUpdate of - False -> [ SubmissionChangedBy =. userId, SubmissionChanged =. now ] - True -> [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] + lift $ case isUpdate of + False -> insert_ $ SubmissionEdit userId now submissionId + True -> update submissionId [ SubmissionRatingBy =. Just userId, SubmissionRatingTime =. Just now ] tell $ mempty{ sinkSubmissionTouched = Any True } finalize :: SubmissionSinkState -> YesodDB UniWorX () diff --git a/src/Handler/Utils/Templates.hs b/src/Handler/Utils/Templates.hs index 245159eeb..8bae783b0 100644 --- a/src/Handler/Utils/Templates.hs +++ b/src/Handler/Utils/Templates.hs @@ -6,3 +6,17 @@ import Import.NoFoundation lipsum :: WidgetT site IO () lipsum = $(widgetFile "widgets/lipsum") + +modal :: [Char] -> Maybe [Char] -> WidgetT site IO () +modal modalTrigger (Just modalContent) = do + let + modalId :: Int32 + modalId = 13 + $(widgetFile "widgets/modal") +modal modalTrigger Nothing = do + let + modalId :: Int32 + modalId = 13 + modalContent :: [Char] + modalContent = "placeholder" + $(widgetFile "widgets/modal") diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 7201671ab..321df30b8 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -55,7 +55,7 @@ deriveJSON defaultOptions ''SheetType derivePersistFieldJSON "SheetType" data SheetGroup - = Arbitrary { maxParticipants :: Int } + = Arbitrary { maxParticipants :: Int } -- Distinguish Limited/Arbitrary | RegisteredGroups | NoGroups deriving (Show, Read, Eq) diff --git a/templates/course.hamlet b/templates/course.hamlet index 14e8f6ad2..94d8dbfb4 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -16,7 +16,7 @@ \ bis #{formatTimeGerWD regTo}
-
+ ^{regWidget}
diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index a785cb89c..ef15995c0 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -38,7 +38,12 @@ $newline never \ }); } - + + + +