Form for Degrees changes implemented

messages/uniworx/de.msg

@@ -419,6 +419,8 @@ DegreeShort: Abschlusskürzel
 StudyTermsKey: Schlüssel Studiengang
 StudyTermsName: Studiengang
 StudyTermsShort: Studiengangkürzel
+StudyDegreeChangeSuccess: Abschlusszuordnungen wurden aktualisiert
+
 
 MailTestFormEmail: Email-Addresse
 MailTestFormLanguages: Spracheinstellungen

routes

@@ -39,7 +39,7 @@
 /users/#CryptoUUIDUser        AdminUserR        GET POST      !development
 /users/#CryptoUUIDUser/hijack AdminHijackUserR  POST          !adminANDno-escalation
 /admin/test                   AdminTestR        GET POST
-/admin/features               AdminFeaturesR    GET --POST    
+/admin/features               AdminFeaturesR    GET POST
 /admin/errMsg                 AdminErrMsgR      GET POST
 
 /info                         InfoR             GET            !free

src/Handler/Admin.hs

@@ -163,13 +163,24 @@ postAdminErrMsgR = do
 
 
 
-getAdminFeaturesR :: Handler Html
-getAdminFeaturesR = do
-    (degreeTable,studytermsTable,candidateTable) <- runDB $ (,,)
+getAdminFeaturesR, postAdminFeaturesR :: Handler Html
+getAdminFeaturesR = postAdminFeaturesR
+postAdminFeaturesR = do
+    ((degreeResult,degreeTable),studytermsTable,candidateTable) <- runDB $ (,,)
       <$> mkDegreeTable
       <*> mkStudytermsTable
       <*> mkCandidateTable
 
+    let degreeResult' :: FormResult (Map (Key StudyDegree) (Maybe Text, Maybe Text))
+        degreeResult' = degreeResult <&> getDBFormResult
+          (\row -> ( row ^. _dbrOutput . _entityVal . _studyDegreeName
+                   , row ^. _dbrOutput . _entityVal . _studyDegreeShorthand
+          ))
+        updateDegree degreeKey (name,short) = update degreeKey [StudyDegreeName =. name, StudyDegreeShorthand =. short]
+    formResult degreeResult' $ \res -> do
+      void . runDB $ Map.traverseWithKey updateDegree res
+      addMessageI Success MsgStudyDegreeChangeSuccess
+
     siteLayoutMsg MsgAdminFeaturesHeading $ do
       setTitleI MsgAdminFeaturesHeading
       [whamlet|
@@ -184,6 +195,7 @@ getAdminFeaturesR = do
             ^{candidateTable}
       |]
   where
+    mkDegreeTable :: DB (FormResult (DBFormResult (Key StudyDegree) (Maybe Text, Maybe Text) (DBRow (Entity StudyDegree))), Widget)
     mkDegreeTable =
       let dbtIdent      = "admin-studydegrees" :: Text
           dbtStyle      = def
@@ -193,8 +205,18 @@ getAdminFeaturesR = do
           dbtProj       = return
           dbtColonnade  = mconcat
             [ sortable (Just "degree-key")   (i18nCell MsgDegreeKey)   (numCell . view (_dbrOutput . _entityVal . _studyDegreeKey))
-            , sortable (Just "degree-name")  (i18nCell MsgDegreeName)  (foldMap textCell . view (_dbrOutput . _entityVal . _studyDegreeName))
-            , sortable (Just "degree-short") (i18nCell MsgDegreeShort) (foldMap textCell . view (_dbrOutput . _entityVal . _studyDegreeShorthand))
+            , 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)
+              ))
             ]
           dbtSorting    = Map.fromList
             [ ("degree-key"  , SortColumn (E.^. StudyDegreeKey))
@@ -203,9 +225,9 @@ getAdminFeaturesR = do
             ]
           dbtFilter     = mempty
           dbtFilterUI   = mempty
-          dbtParams     = def
+          dbtParams     = def { dbParamsFormAddSubmit = True }
           psValidator   = def & defaultSorting [SortAscBy "degree-name", SortAscBy "degree-short", SortAscBy "degree-key"]
-      in dbTableWidget' psValidator DBTable{..}
+      in dbTable psValidator DBTable{..}
 
     mkStudytermsTable =
       let dbtIdent      = "admin-studyterms" :: Text

src/Handler/Course.hs

@@ -787,7 +787,7 @@ makeCourseUserTable cid colChoices psValidator =
         -- , ("course-user-note", error "TODO") -- TODO
         ]
       dbtFilterUI mPrev = mconcat
-        [ fltrUserNameEmailUI   mPrev
+        [ fltrUserNameEmailUI  mPrev
         , fltrUserMatriclenrUI mPrev
         ]
       dbtParams    = def

src/Handler/Utils/Table/Pagination.hs

@@ -844,11 +844,11 @@ instance Ord i => Monoid (DBFormResult i a r) where
 getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult i a r -> Map i a
 getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
 
-formCell :: forall res r i a. (Ord i, Monoid res)
-         => Lens' res (FormResult (DBFormResult i a (DBRow r)))
-         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
+formCell :: forall x r i a. (Ord i, Monoid x)
+         => Lens' x (FormResult (DBFormResult i a (DBRow r)))   -- ^ lens focussing on the form result within the larger DBResult; @id@ iff the form delivers the only result of the table
+         -> (DBRow r -> MForm (HandlerT UniWorX IO) i)          -- ^ generate row identfifiers for use in form result
          -> (DBRow r -> (forall p. PathPiece p => p -> Text) -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget)) -- ^ Given the row data and a callback to make an input name suitably unique generate the `MForm`
-         -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) res)
+         -> (DBRow r -> DBCell (MForm (HandlerT UniWorX IO)) x)
 formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
   { formCellAttrs    = []
   , formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
@@ -871,11 +871,11 @@ formCell formCellLens genIndex genForm input@(DBRow{dbrKey}) = FormCell
 dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
 dbRow = Colonnade.singleton (headednessPure $ i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
 
-dbSelect :: forall res h r i a. (Headedness h, Ord i, PathPiece i, Monoid res)
-         => Lens' res (FormResult (DBFormResult i a (DBRow r)))
+dbSelect :: forall x h r i a. (Headedness h, Ord i, PathPiece i, Monoid x)
+         => Lens' x (FormResult (DBFormResult i a (DBRow r)))
          -> Setter' a Bool
          -> (DBRow r -> MForm (HandlerT UniWorX IO) i)
-         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) res)
+         -> Colonnade h (DBRow r) (DBCell (MForm (HandlerT UniWorX IO)) x)
 dbSelect resLens selLens genIndex = Colonnade.singleton (headednessPure $ i18nCell MsgSelectColumn) $ formCell resLens genIndex genForm
   where
     genForm _ mkUnique = do