From ada41e21645d8524a21e3c2c54590071d10dfb89 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Sep 2019 18:05:39 +0200 Subject: [PATCH 1/7] style(allocation): improve structure of allocation-page --- messages/uniworx/de.msg | 1 + src/Handler/Allocation/Show.hs | 2 ++ templates/allocation/show.hamlet | 3 +++ templates/allocation/show.lucius | 24 +++++++++++++++++------- 4 files changed, 23 insertions(+), 7 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 7228f0612..d79a825ca 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -1523,6 +1523,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 diff --git a/src/Handler/Allocation/Show.hs b/src/Handler/Allocation/Show.hs index bb6410ef0..0029581b7 100644 --- a/src/Handler/Allocation/Show.hs +++ b/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") diff --git a/templates/allocation/show.hamlet b/templates/allocation/show.hamlet index 5d5462da4..3f0e97fe1 100644 --- a/templates/allocation/show.hamlet +++ b/templates/allocation/show.hamlet @@ -78,6 +78,9 @@ $if not (null courseWidgets)

_{MsgAllocationPriorityTip}

_{MsgAllocationPriorityRelative}

_{MsgApplicationEditTip} + $if is _Just muid +

+ _{MsgAllocationNumCoursesAvailableApplied numCourses numAppliedCourses}

$forall courseWgt <- courseWidgets ^{courseWgt} diff --git a/templates/allocation/show.lucius b/templates/allocation/show.lucius index ebbaab266..7cf292a62 100644 --- a/templates/allocation/show.lucius +++ b/templates/allocation/show.lucius @@ -3,8 +3,14 @@ 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 { @@ -19,15 +25,19 @@ grid-gap: 5px 7px; padding: 12px 10px; - &:last-child { - padding: 12px 10px 0 10px; - } + /* &:last-child { + * padding: 12px 10px 0 10px; + * } + * + * & + .allocation-course { + * border-top: 1px solid var(--color-grey); + * } + */ - & + .allocation-course { - border-top: 1px solid var(--color-grey); + &:nth-child(2n) { + background-color: rgba(0, 0, 0, 0.03); } - .allocation-course__priority { grid-area: prio; } From bf7b63ebfc2a95a000379fe8fd8719bb4626136c Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Sep 2019 18:17:26 +0200 Subject: [PATCH 2/7] style(allocation): more clearly separate courses --- templates/allocation/show.lucius | 11 +++++++---- 1 file changed, 7 insertions(+), 4 deletions(-) diff --git a/templates/allocation/show.lucius b/templates/allocation/show.lucius index 7cf292a62..54e085ed3 100644 --- a/templates/allocation/show.lucius +++ b/templates/allocation/show.lucius @@ -15,15 +15,18 @@ .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; + + border-left: 1px solid var(--color-grey); /* &:last-child { * padding: 12px 10px 0 10px; @@ -35,7 +38,7 @@ */ &:nth-child(2n) { - background-color: rgba(0, 0, 0, 0.03); + background-color: rgba(0, 0, 0, 0.015); } .allocation-course__priority { From 5826f79e75f34858c6264b50a2a9091d73c81e64 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Sep 2019 18:35:09 +0200 Subject: [PATCH 3/7] chore(release): 6.5.0 --- CHANGELOG.md | 15 +++++++++++++++ package-lock.json | 2 +- package.json | 2 +- package.yaml | 2 +- 4 files changed, 18 insertions(+), 3 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 1c7122941..f99061c58 100644 --- a/CHANGELOG.md +++ b/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) diff --git a/package-lock.json b/package-lock.json index dd474e46f..82fa1307c 100644 --- a/package-lock.json +++ b/package-lock.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.4.0", + "version": "6.5.0", "lockfileVersion": 1, "requires": true, "dependencies": { diff --git a/package.json b/package.json index 998a27ff6..25c9cb292 100644 --- a/package.json +++ b/package.json @@ -1,6 +1,6 @@ { "name": "uni2work", - "version": "6.4.0", + "version": "6.5.0", "description": "", "keywords": [], "author": "", diff --git a/package.yaml b/package.yaml index 61be0c32e..bfd7e66ed 100644 --- a/package.yaml +++ b/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 From b7496f994075836949a9f6f5c584fa34a2441d1d Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Sep 2019 19:14:10 +0200 Subject: [PATCH 4/7] feat(forms): show studyFeaturesField in studyFeaturesFieldFor Fixes #451 --- messages/uniworx/de.msg | 2 ++ src/Foundation.hs | 11 +++++++++++ src/Handler/Utils/Form.hs | 20 +++++++++++++++----- 3 files changed, 28 insertions(+), 5 deletions(-) diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index d79a825ca..67666668f 100644 --- a/messages/uniworx/de.msg +++ b/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 diff --git a/src/Foundation.hs b/src/Foundation.hs index eb0991496..60143db44 100644 --- a/src/Foundation.hs +++ b/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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 3e701a619..5e91321e2 100644 --- a/src/Handler/Utils/Form.hs +++ b/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 mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do + procOptions :: Bool -> (forall msg. RenderMessage UniWorX msg => msg -> Text) -> (Entity StudyFeatures, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId)) + 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) } From 692e533da0380337838c63e32370fde060905ac7 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Sep 2019 19:24:06 +0200 Subject: [PATCH 5/7] fix(campus-login): add i18n for ident placeholder Fixes #417 --- messages/campus/de.msg | 2 +- src/Auth/LDAP.hs | 20 +++++++++++++------- 2 files changed, 14 insertions(+), 8 deletions(-) diff --git a/messages/campus/de.msg b/messages/campus/de.msg index 5fdf477b7..9a4b384fc 100644 --- a/messages/campus/de.msg +++ b/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 diff --git a/src/Auth/LDAP.hs b/src/Auth/LDAP.hs index 74c669f3c..320ab6e27 100644 --- a/src/Auth/LDAP.hs +++ b/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 -campusForm = CampusLogin - <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote & addAttr "autofocus" "") Nothing - <*> areq passwordField (fslI MsgCampusPassword) Nothing + ) => WForm (HandlerT site IO) (FormResult CampusLogin) +campusForm = do + MsgRenderer mr <- getMsgRenderer + + 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" [] From 412ce98fa0efc2715a9ba75ba8e95786fef47450 Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Thu, 5 Sep 2019 20:08:15 +0200 Subject: [PATCH 6/7] feat(forms): allow customisation of user-facing datalist values --- models/materials | 2 +- src/Auth/Dummy.hs | 4 ++-- src/Handler/Material.hs | 17 +++++++++-------- src/Handler/School.hs | 6 +++--- src/Handler/Tutorial.hs | 4 ++-- src/Handler/Utils/Form.hs | 11 +++++++---- src/Utils/Form.hs | 24 +++++++++++++++++++----- 7 files changed, 43 insertions(+), 25 deletions(-) diff --git a/models/materials b/models/materials index 062ab3232..01076a1cf 100644 --- a/models/materials +++ b/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 diff --git a/src/Auth/Dummy.hs b/src/Auth/Dummy.hs index 9f6ad4964..53a10acde 100644 --- a/src/Auth/Dummy.hs +++ b/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 diff --git a/src/Handler/Material.hs b/src/Handler/Material.hs index 025b0c9bc..bb17d4788 100644 --- a/src/Handler/Material.hs +++ b/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] - previouslyUsed <- liftHandlerT . runDB $ + let defaults = Set.fromList $ map (CI.mk . mr) [MsgMaterialTypeSlides,MsgMaterialTypeCode,MsgMaterialTypeExample] + 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 diff --git a/src/Handler/School.hs b/src/Handler/School.hs index c743dfae2..19f2646f4 100644 --- a/src/Handler/School.hs +++ b/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 = liftHandlerT . runDB $ + ldapOrgs :: HandlerT UniWorX IO (OptionList (CI Text)) + 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) diff --git a/src/Handler/Tutorial.hs b/src/Handler/Tutorial.hs index 4bacd9cd7..1e11629e2 100644 --- a/src/Handler/Tutorial.hs +++ b/src/Handler/Tutorial.hs @@ -340,8 +340,8 @@ tutorialForm cid template html = do ) (tfDeregisterUntil <$> template) <*> tutorForm where - tutTypeDatalist :: WidgetT UniWorX IO (Set (CI Text)) - tutTypeDatalist = liftHandlerT . runDB $ + tutTypeDatalist :: HandlerT UniWorX IO (OptionList (CI Text)) + 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 diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index 5e91321e2..7dc44c04a 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -651,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 @@ -900,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 True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages +langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts + 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 diff --git a/src/Utils/Form.hs b/src/Utils/Form.hs index 092deaa1e..52e1900f7 100644 --- a/src/Utils/Form.hs +++ b/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 mValues field = field +addDatalist :: MonadHandler m => HandlerT (HandlerSite m) IO (OptionList a) -> Field m a -> Field m a +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 - $forall value <- values -