diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 8568ce0e3..3521e81cb 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1031,6 +1031,8 @@ MenuExamAddMembers: Prüfungsteilnehmer hinzufügen MenuLecturerInvite: Dozenten hinzufügen MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung MenuCourseApplicationsFiles: Dateien aller Bewerbungen +MenuSchoolList: Institute +MenuSchoolNew: Neues Institut anlegen AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren. AuthPredsActive: Aktive Authorisierungsprädikate @@ -1562,4 +1564,13 @@ CourseApplicationNoRatingPoints: Keine Bewertung CourseApplicationNoRatingComment: Kein Kommentar UserDisplayName: Voller Name -UserMatriculation: Matrikelnummer \ No newline at end of file +UserMatriculation: Matrikelnummer + +SchoolShort: Kürzel +SchoolName: Name + +SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst +SchoolTitle ssh@SchoolId: Institut „#{ssh}“ +TitleSchoolNew: Neues Institut anlegen +SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt +SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits \ No newline at end of file diff --git a/routes b/routes index b8c14a9e7..1c42a5478 100644 --- a/routes +++ b/routes @@ -78,8 +78,9 @@ !/term/#TermId TermCourseListR GET !free !/term/#TermId/#SchoolId TermSchoolCourseListR GET !free -/school SchoolListR GET !development -/school/#SchoolId SchoolShowR GET !development +/school SchoolListR GET +!/school/new SchoolNewR GET POST +/school/#SchoolId SchoolShowR GET POST /allocation/ AllocationListR GET !free /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR: diff --git a/src/Foundation.hs b/src/Foundation.hs index 1852150ac..e0472c50e 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -1723,6 +1723,10 @@ instance YesodBreadcrumbs UniWorX where breadcrumb AdminFeaturesR = return ("Test" , Just AdminR) breadcrumb AdminTestR = return ("Test" , Just AdminR) breadcrumb AdminErrMsgR = return ("Test" , Just AdminR) + + breadcrumb SchoolListR = return ("Institute" , Just AdminR) + breadcrumb (SchoolShowR ssh) = return (original (unSchoolKey ssh), Just SchoolListR) + breadcrumb SchoolNewR = return ("Neu" , Just SchoolListR) breadcrumb InfoR = return ("Information" , Nothing) breadcrumb InfoLecturerR = return ("Veranstalter" , Just InfoR) @@ -1996,6 +2000,14 @@ pageActions (HomeR) = ] pageActions (AdminR) = [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSchoolList + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute SchoolListR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + , MenuItem { menuItemType = PageActionPrime , menuItemLabel = MsgAdminFeaturesHeading , menuItemIcon = Nothing @@ -2028,6 +2040,16 @@ pageActions (AdminR) = , menuItemAccessCallback' = return True } ] +pageActions (SchoolListR) = + [ MenuItem + { menuItemType = PageActionPrime + , menuItemLabel = MsgMenuSchoolNew + , menuItemIcon = Nothing + , menuItemRoute = SomeRoute SchoolNewR + , menuItemModal = False + , menuItemAccessCallback' = return True + } + ] pageActions (UsersR) = [ MenuItem { menuItemType = PageActionPrime diff --git a/src/Handler/Course/Application/List.hs b/src/Handler/Course/Application/List.hs index a3faa9a89..b9dac3f39 100644 --- a/src/Handler/Course/Application/List.hs +++ b/src/Handler/Course/Application/List.hs @@ -525,6 +525,7 @@ postCApplicationsR tid ssh csh = do psValidator :: PSValidator _ _ psValidator = def + & defaultSorting [SortAscBy "user-name"] dbTableWidget' psValidator DBTable{..} diff --git a/src/Handler/School.hs b/src/Handler/School.hs index 9dad647e0..04eac6bc8 100644 --- a/src/Handler/School.hs +++ b/src/Handler/School.hs @@ -1,10 +1,133 @@ module Handler.School where import Import +import Handler.Utils +import Handler.Utils.Table.Columns + +import qualified Database.Esqueleto as E getSchoolListR :: Handler Html -getSchoolListR = error "getSchoolListR: Not implemented" +getSchoolListR = do + let + schoolLink :: SchoolId -> SomeRoute UniWorX + schoolLink ssh = SomeRoute $ SchoolShowR ssh + + dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _ + dbtSQLQuery = return -getSchoolShowR :: SchoolId -> Handler Html -getSchoolShowR = error "getSchoolShowR: Not implemented" + dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School)) + dbtProj = return + dbtRowKey = (E.^. SchoolId) + + dbtColonnade :: Colonnade Sortable _ _ + dbtColonnade = mconcat + [ colSchoolShort $ _dbrOutput . _entityKey + , anchorColonnade (views (_dbrOutput . _entityKey) schoolLink) $ colSchoolName (_dbrOutput . _entityVal . _schoolName) + ] + + dbtSorting = mconcat + [ sortSchoolShort $ to (E.^. SchoolId) + , sortSchoolName $ to (E.^. SchoolName) + ] + + dbtFilter = mempty + dbtFilterUI = mempty + + dbtStyle = def + dbtParams = def + + dbtCsvEncode = noCsvEncode + dbtCsvDecode = Nothing + + dbtIdent :: Text + dbtIdent = "schools" + + psValidator = def + & defaultSorting [SortAscBy "school-name"] + + + table <- runDB $ dbTableWidget' psValidator DBTable{..} + + let title = MsgMenuSchoolList + siteLayoutMsg title $ do + setTitleI title + table + +data SchoolForm = SchoolForm + { sfShorthand :: CI Text + , sfName :: CI Text + } + +mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm +mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm + <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort) + <*> areq ciField (fslI MsgSchoolName) (sfName <$> template) + +schoolToForm :: SchoolId -> DB (Form SchoolForm) +schoolToForm ssh = do + School{..} <- get404 ssh + return . mkSchoolForm (Just ssh) $ Just SchoolForm + { sfShorthand = schoolShorthand + , sfName = schoolName + } + + +getSchoolShowR, postSchoolShowR :: SchoolId -> Handler Html +getSchoolShowR = postSchoolShowR +postSchoolShowR ssh = do + sForm <- runDB $ schoolToForm ssh + + ((sfResult, sfView), sfEnctype) <- runFormPost sForm + + formResult sfResult $ \SchoolForm{..} -> do + runDB $ do + update ssh [ SchoolName =. sfName ] + addMessageI Success $ MsgSchoolUpdated ssh + redirect $ SchoolShowR ssh + + let sfView' = wrapForm sfView FormSettings + { formMethod = POST + , formAction = Just . SomeRoute $ SchoolShowR ssh + , formEncoding = sfEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Nothing :: Maybe Text + } + + siteLayoutMsg (MsgSchoolTitle ssh) $ do + setTitleI $ MsgSchoolTitle ssh + sfView' + +getSchoolNewR, postSchoolNewR :: Handler Html +getSchoolNewR = postSchoolNewR +postSchoolNewR = do + ((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing + + formResult sfResult $ \SchoolForm{..} -> do + let ssh = SchoolKey sfShorthand + insertOkay <- runDB $ do + fmap (is _Just) $ insertUnique School + { schoolShorthand = sfShorthand + , schoolName = sfName + } + + if + | insertOkay -> do + addMessageI Success $ MsgSchoolCreated ssh + redirect $ SchoolShowR ssh + | otherwise + -> addMessageI Error $ MsgSchoolExists ssh + + let sfView' = wrapForm sfView FormSettings + { formMethod = POST + , formAction = Just $ SomeRoute SchoolNewR + , formEncoding = sfEnctype + , formAttrs = [] + , formSubmit = FormSubmit + , formAnchor = Nothing :: Maybe Text + } + + siteLayoutMsg MsgTitleSchoolNew $ do + setTitleI MsgTitleSchoolNew + sfView' diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs index 3fe114257..595b5ebe8 100644 --- a/src/Handler/Utils/Table/Columns.hs +++ b/src/Handler/Utils/Table/Columns.hs @@ -102,8 +102,8 @@ fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) m -- Schools -- ------------- -colSchoolShort :: OpticColonnade SchoolId -colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body +colSchool :: OpticColonnade SchoolId +colSchool resultSsh = Colonnade.singleton (fromSortable header) body where header = Sortable (Just "school") (i18nCell MsgSchool) body = i18nCell . unSchoolKey . view resultSsh @@ -111,6 +111,24 @@ colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body sortSchool :: OpticSortColumn SchoolId sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh +colSchoolShort :: OpticColonnade SchoolId +colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "school-short") (i18nCell MsgSchoolShort) + body = i18nCell . unSchoolKey . view resultSsh + +sortSchoolShort :: OpticSortColumn SchoolId +sortSchoolShort querySsh = singletonMap "school-short" . SortColumn $ view querySsh + +colSchoolName :: OpticColonnade SchoolName +colSchoolName resultSn = Colonnade.singleton (fromSortable header) body + where + header = Sortable (Just "school-name") (i18nCell MsgSchoolName) + body = i18nCell . view resultSn + +sortSchoolName :: OpticSortColumn SchoolName +sortSchoolName querySn = singletonMap "school-name" . SortColumn $ view querySn + fltrSchool :: OpticFilterColumn t SchoolId fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh) diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index d72fdac3e..17159f659 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -167,6 +167,8 @@ makeLenses_ ''Allocation makeLenses_ ''File +makeLenses_ ''School + -- makeClassy_ ''Load