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 -