Merge branch '307-studiengange-behandeln' of gitlab.cip.ifi.lmu.de:jost/UniWorX into 307-studiengange-behandeln

messages/uniworx/de.msg

@@ -53,6 +53,7 @@ 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
 CourseSecretWrong: Falsches Kennwort
 CourseSecret: Zugangspasswort
 CourseNewOk        tid@TermId ssh@SchoolId csh@CourseShorthand: Kurs #{display tid}-#{display ssh}-#{csh} wurde erfolgreich erstellt.

src/CryptoID.hs

@@ -36,6 +36,7 @@ decCryptoIDs [ ''SubmissionId
              , ''SheetId
              , ''SystemMessageId
              , ''SystemMessageTranslationId
+             , ''StudyFeaturesId
              ]
 
 instance {-# OVERLAPS #-} namespace ~ CryptoIDNamespace (CI FilePath) SubmissionId => PathPiece (E.CryptoID namespace (CI FilePath)) where

src/Handler/Course.hs

@@ -5,6 +5,7 @@ module Handler.Course where
 import Import
 
 import Utils.Lens
+import Utils.Form
 -- import Utils.DB
 import Handler.Utils
 import Handler.Utils.Table.Cells
@@ -263,8 +264,8 @@ getTermCourseListR tid = do
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
-  (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do
+  (course,schoolName,participants,registration,lecturers) <- runDB . maybeT notFound $ do
-    [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)]
+    [(E.Entity cid course, E.Value schoolName, E.Value participants, fmap entityVal -> registration)]
        <- lift . E.select . E.from $
          \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
             E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
@@ -276,17 +277,19 @@ getCShowR tid ssh csh = do
             let numParticipants = E.sub_select . E.from $ \part -> do
                   E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
                   return ( E.countRows :: E.SqlExpr (E.Value Int64))
-            return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration)
+            return (course,school E.^. SchoolName, numParticipants, participant)
+
     lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
       E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
       E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
       return $ user E.^. UserDisplayName
-    return (course,schoolName,participants,registered,map E.unValue lecturers)
+
+    return (course,schoolName,participants,registration,map E.unValue lecturers)
   mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
   mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
   mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
-  mRegAt   <- traverse (formatTime SelFormatDateTime)   registered
+  mRegAt   <- traverse (formatTime SelFormatDateTime) $ courseParticipantRegistration <$> registration
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
+  (regWidget, regEnctype) <- generateFormPost $ identForm FIDcourseRegister $ registerForm (isJust mRegAt) $ courseRegisterSecret course
   registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
   siteLayout (toWgt $ courseName course) $ do
     setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
@@ -294,11 +297,15 @@ getCShowR tid ssh csh = do
 
 
 registerForm :: Bool -> Maybe Text -> Form Bool
+-- unfinished WIP: must take study features if registred and show as mforced field
 registerForm registered msecret extra = do
   (msecretRes', msecretView) <- case msecret of
     (Just _) | not registered -> bimap Just Just <$> mreq textField (fslpI MsgCourseSecret "Code") Nothing
     _ -> return (Nothing,Nothing)
+  (sfRes' , sfView) <- if not registered then return (Nothing,Nothing) else
+                       mopt (studyFeaturesPrimaryFieldFor (error "TODO SJ REMOVE")) (fslI MsgCourseStudyFeature) Nothing
   (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
+
   let widget = $(widgetFile "widgets/register-form/register-form")
   let msecretRes | Just res <- msecretRes' = Just <$> res
                  | otherwise               = FormSuccess Nothing

src/Handler/Utils/Form.hs

@@ -214,6 +214,29 @@ 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
+studyFeaturesPrimaryFieldFor :: UserId -> Field Handler StudyFeaturesId
+studyFeaturesPrimaryFieldFor uid = selectField $ do
+    -- we wanted to use optionsPersistCryptoId, but we need a join here
+    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.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
+        E.where_ $ feature E.^. StudyFeaturesUser   E.==. E.val uid
+        E.where_ $ feature E.^. StudyFeaturesValid  E.==. E.val True 
+        E.where_ $ feature E.^. StudyFeaturesType   E.==. E.val FieldPrimary
+        return (feature E.^. StudyFeaturesId, degree, field)
+    mkOptionList <$> mapM procOptions rawOptions
+  where
+    procOptions (E.Value sfid, Entity dgid StudyDegree{..}, Entity stid StudyTerms{..}) = do
+      let dgname = fromMaybe (tshow dgid) (studyDegreeShorthand <|> studyDegreeName)
+          stname = fromMaybe (tshow stid) (studyTermsShorthand  <|> studyTermsName )
+      cfid <- encrypt sfid
+      return Option
+        { optionDisplay = stname <> " (" <> dgname <> ")"
+        , optionInternalValue = sfid
+        , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId)
+        }
+
 uploadModeField :: Field Handler UploadMode
 uploadModeField = selectField optionsFinite
 

src/Handler/Utils/StudyFeatures.hs

@@ -11,7 +11,7 @@ import Text.Parsec.Text
 parseStudyFeatures :: UserId -> UTCTime -> Text -> Either Text [StudyFeatures]
 parseStudyFeatures uId now = first tshow . parse (pStudyFeatures uId now <* eof) ""
 
-  
+
 pStudyFeatures :: UserId -> UTCTime -> Parser [StudyFeatures]
 pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
   studyFeaturesDegree <- StudyDegreeKey' <$> pKey
@@ -28,12 +28,11 @@ pStudyFeatures studyFeaturesUser studyFeaturesUpdated = do
       studyFeaturesType <- pType
       void $ char '!'
       studyFeaturesSemester <- decimal
-
       let studyFeaturesValid = True
       return StudyFeatures{..}
 
   pStudyFeature `sepBy1` char '#'
-
+  
 pKey :: Parser Int
 pKey = decimal
 

src/Utils/Form.hs

@@ -194,6 +194,7 @@ addAutosubmit = addAttr "data-autosubmit" ""
 
 data FormIdentifier
   = FIDcourse
+  | FIDcourseRegister
   | FIDsheet
   | FIDsubmission
   | FIDsettings

templates/widgets/register-form/register-form.hamlet

@@ -3,5 +3,6 @@ $# extra protects us against CSRF
 $# Maybe display textField for passcode
 $maybe secretView <- msecretView
   ^{fvInput secretView}
+$# Ask for associated primary field uf study, unless registered
 $# Always display register/deregister button
 ^{fvInput btnView}