diff --git a/db.sh b/db.sh index bb9685550..2e6f5026a 100755 --- a/db.sh +++ b/db.sh @@ -1,4 +1,4 @@ #!/usr/bin/env -S bash -xe - +# Options: see /test/Database.hs (Main) stack build --fast --flag uniworx:library-only --flag uniworx:dev stack exec uniworxdb -- $@ diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 1645c1da7..d92e4810a 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -419,8 +419,8 @@ DegreeShort: Abschlusskürzel StudyTermsKey: Schlüssel Studiengang StudyTermsName: Studiengang StudyTermsShort: Studiengangkürzel -StudyDegreeChangeSuccess: Abschlusszuordnungen wurden aktualisiert - +StudyTermsChangeSuccess: Zuordnung Abschlüsse aktualisiert +StudyDegreeChangeSuccess: Zuordnung Studiengänge aktualisiert MailTestFormEmail: Email-Addresse MailTestFormLanguages: Spracheinstellungen diff --git a/src/Handler/Admin.hs b/src/Handler/Admin.hs index 741e4b17e..da90c398f 100644 --- a/src/Handler/Admin.hs +++ b/src/Handler/Admin.hs @@ -166,7 +166,9 @@ postAdminErrMsgR = do getAdminFeaturesR, postAdminFeaturesR :: Handler Html getAdminFeaturesR = postAdminFeaturesR postAdminFeaturesR = do - ((degreeResult,degreeTable),studytermsTable,candidateTable) <- runDB $ (,,) + ( (degreeResult,degreeTable) + , (studyTermsResult,studytermsTable) + , ((),candidateTable)) <- runDB $ (,,) <$> mkDegreeTable <*> mkStudytermsTable <*> mkCandidateTable @@ -181,6 +183,16 @@ postAdminFeaturesR = do void . runDB $ Map.traverseWithKey updateDegree res addMessageI Success MsgStudyDegreeChangeSuccess + let studyTermsResult' :: FormResult (Map (Key StudyTerms) (Maybe Text, Maybe Text)) + studyTermsResult' = studyTermsResult <&> getDBFormResult + (\row -> ( row ^. _dbrOutput . _entityVal . _studyTermsName + , row ^. _dbrOutput . _entityVal . _studyTermsShorthand + )) + updateStudyTerms studyTermsKey (name,short) = update studyTermsKey [StudyTermsName =. name, StudyTermsShorthand =. short] + formResult studyTermsResult' $ \res -> do + void . runDB $ Map.traverseWithKey updateStudyTerms res + addMessageI Success MsgStudyTermsChangeSuccess + siteLayoutMsg MsgAdminFeaturesHeading $ do setTitleI MsgAdminFeaturesHeading [whamlet| @@ -195,6 +207,12 @@ postAdminFeaturesR = do ^{candidateTable} |] where + textInputCell lensRes lensDefault = formCell id (return . view (_dbrOutput . _entityKey)) + (\row _mkUnique -> (\(res,fieldView) -> (set lensRes <$> res, fvInput fieldView)) + <$> mopt textField "" (Just $ row ^. lensDefault) + ) + + mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget) mkDegreeTable = let dbtIdent = "admin-studydegrees" :: Text @@ -203,20 +221,10 @@ postAdminFeaturesR = do dbtSQLQuery = return dbtRowKey = (E.^. StudyDegreeKey) dbtProj = return - dbtColonnade = mconcat + dbtColonnade = formColonnade $ mconcat [ sortable (Just "degree-key") (i18nCell MsgDegreeKey) (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey)) - , sortable (Just "degree-name") (i18nCell MsgDegreeName) - (formCell id (return . view (_dbrOutput . _entityKey)) - (\row _mkUnique -> - (\(res,nameview) -> (set _1 <$> res, fvInput nameview)) <$> - mopt textField "" (Just $ row ^. _dbrOutput . _entityVal . _studyDegreeName) - )) - , sortable (Just "degree-short") (i18nCell MsgDegreeShort) - (formCell id (return . view (_dbrOutput . _entityKey)) - (\row _mkUnique -> - (\(res,shortview) -> (set _2 <$> res, fvInput shortview)) <$> - mopt textField "" (Just $ row ^. _dbrOutput . _entityVal . _studyDegreeShorthand) - )) + , sortable (Just "degree-name") (i18nCell MsgDegreeName) (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName)) + , sortable (Just "degree-short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand)) ] dbtSorting = Map.fromList [ ("degree-key" , SortColumn (E.^. StudyDegreeKey)) @@ -225,10 +233,11 @@ postAdminFeaturesR = do ] dbtFilter = mempty dbtFilterUI = mempty - dbtParams = def { dbParamsFormAddSubmit = True } + dbtParams = def { dbParamsFormAddSubmit = True } -- dbParamsFormEvaluate = liftHandlerT . (runFormPost . identifyForm "degree-table" - (identForm FIDdegree))} psValidator = def & defaultSorting [SortAscBy "degree-name", SortAscBy "degree-short", SortAscBy "degree-key"] in dbTable psValidator DBTable{..} + mkStudytermsTable :: DB (FormResult (DBFormResult (Key StudyTerms) (Maybe Text, Maybe Text) (DBRow (Entity StudyTerms))), Widget) mkStudytermsTable = let dbtIdent = "admin-studyterms" :: Text dbtStyle = def @@ -236,10 +245,10 @@ postAdminFeaturesR = do dbtSQLQuery = return dbtRowKey = (E.^. StudyTermsKey) dbtProj = return - dbtColonnade = mconcat + dbtColonnade = formColonnade $ mconcat [ sortable (Just "studyterms-key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermsKey)) - , sortable (Just "studyterms-name") (i18nCell MsgStudyTermsName) (foldMap textCell . view (_dbrOutput . _entityVal . _studyTermsName)) - , sortable (Just "studyterms-short") (i18nCell MsgStudyTermsShort) (foldMap textCell . view (_dbrOutput . _entityVal . _studyTermsShorthand)) + , sortable (Just "studyterms-name") (i18nCell MsgStudyTermsName) (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName)) + , sortable (Just "studyterms-short") (i18nCell MsgStudyTermsShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyTermsShorthand)) ] dbtSorting = Map.fromList [ ("studyterms-key" , SortColumn (E.^. StudyTermsKey)) @@ -248,9 +257,9 @@ postAdminFeaturesR = do ] dbtFilter = mempty dbtFilterUI = mempty - dbtParams = def + dbtParams = def { dbParamsFormAddSubmit = True } -- , dbParamsFormEvaluate = liftHandlerT . runFormPost } psValidator = def & defaultSorting [SortAscBy "studyterms-name", SortAscBy "studyterms-short", SortAscBy "studyterms-key"] - in dbTableWidget' psValidator DBTable{..} + in dbTable psValidator DBTable{..} mkCandidateTable = let dbtIdent = "admin-termcandidate" :: Text @@ -259,7 +268,7 @@ postAdminFeaturesR = do dbtSQLQuery = return dbtRowKey = (E.^. StudyTermCandidateId) dbtProj = return - dbtColonnade = mconcat + dbtColonnade = dbColonnade $ mconcat [ sortable (Just "termcandidate-key") (i18nCell MsgStudyTermsKey) (numCell . view (_dbrOutput . _entityVal . _studyTermCandidateKey)) , sortable (Just "termcandidate-name") (i18nCell MsgStudyTermsName) (textCell . view (_dbrOutput . _entityVal . _studyTermCandidateName)) , sortable (Just "termcandidate-incidence") (i18nCell MsgStudyTermsShort) (pathPieceCell . view (_dbrOutput . _entityVal . _studyTermCandidateIncidence)) @@ -273,4 +282,4 @@ postAdminFeaturesR = do dbtFilterUI = mempty dbtParams = def psValidator = def & defaultSorting [SortAscBy "termcandidate-name", SortAscBy "termcandidate-key"] - in dbTableWidget' psValidator DBTable{..} \ No newline at end of file + in dbTable psValidator DBTable{..} \ No newline at end of file diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index d832b868b..d4b9e5249 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -45,6 +45,11 @@ htmlCell = cell . toWidget . toMarkup pathPieceCell :: (IsDBTable m a, PathPiece p) => p -> DBCell m a pathPieceCell = cell . toWidget . toPathPiece +-- | execute a DB action that return a widget for the cell contents +sqlCell :: (IsDBTable (YesodDB UniWorX) a) => YesodDB UniWorX Widget -> DBCell (YesodDB UniWorX) a +sqlCell act = mempty & cellContents .~ lift act + + --------------------- -- Icon cells