diff --git a/src/Foundation.hs b/src/Foundation.hs index f19b46633..ed02dcd74 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -90,6 +90,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) @@ -277,7 +278,7 @@ instance YesodBreadcrumbs UniWorX where defaultLinks :: [MenuTypes] defaultLinks = -- Define the menu items of the header. - [ NavbarLeft $ MenuItem + [ NavbarRight $ MenuItem { menuItemLabel = "Home" , menuItemRoute = HomeR , menuItemAccessCallback = return True @@ -287,7 +288,7 @@ defaultLinks = -- Define the menu items of the header. , menuItemRoute = CourseListR , menuItemAccessCallback = return True } - , NavbarRight $ MenuItem + , NavbarLeft $ MenuItem { menuItemLabel = "Users" , menuItemRoute = UsersR , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False @@ -297,12 +298,12 @@ defaultLinks = -- Define the menu items of the header. , menuItemRoute = ProfileR , menuItemAccessCallback = isJust <$> maybeAuthPair } - , NavbarRight $ MenuItem + , NavbarSecondary $ MenuItem { menuItemLabel = "Login" , menuItemRoute = AuthR LoginR , menuItemAccessCallback = isNothing <$> maybeAuthPair } - , NavbarRight $ MenuItem + , NavbarSecondary $ MenuItem { menuItemLabel = "Logout" , menuItemRoute = AuthR LogoutR , menuItemAccessCallback = isJust <$> maybeAuthPair diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 28250fb7d..9514b1fa0 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,60 @@ 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" , 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 +110,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 +143,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 +179,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 +204,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 +222,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 +253,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 +282,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 +293,18 @@ newCourseForm template = identForm FIDcourse $ \html -> do

Fehler: