fix(course): fix #148 course qualification ordering

some refactoring done along the way, fixing a bug in relation to #150 as well

src/Handler/Course/Edit.hs

@@ -92,16 +92,8 @@ makeCourseForm miButtonAction template = identifyForm FIDcourse . validateFormDB
       oldSchool <- forM (cfCourseId =<< template) $ fmap courseSchool . getJust
       let elegibleSchools = Set.fromList $ lecturerSchools ++ adminSchools
           userSchools = Set.toList $ maybe id Set.insert oldSchool elegibleSchools
-          q2opt :: Entity Qualification -> Option QualificationId
-          q2opt (Entity qid Qualification{..}) =
-            let qsh = CI.original $ unSchoolKey qualificationSchool
-            in  Option{ optionDisplay       =        CI.original qualificationName      <> " ("  <> qsh <> ")"
-                      , optionExternalValue = "(" <> CI.original qualificationShorthand <> "___" <> qsh <> ")"
-                      , optionInternalValue = qid
-                      }
       elegibleQualifications <- selectList [QualificationSchool <-. Set.toList elegibleSchools] [Asc QualificationName, Asc QualificationSchool]
-      return (userSchools, mkOptionList (map q2opt elegibleQualifications))
+      return (userSchools, qualificationsOptionList elegibleQualifications)
-
 
     (termsField, userTerms) <- liftHandler $ case template of
       -- Change of term is only allowed if user may delete the course (i.e. no participants) or admin
@@ -469,10 +461,15 @@ upsertCourseQualifications :: UserId -> CourseId -> [(QualificationId, Int)] ->
 upsertCourseQualifications uid cid qualis = do
   let newQualis = Map.fromList qualis
   oldQualis <- Map.fromDistinctAscList . fmap (\Entity{entityKey=k, entityVal=CourseQualification{..}} -> (courseQualificationQualification, (k, courseQualificationSortOrder)))
-                <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationSortOrder]
+                <$> selectList [CourseQualificationCourse ==. cid] [Asc CourseQualificationQualification]
   -- NOTE: CourseQualification allow the immediate assignment of these qualifications to any enrolled user. Hence SchoolAdmins must not be allowed to assign school-foreign qualifications, see #150
   okSchools <- Set.fromDistinctAscList . fmap (userFunctionSchool . entityVal)
                 <$> selectList [UserFunctionUser ==. uid, UserFunctionFunction <-. [SchoolAdmin, SchoolLecturer]] [Asc UserFunctionSchool]
+  {- Some debugging due to an error caused by using fromDistinctAscList with violated precondition:
+  $logErrorS "CourseQuali" $ "OLD  Course Qualifications:" <> tshow oldQualis
+  $logErrorS "CourseQuali" $ "NEW  Course Qualifications:" <> tshow newQualis
+  $logErrorS "CourseQuali" $ "DIFF Course Qualifications:" <> tshow (newQualis Map.\\ oldQualis)
+  -}
   foldWithKeyMapM oldQualis $ \qu (k, so_old) -> case Map.lookup qu newQualis of
         Just so_new | so_new /= so_old
                 -> update k [CourseQualificationSortOrder =. so_new] -- existing CourseQualifications may be re-ordered, regardless of school association

src/Handler/Tutorial/Users.hs

@@ -50,7 +50,7 @@ data TutorialUserActionData
   | TutorialUserGrantQualificationData
     { tuQualification :: QualificationId
     , tuValidUntil    :: Day
-    }    
+    }
   | TutorialUserSendMailData
   | TutorialUserDeregisterData{}
   deriving (Eq, Ord, Read, Show, Generic)
@@ -62,7 +62,7 @@ postTUsersR tid ssh csh tutn = do
   isAdmin <- hasReadAccessTo AdminR
   (Entity tutid tut@Tutorial{..}, (participantRes, participantTable), qualifications) <- runDB $ do
     cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
-    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn    
+    tutEnt@(Entity tutid _) <- fetchTutorial tid ssh csh tutn
     qualifications <- getCourseQualifications cid
     now <- liftIO getCurrentTime
     let nowaday = utctDay now
@@ -70,7 +70,7 @@ postTUsersR tid ssh csh tutn = do
         dayExpiry = flip addGregorianDurationClip nowaday . fromMonths <$> minDur
         colChoices  = mconcat $ catMaybes
           [ pure $ dbSelect (applying _2) id (return . view (hasEntity . _entityKey))
-          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR          
+          , pure $ colUserNameModalHdr MsgTableCourseMembers ForProfileDataR
           , pure   colUserEmail
           , pure $ colUserMatriclenr isAdmin
           , pure $ colUserQualifications nowaday
@@ -80,34 +80,27 @@ postTUsersR tid ssh csh tutn = do
           & defaultSortingByName
           & restrictSorting (\name _ -> none (== name) ["note", "registration", "tutorials", "exams", "submission-group", "state"]) -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
           & restrictFilter  (\name _ -> none (== name) ["tutorial", "exam", "submission-group", "active", "has-personalised-sheet-files"])
-        isInTut q = E.exists $ do 
+        isInTut q = E.exists $ do
           tutorialParticipant <- E.from $ E.table @TutorialParticipant
           E.where_ $ tutorialParticipant E.^. TutorialParticipantUser E.==. queryUser q E.^. UserId
                E.&&. tutorialParticipant E.^. TutorialParticipantTutorial E.==. E.val tutid
         csvColChoices = flip elem ["name", "matriculation", "email", "qualifications"]
-    
+
-    let      
+        qualOptions = qualificationsOptionList qualifications
-      qualOpt :: Entity Qualification -> Handler (Option QualificationId)
+    let
-      qualOpt (Entity qualId qual) = do
-        cQualId :: CryptoUUIDQualification <- encrypt qualId
-        return $ Option
-          { optionDisplay       = CI.original $ qualificationName qual
-          , optionInternalValue = qualId
-          , optionExternalValue = tshow cQualId
-          }
       acts :: Map TutorialUserAction (AForm Handler TutorialUserActionData)
       acts = Map.fromList $
         (if null qualifications then mempty else
           [ ( TutorialUserRenewQualification
             , TutorialUserRenewQualificationData
-              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing            
+              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
             )
           , ( TutorialUserGrantQualification
             , TutorialUserGrantQualificationData
-              <$> apopt (selectField . fmap mkOptionList $ mapM qualOpt qualifications) (fslI MsgQualificationName) Nothing
+              <$> apopt (selectField $ pure qualOptions) (fslI MsgQualificationName) Nothing
               <*> apopt dayField (fslI MsgLmsQualificationValidUntil) dayExpiry
-            )                     
+            )
-          ] 
+          ]
         ) ++
         [ ( TutorialUserSendMail          , pure TutorialUserSendMailData           )
         , ( TutorialUserDeregister        , pure TutorialUserDeregisterData         )
@@ -122,20 +115,20 @@ postTUsersR tid ssh csh tutn = do
         rcvr <- requireAuth
         encRcvr <- encrypt $ entityKey rcvr
         letters <- runDB $ makeCourseCertificates tut Nothing $ toList selectedUsers
-        let mbAletter = anyone letters 
+        let mbAletter = anyone letters
-        case mbAletter of 
+        case mbAletter of
           Nothing -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing -- TODO: better error message
-          Just aletter -> do             
+          Just aletter -> do
             now <- liftIO getCurrentTime
-            apcIdent <- letterApcIdent aletter encRcvr now        
+            apcIdent <- letterApcIdent aletter encRcvr now
             let fName = letterFileName aletter
             renderLetters rcvr letters apcIdent >>= \case
-              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err                      
+              Left err  -> sendResponseStatus internalServerError500 $ "PDF generation failed: \n" <> err
               Right pdf -> return $ Just (sendByteStringAsFile fName (LBS.toStrict pdf) now)
                 -- sendResponseByteStringFile "demoPDF.pdf" (LBS.toStrict pdf)
-                -- let typePDF :: ContentType 
+                -- let typePDF :: ContentType
                 --     typePDF = "application/pdf"
-                -- sendResponse (typePDF, toContent pdf)          
+                -- sendResponse (typePDF, toContent pdf)
     (TutorialUserGrantQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
         -- today <- localDay . TZ.utcToLocalTimeTZ appTZ <$> liftIO getCurrentTime
@@ -146,7 +139,7 @@ postTUsersR tid ssh csh tutn = do
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserRenewQualificationData{..}, selectedUsers)
       | tuQualification `Set.member` courseQids -> do
-        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers      
+        noks <- runDB $ renewValidQualificationUsers tuQualification Nothing Nothing $ Set.toList selectedUsers
         addMessageI (if noks > 0 && noks == Set.size selectedUsers then Success else Warning) $ MsgTutorialUserRenewedQualification noks
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     (TutorialUserSendMailData{}, selectedUsers) -> do
@@ -160,8 +153,8 @@ postTUsersR tid ssh csh tutn = do
         addMessageI Success $ MsgTutorialUsersDeregistered nrDel
         redirect $ CTutorialR tid ssh csh tutn TUsersR
     _other -> addMessageI Error MsgErrorUnknownFormAction >> return Nothing
-  
+
-  case tcontent of 
+  case tcontent of
     Just act -> act -- abort and return produced content
     Nothing -> do
       tutors <- runDB $ E.select $ do

src/Handler/Utils/Course.hs

@@ -109,14 +109,14 @@ showCourseEventRoom uid courseEvent = E.or
   ]
 
 getCourseQualifications :: ( MonadHandler m
-                           , backend ~ SqlBackend                           
+                           , backend ~ SqlBackend
-                           ) 
+                           )
                         => CourseId -> ReaderT backend m [Entity Qualification]
-getCourseQualifications cid = Ex.select $ do 
+getCourseQualifications cid = Ex.select $ do
   (qual :& courseQual) <-
     Ex.from $      Ex.table @Qualification
     `Ex.innerJoin` Ex.table @CourseQualification
-    `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification) 
+    `Ex.on` (\(qual :& courseQual) -> qual E.^. QualificationId E.==. courseQual E.^. CourseQualificationQualification)
   Ex.where_ $ courseQual E.^. CourseQualificationCourse E.==. E.val cid
-  Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder]
+  Ex.orderBy [E.asc $ courseQual E.^. CourseQualificationSortOrder, E.asc $ qual E.^. QualificationName]
   pure qual

src/Handler/Utils/Qualification.hs

@@ -289,3 +289,31 @@ qualificationUserUnblockByReason qid uids mbUnblockTime (qualificationChangeReas
         E.&&.  quserBlockAux True (E.val cutoff) (E.==. (quser E.^. QualificationUserId)) (Just (\qblock -> (qblock E.^. QualificationUserBlockReason) E.==. E.val reason))
     return $ quser E.^. QualificationUserUser
   qualificationUserBlocking qid (E.unValue <$> toUnblock) True mbUnblockTime undo_reason notify
+
+
+-----------
+-- Forms --
+-----------
+
+
+qualificationOption :: Entity Qualification -> Option QualificationId
+qualificationOption (Entity qid Qualification{..}) =
+  let qsh = ciOriginal $ unSchoolKey qualificationSchool
+  in  Option{ optionDisplay       =        ciOriginal qualificationName      <> " ("  <> qsh <> ")"
+            , optionExternalValue = "(" <> ciOriginal qualificationShorthand <> "___" <> qsh <> ")"
+            , optionInternalValue = qid
+            }
+
+qualificationsOptionList :: [Entity Qualification] -> OptionList QualificationId
+qualificationsOptionList = mkOptionList . map qualificationOption
+
+{- Should we encrypt the external value or simply rely on uniqueness?
+qualOpt :: Entity Qualification -> Handler (Option QualificationId)
+qualOpt (Entity qualId qual) = do
+  cQualId :: CryptoUUIDQualification <- encrypt qualId
+  return $ Option
+    { optionDisplay       = ciOriginal $ qualificationName qual
+    , optionInternalValue = qualId
+    , optionExternalValue = tshow cQualId
+    }
+-}