Merge branch 'master' into 302-transaction-log

CHANGELOG.md

@@ -2,6 +2,21 @@
 
 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.
 
+## [6.5.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.4.0...v6.5.0) (2019-09-05)
+
+
+### Bug Fixes
+
+* **course-edit:** expand rights of allocation admins ([7f2dd78](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/7f2dd78))
+* **jobs:** implement job priorities ([e29f042](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/e29f042))
+
+
+### Features
+
+* **allocation-list:** show numbers of avail. and applied-to courses ([a3f236c](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/commit/a3f236c))
+
+
+
 ## [6.4.0](https://gitlab.cip.ifi.lmu.de/jost/UniWorX/compare/v6.3.0...v6.4.0) (2019-09-05)
 
 

messages/campus/de.msg

@@ -1,4 +1,4 @@
-CampusIdentNote: Campus-Kennung bitte inkl. Domain-Teil (@campus.lmu.de) angeben.
+CampusIdentPlaceholder: Vorname.Nachname@campus.lmu.de
 CampusIdent: Campus-Kennung
 CampusPassword: Passwort
 CampusSubmit: Abschicken

messages/uniworx/de.msg

@@ -719,6 +719,8 @@ StudyFeatureAge: Fachsemester
 StudyFeatureDegree: Abschluss
 FieldPrimary: Hauptfach
 FieldSecondary: Nebenfach
+ShortFieldPrimary: HF
+ShortFieldSecondary: NF
 NoStudyField: Kein Studienfach
 StudyFeatureType:
 StudyFeatureValid: Aktiv
@@ -1227,7 +1229,7 @@ TutorialEdited tutn@TutorialName: Tutiorium #{tutn} erfolgreich bearbeitet
 
 TutorialEditHeading tutn@TutorialName: #{tutn} bearbeiten
 
-MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Alle Änderungen müssen noch durch Drücken des Forumular-Knopfes bestätigt werden.
+MassInputTip: Es können mehrere Werte angegeben werden. Werte müssen mit + zur Liste hinzugefügt werden und können mit - wieder entfernt werden. Alle Änderungen müssen noch durch Drücken des Formular-Knopfes bestätigt werden.
 
 HealthReport: Instanz-Zustand
 InstanceIdentification: Instanz-Identifikation
@@ -1523,6 +1525,7 @@ AllocationActive: Aktiv
 AllocationName: Name
 AllocationAvailableCourses: Kurse
 AllocationAppliedCourses: Bewerbungen
+AllocationNumCoursesAvailableApplied available@Int applied@Int: Sie haben sich bisher für #{applied}/#{available} #{pluralDE applied "Kurs" "Kursen"} beworben
 AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
 AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
 AllocationDescription: Beschreibung

models/materials

@@ -1,7 +1,7 @@
 Material -- course material for disemination to course participants
   course          CourseId
   name            (CI Text)
-  type            Text Maybe
+  type            (CI Text) Maybe
   description     Html Maybe
   visibleFrom     UTCTime Maybe    -- Invisible to enrolled participants before
   lastEdit        UTCTime

package-lock.json

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

package.json

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

package.yaml

@@ -1,5 +1,5 @@
 name:    uniworx
-version: 6.4.0
+version: 6.5.0
 
 dependencies:
   # Due to a bug in GHC 8.0.1, we block its usage

src/Auth/Dummy.hs

@@ -23,10 +23,10 @@ dummyForm :: ( RenderMessage site FormMessage
              , SqlBackendCanRead (YesodPersistBackend site)
              , Button site ButtonSubmit
              ) => AForm (HandlerT site IO) (CI Text)
-dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
+dummyForm = areq (ciField & addDatalist userList) (fslI MsgDummyIdent & noAutocomplete) Nothing
   where
     userList = fmap mkOptionList . runDB $ map toOption <$> selectList [] [Asc UserIdent]
-    toOption (Entity _ User{..}) = Option (CI.original userIdent) userIdent (CI.original userIdent)
+    toOption (Entity _ User{..}) = Option userDisplayName userIdent (CI.original userIdent)
 
 dummyLogin :: ( YesodAuth site
               , YesodPersist site

src/Auth/LDAP.hs

@@ -33,7 +33,7 @@ data CampusLogin = CampusLogin
   , campusPassword :: Text
   } deriving (Generic, Typeable)
 
-data CampusMessage = MsgCampusIdentNote
+data CampusMessage = MsgCampusIdentPlaceholder
                    | MsgCampusIdent
                    | MsgCampusPassword
                    | MsgCampusSubmit
@@ -117,10 +117,16 @@ campusUser' conf pool User{userIdent}
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage
               , Button site ButtonSubmit
-              ) => AForm (HandlerT site IO) CampusLogin
+              ) => WForm (HandlerT site IO) (FormResult CampusLogin)
-campusForm = CampusLogin
+campusForm = do
-  <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing
+  MsgRenderer mr <- getMsgRenderer
-  <*> areq passwordField (fslI MsgCampusPassword) Nothing
+  
+  ident <- wreq ciField (fslpI MsgCampusIdent (mr MsgCampusIdentPlaceholder) & addAttr "autofocus" "") Nothing
+  password <- wreq passwordField (fslI MsgCampusPassword) Nothing
+
+  return $ CampusLogin
+    <$> ident
+    <*> password
 
 apLdap :: Text
 apLdap = "LDAP"
@@ -137,7 +143,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
     apName = apLdap
     apDispatch :: Text -> [Text] -> HandlerT Auth (HandlerT site IO) TypedContent
     apDispatch "POST" [] = do
-      ((loginRes, _), _) <- lift . runFormPost $ renderAForm FormStandard campusForm
+      ((loginRes, _), _) <- lift . runFormPost $ renderWForm FormStandard campusForm
       case loginRes of
         FormFailure errs -> do
           forM_ errs $ addMessage Error . toHtml
@@ -169,7 +175,7 @@ campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
               loginErrorMessageI LoginR Msg.AuthError
     apDispatch _ _ = notFound
     apLogin toMaster = do
-      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderAForm FormStandard campusForm
+      (login, loginEnctype) <- handlerToWidget . generateFormPost $ renderWForm FormStandard campusForm
       let loginForm = wrapForm login FormSettings
             { formMethod = POST
             , formAction = Just . SomeRoute . toMaster $ PluginR "LDAP" []

src/Foundation.hs

@@ -350,6 +350,17 @@ instance RenderMessage UniWorX StudyDegreeTerm where
     where
       mr :: RenderMessage UniWorX msg => msg -> Text
       mr = renderMessage foundation ls
+  
+newtype ShortStudyFieldType = ShortStudyFieldType StudyFieldType
+embedRenderMessageVariant ''UniWorX ''ShortStudyFieldType ("Short" <>)
+
+data StudyDegreeTermType = StudyDegreeTermType StudyDegree StudyTerms StudyFieldType
+
+instance RenderMessage UniWorX StudyDegreeTermType where
+  renderMessage foundation ls (StudyDegreeTermType deg trm typ) = (mr trm) <> " (" <> (mr $ ShortStudyDegree deg) <> ", " <> (mr $ ShortStudyFieldType typ) <> ")"
+    where
+      mr :: RenderMessage UniWorX msg => msg -> Text
+      mr = renderMessage foundation ls
 
 instance RenderMessage UniWorX ExamGrade where
   renderMessage _ _ = pack . (showFixed False :: Deci -> String) . fromRational . review numberGrade

src/Handler/Allocation/Show.hs

@@ -96,4 +96,6 @@ getAShowR tid ssh ash = do
                      |]
     let daysToRegistrationStart = assertM (>0) $ (`diffUTCTime` now) <$> allocationRegisterFrom
         allocationInfoModal     = modal [whamlet|_{MsgMenuAllocationInfo}|] $ Left $ SomeRoute InfoAllocationR
+        numCourses = length courses
+        numAppliedCourses = lengthOf (folded . _2 . _Just) courses
     $(widgetFile "allocation/show")

src/Handler/Material.hs

@@ -8,7 +8,7 @@ import qualified Data.Set as Set
 -- import Data.Map (Map)
 import qualified Data.Map as Map
 import qualified Data.Conduit.List as C
--- import qualified Data.CaseInsensitive as CI
+import qualified Data.CaseInsensitive as CI
 -- import qualified Data.Text.Encoding as Text
 
 import qualified Database.Esqueleto as E
@@ -27,7 +27,7 @@ import System.FilePath (addExtension)
 
 data MaterialForm = MaterialForm
       { mfName         :: MaterialName
-      , mfType         :: Maybe Text
+      , mfType         :: Maybe (CI Text)
       , mfDescription  :: Maybe Html
       , mfVisibleFrom  :: Maybe UTCTime
       , mfFiles        :: Maybe (Source Handler (Either FileId File))
@@ -42,16 +42,17 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
         | Just source <- template >>= mfFiles
                     = runConduit $ source .| C.foldMap setIds
         | otherwise = return Set.empty
-      typeOptions :: WidgetT UniWorX IO (Set Text)
+      typeOptions :: HandlerT UniWorX IO (OptionList (CI Text))
       typeOptions = do
-        let defaults = Set.fromList $ map mr [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
+        let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample]
-        previouslyUsed <- liftHandlerT . runDB $
+        previouslyUsed <- runDB $
           E.select $ E.from $ \material ->
             E.distinctOnOrderBy [E.asc $ material E.^. MaterialType] $ do
               E.where_ $ material E.^. MaterialCourse E.==. E.val cid
                    E.&&. E.not_ (E.isNothing $ material E.^. MaterialType)
               return $ material E.^. MaterialType
-        return $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)
+        return . mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList
+          $ defaults <> Set.fromList (mapMaybe E.unValue previouslyUsed)
 
   now <- liftIO getCurrentTime
   let ctime = ceilingQuarterHour now
@@ -62,7 +63,7 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
 
   flip (renderAForm FormStandard) html $ MaterialForm
       <$> areq ciField        (fslI MsgMaterialName)         (mfName        <$> template)
-      <*> aopt (textField & addDatalist typeOptions)
+      <*> aopt (ciField & addDatalist typeOptions)
                               (fslpI MsgMaterialType $ mr MsgMaterialTypePlaceholder)
                                                              (mfType        <$> template)
       <*> aopt htmlField      (fslpI MsgMaterialDescription "Html")
@@ -126,7 +127,7 @@ getMaterialListR tid ssh csh = do
       , dbtColonnade = widgetColonnade $ mconcat
             [ -- dbRow,
               sortable (Just "type") (i18nCell MsgMaterialType)
-                $ foldMap textCell . materialType . row2material
+                $ foldMap (textCell . CI.original) . materialType . row2material
             , sortable (Just "name") (i18nCell MsgMaterialName)
                 $ liftA2 anchorCell matLink toWgt . materialName . row2material
             , sortable (toNothingS "description") mempty

src/Handler/School.hs

@@ -69,10 +69,10 @@ mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
 mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
   <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort)
   <*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
-  <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) <$> massInputListA (textField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (fmap CI.original . Set.toList . sfOrgUnits <$> template))
+  <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
   where
-    ldapOrgs :: WidgetT UniWorX IO (Set (CI Text))
+    ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text))
-    ldapOrgs = liftHandlerT . runDB $
+    ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
       setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []
 
 schoolToForm :: SchoolId -> DB (Form SchoolForm)

src/Handler/Tutorial.hs

@@ -341,8 +341,8 @@ tutorialForm cid template html = do
                             ) (tfDeregisterUntil <$> template)
     <*> tutorForm
   where
-    tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text))
+    tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text))
-    tutTypeDatalist = liftHandlerT . runDB $
+    tutTypeDatalist = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
       fmap (setOf $ folded . _Value) . E.select . E.from $ \tutorial -> do
         E.where_ $ tutorial E.^. TutorialCourse E.==. E.val cid
         return $ tutorial E.^. TutorialType

src/Handler/Utils/Form.hs

@@ -374,9 +374,17 @@ studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do
         E.on     $   feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
         E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
               E.||. (isActiveUserStudyFeature feature E.&&. isCorrectType feature)
-        return (feature E.^. StudyFeaturesId, degree, field)
+        return (feature, degree, field)
     MsgRenderer mr <- getMsgRenderer
-    mkOptionList . nonEmptyOptions (mr MsgNoStudyField) <$> mapM (procOptions mr) rawOptions
+    let showTypes
+          | length rawOptions <= 1
+          = False
+          | Just restr <- mRestr
+          , Set.size restr == 1
+          = False
+          | otherwise
+          = True
+    mkOptionList . nonEmptyOptions (mr MsgNoStudyField) <$> mapM (procOptions showTypes mr) rawOptions
   where
     isActiveUserStudyFeature feature = case mbuid of
       Nothing  -> E.false
@@ -386,11 +394,13 @@ studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do
       Nothing    -> E.true
       Just restr -> feature E.^. StudyFeaturesType `E.in_` E.valList (Set.toList restr)
 
-    procOptions :: (StudyDegreeTerm -> Text) -> (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
+    procOptions :: Bool -> (forall msg. RenderMessage UniWorX msg => msg -> Text) -> (Entity StudyFeatures, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
-    procOptions mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do
+    procOptions showTypes mr (Entity sfid sfeat, Entity _dgid sdegree, Entity _stid sterm) = do
       cfid <- encrypt sfid
       return Option
-        { optionDisplay = mr $ StudyDegreeTerm sdegree sterm
+        { optionDisplay = if
+            | showTypes -> mr $ StudyDegreeTermType sdegree sterm (studyFeaturesType sfeat)
+            | otherwise -> mr $ StudyDegreeTerm sdegree sterm
         , optionInternalValue = Just sfid
         , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId)
         }
@@ -641,9 +651,9 @@ examGradingRuleForm prev = multiActionA actions (fslI MsgExamGradingRule) $ clas
 
 
 pseudonymWordField :: Field Handler PseudonymWord
-pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
+pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOptionList [ Option w' w w' | w <- pseudonymWordlist, let w' = CI.original w ])
   where
-    doCheck (CI.mk -> w)
+    doCheck w
       | Just w' <- find (== w) pseudonymWordlist
       = return $ Right w'
       | otherwise
@@ -890,8 +900,11 @@ utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeFiel
 
 langField :: Bool -- ^ Only allow values from `appLanguages`
           -> Field (HandlerT UniWorX IO) Lang
-langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
+langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts
-langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages
+  where langCheck (T.splitOn "-" -> lParts)
+          = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
+         && not (null lParts)
+langField True = selectField appLanguagesOpts
 
 jsonField :: ( ToJSON a, FromJSON a
              , MonadHandler m

src/Utils/Form.hs

@@ -153,22 +153,36 @@ setNameClass fs gName gClass = fs { fsName = Just gName
 setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
 setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }
 
-addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
+addDatalist :: MonadHandler m => HandlerT (HandlerSite m) IO (OptionList a) -> Field m a -> Field m a
-addDatalist mValues field = field
+addDatalist mkOptions field = field
   { fieldView = \fId fName fAttrs fRes fReq -> do
       listId <- newIdent
-      values <- map toPathPiece . otoList <$> mValues
+
       fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
+
+      options <- liftHandlerT $ olOptions <$> mkOptions
       [whamlet|
         $newline never
         <datalist ##{listId}>
-          $forall value <- values
+          $forall Option{optionDisplay, optionExternalValue} <- options
-            <option value=#{value}>
+            <option value=#{optionExternalValue}>
+              #{optionDisplay}
       |]
+  , fieldParse = fieldParse'
   }
+  where
+    fieldParse' [t] [] = do
+      readExt <- liftHandlerT $ olReadExternal <$> mkOptions
+      case readExt t of
+        Just v  -> return . Right $ Just v
+        Nothing -> fieldParse field [t] []
+    fieldParse' ts fs = fieldParse field ts fs
 
 noValidate :: FieldSettings site -> FieldSettings site
 noValidate = addAttr "formnovalidate" ""
+  
+noAutocomplete :: FieldSettings site -> FieldSettings site
+noAutocomplete = addAttr "autocomplete" "off"
 
 inputDisabled :: FieldSettings site -> FieldSettings site
 inputDisabled = addAttr "disabled" ""

templates/allocation/show.hamlet

@@ -78,6 +78,9 @@ $if not (null courseWidgets)
       <p>_{MsgAllocationPriorityTip}
       <p>_{MsgAllocationPriorityRelative}
       <p>_{MsgApplicationEditTip}
+      $if is _Just muid
+        <p .allocation__state>
+          _{MsgAllocationNumCoursesAvailableApplied numCourses numAppliedCourses}
     <div .allocation__courses>
       $forall courseWgt <- courseWidgets
         ^{courseWgt}

templates/allocation/show.lucius

@@ -3,31 +3,44 @@
   font-style: italic;
 }
 
+.allocation__state {
+  color: var(--color-font);
+  font-weight: 600;
+  font-style: normal;
+}
+
 .allocation__courses {
-  margin-top: 20px;
+  margin: 20px 0 0 40px;
 }
 
 .allocation-course {
   display: grid;
-  grid-template-columns: 140px 1fr;
+  grid-template-columns: minmax(105px, 1fr) 9fr;
   grid-template-areas:
-    '.           name   '
+    'name        name   '
     'prio-label  prio   '
     'instr-label instr  '
     'form-label  form   ';
 
   grid-gap: 5px 7px;
-  padding: 12px 10px;
+  margin: 12px 0;
+  padding: 0 10px 12px 7px;
 
-  &:last-child {
+  border-left: 1px solid var(--color-grey);
-    padding: 12px 10px 0 10px;
+
+  /* &:last-child {
+   *   padding: 12px 10px 0 10px;
+   * }
+   *
+   * & + .allocation-course {
+   *   border-top: 1px solid var(--color-grey);
+   * }
+   */
+
+  &:nth-child(2n) {
+    background-color: rgba(0, 0, 0, 0.015);
   }
 
-  & + .allocation-course {
-    border-top: 1px solid var(--color-grey);
-  }
-
-
   .allocation-course__priority {
     grid-area: prio;
   }