diff --git a/src/Foundation.hs b/src/Foundation.hs index 0bc8713fc..123ca4cff 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -51,6 +51,8 @@ import Handler.Utils.StudyFeatures import System.FilePath +import Handler.Utils.Templates + -- | 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,6 +82,7 @@ mkYesodData "UniWorX" $(parseRoutesFile "routes") data MenuItem = MenuItem { menuItemLabel :: Text + , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback :: Handler Bool } @@ -88,6 +91,7 @@ data MenuTypes = NavbarLeft { menuItem :: MenuItem } | NavbarRight { menuItem :: MenuItem } | NavbarExtra { menuItem :: MenuItem } + | NavbarSecondary { menuItem :: MenuItem } -- | A convenient synonym for creating forms. type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget) @@ -219,10 +223,10 @@ submissionAccess cID = do adminAccess :: Maybe SchoolId -- ^ If @Just@, matched exactly against 'userAdminSchool' -> YesodDB UniWorX AuthResult -adminAccess school = do +adminAccess school = do authId <- lift requireAuthId - adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] - return $ if (not $ null adrights) + adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) [] + return $ if (not $ null adrights) then Authorized else Unauthorized "No admin access" @@ -230,7 +234,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" @@ -250,15 +254,15 @@ isAuthorized' :: Route UniWorX -> Bool -> Handler Bool isAuthorized' route isWrite = runDB $ isAuthorizedDB' route isWrite -- Define breadcrumbs. -instance YesodBreadcrumbs UniWorX where +instance YesodBreadcrumbs UniWorX where breadcrumb TermShowR = return ("Semester", Just HomeR) breadcrumb TermEditR = return ("Neu", Just TermShowR) breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) - + breadcrumb CourseListR = return ("Kurs", Just HomeR) breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR) breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term) - breadcrumb CourseEditR = return ("Neu", Just CourseListR) + breadcrumb CourseEditR = return ("Neu", Just CourseListR) breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR) breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh) @@ -266,42 +270,48 @@ instance YesodBreadcrumbs UniWorX where breadcrumb SubmissionListR = return ("Abgaben", Just HomeR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) - + breadcrumb HomeR = return ("ReWorX", Nothing) breadcrumb (AuthR _) = return ("Login", Just HomeR) breadcrumb ProfileR = return ("Profile", Just HomeR) breadcrumb _ = return ("home", Nothing) - + defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. - [ NavbarLeft $ MenuItem + [ NavbarRight $ MenuItem { menuItemLabel = "Home" + , menuItemIcon = Just "home" , menuItemRoute = HomeR , menuItemAccessCallback = return True } , NavbarLeft $ MenuItem { menuItemLabel = "Kurse" + , menuItemIcon = Just "book" , menuItemRoute = CourseListR , menuItemAccessCallback = return True - } - , NavbarRight $ MenuItem + } + , NavbarLeft $ MenuItem { menuItemLabel = "Users" + , menuItemIcon = Just "user" , menuItemRoute = UsersR , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False } , NavbarRight $ MenuItem { menuItemLabel = "Profile" + , menuItemIcon = Just "user" , menuItemRoute = ProfileR , menuItemAccessCallback = isJust <$> maybeAuthPair } - , NavbarRight $ MenuItem + , NavbarSecondary $ MenuItem { menuItemLabel = "Login" + , menuItemIcon = Just "login" , menuItemRoute = AuthR LoginR , menuItemAccessCallback = isNothing <$> maybeAuthPair } - , NavbarRight $ MenuItem + , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" + , menuItemIcon = Just "logout" , menuItemRoute = AuthR LogoutR , menuItemAccessCallback = isJust <$> maybeAuthPair } @@ -328,12 +338,24 @@ defaultMenuLayout menu widget = do -- value passed to hamletToRepHtml cannot be a widget, this allows -- you to use normal widget features in default-layout. + let + navbar :: Widget + navbar = $(widgetFile "widgets/navbar") + asidenav :: Widget + asidenav = $(widgetFile "widgets/asidenav") + breadcrumbs :: Widget + breadcrumbs = $(widgetFile "widgets/breadcrumbs") + pc <- widgetToPageContent $ do - addStylesheet $ StaticR css_bootstrap_css + addStylesheetRemote "https://fonts.googleapis.com/css?family=Source+Sans+Pro:300,400,600,800,900" + addStylesheet $ StaticR css_fonts_css + addStylesheet $ StaticR css_icons_css $(widgetFile "default-layout") + $(widgetFile "standalone/showHide") + $(widgetFile "standalone/sortable") + $(widgetFile "standalone/inputs") withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet") - -- How to run database actions. instance YesodPersist UniWorX where type YesodPersistBackend UniWorX = SqlBackend @@ -363,7 +385,7 @@ instance YesodAuth UniWorX where $logDebugS "auth" $ tshow ((userPlugin, userIdent), creds) - when isDummy . (throwError =<<) . lift $ + when isDummy . (throwError =<<) . lift $ maybe (UserError $ IdentifierNotFound credsIdent) (Authenticated . entityKey) <$> getBy uAuth let @@ -373,7 +395,7 @@ instance YesodAuth UniWorX where userEmail <- maybe (throwError $ ServerError "Could not retrieve user email") return userEmail' userDisplayName <- maybe (throwError $ ServerError "Could not retrieve user name") return userDisplayName' - + let newUser = User{..} userUpdate = [ UserMatrikelnummer =. userMatrikelnummer @@ -388,13 +410,13 @@ instance YesodAuth UniWorX where userStudyFeatures' = [ v | (k, v) <- credsExtra, k == "dfnEduPersonFeaturesOfStudy" ] fs <- either (\err -> throwError . ServerError $ "Could not parse features of study: " <> err) return userStudyFeatures - + lift $ deleteWhere [StudyFeaturesUser ==. userId] forM_ fs $ \StudyFeatures{..} -> do lift . insertMaybe studyFeaturesDegree $ StudyDegree (unStudyDegreeKey studyFeaturesDegree) Nothing Nothing lift . insertMaybe studyFeaturesField $ StudyTerms (unStudyTermsKey studyFeaturesField) Nothing Nothing - + lift $ insertMany_ fs return $ Authenticated userId where @@ -419,7 +441,7 @@ ldapConfig _app@(appSettings -> settings) = LDAPConfig } where principalName :: IsString a => a - principalName = "userPrincipalName" + principalName = "userPrincipalName" identifierModifier _ entry = case lookup principalName $ leattrs entry of Just [n] -> Text.pack n _ -> error "Could not determine user principal name" diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 28250fb7d..75767a26a 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -9,38 +9,38 @@ module Handler.Course where -import Import +import Import import Handler.Utils -- import Data.Time 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 Yesod.Colonnade import qualified Data.UUID.Cryptographic as UUID getCourseListR :: Handler TypedContent -getCourseListR = redirect TermShowR +getCourseListR = redirect TermShowR getCourseListTermR :: TermId -> Handler Html getCourseListTermR tidini = do - (term,courses) <- runDB $ (,) + (term,courses) <- runDB $ (,) <$> get tidini <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand] when (isNothing term) $ do 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 -> + -- TODO: several runDBs per TableRow are probably too inefficient! + let colonnadeTerms = mconcat + [ headed "Kürzel" $ (\ckv -> let c = entityVal ckv - shd = courseShorthand c + 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 @@ -49,60 +49,61 @@ getCourseListTermR tidini = do partiNum <- handlerToWidget $ runDB $ count [CourseParticipantCourseId ==. cid] [whamlet| #{show partiNum} |] ) - , headed " " $ (\ckv -> + , headed " " $ (\ckv -> let c = entityVal ckv - shd = courseShorthand c + shd = courseShorthand c tid = courseTermId c in do adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else "" - [whamlet| + [whamlet| $if adminLink == Authorized editieren |] - ) + ) ] - let pageLinks = + let pageLinks = [ NavbarLeft $ MenuItem { menuItemLabel = "Neuer Kurs" + , menuItemIcon = Just "book" , menuItemRoute = CourseEditR , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseEditR False } - ] + ] + let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses defaultLinkLayout pageLinks $ do --- defaultLayout $ do - setTitle "Semesterkurse" - linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR - encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) + -- defaultLayout $ do + setTitle "Semesterkurse" + $(widgetFile "courses") getCourseShowR :: TermId -> Text -> Handler Html getCourseShowR tid csh = do mbAid <- maybeAuthId (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh - dependent <- (,,) + dependent <- (,,) <$> get (courseSchoolId course) -- join - <*> count [CourseParticipantCourseId ==. cid] -- 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 + let course = entityVal courseEnt + (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered defaultLayout $ do setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|] $(widgetFile "course") - + registerButton :: Bool -> Form () -registerButton registered = renderAForm FormStandard $ - pure () <* bootstrapSubmit regMsg - where +registerButton registered = renderAForm FormStandard $ + pure () <* bootstrapSubmit regMsg + where msg = if registered then "Abmelden" else "Anmelden" regMsg = msg :: BootstrapSubmit Text - + postCourseShowR :: TermId -> Text -> Handler Html postCourseShowR tid csh = do aid <- requireAuthId @@ -110,30 +111,30 @@ postCourseShowR tid csh = do (Entity cid _) <- getBy404 $ CourseTermShort tid csh registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid) return (cid, registered) - ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered - case regResult of + ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered + case regResult of (FormSuccess _) - | registered -> do - runDB $ deleteBy $ UniqueCourseParticipant cid aid - addMessage "info" "Sie wurden abgemeldet." + | registered -> do + runDB $ deleteBy $ UniqueCourseParticipant cid aid + addMessage "info" "Sie wurden abgemeldet." | otherwise -> 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 - + getCourseShowR tid csh + getCourseEditR :: Handler Html getCourseEditR = do -- TODO: Defaults für Semester hier ermitteln und übergeben courseEditHandler Nothing - + postCourseEditR :: Handler Html postCourseEditR = courseEditHandler Nothing - + getCourseEditExistR :: TermId -> Text -> Handler Html -getCourseEditExistR tid csh = do +getCourseEditExistR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh courseEditHandler course @@ -143,28 +144,28 @@ getCourseEditExistIDR cID = do courseID <- UUID.decrypt cIDKey cID courseEditHandler =<< runDB (getEntity courseID) - + courseEditHandler :: Maybe (Entity Course) -> Handler Html courseEditHandler course = do aid <- requireAuthId ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course action <- lookupPostParam "formaction" case (result,action) of - (FormSuccess res, fAct) + (FormSuccess res, fAct) | fAct == formActionDelete - , Just cid <- cfCourseId res -> do + , Just cid <- cfCourseId res -> do runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! 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 + | fAct == formActionSave + , Just cid <- cfCourseId res -> do let tid = cfTerm res actTime <- liftIO getCurrentTime updateokay <- runDB $ do - exists <- getBy $ CourseTermShort tid $ cfShort res + exists <- getBy $ CourseTermShort tid $ cfShort res let upokay = isNothing exists - when upokay $ update cid + when upokay $ update cid [ CourseName =. cfName res , CourseDescription =. cfDesc res , CourseLinkExternal =. cfLink res @@ -179,17 +180,17 @@ courseEditHandler course = do ] return upokay let cti = toPathPiece $ cfTerm res - if updateokay - then do + if updateokay + then do addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] redirect $ CourseListTermR $ cfTerm res else do - addMessage "danger" [shamlet| Kurs #{cti}/#{cfShort res} konnte nicht geändert werden. + addMessage "danger" [shamlet| Kurs #{cti}/#{cfShort res} konnte nicht geändert werden. \ Es gibt bereits einen anderen Kurs mit diesem Kürzel in diesem Semester.|] | fAct == formActionSave , Nothing <- cfCourseId res -> do actTime <- liftIO getCurrentTime - insertOkay <- runDB $ insertUnique $ Course + insertOkay <- runDB $ insertUnique $ Course { courseName = cfName res , courseDescription = cfDesc res , courseLinkExternal = cfLink res @@ -204,17 +205,17 @@ courseEditHandler course = do , courseChanged = actTime , courseCreatedBy = aid , courseChangedBy = aid - } - case insertOkay of + } + case insertOkay of (Just cid) -> do - runDB $ insert_ $ Lecturer aid cid + runDB $ insert_ $ Lecturer aid cid let cti = toPathPiece $ cfTerm res addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|] redirect $ CourseListTermR $ cfTerm res Nothing -> do let cti = toPathPiece $ cfTerm res - addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|] - (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." + addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|] + (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." _other -> return () let formTitle = "Kurs editieren/anlegen" :: Text let actionUrl = CourseEditR @@ -222,28 +223,28 @@ courseEditHandler course = do defaultLayout $ do setTitle [shamlet| #{formTitle} |] $(widgetFile "formPage") - - -data CourseForm = CourseForm + + +data CourseForm = CourseForm { cfCourseId :: Maybe CourseId -- Maybe CryptoUUIDCourse - , cfName :: Text + , cfName :: Text , cfDesc :: Maybe Html - , cfLink :: Maybe Text - , cfShort :: Text + , cfLink :: Maybe Text + , cfShort :: Text , cfTerm :: TermId , cfSchool :: SchoolId - , cfCapacity :: Maybe Int + , cfCapacity :: Maybe Int , cfHasReg :: Bool - , cfRegFrom :: Maybe UTCTime - , cfRegTo :: Maybe UTCTime - } + , cfRegFrom :: Maybe UTCTime + , cfRegTo :: Maybe UTCTime + } instance Show CourseForm where show cf = T.unpack (cfShort cf) ++ ' ':(show $ cfCourseId cf) - + courseToForm :: Entity Course -> CourseForm -courseToForm cEntity = CourseForm +courseToForm cEntity = CourseForm { cfCourseId = Just $ entityKey cEntity , cfName = courseName course , cfDesc = courseDescription course @@ -253,26 +254,26 @@ courseToForm cEntity = CourseForm , cfSchool = courseSchoolId course , cfCapacity = courseCapacity course , cfHasReg = courseHasRegistration course - , cfRegFrom = courseRegisterFrom course - , cfRegTo = courseRegisterTo course + , cfRegFrom = courseRegisterFrom course + , cfRegTo = courseRegisterTo course } where course = entityVal cEntity - + newCourseForm :: Maybe CourseForm -> Form CourseForm newCourseForm template = identForm FIDcourse $ \html -> do - -- mopt hiddenField + -- mopt hiddenField -- cidKey <- getsYesod appCryptoIDKey -- courseId <- runMaybeT $ do -- cid <- cfCourseId template - -- UUID.encrypt cidKey cid + -- UUID.encrypt cidKey cid (result, widget) <- flip (renderAForm FormStandard) html $ CourseForm -- <$> pure cid -- $ join $ cfCourseId <$> template -- why doesnt this work? <$> aopt hiddenField "KursId" (cfCourseId <$> template) <*> areq textField (fsb "Name") (cfName <$> template) <*> aopt htmlField (fsb "Beschreibung") (cfDesc <$> template) <*> aopt urlField (fsb "Homepage") (cfLink <$> template) - <*> areq textField (fsb "Kürzel" + <*> areq textField (fsb "Kürzel" -- & addAttr "disabled" "disabled" & setTooltip "Muss innerhalb des Semesters eindeutig sein") (cfShort <$> template) @@ -282,9 +283,9 @@ newCourseForm template = identForm FIDcourse $ \html -> do <*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template) <*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template) <*> aopt utcTimeField (fsb "Anmeldung bis:") (cfRegTo <$> template) - -- <* bootstrapSubmit (bsSubmit (show cid)) - return $ case result of - FormSuccess courseResult + -- <* bootstrapSubmit (bsSubmit (show cid)) + return $ case result of + FormSuccess courseResult | errorMsgs <- validateCourse courseResult , not $ null errorMsgs -> (FormFailure errorMsgs, @@ -293,18 +294,18 @@ newCourseForm template = identForm FIDcourse $ \html -> do

Fehler: