Forms for terms added, but buggy

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 -- $@

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

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)
+            , sortable (Just "degree-name")  (i18nCell MsgDegreeName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyDegreeName))
-              (formCell id (return . view (_dbrOutput . _entityKey))
+            , sortable (Just "degree-short") (i18nCell MsgDegreeShort) (textInputCell _2 (_dbrOutput . _entityVal . _studyDegreeShorthand))
-                (\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)
-              ))
             ]
           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-name")  (i18nCell MsgStudyTermsName)  (textInputCell _1 (_dbrOutput . _entityVal . _studyTermsName))
-            , sortable (Just "studyterms-short") (i18nCell MsgStudyTermsShort) (foldMap textCell . view (_dbrOutput . _entityVal . _studyTermsShorthand))
+            , 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{..}
+      in dbTable psValidator DBTable{..}

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