Registration takes Field of Studies now

messages/uniworx/de.msg

@@ -53,7 +53,8 @@ CourseNoCapacity: In diesem Kurs sind keine Plätze mehr frei.
 CourseNotEmpty: In diesem Kurs sind momentan Teilnehmer angemeldet.
 CourseRegisterOk: Sie wurden angemeldet
 CourseDeregisterOk: Sie wurden abgemeldet
-CourseStudyFeature: Relevantes Hauptfach
+CourseStudyFeature: Asoziiertes Hauptfach
+CourseStudyFeatureTooltip: Korrekte Angabe kann Notenweiterleitungen beschleunigen
 CourseSecretWrong: Falsches Kennwort
 CourseSecret: Zugangspasswort
 CourseNewOk        tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.

src/Handler/Course.hs

@@ -290,48 +290,64 @@ getCShowR tid ssh csh = do
   mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
   mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
   mRegAt   <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
-  (regWidget, regEnctype) <- generateFormPost $ identForm FIDcourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course
+  (regWidget, regEnctype) <- generateFormPost $ registerForm mbAid registration $ courseRegisterSecret course
   registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
   siteLayout (toWgt $ courseName course) $ do
     setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
 
-
+-- | Registration button with primary study features if logged in
-registerForm :: Bool -> Maybe Text -> Form Bool
+-- , existing features if already registered
+-- , and possibly a course secret
+registerForm :: Maybe UserId -> Maybe CourseParticipant -> Maybe Text -> Form (Maybe StudyFeaturesId, Bool)
 -- unfinished WIP: must take study features if registred and show as mforced field
-registerForm registered msecret extra = do
+registerForm loggedin participant msecret = identForm FIDcourseRegister $ \extra -> do
-  (msecretRes', msecretView) <- case msecret of
+    -- secret fields
-    (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
+    (msecretRes', msecretView) <- case msecret of
-    _ -> return (Nothing,Nothing)
+      (Just _) | not isRegistered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
-  (_msfRes, msfView) <- if not registered then return (Nothing, Nothing) else
+      _ -> return (Nothing,Nothing)
-                        bimap Just Just <$> mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing
+    -- study features
-  (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
+    (msfRes', msfView) <- case loggedin of
+      Nothing -> return (Nothing,Nothing)
+      Just _  -> bimap Just Just <$> case participant of
+        Just CourseParticipant{courseParticipantField=Just sfid}
+                -> mopt (studyFeaturesPrimaryFieldFor [sfid] loggedin) (fslI MsgCourseStudyFeature)  (Just $ Just sfid)
+        _other  -> mopt (studyFeaturesPrimaryFieldFor [ ]    loggedin) (fslI MsgCourseStudyFeature
+                                                                 & setTooltip  MsgCourseStudyFeatureTooltip) Nothing
+    -- button de-/register
+    (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister isRegistered) "buttonField ignores settings anyway" Nothing
 
-  let widget = $(widgetFile "widgets/register-form/register-form")
+    let widget = $(widgetFile "widgets/register-form/register-form")
-  let msecretRes | Just res <- msecretRes' = Just <$> res
+    let msecretRes | Just res <- msecretRes' = Just <$> res
-                 | otherwise               = FormSuccess Nothing
+                   | otherwise               = FormSuccess Nothing
-  return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
+    let msfRes     | Just res <- msfRes'     = res
+                   | otherwise               = FormSuccess Nothing
+    -- checks that correct button was pressed, and ignores result of btnRes
+    let formRes = (,) <$ btnRes <*> msfRes <*> ((==msecret) <$> msecretRes)
+    return (formRes, widget)
+  where
+    isRegistered = isJust participant
 
 
 postCRegisterR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 postCRegisterR tid ssh csh = do
   aid <- requireAuthId
-  (cid, course, registered) <- runDB $ do
+  (cid, course, registration) <- runDB $ do
       (Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
-      registered <- isJust <$> getBy (UniqueParticipant aid cid)
+      registration <- getBy (UniqueParticipant aid cid)
-      return (cid, course, registered)
+      return (cid, course, entityVal <$> registration)
-  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+  let isRegistered  = isJust registration
-  case regResult of
+  ((regResult,_), _) <- runFormPost $ registerForm (Just aid) registration $ courseRegisterSecret course
-    (FormSuccess codeOk)
+  formResult regResult $ \(mbSfId,codeOk) -> if
-      | registered -> do
+      | isRegistered -> do
           runDB $ deleteBy $ UniqueParticipant aid cid
           addMessageI Info MsgCourseDeregisterOk
       | codeOk -> do
           actTime <- liftIO getCurrentTime
-          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime Nothing -- TODO
+          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime mbSfId
           when (isJust regOk) $ addMessageI Success MsgCourseRegisterOk
       | otherwise -> addMessageI Warning MsgCourseSecretWrong
-    _other -> return () -- TODO check this!
+  -- addMessage Info $ toHtml $ show regResult -- For debugging only
   redirect $ CourseR tid ssh csh CShowR
 
 

src/Handler/Utils/Form.hs

@@ -214,19 +214,25 @@ schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
 schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
 schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
 
--- | Select one of the user's primary courses
+-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
-studyFeaturesPrimaryFieldFor :: UserId -> Field Handler StudyFeaturesId
+studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler StudyFeaturesId
-studyFeaturesPrimaryFieldFor uid = selectField $ do
+studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
-    -- we wanted to use optionsPersistCryptoId, but we need a join here
+    -- we need a join, so we cannot just use optionsPersistCryptoId
     rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do
-        E.on     $ feature E.^. StudyFeaturesField  E.==. field  E.^. StudyTermsId
+        E.on     $   feature E.^. StudyFeaturesField  E.==. field  E.^. StudyTermsId
-        E.on     $ feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
+        E.on     $   feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
-        E.where_ $ feature E.^. StudyFeaturesUser   E.==. E.val uid
+        E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
-        E.where_ $ feature E.^. StudyFeaturesValid  E.==. E.val True 
+              E.||. isPrimaryActiveUserStudyFeature feature
-        E.where_ $ feature E.^. StudyFeaturesType   E.==. E.val FieldPrimary
         return (feature E.^. StudyFeaturesId, degree, field)
     mkOptionList <$> mapM procOptions rawOptions
   where
+    isPrimaryActiveUserStudyFeature feature = case mbuid of
+      Nothing    -> E.val False
+      (Just uid) -> feature E.^. StudyFeaturesUser  E.==. E.val uid
+              E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
+              E.&&. feature E.^. StudyFeaturesType  E.==. E.val FieldPrimary
+
+    procOptions :: (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option StudyFeaturesId)
     procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do
       let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName)
           stname = fromMaybe (tshow stid) (studyTermsShorthand  <|> studyTermsName )

test/Database.hs

@@ -448,8 +448,8 @@ fillDb = do
     , courseRegisterFrom = Nothing
     , courseRegisterTo = Nothing
     , courseDeregisterUntil = Nothing
-    , courseRegisterSecret  = Nothing
+    , courseRegisterSecret  = Just "dbs"
-    , courseMaterialFree    = True
+    , courseMaterialFree    = False
     }
   insert_ $ CourseEdit gkleen now dbs
   void . insert' $ DegreeCourse dbs sdBsc sdInf