Merge branch 'master' into workflows

CHANGELOG.md

@@ -2,6 +2,27 @@
 
 All notable changes to this project will be documented in this file. See [standard-version](https://github.com/conventional-changelog/standard-version) for commit guidelines.
 
+### [20.8.1](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.8.0...v20.8.1) (2020-10-12)
+
+
+### Bug Fixes
+
+* **authorization:** have AllocationTime consider ParticipantState ([b69481e](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/b69481e88fb20890b4ece7a0023dcfdad21604d6))
+
+## [20.8.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.7.0...v20.8.0) (2020-10-10)
+
+
+### Features
+
+* **allocations:** csv-export new-assigned ([a4114a7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/a4114a79f1bfd968bb9d300f0c39400a8904ee7c))
+
+## [20.7.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.6.0...v20.7.0) (2020-10-10)
+
+
+### Features
+
+* **allocations:** include study features in users table ([7f7d2c7](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/commit/7f7d2c795767fd6fac1fa4a10a304e3e3d2280c3))
+
 ## [20.6.0](https://gitlab2.rz.ifi.lmu.de/uni2work/uni2work/compare/v20.5.1...v20.6.0) (2020-10-06)
 
 

messages/uniworx/de-de-formal.msg

@@ -2724,10 +2724,12 @@ CsvColumnAllocationUserSurname: Nachname(n) des Bewerbers
 CsvColumnAllocationUserFirstName: Vorname(n) des Bewerbers
 CsvColumnAllocationUserName: Voller Name des Bewerbers
 CsvColumnAllocationUserMatriculation: Matrikelnummer des Bewerber
+CsvColumnAllocationUserStudyFeatures: Studiendaten
 CsvColumnAllocationUserRequested: Maximale Anzahl von Plätzen, die der Bewerber bereit ist, zu akzeptieren
 CsvColumnAllocationUserApplied: Anzahl von Bewerbungen, die der Bewerber eingereicht hat
 CsvColumnAllocationUserVetos: Anzahl von Bewerbungen, die von Kursverwaltern ein Veto oder eine Note erhalten haben, die äquivalent ist zu "Nicht Bestanden" (5.0)
 CsvColumnAllocationUserAssigned: Anzahl von Plätzen, die der Bewerber durch diese Zentralanmeldung bereits erhalten hat
+CsvColumnAllocationUserNewAssigned: Anzahl von Plätzen, die der Bewerber, nach Akzeptieren der berechneten Verteilung, zusätzlich erhalten würde
 CsvColumnAllocationUserPriority: Zentrale Dringlichkeit des Bewerbers; entweder einzelne Zahl für Sortierungsbasierte Dringlichkeiten (höhere Dringlichkeit entspricht größerer Zahl) oder Komma-separierte Liste von numerischen Dringlichkeiten in eckigen Klammern (z.B. [1, 2, 3])
 AllocationUsersCsvName tid@TermId ssh@SchoolId ash@AllocationShorthand: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-bewerber
 

messages/uniworx/en-eu.msg

@@ -2697,10 +2697,12 @@ CsvColumnAllocationUserSurname: Applicant's surname(s)
 CsvColumnAllocationUserFirstName: Applicants's first name(s)
 CsvColumnAllocationUserName: Applicant's full name
 CsvColumnAllocationUserMatriculation: Applicant's matriculation
+CsvColumnAllocationUserStudyFeatures: Features of study
 CsvColumnAllocationUserRequested: Maximum number of placements the applicant is prepared to accept
 CsvColumnAllocationUserApplied: Number of applications the applicant has provided
 CsvColumnAllocationUserVetos: Number of applications that have received a veto from a course administrator or have been rated with a grade that is equivalent to "failed" (5.0)
 CsvColumnAllocationUserAssigned: Number of assignments the applicant has already received
+CsvColumnAllocationUserNewAssigned: Number of assignments the applicant would receive, if the calculated matching is accepted
 CsvColumnAllocationUserPriority: Central priority of this applicant; either a number based on the applicants position in the list sorted by priority (higher numbers mean a higher priority) or a comma-separated list of numerical priorities in square brackets (e.g. [1, 2, 3])
 AllocationUsersCsvName tid ssh ash: #{foldCase (termToText (unTermKey tid))}-#{foldedCase (unSchoolKey ssh)}-#{foldedCase ash}-applicants
 

package-lock.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "20.6.0",
+  "version": "20.8.1",
   "lockfileVersion": 1,
   "requires": true,
   "dependencies": {

package.json

@@ -1,6 +1,6 @@
 {
   "name": "uni2work",
-  "version": "20.6.0",
+  "version": "20.8.1",
   "description": "",
   "keywords": [],
   "author": "",

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 20.6.0
+version: 20.8.1
 
 dependencies:
   - base

src/Foundation/Authorization.hs

@@ -784,7 +784,7 @@ tagAccessPredicate AuthAllocationTime = APDB $ \mAuthId route _ -> case route of
       Nothing -> return Authorized
       Just (cid, Allocation{..}) -> do
         registered <- case mAuthId of
-          Just uid -> $cachedHereBinary (uid, cid) . existsBy $ UniqueParticipant uid cid
+          Just uid -> $cachedHereBinary (uid, cid) $ exists [ CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid, CourseParticipantState ==. CourseParticipantActive ]
           _        -> return False
         if
           | not registered

src/Handler/Allocation/Users.hs

@@ -10,6 +10,7 @@ import Handler.Allocation.Accept
 
 import Handler.Utils
 import Handler.Utils.Allocation
+import Handler.Utils.StudyFeatures
 
 import qualified Database.Esqueleto as E
 import qualified Database.Esqueleto.Utils as E
@@ -22,6 +23,8 @@ import qualified Data.Set as Set
 
 import Text.Blaze (toMarkup)
 
+import qualified Data.Conduit.Combinators as C
+
 
 type UserTableExpr = E.SqlExpr (Entity User)
        `E.InnerJoin` E.SqlExpr (Entity AllocationUser)
@@ -59,6 +62,7 @@ queryVetoedCourses = queryAllocationUser . to queryVetoedCourses'
 
 
 type UserTableData = DBRow ( Entity User
+                           , UserTableStudyFeatures
                            , Entity AllocationUser
                            , Int -- ^ Applied
                            , Int -- ^ Assigned
@@ -68,13 +72,16 @@ type UserTableData = DBRow ( Entity User
 resultUser :: Lens' UserTableData (Entity User)
 resultUser = _dbrOutput . _1
 
+resultStudyFeatures :: Lens' UserTableData UserTableStudyFeatures
+resultStudyFeatures = _dbrOutput . _2
+
 resultAllocationUser :: Lens' UserTableData (Entity AllocationUser)
-resultAllocationUser = _dbrOutput . _2
+resultAllocationUser = _dbrOutput . _3
 
 resultAppliedCourses, resultAssignedCourses, resultVetoedCourses :: Lens' UserTableData Int
-resultAppliedCourses  = _dbrOutput . _3
+resultAppliedCourses  = _dbrOutput . _4
-resultAssignedCourses = _dbrOutput . _4
+resultAssignedCourses = _dbrOutput . _5
-resultVetoedCourses = _dbrOutput . _5
+resultVetoedCourses = _dbrOutput . _6
 
 
 data AllocationUserTableCsv = AllocationUserTableCsv
@@ -82,10 +89,12 @@ data AllocationUserTableCsv = AllocationUserTableCsv
   , csvAUserFirstName     :: Text
   , csvAUserName          :: Text
   , csvAUserMatriculation :: Maybe Text
+  , csvAUserStudyFeatures :: UserTableStudyFeatures
   , csvAUserRequested
   , csvAUserApplied
   , csvAUserVetos
   , csvAUserAssigned      :: Natural
+  , csvAUserNewAssigned   :: Maybe Natural
   , csvAUserPriority      :: Maybe AllocationPriority
   } deriving (Generic)
 makeLenses_ ''AllocationUserTableCsv
@@ -94,10 +103,22 @@ allocationUserTableCsvOptions :: Csv.Options
 allocationUserTableCsvOptions = Csv.defaultOptions { Csv.fieldLabelModifier = camelToPathPiece' 3}
 
 instance Csv.ToNamedRecord AllocationUserTableCsv where
-  toNamedRecord = Csv.genericToNamedRecord allocationUserTableCsvOptions
+  toNamedRecord AllocationUserTableCsv{..} = Csv.namedRecord $
-
+    [ "surname"        Csv..= csvAUserSurname
-instance Csv.DefaultOrdered AllocationUserTableCsv where
+    , "first-name"     Csv..= csvAUserFirstName
-  headerOrder = Csv.genericHeaderOrder allocationUserTableCsvOptions
+    , "name"           Csv..= csvAUserName
+    , "matriculation"  Csv..= csvAUserMatriculation
+    , "study-features" Csv..= csvAUserStudyFeatures
+    , "requested"      Csv..= csvAUserRequested
+    , "applied"        Csv..= csvAUserApplied
+    , "vetos"          Csv..= csvAUserVetos
+    , "assigned"       Csv..= csvAUserAssigned
+    ] ++
+    [ "new-assigned"   Csv..= newAssigned
+    | newAssigned <- hoistMaybe csvAUserNewAssigned
+    ] ++
+    [ "priority"       Csv..= csvAUserPriority
+    ]
 
 instance CsvColumnsExplained AllocationUserTableCsv where
   csvColumnsExplanations = genericCsvColumnsExplanations allocationUserTableCsvOptions $ mconcat
@@ -105,13 +126,33 @@ instance CsvColumnsExplained AllocationUserTableCsv where
     , singletonMap 'csvAUserFirstName     MsgCsvColumnAllocationUserFirstName
     , singletonMap 'csvAUserName          MsgCsvColumnAllocationUserName
     , singletonMap 'csvAUserMatriculation MsgCsvColumnAllocationUserMatriculation
+    , singletonMap 'csvAUserStudyFeatures MsgCsvColumnAllocationUserStudyFeatures
     , singletonMap 'csvAUserRequested     MsgCsvColumnAllocationUserRequested
     , singletonMap 'csvAUserApplied       MsgCsvColumnAllocationUserApplied
     , singletonMap 'csvAUserVetos         MsgCsvColumnAllocationUserVetos
     , singletonMap 'csvAUserAssigned      MsgCsvColumnAllocationUserAssigned
+    , singletonMap 'csvAUserNewAssigned   MsgCsvColumnAllocationUserNewAssigned
     , singletonMap 'csvAUserPriority      MsgCsvColumnAllocationUserPriority
     ]
 
+userTableCsvHeader :: Bool -> Csv.Header
+userTableCsvHeader hasNewAssigned = Csv.header $
+  [ "surname"
+  , "first-name"
+  , "name"
+  , "matriculation"
+  , "study-features"
+  , "requested"
+  , "applied"
+  , "vetos"
+  , "assigned"
+  ] ++
+  [ "new-assigned"
+  | hasNewAssigned
+  ] ++
+  [ "priority"
+  ]
+
 
 getAUsersR, postAUsersR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
 getAUsersR = postAUsersR
@@ -148,13 +189,15 @@ postAUsersR tid ssh ash = do
                    , assigned
                    , vetoed)
           dbtRowKey = views queryAllocationUser (E.^. AllocationUserId)
-          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $
+          dbtProj = runReaderT $ (asks . set _dbrOutput) <=< magnify _dbrOutput $ do
-            (,,,,)
+            feats <- lift . allocationUserStudyFeatures aId =<< views _1 entityKey
-              <$> view _1 <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
+            (,,,,,)
+              <$> view _1 <*> pure feats <*> view _2 <*> view (_3 . _Value) <*> view (_4 . _Value) <*> view (_5 . _Value)
           dbtColonnade :: Colonnade Sortable _ _
           dbtColonnade = mconcat . catMaybes $
             [ pure $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
             , pure $ colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
+            , pure $ colStudyFeatures resultStudyFeatures
             , pure $ colAllocationRequested (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
             , pure . coursesModalApplied $ colAllocationApplied resultAppliedCourses
             , pure . coursesModalVetoed $ colAllocationVetoed resultVetoedCourses
@@ -253,16 +296,26 @@ postAUsersR tid ssh ash = do
           dbtParams = def
           dbtIdent :: Text
           dbtIdent = "allocation-users"
-          dbtCsvEncode = simpleCsvEncode csvName $ AllocationUserTableCsv
+          dbtCsvEncode = return DBTCsvEncode
-            <$> view (resultUser . _entityVal . _userSurname)
+            { dbtCsvExportForm = pure ()
-            <*> view (resultUser . _entityVal . _userFirstName)
+            , dbtCsvDoEncode = \() -> C.mapM $ \(_, row) -> flip runReaderT row $
-            <*> view (resultUser . _entityVal . _userDisplayName)
+                AllocationUserTableCsv
-            <*> view (resultUser . _entityVal . _userMatrikelnummer)
+                  <$> view (resultUser . _entityVal . _userSurname)
-            <*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
+                  <*> view (resultUser . _entityVal . _userFirstName)
-            <*> view (resultAppliedCourses . to fromIntegral)
+                  <*> view (resultUser . _entityVal . _userDisplayName)
-            <*> view (resultVetoedCourses . to fromIntegral)
+                  <*> view (resultUser . _entityVal . _userMatrikelnummer)
-            <*> view (resultAssignedCourses . to fromIntegral)
+                  <*> view  resultStudyFeatures
-            <*> view (resultAllocationUser . _entityVal . _allocationUserPriority)
+                  <*> view (resultAllocationUser . _entityVal . _allocationUserTotalCourses)
+                  <*> view (resultAppliedCourses . to fromIntegral)
+                  <*> view (resultVetoedCourses . to fromIntegral)
+                  <*> view (resultAssignedCourses . to fromIntegral)
+                  <*> views (resultUser . _entityKey) (\uid -> maybe 0 (fromIntegral . olength) . Map.lookup uid <$> allocMatching)
+                  <*> view (resultAllocationUser . _entityVal . _allocationUserPriority)
+            , dbtCsvName = unpack csvName
+            , dbtCsvNoExportData = Just id
+            , dbtCsvHeader = \_ -> return . userTableCsvHeader $ is _Just allocMatching
+            , dbtCsvExampleData = Nothing
+            }
           dbtCsvDecode = Nothing
       allocationUsersDBTableValidator = def
         & defaultSorting [SortAscBy "priority", SortAscBy "user-matriculation"]

src/Handler/Utils/StudyFeatures.hs

@@ -9,6 +9,7 @@ module Handler.Utils.StudyFeatures
   , isCourseStudyFeature, courseUserStudyFeatures
   , isExternalExamStudyFeature, externalExamUserStudyFeatures
   , isTermStudyFeature
+  , isAllocationStudyFeature, allocationUserStudyFeatures
   ) where
 
 import Import.NoFoundation
@@ -184,3 +185,24 @@ externalExamUserStudyFeatures eeId uid = do
 
 isTermStudyFeature :: E.SqlExpr (Entity Term) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
 isTermStudyFeature = isRelevantStudyFeatureCached TermId
+
+
+isAllocationStudyFeature :: E.SqlExpr (Entity Allocation) -> E.SqlExpr (Entity StudyFeatures) -> E.SqlExpr (E.Value Bool)
+isAllocationStudyFeature = isRelevantStudyFeatureCached AllocationTerm
+  
+allocationUserStudyFeatures :: MonadIO m => AllocationId -> UserId -> SqlPersistT m UserTableStudyFeatures
+allocationUserStudyFeatures aId uid = do
+  feats <- E.select . E.from $ \(allocation `E.InnerJoin` studyFeatures `E.InnerJoin` terms `E.InnerJoin` degree) -> do
+    E.on $ degree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
+    E.on $ terms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
+    E.on $ isAllocationStudyFeature allocation studyFeatures
+    E.where_ $ allocation E.^. AllocationId E.==. E.val aId
+    E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
+    return (terms, degree, studyFeatures)
+  return . UserTableStudyFeatures . Set.fromList . flip map feats $
+    \(Entity _ StudyTerms{..}, Entity _ StudyDegree{..}, Entity _ StudyFeatures{..}) -> UserTableStudyFeature
+      { userTableField = fromMaybe (tshow studyTermsKey) studyTermsName
+      , userTableDegree = fromMaybe (tshow studyDegreeKey) studyDegreeName
+      , userTableSemester = studyFeaturesSemester
+      , userTableFieldType = studyFeaturesType
+      }