fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fix(exam import): inactive registered features may be selected

Browse Source
This commit is contained in:
Steffen Jost 2019-08-20 14:10:09 +02:00
parent 440f0a97d0
commit 3c4172cbc2
2 changed files with 24 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
src/Handler/Exam/Users.hs
View File

@ -16,18 +16,18 @@ import Handler.Utils.Csv
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Database.Esqueleto.Utils.TH import Database.Esqueleto.Utils.TH
import qualified Data.Csv as Csv import qualified Data.Csv as Csv
import Data.Map ((!)) import Data.Map ((!))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set import qualified Data.Set as Set
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Lens as Text import qualified Data.Text.Lens as Text
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Numeric.Lens (integral) import Numeric.Lens (integral)
@ -320,7 +320,7 @@ postEUsersR tid ssh csh examn = do
criteria'' criteria''
| ExamAttended (ExamPassed True) `Set.member` criteria | ExamAttended (ExamPassed True) `Set.member` criteria
= criteria' `Set.union` Set.fromList passed = criteria' `Set.union` Set.fromList passed
| otherwise | otherwise
= criteria' = criteria'
in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'') in queryExamResult row E.?. ExamResultResult `E.in_` E.valList (Just <$> Set.toList criteria'')
) )
@ -431,7 +431,7 @@ postEUsersR tid ssh csh examn = do
ExamUserCsvCourseRegister -> DBCsvActionNew ExamUserCsvCourseRegister -> DBCsvActionNew
ExamUserCsvRegister -> DBCsvActionNew ExamUserCsvRegister -> DBCsvActionNew
ExamUserCsvDeregister -> DBCsvActionMissing ExamUserCsvDeregister -> DBCsvActionMissing
_other -> DBCsvActionExisting _other -> DBCsvActionExisting
, dbtCsvExecuteActions = do , dbtCsvExecuteActions = do
C.mapM_ $ \case C.mapM_ $ \case
ExamUserCsvCourseRegisterData{..} -> do ExamUserCsvCourseRegisterData{..} -> do
@ -496,7 +496,7 @@ postEUsersR tid ssh csh examn = do
ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do ExamUserCsvSetCourseNoteData{ examUserCsvActCourseNote = Just note, .. } -> do
now <- liftIO getCurrentTime now <- liftIO getCurrentTime
uid <- liftHandlerT requireAuthId uid <- liftHandlerT requireAuthId
Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ] Entity nid _ <- upsert (CourseUserNote examCourse examUserCsvActUser note) [ CourseUserNoteNote =. note ]
insert_ $ CourseUserNoteEdit uid now nid insert_ $ CourseUserNoteEdit uid now nid
return $ CExamR tid ssh csh examn EUsersR return $ CExamR tid ssh csh examn EUsersR
, dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case , dbtCsvRenderKey = \(registeredUserName -> registeredUserName') -> \case
@ -579,12 +579,12 @@ postEUsersR tid ssh csh examn = do
$newline never $newline never
_{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester} _{StudyDegreeTerm degree terms}, _{MsgStudyFeatureAge} #{studyFeaturesSemester}
|] |]
registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget registeredUserName :: Map (E.Value ExamRegistrationId) ExamUserTableData -> ExamRegistrationId -> Widget
registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname registeredUserName existing (E.Value -> registration) = nameWidget userDisplayName userSurname
where where
Entity _ User{..} = view resultUser $ existing ! registration Entity _ User{..} = view resultUser $ existing ! registration
guessUser :: ExamUserTableCsv -> DB (Bool, UserId) guessUser :: ExamUserTableCsv -> DB (Bool, UserId)
guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do guessUser ExamUserTableCsv{..} = $cachedHereBinary (csvEUserMatriculation, csvEUserName, csvEUserSurname) $ do
users <- E.select . E.from $ \user -> do users <- E.select . E.from $ \user -> do
@ -620,7 +620,7 @@ postEUsersR tid ssh csh examn = do
studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do studyFeatures <- E.select . E.from $ \(studyFeatures `E.InnerJoin` studyDegree `E.InnerJoin` studyTerms) -> do
E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField E.on $ studyTerms E.^. StudyTermsId E.==. studyFeatures E.^. StudyFeaturesField
E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree E.on $ studyDegree E.^. StudyDegreeId E.==. studyFeatures E.^. StudyFeaturesDegree
E.where_ . E.and $ catMaybes E.where_ . E.and $ catMaybes
[ do [ do
field <- csvEUserField field <- csvEUserField
return . E.or $ catMaybes return . E.or $ catMaybes
@ -638,8 +638,13 @@ postEUsersR tid ssh csh examn = do
, (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester , (studyFeatures E.^. StudyFeaturesSemester E.==.) . E.val <$> csvEUserSemester
] ]
E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid E.where_ $ studyFeatures E.^. StudyFeaturesUser E.==. E.val uid
E.&&. studyFeatures E.^. StudyFeaturesValid E.==. E.val True let isCourseParticipantFeature = E.exists $ E.from $ \courseParticipant -> do
E.limit 2 E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val examCourse
E.where_ $ courseParticipant E.^. CourseParticipantUser E.==. E.val uid
E.where_ $ courseParticipant E.^. CourseParticipantField E.==. E.just (studyFeatures E.^. StudyFeaturesId)
E.where_ $ (studyFeatures E.^. StudyFeaturesValid E.==. E.val True)
E.||. isCourseParticipantFeature -- either active studyFeature or the one previously associated with the course
E.limit 2 -- we just need to know whether there is a unique one, none, or more than one
return $ studyFeatures E.^. StudyFeaturesId return $ studyFeatures E.^. StudyFeaturesId
case studyFeatures of case studyFeatures of
[E.Value fid] -> return $ Just fid [E.Value fid] -> return $ Just fid

12
stack.yaml.lock
View File

@ -10,13 +10,13 @@ packages:
sha256: 2cab90bba4d15bf6a17e3cb8e50bc8708c1091de503dd4e91d3954240e89f37b sha256: 2cab90bba4d15bf6a17e3cb8e50bc8708c1091de503dd4e91d3954240e89f37b
name: zip-stream name: zip-stream
version: 0.1.0.1 version: 0.1.0.1
git: https://github.com/pngwjpgh/zip-stream.git git: https://github.com/uni2work/zip-stream.git
pantry-tree: pantry-tree:
size: 657 size: 657
sha256: d1626bbc3fb88a48ce9c5c37199f8cbf426be6410740891d76a8343de4f3c109 sha256: d1626bbc3fb88a48ce9c5c37199f8cbf426be6410740891d76a8343de4f3c109
commit: 9272bbed000928d500febad1cdc98d1da29d399e commit: 9272bbed000928d500febad1cdc98d1da29d399e
original: original:
git: https://github.com/pngwjpgh/zip-stream.git git: https://github.com/uni2work/zip-stream.git
commit: 9272bbed000928d500febad1cdc98d1da29d399e commit: 9272bbed000928d500febad1cdc98d1da29d399e
- completed: - completed:
cabal-file: cabal-file:
@ -24,13 +24,13 @@ packages:
sha256: 88537113b855381b8d70da2442ae644dc979ad6b32aaaec2ebf55306764c8f1a sha256: 88537113b855381b8d70da2442ae644dc979ad6b32aaaec2ebf55306764c8f1a
name: encoding name: encoding
version: 0.8.2 version: 0.8.2
git: https://github.com/pngwjpgh/encoding.git git: https://github.com/uni2work/encoding.git
pantry-tree: pantry-tree:
size: 5668 size: 5668
sha256: 57160d758802aba6a0d2cc88c53f2f0bb60df7d5e6822938351618b7eca0beab sha256: 57160d758802aba6a0d2cc88c53f2f0bb60df7d5e6822938351618b7eca0beab
commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
original: original:
git: https://github.com/pngwjpgh/encoding.git git: https://github.com/uni2work/encoding.git
commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84 commit: 67bb87ceff53f0178c988dd4e15eeb2daee92b84
- completed: - completed:
cabal-file: cabal-file:
@ -38,13 +38,13 @@ packages:
sha256: 7b25a0ef819e8a01b485d6d0865baa3445faa826ffb3876c94109dd2469ffbd3 sha256: 7b25a0ef819e8a01b485d6d0865baa3445faa826ffb3876c94109dd2469ffbd3
name: memcached-binary name: memcached-binary
version: 0.2.0 version: 0.2.0
git: https://github.com/pngwjpgh/memcached-binary.git git: https://github.com/uni2work/memcached-binary.git
pantry-tree: pantry-tree:
size: 1170 size: 1170
sha256: c466f91129410bae1f53e25aec4026f6984ce2dff0ada4516e2548048aba549a sha256: c466f91129410bae1f53e25aec4026f6984ce2dff0ada4516e2548048aba549a
commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
original: original:
git: https://github.com/pngwjpgh/memcached-binary.git git: https://github.com/uni2work/memcached-binary.git
commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad commit: b5461747e7be226d3b67daebc3c9aefe8a4490ad
- completed: - completed:
hackage: colonnade-1.2.0@sha256:5620e999a68a394abfe157da6302dd6d8ce8a89b527ea9c294519efd7c4edb2c,2092 hackage: colonnade-1.2.0@sha256:5620e999a68a394abfe157da6302dd6d8ce8a89b527ea9c294519efd7c4edb2c,2092