Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

messages/uniworx/de.msg

@@ -65,8 +65,8 @@ CourseCapacity: Kapazität
 CourseCapacityTip: Anzahl erlaubter Kursanmeldungen, leer lassen für unbeschränkte Kurskapazität
 CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
 CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
-CourseRegisterOk: Sie wurden angemeldet
+CourseRegisterOk: Anmeldung erfolgreich
-CourseDeregisterOk: Sie wurden abgemeldet
+CourseDeregisterOk: Erfolgreich abgemeldet
 CourseStudyFeature: Assoziiertes Hauptfach
 CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
 CourseSecretWrong: Falsches Kennwort
@@ -112,6 +112,9 @@ CourseUserNote: Notiz
 CourseUserNoteTooltip: Nur für Dozenten dieses Kurses einsehbar
 CourseUserNoteSaved: Notizänderungen gespeichert
 CourseUserNoteDeleted: Teilnehmernotiz gelöscht
+CourseUserDeregister: Abmelden
+CourseUsersDeregistered count@Int64: #{show count} Teilnehmer abgemeldet
+
 CourseLecturers: Kursverwalter
 CourseLecturer: Dozent
 CourseAssistant: Assistent

routes

@@ -75,7 +75,7 @@
   /register                   CRegisterR          POST        !timeANDcapacity
   /edit                       CEditR          GET POST
   /delete                     CDeleteR        GET POST        !lecturerANDempty
-  /users                      CUsersR         GET
+  /users                      CUsersR         GET POST
   /users/#CryptoUUIDUser      CUserR          GET POST        !lecturerANDparticipant
   /correctors                 CHiWisR         GET
   /notes                      CNotesR         GET POST        !corrector

src/Database/Esqueleto/Utils.hs

@@ -5,8 +5,9 @@ module Database.Esqueleto.Utils
   , isInfixOf, hasInfix
   , any, all
   , SqlIn(..)
-  , mkExactFilter, mkContainsFilter
+  , mkExactFilter, mkExactFilterWith
-  , anyFilter
+  , mkContainsFilter
+  , anyFilter, allFilter
   ) where
 
 import ClassyPrelude.Yesod hiding (isInfixOf, any, all)
@@ -74,13 +75,22 @@ _queryFeaturesDegree  = $(sqlIJproj 3 2)
 --   Given a lens-like function, make filter for exact matches in a collection
 --   (Generalizing from Set to Foldable ok here, but gives ambigouus types elsewhere)
 mkExactFilter :: (PersistField a)
-  =>  (t -> E.SqlExpr (E.Value a)) -- ^ getter from query to searched element
+  => (t -> E.SqlExpr (E.Value a))  -- ^ getter from query to searched element
   -> t                             -- ^ query row
   -> Set.Set a                     -- ^ needle collection
   -> E.SqlExpr (E.Value Bool)
-mkExactFilter lenslike row criterias
+mkExactFilter = mkExactFilterWith id
+
+-- | like @mkExactFiler@ but allows for conversion; convenient in conjunction with @anyFilter@ and @allFilter@
+mkExactFilterWith :: (PersistField b)
+  => (a -> b)                      -- ^ type conversion
+  -> (t -> E.SqlExpr (E.Value b))  -- ^ getter from query to searched element
+  -> t                             -- ^ query row
+  -> Set.Set a                     -- ^ needle collection
+  -> E.SqlExpr (E.Value Bool)
+mkExactFilterWith cast lenslike row criterias
   | Set.null criterias = true
-  | otherwise = lenslike row `E.in_` E.valList (Set.toList criterias)
+  | otherwise = lenslike row `E.in_` E.valList (cast <$> Set.toList criterias)
 
 -- | generic filter creation for dbTable
 --   Given a lens-like function, make filter searching for needles in String-like elements
@@ -94,9 +104,22 @@ mkContainsFilter lenslike row criterias
   | Set.null criterias = true
   | otherwise = any (hasInfix $ lenslike row) criterias
 
-
+-- | Combine several filters, using logical or
-anyFilter :: (Foldable f) => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+anyFilter :: (Foldable f)
-                   -> t -> Set.Set Text-> E.SqlExpr (E.Value Bool)
+  => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+  -> t
+  -> Set.Set Text
+  -> E.SqlExpr (E.Value Bool)
 anyFilter fltrs needle criterias = F.foldr aux false fltrs
   where
-    aux fltr acc = fltr needle criterias E.||. acc
+    aux fltr acc = fltr needle criterias E.||. acc
+
+-- | Combine several filters, using logical and
+allFilter :: (Foldable f)
+  => f (t -> Set.Set Text-> E.SqlExpr (E.Value Bool))
+  -> t
+  -> Set.Set Text
+  -> E.SqlExpr (E.Value Bool)
+allFilter fltrs needle criterias = F.foldr aux true fltrs
+  where
+    aux fltr acc = fltr needle criterias E.&&. acc

src/Handler/Admin.hs

@@ -305,7 +305,6 @@ postAdminFeaturesR = do
         unless (null infRedundant) . addMessageI Info . MsgRedundantCandidatesRemoved $ length infRedundant
         let newKeys = map (StudyTermsKey' . fst) infAccepted
         setSessionJson sessionKeyNewStudyTerms newKeys
-        -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newKeys
         if  | null infAccepted
               -> addMessageI Info      MsgNoCandidatesInferred
             | otherwise
@@ -324,7 +323,6 @@ postAdminFeaturesR = do
       _other -> runDB Candidates.conflicts
 
     newStudyTermKeys <- fromMaybe [] <$> lookupSessionJson sessionKeyNewStudyTerms
-    -- addMessageI Error $ MsgPrintDebugForStupid $ tshow newStudyTermKeys
     (   (degreeResult,degreeTable)
       , (studyTermsResult,studytermsTable)
       , ((), candidateTable)) <- runDB $ (,,)

src/Handler/Course.hs

@@ -14,6 +14,7 @@ import Handler.Utils.Delete
 import Handler.Utils.Database
 import Handler.Utils.Table.Cells
 import Handler.Utils.Table.Columns
+import Database.Persist.Sql (deleteWhereCount)
 import qualified Database.Esqueleto.Utils as E
 import Database.Esqueleto.Utils.TH
 
@@ -705,7 +706,7 @@ validateCourse CourseForm{..} = do
   uid <- liftHandlerT requireAuthId
   userAdmin <- liftHandlerT . runDB . getBy $ UniqueUserAdmin uid cfSchool -- FIXME: This /needs/ to be a call to `isAuthorized` on a route
   MsgRenderer mr <- getMsgRenderer
-  
+
   return
     [ mr msg | (False, msg) <-
         [
@@ -819,57 +820,100 @@ colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell
 colUserDegreeShort = sortable (Just "degree-short") (i18nCell MsgStudyFeatureDegree) $
     foldMap (i18nCell . ShortStudyDegree) . preview (_userTableFeatures . _2 . _Just)
 
-makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget
-makeCourseUserTable cid colChoices psValidator =
-  -- -- psValidator has default sorting and filtering
-  let dbtIdent     = "courseUsers" :: Text
-      dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
-      dbtSQLQuery  = userTableQuery cid
-      dbtRowKey    = queryUser >>> (E.^. UserId)
-      dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
-      dbtColonnade = colChoices
-      dbtSorting   = Map.fromList
-        [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
-        , sortUserSurname     queryUser -- needed for initial sorting
-        , sortUserDisplayName queryUser -- needed for initial sorting
-        , sortUserEmail       queryUser
-        , sortUserMatriclenr  queryUser
-        , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
-        , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
-        , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
-        , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
-        , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-        , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
-        , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
-              E.sub_select . E.from $ \edit -> do
-                E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
-                return . E.max_ $ edit E.^. CourseUserNoteEditTime
-          )
-        ]
-      dbtFilter    = Map.fromList
-        [ fltrUserNameLink    queryUser
-        , fltrUserEmail       queryUser
-        , fltrUserMatriclenr  queryUser
-        , fltrUserNameEmail   queryUser
-        -- , ("course-user-degree", error "TODO") -- TODO
-        -- , ("course-user-field" , error "TODO") -- TODO
-        , ("course-user-semesternr", FilterColumn $ E.mkExactFilter $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
-        -- , ("course-registration", error "TODO") -- TODO
-        -- , ("course-user-note", error "TODO") -- TODO
-        ]
-      dbtFilterUI mPrev = mconcat
-        [ fltrUserNameEmailUI  mPrev
-        , fltrUserMatriclenrUI mPrev
-        ]
-      dbtParams    = def
-  in dbTableWidget' psValidator DBTable{..}
 
+data CourseUserAction = CourseUserDeregister
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
-getCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+instance Universe CourseUserAction
-getCUsersR tid ssh csh = do
+instance Finite CourseUserAction
-  (course, numParticipants, participantTable) <- runDB $ do
+nullaryPathPiece ''CourseUserAction $ camelToPathPiece' 2
+embedRenderMessage ''UniWorX ''CourseUserAction id
+
+makeCourseUserTable :: CourseId -> _ -> _ -> DB (FormResult (CourseUserAction, Set UserId), Widget)
+makeCourseUserTable cid colChoices psValidator = do
+    Just currentRoute <- liftHandlerT getCurrentRoute
+    -- -- psValidator has default sorting and filtering
+    let dbtIdent     = "courseUsers" :: Text
+        dbtStyle     = def { dbsFilterLayout = defaultDBSFilterLayout }
+        dbtSQLQuery  = userTableQuery cid
+        dbtRowKey    = queryUser >>> (E.^. UserId)
+        dbtProj      = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms))
+        dbtColonnade = colChoices
+        dbtSorting   = Map.fromList
+          [ sortUserNameLink    queryUser -- slower sorting through clicking name column header
+          , sortUserSurname     queryUser -- needed for initial sorting
+          , sortUserDisplayName queryUser -- needed for initial sorting
+          , sortUserEmail       queryUser
+          , sortUserMatriclenr  queryUser
+          , ("degree"      , SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeName))
+          , ("degree-short", SortColumn $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand))
+          , ("field"       , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsName))
+          , ("field-short" , SortColumn $ queryFeaturesField  >>> (E.?. StudyTermsShorthand))
+          , ("semesternr"  , SortColumn $ queryFeaturesStudy  >>> (E.?. StudyFeaturesSemester))
+          , ("registration", SortColumn $ queryParticipant    >>> (E.^. CourseParticipantRegistration))
+          , ("note"        , SortColumn $ queryUserNote >>> \note -> -- sort by last edit date
+                E.sub_select . E.from $ \edit -> do
+                  E.where_ $ note E.?. CourseUserNoteId E.==. E.just (edit E.^. CourseUserNoteEditNote)
+                  return . E.max_ $ edit E.^. CourseUserNoteEditTime
+            )
+          ]
+        dbtFilter    = Map.fromList
+          [ fltrUserNameLink    queryUser
+          , fltrUserEmail       queryUser
+          , fltrUserMatriclenr  queryUser
+          , fltrUserNameEmail   queryUser
+          , ("field-name"  , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsName))
+          , ("field-short" , FilterColumn $ E.mkContainsFilter $ queryFeaturesField >>> (E.?. StudyTermsShorthand))
+          , ("field-key"   , FilterColumn $ E.mkExactFilter    $ queryFeaturesField >>> (E.?. StudyTermsKey))
+          , ("field"       , FilterColumn $ E.anyFilter
+                                 [ E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsName)
+                                 , E.mkContainsFilter          $ queryFeaturesField >>> (E.?. StudyTermsShorthand)
+                                 , E.mkExactFilterWith readMay $ queryFeaturesField >>> (E.?. StudyTermsKey)
+                                 ] )
+          , ("degree"      , FilterColumn $ E.anyFilter
+                                 [ E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeName)
+                                 , E.mkContainsFilter          $ queryFeaturesDegree >>> (E.?. StudyDegreeShorthand)
+                                 , E.mkExactFilterWith readMay $ queryFeaturesDegree >>> (E.?. StudyDegreeKey)
+                                 ] )
+          , ("semesternr"  , FilterColumn $ E.mkExactFilter    $ queryFeaturesStudy >>> (E.?. StudyFeaturesSemester))
+          -- , ("course-registration", error "TODO") -- TODO
+          -- , ("course-user-note", error "TODO") -- TODO
+          ]
+        dbtFilterUI mPrev = mconcat
+          [ fltrUserNameEmailUI  mPrev
+          , fltrUserMatriclenrUI mPrev
+          , prismAForm (singletonFilter "degree") mPrev $ aopt (searchField False) (fslI MsgStudyFeatureDegree)
+          , prismAForm (singletonFilter "field")  mPrev $ aopt (searchField False) (fslI MsgCourseStudyFeature)
+          ]
+        dbtParams    = DBParamsForm
+          { dbParamsFormMethod = POST
+          , dbParamsFormAction = Just $ SomeRoute currentRoute
+          , dbParamsFormAttrs  = []
+          , dbParamsFormSubmit = FormSubmit
+          , dbParamsFormAdditional = \csrf -> do
+              (res,vw) <- mreq (selectField optionsFinite) "" Nothing
+              let formWgt = toWidget csrf <> fvInput vw
+                  formRes = (, mempty) . First . Just <$> res
+              return (formRes,formWgt)
+          , dbParamsFormEvaluate = liftHandlerT . runFormPost
+          , dbParamsFormResult   = id
+          , dbParamsFormIdent    = def
+          }
+    over _1 postprocess <$> dbTable psValidator DBTable{..}
+  where
+    postprocess :: FormResult (First CourseUserAction, DBFormResult UserId Bool  UserTableData) -> FormResult (CourseUserAction, Set UserId)
+    postprocess inp = do
+      (First (Just act), usrMap) <- inp
+      let usrSet = Map.keysSet . Map.filter id $ getDBFormResult (const False) usrMap
+      return (act, usrSet)
+
+getCUsersR, postCUsersR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
+getCUsersR = postCUsersR
+postCUsersR tid ssh csh = do
+  (Entity cid course, numParticipants, (participantRes,participantTable)) <- runDB $ do
     let colChoices  = mconcat
-          [ colUserNameLink (CourseR tid ssh csh . CUserR)
+          [ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
+          , colUserNameLink (CourseR tid ssh csh . CUserR)
           , colUserEmail
           , colUserMatriclenr
           , colUserDegreeShort
@@ -879,10 +923,18 @@ getCUsersR tid ssh csh = do
           , colUserComment tid ssh csh
           ]
         psValidator = def & defaultSortingByName
-    Entity cid course <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    ent@(Entity cid _) <- getBy404 $ TermSchoolCourseShort tid ssh csh
     numParticipants <- count [CourseParticipantCourse ==. cid]
-    participantTable <- makeCourseUserTable cid colChoices psValidator
+    table <- makeCourseUserTable cid colChoices psValidator
-    return (course, numParticipants, participantTable)
+    return (ent, numParticipants, table)
+  formResult participantRes $ \case
+    (CourseUserDeregister,selectedUsers) -> do
+        nrDel <- runDB $ deleteWhereCount
+          [ CourseParticipantCourse ==. cid
+          , CourseParticipantUser <-. Set.toList selectedUsers
+          ]
+        addMessageI Success $ MsgCourseUsersDeregistered nrDel
+        redirect $ CourseR tid ssh csh CUsersR
   let headingLong  = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|]
       headingShort = prependCourseTitle tid ssh csh MsgCourseMembers
   siteLayout headingLong $ do