diff --git a/README.md b/README.md index e0296b226..348fcc55f 100644 --- a/README.md +++ b/README.md @@ -1,21 +1,24 @@ # Quick Start Guide -Assuming Ubuntu or similar +The following Description applies to Ubuntu or similar. + +## Clone repository + Clone this repository `git clone https://gitlab.cip.ifi.lmu.de/jost/UniWorX.git` and navigate into the new directory `cd UniWorX`. ## LDAP - install:
- `sudo apt-get install slapd ldap-utils` + install: + `sudo apt-get install slapd ldap-utils` ## PostgreSQL - install:
- `sudo apt-get install postgresql` + install: + `sudo apt-get install postgresql` - switch to user *postgres* (got created during installation):
- `sudo -i -u postgres` + switch to user *postgres* (got created during installation): + `sudo -i -u postgres` - add db user *uniworx*:
- `createuser --interactive` + add db user *uniworx*: + `createuser --interactive` you'll get a prompt: @@ -24,49 +27,60 @@ Assuming Ubuntu or similar Shall the new role be a superuser? (y/n)` - [not exactly sure. Guess not?] ``` - create database *uniworx*:
- `createdb uniworx` + create database *uniworx*: + `createdb uniworx` - to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*:
- `sudo adduser uniworx` + to access the database as user *uniworx* you now need to add a new linux-user called *uniworx*: + `sudo adduser uniworx` - log-in as new user *uniworx*:
- `sudo -i -u uniworx` + log-in as new user *uniworx*: + `sudo -i -u uniworx` you can now use `psql uniworx` to execute SQL-commands and such. - you might for example want to add a test-account to be able to login on the page:
- `INSERT INTO user (plugin, ident, matrikelnummer, email, display_name) VALUES ('LDAP', '[YOUR_EMAIL_ADDRESS]', null, '[YOUR_EMAIL_ADDRESS]', '[YOUR_NAME]');` - ## stack - Install with:
- `curl -sSL https://get.haskellstack.org/ | sh` + Install with: + `curl -sSL https://get.haskellstack.org/ | sh` - setup stack and install dependencies:
- `stack setup` + setup stack and install dependencies: + `stack setup` - There might be packages missing during setup. You most probably simply need to install them and try again.
- Instructions are easy to find via search engine of your choice and the specific error you got.
- Example from experience: For LDAP `ldab` and `lber` header files were missing. + During this step or the next you might get an error that says something about missing C libraries for `ldap` and `lber`. You can install these using + `sudo apt-get install libsasl2-dev libldap2-dev` - Build the app:
- `stack build` + If you get an error that says *You need to install postgresql-server-dev-X.Y for building a server-side extension or libpq-dev for building a client-side application.* + Go ahead an install `libpq-dev` with + `sudo apt-get install libpq-dev` - Run the app (with environment variable DUMMY_LOGIN set to true):
- `env DUMMY_LOGIN=true stack exec -- yesod devel` + Build the app: + `stack build` - `Devel application launched: http://localhost:3000`
+ This might take a few minutes if not hours... be prepared. + + install yesod: + `stack install yesod-bin --install-ghc` + +## Add Dumy-Data and run the app + After building the app you can prepare the database and add some dummy data: + `./fill-db.hs` + + Run the app: + `./start.sh` + + `Devel application launched: http://localhost:3000` means you are good to go. + If you followed the steps above you should now be able to login as user Gregor Kleen using `LDAP:g.kleen@ifi.lmu.de` as dummy login. + *** # Sources and more infos - PostgreSQl:
+ PostgreSQl: https://www.digitalocean.com/community/tutorials/how-to-install-and-use-postgresql-on-ubuntu-16-04 - stack:
https://docs.haskellstack.org/en/stable/README/#how-to-install + stack: https://docs.haskellstack.org/en/stable/README/#how-to-install - ldap:
https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/ + ldap: https://wiki.ubuntuusers.de/OpenLDAP_ab_Precise/ *** diff --git a/fill-db.hs b/fill-db.hs index 41631aebb..d90c8af28 100755 --- a/fill-db.hs +++ b/fill-db.hs @@ -14,6 +14,7 @@ main :: IO () main = db $ do now <- liftIO getCurrentTime let + summer2017 = TermIdentifier 2017 Summer winter2017 = TermIdentifier 2017 Winter summer2018 = TermIdentifier 2018 Summer gkleen <- insert User @@ -23,6 +24,29 @@ main = db $ do , userEmail = "G.Kleen@campus.lmu.de" , userDisplayName = "Gregor Kleen" } + fhamann <- insert User + { userPlugin = "LDAP" + , userIdent = "felix.hamann@campus.lmu.de" + , userMatrikelnummer = Nothing + , userEmail = "felix.hamann@campus.lmu.de" + , userDisplayName = "Felix Hamann" + } + jost <- insert User + { userPlugin = "LDAP" + , userIdent = "jost@tcs.ifi.lmu.de" + , userMatrikelnummer = Nothing + , userEmail = "jost@tcs.ifi.lmu.de" + , userDisplayName = "Steffen Jost" + } + void . insert $ Term + { termName = summer2017 + , termStart = fromGregorian 2017 04 09 + , termEnd = fromGregorian 2017 07 14 + , termHolidays = [] + , termLectureStart = fromGregorian 2017 04 09 + , termLectureEnd = fromGregorian 2018 07 14 + , termActive = False + } void . insert $ Term { termName = winter2017 , termStart = fromGregorian 2017 10 16 @@ -45,9 +69,16 @@ main = db $ do mi <- insert $ School "Institut für Mathematik" "MI" void . insert $ UserAdmin gkleen ifi void . insert $ UserAdmin gkleen mi + void . insert $ UserAdmin fhamann ifi + void . insert $ UserAdmin jost ifi + void . insert $ UserAdmin jost mi void . insert $ UserLecturer gkleen ifi + void . insert $ UserLecturer fhamann ifi + void . insert $ UserLecturer jost ifi ifiBsc <- insert $ Degree "Bachelor Informatik" ifi ifiMsc <- insert $ Degree "Master Informatik" ifi + miBsc <- insert $ Degree "Bachelor Mathematik" mi + -- FFP ffp <- insert Course { courseName = "Fortgeschrittene Funktionale Programmierung" , courseDescription = Nothing @@ -69,3 +100,99 @@ main = db $ do 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 + -- EIP + eip <- insert Course + { courseName = "Einführung in die Programmierung" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "eip" + , courseTermId = TermKey summer2017 + , courseSchoolId = ifi + , courseCapacity = Just 20 + , courseCreated = now + , courseChanged = now + , courseCreatedBy = fhamann + , courseChangedBy = fhamann + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + void . insert $ DegreeCourse ifiBsc eip + void . insert $ DegreeCourse ifiMsc eip + void . insert $ Lecturer fhamann eip + -- interaction design + ixd <- insert Course + { courseName = "Interaction Design (User Experience Design I & II)" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "ixd" + , 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 ) + } + void . insert $ DegreeCourse ifiBsc ixd + void . insert $ Lecturer fhamann ixd + -- concept development + ux3 <- insert Course + { courseName = "Concept Development (User Experience Design III)" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "ux3" + , courseTermId = TermKey winter2017 + , courseSchoolId = ifi + , courseCapacity = Just 30 + , courseCreated = now + , courseChanged = now + , courseCreatedBy = fhamann + , courseChangedBy = fhamann + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + void . insert $ DegreeCourse ifiBsc ux3 + void . insert $ Lecturer fhamann ux3 + -- promo + pmo <- insert Course + { courseName = "Programmierung und Modellierung" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "pmo" + , courseTermId = TermKey summer2017 + , courseSchoolId = ifi + , courseCapacity = Just 50 + , courseCreated = now + , courseChanged = now + , courseCreatedBy = jost + , courseChangedBy = jost + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + void . insert $ DegreeCourse ifiBsc pmo + void . insert $ Lecturer jost pmo + -- datenbanksysteme + dbs <- insert Course + { courseName = "Datenbanksysteme" + , courseDescription = Nothing + , courseLinkExternal = Nothing + , courseShorthand = "dbs" + , courseTermId = TermKey summer2018 + , courseSchoolId = ifi + , courseCapacity = Just 50 + , courseCreated = now + , courseChanged = now + , courseCreatedBy = jost + , courseChangedBy = jost + , courseHasRegistration = False + , courseRegisterFrom = Nothing + , courseRegisterTo = Nothing + } + void . insert $ DegreeCourse ifiBsc dbs + void . insert $ Lecturer jost dbs diff --git a/messages/de.msg b/messages/de.msg index 3938ebdc1..163ca0cfb 100644 --- a/messages/de.msg +++ b/messages/de.msg @@ -1,5 +1,6 @@ SummerTerm year@Integer: Sommersemester #{tshow year} WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year} +PSLimitNonPositive: “pagesize” muss größer als null sein TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert. TermNewTitle: Semester editiere/anlegen. InvalidInput: Eingaben bitte korrigieren. diff --git a/src/Foundation.hs b/src/Foundation.hs index b39b64f7e..a3d7d7e4c 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 @@ -82,14 +84,16 @@ type DB a = YesodDB UniWorX a data MenuItem = MenuItem { menuItemLabel :: Text + , menuItemIcon :: Maybe Text , menuItemRoute :: Route UniWorX , menuItemAccessCallback :: Handler Bool } data MenuTypes - = NavbarLeft { menuItem :: MenuItem } - | NavbarRight { menuItem :: MenuItem } - | NavbarExtra { menuItem :: MenuItem } + = NavbarAside { 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) @@ -227,10 +231,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" -- TODO internationalize @@ -274,11 +278,11 @@ 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) @@ -293,45 +297,63 @@ 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" - , 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" + , menuItemIcon = Just "profile" , 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 } + , NavbarAside $ MenuItem + { menuItemLabel = "Aktuelle Veranstaltungen" + , menuItemIcon = Just "book" + , menuItemRoute = CourseListR -- should be CourseListActiveR or similar in the future + , menuItemAccessCallback = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Alte Veranstaltungen" + , menuItemIcon = Just "book" + , menuItemRoute = CourseListR -- should be CourseListInactiveR or similar in the future + , menuItemAccessCallback = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Veranstaltungen" + , menuItemIcon = Just "book" + , menuItemRoute = CourseListR + , menuItemAccessCallback = return True + } + , NavbarAside $ MenuItem + { menuItemLabel = "Benutzer" + , menuItemIcon = Just "user" + , menuItemRoute = UsersR + , menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False + } ] defaultLinkLayout :: [MenuTypes] -> Widget -> Handler Html @@ -355,12 +377,25 @@ 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" + addScript $ StaticR js_featureChecker_js + 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 @@ -390,7 +425,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 @@ -400,7 +435,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 @@ -415,13 +450,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 @@ -446,7 +481,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 79d52c7e7..07597838c 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,52 +49,53 @@ 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 (CourseEditR tid shd ) False -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else "" - [whamlet| + [whamlet| $if adminLink == Authorized editieren |] - ) + ) ] - let pageActions = - [ NavbarLeft $ MenuItem + let pageLinks = + [ NavbarAside $ MenuItem { menuItemLabel = "Neuer Kurs" + , menuItemIcon = Just "book" , menuItemRoute = CourseNewR , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False } - ] - defaultLinkLayout pageActions $ do --- defaultLayout $ do - setTitle "Semesterkurse" - linkButton "Neuen Kurs anlegen" BCPrimary CourseNewR - encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) + ] + let coursesTable = encodeWidgetTable tableSortable colonnadeTerms courses + defaultLinkLayout pageLinks $ 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 (UniqueParticipant aid cid) 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 let pageActions = - [ NavbarLeft $ MenuItem + [ NavbarAside $ MenuItem { menuItemLabel = "Übungsblätter" + , menuItemIcon = Nothing , menuItemRoute = SheetListR tid csh , menuItemAccessCallback = (== Authorized) <$> isAuthorized (SheetListR tid csh) False } @@ -102,14 +103,14 @@ getCourseShowR tid csh = do defaultLinkLayout pageActions $ 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 @@ -117,20 +118,20 @@ postCourseShowR tid csh = do (Entity cid _) <- getBy404 $ CourseTermShort tid csh registered <- isJust <$> (getBy $ UniqueParticipant aid cid) return (cid, registered) - ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered - case regResult of + ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered + case regResult of (FormSuccess _) - | registered -> do + | registered -> do runDB $ deleteBy $ UniqueParticipant aid cid - addMessage "info" "Sie wurden abgemeldet." + 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 + getCourseNewR :: Handler Html getCourseNewR = do -- TODO: Defaults für Semester hier ermitteln und übergeben @@ -138,7 +139,7 @@ getCourseNewR = do postCourseNewR :: Handler Html postCourseNewR = courseEditHandler Nothing - + getCourseEditR :: TermId -> Text -> Handler Html getCourseEditR tid csh = do course <- runDB $ getBy $ CourseTermShort tid csh @@ -259,28 +260,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 @@ -290,26 +291,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) @@ -320,8 +321,8 @@ newCourseForm template = identForm FIDcourse $ \html -> do <*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template) <*> aopt utcTimeField (fsb "Anmeldung bis:") (cfRegTo <$> template) <* submitButton - return $ case result of - FormSuccess courseResult + return $ case result of + FormSuccess courseResult | errorMsgs <- validateCourse courseResult , not $ null errorMsgs -> (FormFailure errorMsgs, @@ -330,18 +331,18 @@ newCourseForm template = identForm FIDcourse $ \html -> do

Fehler: