2348 lines
105 KiB
Haskell
2348 lines
105 KiB
Haskell
module Handler.Utils.Form
|
|
( module Handler.Utils.Form
|
|
, module Handler.Utils.Form.MassInput
|
|
, module Handler.Utils.Pandoc
|
|
, module Utils.Form
|
|
, MonadWriter(..)
|
|
) where
|
|
|
|
import Utils.Form
|
|
import Utils.Files
|
|
|
|
import Handler.Utils.Form.Types
|
|
|
|
import Handler.Utils.Pandoc
|
|
|
|
import Handler.Utils.DateTime
|
|
|
|
import Handler.Utils.I18n
|
|
|
|
import Handler.Utils.Files
|
|
|
|
import Handler.Utils.Exam
|
|
|
|
import Utils.Term
|
|
|
|
import Import
|
|
import Data.Char ( chr, ord, isDigit )
|
|
import qualified Data.Char as Char
|
|
import qualified Data.Text as Text
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
-- import Yesod.Core
|
|
import qualified Data.Text as T
|
|
-- import Yesod.Form.Types
|
|
import Yesod.Form.Bootstrap3
|
|
|
|
import Handler.Utils.Zip
|
|
import qualified Data.Conduit.Combinators as C
|
|
import qualified Data.Conduit.List as C (mapMaybe, mapMaybeM)
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
import qualified Database.Esqueleto.Internal.Internal as E (SqlSelect)
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Sequence as Seq
|
|
|
|
import Data.Map ((!), (!?))
|
|
import qualified Data.Map as Map
|
|
|
|
import qualified Data.Vector as Vector
|
|
|
|
import qualified Data.HashMap.Lazy as HashMap
|
|
|
|
import Control.Monad.Error.Class (MonadError(..))
|
|
|
|
import Data.Aeson (eitherDecodeStrict')
|
|
import Data.Aeson.Text (encodeToLazyText)
|
|
|
|
import qualified Text.Email.Validate as Email
|
|
|
|
import Data.Text.Lens (unpacked)
|
|
import Text.Blaze (toMarkup)
|
|
|
|
import Handler.Utils.Form.MassInput
|
|
|
|
import qualified Data.Binary as Binary
|
|
import qualified Data.ByteString.Base64.URL as Base64
|
|
|
|
import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
|
import qualified Data.Text.Lazy.Builder as Builder
|
|
|
|
import qualified Data.Yaml as Yaml
|
|
|
|
import Control.Monad.Catch.Pure (runCatch)
|
|
|
|
{-# ANN module ("HLint: ignore Use const" :: String) #-}
|
|
|
|
|
|
----------------------------
|
|
-- Buttons (new version ) --
|
|
----------------------------
|
|
-- NOTE: ButtonSubmit is defined in Utils.Form !
|
|
|
|
|
|
data ButtonDelete = BtnDelete
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonDelete
|
|
instance Finite ButtonDelete
|
|
|
|
nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonDelete id
|
|
instance Button UniWorX ButtonDelete where
|
|
btnClasses BtnDelete = [BCIsButton, BCDanger]
|
|
|
|
data ButtonSave = BtnSave
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonSave
|
|
instance Finite ButtonSave
|
|
|
|
-- | Save-Button as AForm
|
|
saveButton :: (Button (HandlerSite m) ButtonSave, MonadHandler m) => AForm m ()
|
|
saveButton = combinedButtonFieldF_ (Proxy @ButtonSave) ""
|
|
|
|
nullaryPathPiece ''ButtonSave $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonSave id
|
|
instance Button UniWorX ButtonSave where
|
|
btnClasses BtnSave = [BCIsButton, BCPrimary]
|
|
|
|
|
|
|
|
data ButtonHandIn = BtnHandIn
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonHandIn
|
|
instance Finite ButtonHandIn
|
|
|
|
nullaryPathPiece ''ButtonHandIn $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonHandIn id
|
|
instance Button UniWorX ButtonHandIn where
|
|
btnClasses BtnHandIn = [BCIsButton, BCPrimary]
|
|
|
|
|
|
|
|
data ButtonRegister = BtnRegister | BtnDeregister
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonRegister
|
|
instance Finite ButtonRegister
|
|
|
|
nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonRegister id
|
|
instance Button UniWorX ButtonRegister where
|
|
btnClasses BtnRegister = [BCIsButton, BCPrimary]
|
|
btnClasses BtnDeregister = [BCIsButton, BCDanger]
|
|
|
|
data ButtonHijack = BtnHijack
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe ButtonHijack
|
|
instance Finite ButtonHijack
|
|
|
|
nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonHijack id
|
|
instance Button UniWorX ButtonHijack where
|
|
btnClasses BtnHijack = [BCIsButton, BCDefault]
|
|
|
|
data ButtonSubmitDelete = BtnSubmit' | BtnDelete'
|
|
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
|
|
|
|
instance Universe ButtonSubmitDelete
|
|
instance Finite ButtonSubmitDelete
|
|
|
|
embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'"
|
|
instance Button UniWorX ButtonSubmitDelete where
|
|
btnClasses BtnSubmit' = [BCIsButton, BCPrimary]
|
|
btnClasses BtnDelete' = [BCIsButton, BCDanger]
|
|
|
|
btnValidate _ BtnSubmit' = True
|
|
btnValidate _ BtnDelete' = False
|
|
|
|
nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
|
|
|
|
|
|
-- | Looks like a button, but is just a link (e.g. for create course, etc.)
|
|
linkButton :: Widget -- ^ Widget to display if unauthorized
|
|
-> Widget -- ^ Button label
|
|
-> [ButtonClass UniWorX]
|
|
-> SomeRoute UniWorX
|
|
-> Widget -- Alternative: Handler.Utils.simpleLink
|
|
linkButton defWdgt lbl cls url = do
|
|
access <- hasReadAccessTo $ urlRoute url
|
|
if | not access -> defWdgt
|
|
| otherwise -> do
|
|
url' <- toTextUrl url
|
|
[whamlet|
|
|
$newline never
|
|
<a href=#{url'} :not (onull cls):class=#{unwords $ map toPathPiece cls}>
|
|
^{lbl}
|
|
|]
|
|
|
|
--------------------------
|
|
-- Interactive fieldset --
|
|
--------------------------
|
|
|
|
optionalAction'' :: Bool -- ^ negated?
|
|
-> (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX))
|
|
-> AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX]))
|
|
optionalAction'' negated minp justAct fs@FieldSettings{..} defActive csrf = do
|
|
(doRes, doView) <- minp (bool id (isoField _not) negated checkBoxField) fs defActive
|
|
(actionRes, actionViews') <- over _2 ($ []) <$> aFormToForm justAct
|
|
|
|
let actionViews = over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/optional-action")) actionViews'
|
|
|
|
return (doRes >>= bool (pure Nothing) (Just <$> actionRes), over _fvInput (mappend $ toWidget csrf) doView : actionViews)
|
|
|
|
optionalAction :: AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX]))
|
|
optionalAction = optionalAction' mpopt
|
|
|
|
optionalAction' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX))
|
|
-> AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> (Html -> MForm Handler (FormResult (Maybe a), [FieldView UniWorX]))
|
|
optionalAction' = optionalAction'' False
|
|
|
|
optionalActionA :: AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> AForm Handler (Maybe a)
|
|
optionalActionA = optionalActionA' mpopt
|
|
|
|
optionalActionNegatedA :: AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> AForm Handler (Maybe a)
|
|
optionalActionNegatedA = optionalActionA'' True mpopt
|
|
|
|
optionalActionA' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX))
|
|
-> AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> AForm Handler (Maybe a)
|
|
optionalActionA' minp justAct fs defActive = formToAForm $ optionalAction' minp justAct fs defActive mempty
|
|
|
|
optionalActionA'' :: Bool
|
|
-> (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX))
|
|
-> AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> AForm Handler (Maybe a)
|
|
optionalActionA'' negated minp justAct fs defActive = formToAForm $ optionalAction'' negated minp justAct fs defActive mempty
|
|
|
|
optionalActionW :: AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> WForm Handler (FormResult (Maybe a))
|
|
optionalActionW = optionalActionW' mpopt
|
|
|
|
|
|
optionalActionW' :: (Field Handler Bool -> FieldSettings UniWorX -> Maybe Bool -> MForm Handler (FormResult Bool, FieldView UniWorX))
|
|
-> AForm Handler a
|
|
-> FieldSettings UniWorX
|
|
-> Maybe Bool
|
|
-> WForm Handler (FormResult (Maybe a))
|
|
optionalActionW' minp justAct fs defAction = aFormToWForm $ optionalActionA' minp justAct fs defAction
|
|
|
|
|
|
multiAction :: forall action a.
|
|
( RenderMessage UniWorX action, PathPiece action, Ord action )
|
|
=> Map action (AForm Handler a)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
|
multiAction = multiAction' mpopt
|
|
|
|
multiActionOpts :: forall action a.
|
|
Ord action
|
|
=> Map action (AForm Handler a)
|
|
-> Handler (OptionList action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
|
multiActionOpts = multiActionOpts' mpopt
|
|
|
|
multiAction' :: forall action a.
|
|
( RenderMessage UniWorX action, PathPiece action, Ord action )
|
|
=> (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
|
|
-> Map action (AForm Handler a)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
|
multiAction' minp acts = multiActionOpts' minp acts (optionsF $ Map.keysSet acts)
|
|
|
|
multiActionField :: forall action a.
|
|
Ord action
|
|
=> (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
|
|
-> Map action (AForm Handler a)
|
|
-> (Field Handler action, action -> Maybe Text, action -> Maybe (SomeMessage UniWorX))
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
|
multiActionField minp acts (actField, actExternal, actMessage) fs defAction csrf = do
|
|
(actionRes, actionView) <- minp (checkBool (`Map.member` acts) MsgMultiActionUnknownAction actField) fs defAction
|
|
results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
|
|
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let actionResults = view _1 <$> results
|
|
|
|
actionViews = Map.foldrWithKey accViews [] results
|
|
|
|
accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
|
|
accViews act
|
|
| Just optionExternalValue <- actExternal act
|
|
, Just (mr -> optionDisplay) <- actMessage act
|
|
= flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd
|
|
| otherwise
|
|
= const id
|
|
|
|
return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)
|
|
|
|
|
|
multiActionOpts' :: forall action a.
|
|
Ord action
|
|
=> (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
|
|
-> Map action (AForm Handler a)
|
|
-> Handler (OptionList action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
|
multiActionOpts' minp acts mActsOpts fs defAction csrf = do
|
|
actsOpts <- liftHandler mActsOpts
|
|
let actsOpts' = OptionList
|
|
{ olOptions = filter (flip Map.member acts . optionInternalValue) $ olOptions actsOpts
|
|
, olReadExternal = assertM (`Map.member` acts) . olReadExternal actsOpts
|
|
}
|
|
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue) $ olOptions actsOpts') acts
|
|
|
|
actOption act = find (\Option{..} -> optionInternalValue == act) $ olOptions actsOpts'
|
|
actExternal = fmap optionExternalValue . actOption
|
|
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
|
|
|
multiActionField minp acts' (selectField $ return actsOpts', actExternal, actMessage) fs defAction csrf
|
|
|
|
multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
|
=> Map action (AForm Handler a)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> AForm Handler a
|
|
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty
|
|
|
|
multiActionAOpts :: Ord action
|
|
=> Map action (AForm Handler a)
|
|
-> Handler (OptionList action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> AForm Handler a
|
|
multiActionAOpts acts opts fSettings defAction = formToAForm $ multiActionOpts acts opts fSettings defAction mempty
|
|
|
|
multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
|
=> Map action (AForm Handler a)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> WForm Handler (FormResult a)
|
|
multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction
|
|
|
|
multiActionWOpts :: Ord action
|
|
=> Map action (AForm Handler a)
|
|
-> Handler (OptionList action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> WForm Handler (FormResult a)
|
|
multiActionWOpts acts opts fSettings defAction = aFormToWForm $ multiActionAOpts acts opts fSettings defAction
|
|
|
|
multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action)
|
|
=> Map action (AForm Handler a)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, Widget))
|
|
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction
|
|
|
|
multiActionMOpts :: Ord action
|
|
=> Map action (AForm Handler a)
|
|
-> Handler (OptionList action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, Widget))
|
|
multiActionMOpts acts opts fSettings defAction = renderAForm FormStandard $ multiActionAOpts acts opts fSettings defAction
|
|
|
|
-------------------------
|
|
-- Explained selection --
|
|
-------------------------
|
|
|
|
explainedSelectionField :: forall m a.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, Eq a
|
|
)
|
|
=> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option
|
|
-> Handler ([(Option a, Maybe Widget)], Text -> Maybe a)
|
|
-> Field m a
|
|
explainedSelectionField optMsg' mkOpts = Field{..}
|
|
where
|
|
fieldEnctype = UrlEncoded
|
|
fieldParse ts _ = do
|
|
(_, parser) <- liftHandler mkOpts
|
|
if
|
|
| t : _ <- ts
|
|
, Just t' <- parser t
|
|
-> return . Right $ Just t'
|
|
| t : _ <- ts
|
|
, null t
|
|
-> return $ Right Nothing
|
|
| t : _ <- ts
|
|
-> return . Left . SomeMessage $ MsgInvalidEntry t
|
|
| otherwise
|
|
-> return $ Right Nothing
|
|
fieldView theId name attrs val isReq = do
|
|
(opts, _) <- liftHandler mkOpts
|
|
let optMsg = guardOnM (not isReq) optMsg'
|
|
inputId optExternal = [st|#{theId}__input--#{optExternal}|]
|
|
matchesVal Nothing = is _Left val
|
|
matchesVal (Just x) = val == Right x
|
|
$(widgetFile "widgets/explained-selection-field")
|
|
|
|
explainOptionList :: forall a.
|
|
Handler (OptionList a)
|
|
-> (a -> MaybeT Handler Widget)
|
|
-> Handler ([(Option a, Maybe Widget)], Text -> Maybe a)
|
|
explainOptionList ol mkExplanation = do
|
|
OptionList{..} <- ol
|
|
olOptions' <- forM olOptions $ \opt@Option{..} -> (opt, ) <$> runMaybeT (mkExplanation optionInternalValue)
|
|
return (olOptions', olReadExternal)
|
|
|
|
explainedMultiAction' :: forall action a.
|
|
Ord action
|
|
=> (Field Handler action -> FieldSettings UniWorX -> Maybe action -> MForm Handler (FormResult action, FieldView UniWorX))
|
|
-> Map action (AForm Handler a)
|
|
-> Handler ([(Option action, Maybe Widget)], Text -> Maybe action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
|
explainedMultiAction' minp acts mActsOpts fs defAction csrf = do
|
|
(actsOpts, actsReadExternal) <- liftHandler mActsOpts
|
|
let actsOpts' = filter (flip Map.member acts . optionInternalValue . view _1) actsOpts
|
|
actsReadExternal' = assertM (`Map.member` acts) . actsReadExternal
|
|
acts' = Map.filterWithKey (\a _ -> any ((== a) . optionInternalValue . view _1) actsOpts') acts
|
|
|
|
actOption act = find (\Option{..} -> optionInternalValue == act) $ view _1 <$> actsOpts'
|
|
actExternal = fmap optionExternalValue . actOption
|
|
actMessage = fmap (SomeMessage . optionDisplay) . actOption
|
|
|
|
multiActionField minp acts' (explainedSelectionField Nothing $ return (actsOpts', actsReadExternal'), actExternal, actMessage) fs defAction csrf
|
|
|
|
explainedMultiAction :: forall action a.
|
|
Ord action
|
|
=> Map action (AForm Handler a)
|
|
-> Handler ([(Option action, Maybe Widget)], Text -> Maybe action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
|
|
explainedMultiAction = explainedMultiAction' mpopt
|
|
|
|
explainedMultiActionA :: forall action a.
|
|
Ord action
|
|
=> Map action (AForm Handler a)
|
|
-> Handler ([(Option action, Maybe Widget)], Text -> Maybe action)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe action
|
|
-> AForm Handler a
|
|
explainedMultiActionA acts mActsOpts fSettings defAction = formToAForm $ explainedMultiAction acts mActsOpts fSettings defAction mempty
|
|
|
|
------------
|
|
-- Fields --
|
|
------------
|
|
|
|
-- | add some additional text immediately after the field widget; probably not a good idea to use
|
|
annotateField :: ToWidget (HandlerSite m) wgt => wgt -> Field m a -> Field m a
|
|
annotateField ann field@Field{fieldView=fvf} =
|
|
let fvf' idt nmt atts ei bl =
|
|
[whamlet|
|
|
$newline never
|
|
^{fvf idt nmt atts ei bl}
|
|
^{ann}
|
|
|]
|
|
in field { fieldView=fvf'}
|
|
|
|
-- ciField moved to Utils.Form
|
|
|
|
routeField :: ( Monad m
|
|
, HandlerSite m ~ UniWorX
|
|
) => Field m (Route UniWorX)
|
|
routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField
|
|
|
|
natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
|
|
natFieldI msg = convertField fromInteger toInteger $ checkBool (>= 0) msg $ intMinField 0
|
|
|
|
posIntFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
|
|
posIntFieldI msg = convertField fromInteger toInteger $ checkBool (> 0) msg $ intMinField 0
|
|
|
|
-- | Field to request integral number > 'm'
|
|
minIntFieldI :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage, RenderMessage (HandlerSite m) msg) => i -> msg -> Field m i
|
|
minIntFieldI m msg = checkBool (> m) msg $ intMinField m
|
|
|
|
pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points
|
|
pointsField = pointsFieldMinMax (Just 0) Nothing
|
|
|
|
pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points
|
|
pointsFieldMax = pointsFieldMinMax (Just 0)
|
|
|
|
pointsFieldMinMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Maybe Points -> Field m Points
|
|
pointsFieldMinMax lower upper = checklower $ checkupper $ fixedPrecMinMaxField lower upper -- NOTE: fixedPrecMinMaxField uses HTML5 input attributes min & max for better browser supprt, but may not be supported by all browsers yet
|
|
where
|
|
checklower | Just 0 <- lower = checkBool (>= 0) MsgPointsNotPositive
|
|
| Just minp <- lower = checkBool (>= minp) $ MsgPointsTooLow minp
|
|
| otherwise = id
|
|
checkupper | Just maxp <- upper = checkBool (<= maxp) $ MsgPointsTooHigh maxp
|
|
| otherwise = id
|
|
|
|
matriculationField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
|
|
matriculationField = textField -- no restrictions, since not everyone has a matriculation and pupils need special tags here
|
|
|
|
termsActiveField :: Field Handler TermId
|
|
termsActiveField = selectField . fmap (fmap entityKey) $ do
|
|
now <- liftIO getCurrentTime
|
|
muid <- maybeAuthId
|
|
flip optionsE termName . E.from $ \t -> do
|
|
E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
|
|
E.orderBy [E.desc $ t E.^. TermStart]
|
|
return t
|
|
|
|
termsAllowedField :: Field Handler TermId
|
|
termsAllowedField = selectField . fmap (fmap entityKey) $ do
|
|
mayEditTerm <- hasWriteAccessTo TermEditR
|
|
now <- liftIO getCurrentTime
|
|
muid <- maybeAuthId
|
|
flip optionsE termName . E.from $ \t -> do
|
|
unless mayEditTerm $
|
|
E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
|
|
E.orderBy [E.desc $ t E.^. TermStart]
|
|
return t
|
|
|
|
termField :: Field Handler TermId
|
|
termField = selectField $ optionsPersistKey [] [Desc TermStart] termName
|
|
|
|
termsSetField :: [TermId] -> Field Handler TermId
|
|
termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
|
|
-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]
|
|
|
|
termsActiveOrSetField :: [TermId] -> Field Handler TermId
|
|
termsActiveOrSetField tids = selectField . fmap (fmap entityKey) $ do
|
|
now <- liftIO getCurrentTime
|
|
muid <- maybeAuthId
|
|
flip optionsE termName . E.from $ \t -> do
|
|
E.where_ $ termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
|
|
E.||. t E.^. TermId `E.in_` E.valList tids
|
|
E.orderBy [E.desc $ t E.^. TermStart]
|
|
return t
|
|
|
|
-- termActiveOld :: Field Handler TermIdentifier
|
|
-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
|
|
|
termNewField :: Field Handler TermIdentifier
|
|
termNewField = checkMMap (return.termFromText) termToText textField
|
|
|
|
schoolField :: Field Handler SchoolId
|
|
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName
|
|
|
|
schoolFieldEnt :: Field Handler (Entity School)
|
|
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName
|
|
|
|
schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
|
|
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName
|
|
|
|
degreeField :: Field Handler StudyDegreeId
|
|
degreeField = selectField $ optionsPersistKey [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
|
|
|
|
degreeFieldEnt :: Field Handler (Entity StudyDegree)
|
|
degreeFieldEnt = selectField $ optionsPersist [] [Asc StudyDegreeName, Asc StudyDegreeShorthand, Asc StudyDegreeKey] id
|
|
|
|
|
|
-- | Select one of the user's primary active study features, or from a given list of StudyFeatures (regardless of user)
|
|
studyFeaturesPrimaryFieldFor :: Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
|
-> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
|
|
{-# DEPRECATED studyFeaturesPrimaryFieldFor "Use studyFeaturesFieldFor" #-}
|
|
studyFeaturesPrimaryFieldFor = studyFeaturesFieldFor . Just $ Set.singleton FieldPrimary
|
|
|
|
-- | Select one of the user's active study features, or from a given list of StudyFeatures (regardless of user)
|
|
studyFeaturesFieldFor :: Maybe (Set StudyFieldType) -- ^ Optionally restrict fields to only given types
|
|
-> Bool -- ^ Allow user to select `Nothing` (only applies if set of options is nonempty)?
|
|
-> [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
|
|
studyFeaturesFieldFor mRestr isOptional oldFeatures mbuid = selectField $ do
|
|
-- 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.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
|
|
E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
|
|
E.||. (isActiveUserStudyFeature feature E.&&. isCorrectType feature)
|
|
return (feature, degree, field)
|
|
MsgRenderer mr <- getMsgRenderer
|
|
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
|
|
Just uid -> feature E.^. StudyFeaturesUser E.==. E.val uid
|
|
E.&&. feature E.^. StudyFeaturesValid
|
|
isCorrectType feature = case mRestr of
|
|
Nothing -> E.true
|
|
Just restr -> feature E.^. StudyFeaturesType `E.in_` E.valList (Set.toList restr)
|
|
|
|
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 = if
|
|
| showTypes -> mr $ StudyDegreeTermType sdegree sterm (studyFeaturesType sfeat)
|
|
| otherwise -> mr $ StudyDegreeTerm sdegree sterm
|
|
, optionInternalValue = Just sfid
|
|
, optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId)
|
|
}
|
|
|
|
nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)]
|
|
nonEmptyOptions emptyOpt opts
|
|
| null opts = pure nullOption
|
|
| isOptional = nullOption : opts
|
|
| otherwise = opts
|
|
where
|
|
nullOption = Option
|
|
{ optionDisplay = emptyOpt
|
|
, optionInternalValue = Nothing
|
|
, optionExternalValue = "NoStudyField"
|
|
}
|
|
|
|
|
|
uploadModeForm :: FieldSettings UniWorX -> Maybe UploadMode -> AForm Handler UploadMode
|
|
uploadModeForm fs prev = multiActionA actions fs (classifyUploadMode <$> prev)
|
|
where
|
|
actions :: Map UploadModeDescr (AForm Handler UploadMode)
|
|
actions = Map.fromList
|
|
[ ( UploadModeNone, pure NoUpload)
|
|
, ( UploadModeAny
|
|
, UploadAny
|
|
<$> (fromMaybe False <$> aopt checkBoxField (fslI MsgUploadModeUnpackZips & setTooltip MsgUploadModeUnpackZipsTip) (Just $ prev ^? _Just . _uploadUnpackZips))
|
|
<*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _uploadExtensionRestriction) <|> fmap Just defaultExtensionRestriction)
|
|
<*> apopt checkBoxField (fslI MsgUploadAnyEmptyOk & setTooltip MsgUploadAnyEmptyOkTip) (preview (_Just . _uploadEmptyOk) prev <|> Just False)
|
|
)
|
|
, ( UploadModeSpecific
|
|
, UploadSpecific <$> specificFileForm
|
|
)
|
|
]
|
|
|
|
extensionRestrictionField :: Field Handler (NonNull (Set Extension))
|
|
extensionRestrictionField = checkMMap (return . maybe (Left MsgUploadModeExtensionRestrictionEmpty) Right . fromNullable . toSet) (intercalate ", " . Set.toList . toNullable) textField
|
|
where
|
|
toSet = Set.fromList . filter (not . Text.null) . map (stripDot . Text.strip) . Text.splitOn ","
|
|
stripDot ext
|
|
| Just nExt <- Text.stripPrefix "." ext = nExt
|
|
| otherwise = ext
|
|
|
|
specificFileForm :: AForm Handler (NonNull (Set UploadSpecificFile))
|
|
specificFileForm = wFormToAForm $ do
|
|
currentRoute' <- getCurrentRoute
|
|
let miButtonAction :: forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX)
|
|
miButtonAction frag = do
|
|
currentRoute <- currentRoute'
|
|
return . SomeRoute $ currentRoute :#: frag
|
|
miIdent <- ("specific-files--" <>) <$> newIdent
|
|
postProcess =<< massInputW MassInput{..} (fslI MsgUploadSpecificFiles) True (preProcess <$> prev ^? _Just . _uploadSpecificFiles)
|
|
where
|
|
preProcess :: NonNull (Set UploadSpecificFile) -> Map ListPosition (UploadSpecificFile, UploadSpecificFile)
|
|
preProcess = Map.fromList . zip [0..] . map (\x -> (x, x)) . Set.toList . toNullable
|
|
|
|
postProcess :: FormResult (Map ListPosition (UploadSpecificFile, UploadSpecificFile)) -> WForm Handler (FormResult (NonNull (Set UploadSpecificFile)))
|
|
postProcess mapResult = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return $ do
|
|
mapResult' <- Set.fromList . map snd . Map.elems <$> mapResult
|
|
case fromNullable mapResult' of
|
|
Nothing -> throwError [mr MsgNoUploadSpecificFilesConfigured]
|
|
Just lResult -> do
|
|
let names = Set.map specificFileName mapResult'
|
|
labels = Set.map specificFileLabel mapResult'
|
|
if
|
|
| Set.size names /= Set.size mapResult'
|
|
-> throwError [mr MsgUploadSpecificFilesDuplicateNames]
|
|
| Set.size labels /= Set.size mapResult'
|
|
-> throwError [mr MsgUploadSpecificFilesDuplicateLabels]
|
|
| otherwise
|
|
-> return lResult
|
|
|
|
sFileForm :: (Text -> Text) -> Maybe UploadSpecificFile -> Form UploadSpecificFile
|
|
sFileForm nudge mPrevUF csrf = do
|
|
(labelRes, labelView) <- mpreq textField (fslI MsgUploadSpecificFileLabel & addName (nudge "label")) $ specificFileLabel <$> mPrevUF
|
|
(nameRes, nameView) <- mpreq textField (fslI MsgUploadSpecificFileName & addName (nudge "name")) $ specificFileName <$> mPrevUF
|
|
(emptyOkRes, emptyOkView) <- mpopt checkBoxField (fslI MsgUploadSpecificFileEmptyOk & addName (nudge "empty-ok")) $ fmap specificFileEmptyOk mPrevUF <|> Just False
|
|
(maxSizeRes, maxSizeView) <- mopt (natFieldI MsgUploadSpecificFileMaxSizeNegative) (fslI MsgUploadSpecificFileMaxSize & addName (nudge "max-size")) $ specificFileMaxSize <$> mPrevUF
|
|
(reqRes, reqView) <- mpreq checkBoxField (fslI MsgUploadSpecificFileRequired & addName (nudge "required")) $ specificFileRequired <$> mPrevUF
|
|
|
|
return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes <*> emptyOkRes <*> maxSizeRes
|
|
, $(widgetFile "widgets/massinput/uploadSpecificFiles/form")
|
|
)
|
|
|
|
miAdd _ _ nudge submitView = Just $ \csrf -> do
|
|
(formRes, formWidget) <- sFileForm nudge Nothing csrf
|
|
let formWidget' = $(widgetFile "widgets/massinput/uploadSpecificFiles/add")
|
|
addRes' = formRes <&> \fileRes oldRess ->
|
|
let iStart = maybe 0 (succ . fst) $ Map.lookupMax oldRess
|
|
in pure $ Map.singleton iStart fileRes
|
|
return (addRes', formWidget')
|
|
miCell _ initFile _ nudge csrf =
|
|
sFileForm nudge (Just initFile) csrf
|
|
miDelete :: MassInputDelete ListLength
|
|
miDelete = miDeleteList
|
|
miAllowAdd _ _ _ = True
|
|
miAddEmpty _ _ _ = Set.empty
|
|
miLayout :: MassInputLayout ListLength UploadSpecificFile UploadSpecificFile
|
|
miLayout lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/uploadSpecificFiles/layout")
|
|
|
|
|
|
|
|
|
|
submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
|
|
submissionModeForm prev = explainedMultiActionA actions opts (fslI MsgUtilSheetSubmissionMode) $ classifySubmissionMode <$> prev
|
|
where
|
|
actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
|
|
actions = Map.fromList
|
|
[ ( SubmissionModeNone
|
|
, pure $ SubmissionMode False Nothing
|
|
)
|
|
, ( SubmissionModeCorrector
|
|
, pure $ SubmissionMode True Nothing
|
|
)
|
|
, ( SubmissionModeUser
|
|
, SubmissionMode False . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just)
|
|
)
|
|
, ( SubmissionModeBoth
|
|
, SubmissionMode True . Just <$> uploadModeForm (fslI MsgSheetUploadMode) (prev ^? _Just . _submissionModeUser . _Just)
|
|
)
|
|
]
|
|
|
|
opts = explainOptionList optionsFinite $ \case
|
|
SubmissionModeNone -> mzero
|
|
SubmissionModeCorrector -> return $(i18nWidgetFile "submission-mode-explanation/corrector")
|
|
SubmissionModeUser -> return $(i18nWidgetFile "submission-mode-explanation/user")
|
|
SubmissionModeBoth -> return $ i18n MsgBothSubmissionsTip
|
|
|
|
data ExamBonusRule' = ExamBonusManual'
|
|
| ExamBonusPoints'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
instance Universe ExamBonusRule'
|
|
instance Finite ExamBonusRule'
|
|
|
|
nullaryPathPiece ''ExamBonusRule' $ camelToPathPiece' 1 . dropSuffix "'"
|
|
embedRenderMessage ''UniWorX ''ExamBonusRule' id
|
|
|
|
classifyBonusRule :: ExamBonusRule -> ExamBonusRule'
|
|
classifyBonusRule = \case
|
|
ExamBonusManual{} -> ExamBonusManual'
|
|
ExamBonusPoints{} -> ExamBonusPoints'
|
|
|
|
examBonusRuleForm :: Maybe ExamBonusRule -> AForm Handler ExamBonusRule
|
|
examBonusRuleForm prev = multiActionA actions (fslI MsgUtilExamBonusRule) $ classifyBonusRule <$> prev
|
|
where
|
|
actions :: Map ExamBonusRule' (AForm Handler ExamBonusRule)
|
|
actions = Map.fromList
|
|
[ ( ExamBonusManual'
|
|
, ExamBonusManual
|
|
<$> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev))
|
|
)
|
|
, ( ExamBonusPoints'
|
|
, ExamBonusPoints
|
|
<$ wFormToAForm (pure () <$ (wformMessage =<< messageI Info MsgExamBonusInfoPoints))
|
|
<*> apreq (checkBool (> 0) MsgExamBonusMaxPointsNonPositive pointsField) (fslI MsgExamBonusMaxPoints & setTooltip MsgExamBonusMaxPointsTip) (preview _bonusMaxPoints =<< prev)
|
|
<*> (fromMaybe False <$> aopt checkBoxField (fslI MsgExamBonusOnlyPassed) (Just <$> preview _bonusOnlyPassed =<< prev))
|
|
<*> areq (checkBool (> 0) MsgExamBonusRoundNonPositive pointsField) (fslI MsgExamBonusRound & setTooltip MsgExamBonusRoundTip) (preview _bonusRound =<< prev)
|
|
)
|
|
]
|
|
|
|
data ExamOccurrenceRule' = ExamRoomManual'
|
|
| ExamRoomFifo'
|
|
| ExamRoomSurname'
|
|
| ExamRoomMatriculation'
|
|
| ExamRoomRandom'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
instance Universe ExamOccurrenceRule'
|
|
instance Finite ExamOccurrenceRule'
|
|
|
|
nullaryPathPiece ''ExamOccurrenceRule' $ camelToPathPiece' 1 . dropSuffix "'"
|
|
embedRenderMessage ''UniWorX ''ExamOccurrenceRule' id
|
|
|
|
classifyExamOccurrenceRule :: ExamOccurrenceRule -> ExamOccurrenceRule'
|
|
classifyExamOccurrenceRule = \case
|
|
ExamRoomManual -> ExamRoomManual'
|
|
ExamRoomSurname -> ExamRoomSurname'
|
|
ExamRoomMatriculation -> ExamRoomMatriculation'
|
|
ExamRoomRandom -> ExamRoomRandom'
|
|
ExamRoomFifo -> ExamRoomFifo'
|
|
|
|
examOccurrenceRuleForm :: Maybe ExamOccurrenceRule -> AForm Handler ExamOccurrenceRule
|
|
examOccurrenceRuleForm = fmap reverseClassify . areq (selectField optionsFinite) (fslI MsgExamAutomaticOccurrenceAssignment & setTooltip MsgExamAutomaticOccurrenceAssignmentTip) . fmap classifyExamOccurrenceRule
|
|
where
|
|
reverseClassify = \case
|
|
ExamRoomManual' -> ExamRoomManual
|
|
ExamRoomFifo' -> ExamRoomFifo
|
|
ExamRoomSurname' -> ExamRoomSurname
|
|
ExamRoomMatriculation' -> ExamRoomMatriculation
|
|
ExamRoomRandom' -> ExamRoomRandom
|
|
|
|
data ExamGradingRule' = ExamGradingKey'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
instance Universe ExamGradingRule'
|
|
instance Finite ExamGradingRule'
|
|
|
|
nullaryPathPiece ''ExamGradingRule' $ camelToPathPiece' 2 . dropSuffix "'"
|
|
embedRenderMessage ''UniWorX ''ExamGradingRule' id
|
|
|
|
classifyExamGradingRule :: ExamGradingRule -> ExamGradingRule'
|
|
classifyExamGradingRule = \case
|
|
ExamGradingKey{} -> ExamGradingKey'
|
|
|
|
examGradingRuleForm :: Maybe ExamGradingRule -> AForm Handler ExamGradingRule
|
|
examGradingRuleForm prev = multiActionA actions (fslI MsgUtilExamGradingRule) $ classifyExamGradingRule <$> prev
|
|
where
|
|
actions :: Map ExamGradingRule' (AForm Handler ExamGradingRule)
|
|
actions = Map.fromList
|
|
[ ( ExamGradingKey'
|
|
, ExamGradingKey <$> gradingKeyForm (fslI MsgExamGradingKey & setTooltip MsgExamGradingKeyTip) (preview _examGradingKey =<< prev)
|
|
)
|
|
]
|
|
|
|
|
|
gradingKeyForm :: FieldSettings UniWorX -> Maybe [Points] -> AForm Handler [Points]
|
|
gradingKeyForm FieldSettings{..} template = formToAForm . over (mapped . _2) pure $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
fvId <- maybe newIdent return fsId
|
|
fvName <- maybe newFormIdent return fsName
|
|
|
|
let
|
|
grades :: [ExamGrade]
|
|
grades = universeF
|
|
|
|
let boundsFS (Text.filter isDigit . toPathPiece -> g) = ""
|
|
& addPlaceholder (mr MsgPoints)
|
|
& addName (fvName <> "__" <> g)
|
|
& addId (fvId <> "__" <> g)
|
|
bounds <- forM grades $ \case
|
|
g@Grade50 -> mforced pointsField (boundsFS g) 0
|
|
grade -> mpreq pointsField (boundsFS grade) $ preview (ix . pred $ fromEnum grade) =<< template
|
|
|
|
let errors
|
|
| anyOf (folded . _1 . _FormSuccess) (< 0) bounds = [mr MsgPointsMustBeNonNegative]
|
|
| FormSuccess bounds' <- mapM (view _1) bounds
|
|
, not $ monotone bounds'
|
|
= [mr MsgPointsMustBeMonotonic]
|
|
| otherwise
|
|
= []
|
|
|
|
return ( if
|
|
| null errors -> sequence . unsafeTail $ map fst bounds
|
|
| otherwise -> FormFailure errors
|
|
, FieldView
|
|
{ fvLabel = toMarkup $ mr fsLabel
|
|
, fvTooltip = toMarkup . mr <$> fsTooltip
|
|
, fvId
|
|
, fvInput = let boundWidgets = map (fvInput . snd) bounds
|
|
in $(widgetFile "widgets/gradingKey")
|
|
, fvErrors = if
|
|
| (e : _) <- errors -> Just $ toMarkup e
|
|
| otherwise -> Nothing
|
|
, fvRequired = True
|
|
}
|
|
)
|
|
|
|
where
|
|
monotone (x1:x2:xs) = x1 <= x2 && monotone (x2:xs)
|
|
monotone _ = True
|
|
|
|
|
|
pseudonymWordField :: Field Handler PseudonymWord
|
|
pseudonymWordField = checkMMap doCheck id $ ciField & addDatalist (return $ mkOptionList [ Option w' w w' | w <- pseudonymWordlist, let w' = CI.original w ])
|
|
where
|
|
doCheck w
|
|
| Just w' <- find (== w) pseudonymWordlist
|
|
= return $ Right w'
|
|
| otherwise
|
|
= return . Left $ MsgUnknownPseudonymWord (CI.original w)
|
|
|
|
|
|
uploadContents :: (MonadHandler m, HandlerSite m ~ UniWorX) => ConduitT FileReference ByteString m ()
|
|
uploadContents = transPipe (liftHandler . runDB) sourceFiles .| C.mapMaybeM fileContent'
|
|
where fileContent' f = runMaybeT $ do
|
|
File{fileContent = Just fc} <- return f
|
|
liftHandler . runDB . runConduit $ fc .| C.fold
|
|
|
|
genericFileField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Handler (FileField FileReference) -> Field m FileUploads
|
|
genericFileField mkOpts = Field{..}
|
|
where
|
|
permittedExtension :: FileField FileReference -> FileName -> Bool
|
|
permittedExtension FileField{..} fTitle
|
|
| unpack fTitle `Map.member` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
|
|
= True
|
|
| Just exts <- fieldRestrictExtensions
|
|
= anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fTitle) exts
|
|
| otherwise
|
|
= True
|
|
|
|
getIdent :: forall m'. (MonadHandler m', RenderRoute (HandlerSite m')) => FileField FileReference -> m' (Maybe Text)
|
|
getIdent FileField{..} = do
|
|
ident <- case fieldIdent of
|
|
Just ident -> return $ Just ident
|
|
Nothing -> runMaybeT $ do
|
|
cRoute <- MaybeT getCurrentRoute
|
|
pos <- newIdent
|
|
$logDebugS "genericFileField.getIdent" pos
|
|
return $ hash (cRoute, pos)
|
|
& toStrict . Binary.encode
|
|
& decodeUtf8 . Base64.encodeUnpadded
|
|
$logDebugS "genericFileField.getIdent" $ tshow ident
|
|
return ident
|
|
|
|
getPermittedFiles :: Maybe Text -> FileField FileReference -> DB (Map FilePath (Maybe FileContentReference, UTCTime, FileFieldUserOption Bool))
|
|
getPermittedFiles mIdent opts@FileField{..} = do
|
|
sessionFiles <- for mIdent $ \fieldIdent' ->
|
|
foldMap (HashMap.findWithDefault mempty fieldIdent' . unMergeHashMap) <$> lookupSessionJson @_ @(MergeHashMap Text (Map FilePath (SessionFileId, UTCTime))) @_ SessionFiles
|
|
sessionFiles' <- flip foldMapM sessionFiles $ \sFiles -> flip foldMapM (Map.toList sFiles) $ \(fTitle, (sfId, fModified)) -> maybeT (return Map.empty) $ do
|
|
SessionFile{..} <- MaybeT $ get sfId
|
|
guard $ is _Nothing sessionFileContent || permittedExtension opts (pack fTitle)
|
|
return $ Map.singleton fTitle (sessionFileContent, fModified, FileFieldUserOption False True)
|
|
$logDebugS "genericFileField.getPermittedFiles" $ "Additional: " <> tshow fieldAdditionalFiles
|
|
$logDebugS "genericFileField.getPermittedFiles" $ "Session: " <> tshow sessionFiles'
|
|
return $ mconcat
|
|
[ Map.filter (views _3 $ (||) <$> not . fieldOptionForce <*> not . fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
|
, sessionFiles'
|
|
, Map.filter (views _3 $ (&&) <$> fieldOptionForce <*> fieldOptionDefault) $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
|
]
|
|
|
|
handleUpload :: FileField FileReference -> Maybe Text -> ConduitT (File Handler) FileReference (YesodDB UniWorX) ()
|
|
handleUpload FileField{fieldMaxFileSize} mIdent
|
|
= C.map (transFile liftHandler)
|
|
.| C.mapMaybeM (\f@File{..} -> maybeT (return $ Just f) $ do
|
|
maxSize <- fromIntegral <$> hoistMaybe fieldMaxFileSize
|
|
fc <- hoistMaybe fileContent
|
|
let peekNE n = do
|
|
str <- C.takeE n .| C.fold
|
|
leftover str
|
|
yield str
|
|
(unsealConduitT -> fc', size) <- lift $ fc $$+ peekNE (succ maxSize) .| C.lengthE
|
|
return . guardOn (size <= maxSize) $ f { fileContent = Just fc' }
|
|
)
|
|
.| sinkFiles
|
|
.| C.mapM mkSessionFile
|
|
where
|
|
mkSessionFile fRef@FileReference{..} = fRef <$ do
|
|
now <- liftIO getCurrentTime
|
|
sfId <- insert $ SessionFile fileReferenceContent now
|
|
whenIsJust mIdent $ \ident ->
|
|
modifySessionJson SessionFiles $ \(fromMaybe mempty -> MergeHashMap old) ->
|
|
Just . MergeHashMap $ HashMap.insert ident (Map.insert fileReferenceTitle (sfId, fileReferenceModified) $ HashMap.findWithDefault mempty ident old) old
|
|
|
|
|
|
_FileTitle :: Prism' Text FilePath
|
|
_FileTitle = prism' (("f." <>) . pack) $ fmap unpack . Text.stripPrefix "f."
|
|
|
|
fieldEnctype = Multipart
|
|
fieldParse :: [Text] -> [FileInfo] -> m (Either (SomeMessage (HandlerSite m)) (Maybe FileUploads))
|
|
fieldParse vals files' = runExceptT $ do
|
|
let files = filter (not . null . fileName) files'
|
|
|
|
opts@FileField{..} <- liftHandler mkOpts
|
|
|
|
mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
|
|
fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v
|
|
|
|
let uploadedFilenames = fileName <$> files
|
|
|
|
let
|
|
doUnpack
|
|
| fieldOptionForce fieldUnpackZips = fieldOptionDefault fieldUnpackZips
|
|
| otherwise = unpackZips `elem` vals
|
|
handleFile :: FileInfo -> ConduitT () (File Handler) Handler ()
|
|
handleFile
|
|
| doUnpack = receiveFiles
|
|
| otherwise = yieldM . acceptFile
|
|
invalidUploadExtension fName
|
|
= not (permittedExtension opts fName)
|
|
&& (not doUnpack || ((/=) `on` simpleContentType) (mimeLookup fName) typeZip)
|
|
|
|
whenIsJust fieldMaxFileSize $ \maxSize -> forM_ files $ \fInfo -> do
|
|
fLength <- runConduit $ fileSource fInfo .| C.takeE (fromIntegral $ succ maxSize) .| C.lengthE
|
|
when (fLength > maxSize) $ do
|
|
when (is _Just mIdent) $
|
|
liftHandler . runDB . runConduit $
|
|
mapM_ (transPipe lift . handleFile) files
|
|
.| handleUpload opts mIdent
|
|
.| C.sinkNull
|
|
throwE . SomeMessage . MsgGenericFileFieldFileTooLarge . unpack $ fileName fInfo
|
|
|
|
if | invExt : _ <- filter invalidUploadExtension uploadedFilenames
|
|
-> do
|
|
when (is _Just mIdent) $
|
|
liftHandler . runDB . runConduit $
|
|
mapM_ (transPipe lift . handleFile) files
|
|
.| handleUpload opts mIdent
|
|
.| C.sinkNull
|
|
throwE . SomeMessage . MsgGenericFileFieldInvalidExtension $ unpack invExt
|
|
| otherwise
|
|
-> do
|
|
let fSrc = do
|
|
permittedFiles <- liftHandler . runDB $ getPermittedFiles mIdent opts
|
|
yieldMany [ FileReference{..}
|
|
| ( fileReferenceTitle
|
|
, (fileReferenceContent, fileReferenceModified, FileFieldUserOption{..})
|
|
) <- Map.toList permittedFiles
|
|
, fieldOptionForce, fieldOptionDefault
|
|
]
|
|
yieldMany vals
|
|
.| C.mapMaybe (preview _FileTitle)
|
|
.| C.mapMaybe (\fTitle -> fmap (fTitle, ) . assertM (views _3 $ not . fieldOptionForce) $ Map.lookup fTitle permittedFiles)
|
|
.| C.filter (\(fTitle, _) ->
|
|
fieldMultiple
|
|
|| ( fTitle `elem` mapMaybe (preview _FileTitle) vals
|
|
&& null files
|
|
)
|
|
)
|
|
.| C.map (\(fileReferenceTitle, (fileReferenceContent, fileReferenceModified, _)) -> FileReference{..})
|
|
mapM_ handleFile (bool (take 1) id fieldMultiple files) .| transPipe runDB (handleUpload opts mIdent)
|
|
(fSrc'', allEmpty) <- if
|
|
| fieldAllEmptyOk -> return (fSrc, False)
|
|
| otherwise
|
|
-> let checkEmpty = do
|
|
(peeked, failed) <- go []
|
|
mapM_ leftover $ peeked ++ hoistMaybe failed
|
|
return $ is _Nothing failed
|
|
go acc = do
|
|
next <- await
|
|
case next of
|
|
Nothing -> return (reverse acc, Nothing)
|
|
Just x
|
|
| isEmptyFileReference x -> go $ x : acc
|
|
| otherwise -> return (reverse acc, Just x)
|
|
in liftHandler . over (mapped . _1) unsealConduitT $ fSrc $$+ checkEmpty
|
|
(fSrc', length -> nFiles) <- liftHandler $ runPeekN 2 fSrc''
|
|
$logDebugS "genericFileField.fieldParse" $ tshow nFiles
|
|
if
|
|
| nFiles <= 0 -> return Nothing
|
|
| allEmpty -> throwE $ SomeMessage MsgUploadAtLeastOneNonemptyFile
|
|
| nFiles <= 1 -> return $ Just fSrc'
|
|
| not fieldMultiple -> do
|
|
liftHandler . runDB . runConduit $
|
|
mapM_ (transPipe lift . handleFile) files
|
|
.| handleUpload opts mIdent
|
|
.| sinkNull
|
|
throwE $ SomeMessage MsgOnlyUploadOneFile
|
|
| otherwise -> return $ Just fSrc'
|
|
|
|
fieldView :: FieldViewFunc m FileUploads
|
|
fieldView fieldId fieldName _attrs val req = do
|
|
opts@FileField{..} <- liftHandler mkOpts
|
|
mIdent <- getIdent opts
|
|
identSecret <- for mIdent $ encodedSecretBox SecretBoxShort
|
|
|
|
fileInfos <- liftHandler $ do
|
|
references <- for val $ fmap (Map.fromList . map (\FileReference{..} -> (fileReferenceTitle, (fileReferenceContent, fileReferenceModified)))) . sourceToList
|
|
|
|
permittedFiles <- runDB $ getPermittedFiles mIdent opts
|
|
|
|
let
|
|
sentVals :: Either Text (Set FilePath)
|
|
sentVals = references <&> (`Set.intersection` Map.keysSet permittedFiles) . Map.keysSet
|
|
|
|
let
|
|
toFUI fuiTitle
|
|
= let fuiHtmlId = [st|#{fieldId}--#{fuiTitle}|]
|
|
fuiChecked
|
|
| Right sentVals' <- sentVals
|
|
= fuiTitle `Set.member` sentVals'
|
|
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle $ fieldAdditionalFiles ^. _FileReferenceFileReferenceTitleMap
|
|
= fieldOptionDefault
|
|
| otherwise = False
|
|
fuiSession = fuiTitle `Map.notMember` view _FileReferenceFileReferenceTitleMap fieldAdditionalFiles
|
|
fuiForced
|
|
| Just (_, _, FileFieldUserOption{..}) <- Map.lookup fuiTitle permittedFiles
|
|
= fieldOptionForce
|
|
| otherwise
|
|
= False
|
|
in FileUploadInfo{..}
|
|
|
|
fileInfos' = map toFUI . Set.toList $ fold sentVals <> Map.keysSet permittedFiles
|
|
|
|
return $ sortOn (splitPath . fuiTitle) fileInfos'
|
|
|
|
let
|
|
mayUnpack = not (fieldOptionForce fieldUnpackZips) || fieldOptionDefault fieldUnpackZips
|
|
|
|
zipExtensions = mimeExtensions typeZip
|
|
|
|
acceptRestricted = isJust fieldRestrictExtensions
|
|
accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) mayUnpack ++ toListOf (_Just . re _nullable . folded) fieldRestrictExtensions
|
|
|
|
uploadOnlySessionMessage <- messageIconI Warning IconFileUploadSession MsgFileUploadOnlySessionTip
|
|
|
|
$(widgetFile "widgets/genericFileField")
|
|
unpackZips :: Text
|
|
unpackZips = "unpack-zip"
|
|
|
|
|
|
|
|
fileFieldMultiple :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
|
|
fileFieldMultiple = genericFileField $ return FileField
|
|
{ fieldIdent = Nothing
|
|
, fieldUnpackZips = FileFieldUserOption True False
|
|
, fieldMultiple = True
|
|
, fieldRestrictExtensions = Nothing
|
|
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
|
|
, fieldMaxFileSize = Nothing
|
|
, fieldAllEmptyOk = True
|
|
}
|
|
|
|
|
|
fileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m FileUploads
|
|
fileField = singleFileField $ return ()
|
|
|
|
singleFileField :: (MonadHandler m, HandlerSite m ~ UniWorX) => FileUploads -> Field m FileUploads
|
|
singleFileField prev = genericFileField $ do
|
|
permitted <- runConduit $ prev .| C.foldMap Set.singleton
|
|
return FileField
|
|
{ fieldIdent = Nothing
|
|
, fieldUnpackZips = FileFieldUserOption True False
|
|
, fieldMultiple = False
|
|
, fieldRestrictExtensions = Nothing
|
|
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList
|
|
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
|
| FileReference{..} <- Set.toList permitted
|
|
]
|
|
, fieldMaxFileSize = Nothing
|
|
, fieldAllEmptyOk = True
|
|
}
|
|
|
|
specificFileField :: UploadSpecificFile -> Maybe FileUploads -> Field Handler FileUploads
|
|
specificFileField UploadSpecificFile{..} mPrev = convertField (.| fixupFileTitles) id . genericFileField $ do
|
|
previous <- runConduit $ maybeVoid mPrev .| C.foldMap Set.singleton
|
|
return FileField
|
|
{ fieldIdent = Nothing
|
|
, fieldUnpackZips = FileFieldUserOption True False
|
|
, fieldMultiple = False
|
|
, fieldRestrictExtensions = fromNullable . maybe Set.empty (Set.singleton . view _2) . Map.lookupMin . Map.fromList . map (length &&& id) $ fileNameExtensions specificFileName
|
|
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList
|
|
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
|
| FileReference{..} <- Set.toList previous
|
|
]
|
|
, fieldMaxFileSize = specificFileMaxSize
|
|
, fieldAllEmptyOk = specificFileEmptyOk
|
|
}
|
|
where
|
|
fixupFileTitles = C.map $ set _fileReferenceTitle (unpack specificFileName)
|
|
|
|
zipFileField :: Bool -- ^ Unpack zips?
|
|
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
|
-> Bool -- ^ Empty files ok?
|
|
-> Field Handler FileUploads
|
|
zipFileField doUnpack permittedExtensions emptyOk = zipFileField' doUnpack permittedExtensions emptyOk Nothing
|
|
|
|
zipFileField' :: Bool -- ^ Unpack zips?
|
|
-> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
|
|
-> Bool -- ^ Empty files ok?
|
|
-> Maybe FileUploads
|
|
-> Field Handler FileUploads
|
|
zipFileField' doUnpack permittedExtensions emptyOk mPrev = genericFileField $ do
|
|
previous <- runConduit $ maybeVoid mPrev .| C.foldMap Set.singleton
|
|
return FileField
|
|
{ fieldIdent = Nothing
|
|
, fieldUnpackZips = FileFieldUserOption True doUnpack
|
|
, fieldMultiple = doUnpack
|
|
, fieldRestrictExtensions = permittedExtensions
|
|
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList
|
|
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
|
| FileReference{..} <- Set.toList previous
|
|
]
|
|
, fieldMaxFileSize = Nothing
|
|
, fieldAllEmptyOk = emptyOk
|
|
}
|
|
|
|
fileUploadForm :: Bool -- ^ Required?
|
|
-> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
|
|
-> UploadMode
|
|
-> Maybe FileUploads
|
|
-> AForm Handler (Maybe FileUploads)
|
|
fileUploadForm isReq mkFs uMode mPrev = case uMode of
|
|
NoUpload
|
|
-> pure Nothing
|
|
UploadAny{..}
|
|
-> bool (\f fs d -> aopt f fs $ Just <$> d) (\f fs d -> Just <$> apreq f fs d) isReq (zipFileField' uploadUnpackZips uploadExtensionRestriction uploadEmptyOk mPrev) (mkFs uploadUnpackZips) mPrev
|
|
UploadSpecific{..}
|
|
-> mergeFileSources <$> traverse specificFileForm (Set.toList $ toNullable uploadSpecificFiles)
|
|
where
|
|
specificFileForm :: UploadSpecificFile -> AForm Handler (Maybe FileUploads)
|
|
specificFileForm spec@UploadSpecificFile{..}
|
|
= bool (\f fs d -> aopt f fs $ Just <$> d) (\f fs d -> Just <$> apreq f fs d) (specificFileRequired && isReq) (specificFileField spec mPrev') (fsl specificFileLabel) mPrev'
|
|
where mPrev' = flip (.|) (C.filter . has $ _fileReferenceTitle . only (unpack specificFileName)) <$> mPrev
|
|
|
|
mergeFileSources :: [Maybe FileUploads] -> Maybe FileUploads
|
|
mergeFileSources (catMaybes -> sources) = case sources of
|
|
[] -> Nothing
|
|
fs -> Just $ sequence_ fs
|
|
|
|
multiFileField' :: FileUploads -- ^ Permitted files in same format as produced by `multiFileField`
|
|
-> Field Handler FileUploads
|
|
multiFileField' permittedFiles = multiFileField . runConduit $ permittedFiles .| C.foldMap Set.singleton
|
|
|
|
multiFileField :: Handler (Set FileReference) -- ^ Set of files that may be submitted by id-reference
|
|
-> Field Handler FileUploads
|
|
multiFileField mkPermitted = genericFileField $ mkField <$> mkPermitted
|
|
where mkField permitted = FileField
|
|
{ fieldIdent = Nothing
|
|
, fieldUnpackZips = FileFieldUserOption False False
|
|
, fieldMultiple = True
|
|
, fieldRestrictExtensions = Nothing
|
|
, fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.fromList
|
|
[ (fileReferenceTitle, (fileReferenceContent, fileReferenceModified, FileFieldUserOption False True))
|
|
| FileReference{..} <- Set.toList permitted
|
|
]
|
|
, fieldMaxFileSize = Nothing
|
|
, fieldAllEmptyOk = True
|
|
}
|
|
|
|
data SheetGrading' = Points' | PassPoints' | PassBinary' | PassAlways'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
|
|
|
instance Universe SheetGrading'
|
|
instance Finite SheetGrading'
|
|
|
|
nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
|
|
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)
|
|
|
|
|
|
data SheetGroup' = Arbitrary' | RegisteredGroups' | NoGroups'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
|
|
|
instance Universe SheetGroup'
|
|
instance Finite SheetGroup'
|
|
|
|
nullaryPathPiece ''SheetGroup' (camelToPathPiece . dropSuffix "'")
|
|
embedRenderMessage ''UniWorX ''SheetGroup' (("SheetGroup" <>) . dropSuffix "'")
|
|
|
|
sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
|
|
sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
|
|
where
|
|
selOptions = Map.fromList
|
|
[ ( Points', Points <$> maxPointsReq )
|
|
, ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
|
|
, ( PassBinary', pure PassBinary)
|
|
, ( PassAlways', pure PassAlways)
|
|
]
|
|
classify' :: SheetGrading -> SheetGrading'
|
|
classify' = \case
|
|
Points {} -> Points'
|
|
PassPoints {} -> PassPoints'
|
|
PassBinary {} -> PassBinary'
|
|
PassAlways {} -> PassAlways'
|
|
|
|
maxPointsReq = apreq pointsField (fslI MsgSheetGradingMaxPoints) (template >>= preview _maxPoints)
|
|
passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)
|
|
|
|
|
|
sheetTypeAFormReq :: CourseId -> FieldSettings UniWorX -> Maybe (SheetType ExamPartId) -> AForm Handler (SheetType ExamPartId)
|
|
sheetTypeAFormReq cId fs template = wFormToAForm $ do
|
|
(examParts'', editableExams) <- liftHandler . runDB $ do
|
|
examParts'' <- E.select . E.from $ \(course `E.InnerJoin` exam `E.InnerJoin` examPart) -> do
|
|
E.on $ exam E.^. ExamId E.==. examPart E.^. ExamPartExam
|
|
E.on $ course E.^. CourseId E.==. exam E.^. ExamCourse
|
|
E.where_ $ exam E.^. ExamCourse E.==. E.val cId
|
|
return (exam, course, examPart)
|
|
|
|
editableExams <- fmap Map.keysSet . flip mapFilterM (foldMap (\(Entity eId exam, Entity _ course, _) -> Map.singleton eId (exam, course)) examParts'') $ \(Exam{..}, Course{..}) ->
|
|
hasWriteAccessTo $ CExamR courseTerm courseSchool courseShorthand examName EEditR
|
|
|
|
return (examParts'', editableExams)
|
|
|
|
let
|
|
examParts' = flip foldMap examParts'' $ \(eEnt@(Entity eId _), _, epEnt) -> guardOn @[] (eId `Set.member` editableExams) (eEnt, epEnt)
|
|
examParts = flip sortOn examParts' $ \(Entity _ Exam{..}, Entity _ ExamPart{..}) -> (examName, examPartNumber)
|
|
|
|
doExamPartPoints = fmap classifySheetType template == Just ExamPartPoints'
|
|
|| not (null examParts)
|
|
|
|
acts = Map.fromList $ catMaybes
|
|
[ pure ( Normal', Normal <$> gradingReq )
|
|
, pure ( Bonus' , Bonus <$> gradingReq )
|
|
, pure ( Informational', Informational <$> gradingReq )
|
|
, pure ( NotGraded', pure NotGraded )
|
|
, guardOn doExamPartPoints ( ExamPartPoints', ExamPartPoints <$> examPartReq <*> weightReq <*> gradingReq )
|
|
]
|
|
gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
|
|
& setTooltip MsgSheetGradingInfo) $ template >>= preview _grading
|
|
weightReq = apreq (checkBool (>= 0) MsgSheetTypeExamPartPointsWeightNegative rationalField) (fslI MsgSheetTypeExamPartPointsWeight) $ preview (_Just . _weight) template
|
|
examPartReq = apreq examPartField (fslI MsgSheetTypeExamPartPointsExamPart) $ preview (_Just . _examPart) template >>= assertM' (\epId -> any (\(_, Entity epId' _) -> epId == epId') examParts)
|
|
examPartField = selectField' Nothing . fmap (fmap $ \(_, Entity epId _) -> epId) $ optionsCryptoIdF examParts
|
|
(\(_, Entity epId _) -> return epId)
|
|
(\(Entity _ Exam{..}, Entity _ ExamPart{..}) -> return $ MsgSheetTypeExamPartPointsExamPartOption examName examPartNumber)
|
|
|
|
opts = explainOptionList optionsFinite $ \case
|
|
Normal' -> return $ i18n MsgSheetTypeInfoNormalLecturer
|
|
Bonus' -> return $ i18n MsgSheetTypeInfoBonus
|
|
Informational' -> return $ i18n MsgSheetTypeInfoInformational
|
|
NotGraded' -> return $ i18n MsgSheetTypeInfoNotGraded
|
|
ExamPartPoints' -> return $ i18n MsgSheetTypeInfoExamPartPoints
|
|
|
|
aFormToWForm . explainedMultiActionA acts opts fs $ classifySheetType <$> template
|
|
|
|
sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
|
|
sheetGroupAFormReq fs template = explainedMultiActionA acts opts fs (classify' <$> template)
|
|
where
|
|
acts = Map.fromList
|
|
[ ( Arbitrary', Arbitrary
|
|
<$> apreq (natFieldI MsgGroupSizeNotNatural) (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
|
|
)
|
|
, ( RegisteredGroups', pure RegisteredGroups )
|
|
, ( NoGroups', pure NoGroups )
|
|
]
|
|
opts = explainOptionList optionsFinite $ \case
|
|
Arbitrary' -> return $(i18nWidgetFile "sheet-grouping-explanation/arbitrary")
|
|
RegisteredGroups' -> return $(i18nWidgetFile "sheet-grouping-explanation/registered")
|
|
NoGroups' -> mzero
|
|
classify' :: SheetGroup -> SheetGroup'
|
|
classify' = \case
|
|
Arbitrary _ -> Arbitrary'
|
|
RegisteredGroups -> RegisteredGroups'
|
|
NoGroups -> NoGroups'
|
|
|
|
|
|
{-
|
|
dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
|
|
dayTimeField fs mutc = do
|
|
let (mbDay,mbTime) = case mutcs of
|
|
Nothing -> return (Nothing,Nothing)
|
|
(Just utc) ->
|
|
|
|
(dayResult, dayView) <- mreq dayField fs
|
|
|
|
(result, view) <- (,) <$> dayField <*> timeField
|
|
where
|
|
(mbDay,mbTime)
|
|
| (Just utc) <- mutc =
|
|
let lt = utcToLocalTime ??? utcs
|
|
in (Just $ localDay lt, Just $ localTimeOfDay lt)
|
|
| otherwise = (Nothing,Nothing)
|
|
-}
|
|
|
|
fieldTimeFormat :: String
|
|
-- fieldTimeFormat = "%e.%m.%y %k:%M"
|
|
fieldTimeFormat = "%Y-%m-%dT%H:%M:%S"
|
|
|
|
localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime
|
|
localTimeField = Field
|
|
{ fieldParse = parseHelperGen readTime
|
|
, fieldView = \theId name attrs val isReq -> do
|
|
val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
|
|
[whamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
|
|
|]
|
|
, fieldEnctype = UrlEncoded
|
|
}
|
|
where
|
|
-- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any words
|
|
readTime :: Text -> Either (SomeMessage UniWorX) LocalTime
|
|
readTime t =
|
|
case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
|
|
Just lTime -> Right lTime
|
|
Nothing -> Left (SomeMessage MsgInvalidDateTimeFormat)
|
|
|
|
utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
|
|
utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeField
|
|
where
|
|
localTimeToUTC' l = case localTimeToUTC l of
|
|
LTUUnique{_ltuResult} -> Right _ltuResult
|
|
LTUNone{} -> Left MsgIllDefinedUTCTime
|
|
LTUAmbiguous{} -> Left MsgAmbiguousUTCTime
|
|
|
|
|
|
langField :: Bool -- ^ Only allow values from `appLanguages`
|
|
-> Field Handler Lang
|
|
langField False = checkBool langCheck MsgInvalidLangFormat $ textField & addDatalist appLanguagesOpts & cfStrip
|
|
where langCheck (T.splitOn "-" -> lParts)
|
|
= all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
|
|
&& not (null lParts)
|
|
langField True = selectField appLanguagesOpts
|
|
|
|
data JsonFieldKind
|
|
= JsonFieldNormal
|
|
| JsonFieldLarge
|
|
| JsonFieldHidden
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
|
|
jsonField :: ( ToJSON a, FromJSON a
|
|
, MonadHandler m
|
|
, RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) UniWorXTablePaginationMessage
|
|
)
|
|
=> JsonFieldKind
|
|
-> Field m a
|
|
jsonField fieldKind = Field{..}
|
|
where
|
|
inputType :: Text
|
|
inputType = case fieldKind of
|
|
JsonFieldHidden -> "hidden"
|
|
_other -> "text"
|
|
fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just $ eitherDecodeStrict' v <|> eitherDecodeStrict' (urlDecode True v)
|
|
fieldParse [] [] = return $ Right Nothing
|
|
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
|
fieldView theId name attrs val isReq = case fieldKind of
|
|
JsonFieldLarge -> liftWidget
|
|
[whamlet|
|
|
$newline never
|
|
<textarea id=#{theId} name=#{name} *{attrs} :isReq:required .json>
|
|
#{either fromStrict (Builder.toLazyText . encodePrettyToTextBuilder) val}
|
|
|]
|
|
_other -> liftWidget
|
|
[whamlet|
|
|
$newline never
|
|
<input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val} .json>
|
|
|]
|
|
fieldEnctype = UrlEncoded
|
|
|
|
yamlField :: ( ToJSON a, FromJSON a
|
|
, MonadHandler m
|
|
, RenderMessage (HandlerSite m) FormMessage
|
|
, RenderMessage (HandlerSite m) UniWorXWorkflowMessage
|
|
)
|
|
=> Field m a
|
|
yamlField = Field{..}
|
|
where
|
|
fieldParse [encodeUtf8 -> v] [] = return . bimap (SomeMessage . MsgYAMLFieldDecodeFailure . displayException) Just . runCatch $ Yaml.decodeThrow v <|> Yaml.decodeThrow (urlDecode True v)
|
|
fieldParse [] [] = return $ Right Nothing
|
|
fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
|
|
fieldView theId name attrs val isReq = liftWidget
|
|
[whamlet|
|
|
$newline never
|
|
<textarea id=#{theId} name=#{name} *{attrs} :isReq:required .yaml>
|
|
#{either id (decodeUtf8 . Yaml.encode) val}
|
|
|]
|
|
fieldEnctype = UrlEncoded
|
|
|
|
|
|
boolField :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Maybe (SomeMessage UniWorX) -> Field m Bool
|
|
boolField mkNone = radioGroupField mkNone $ do
|
|
mr <- getMessageRender
|
|
return OptionList
|
|
{ olOptions = [ Option (mr MsgBoolNo ) False "no"
|
|
, Option (mr MsgBoolYes) True "yes"
|
|
]
|
|
, olReadExternal = \case
|
|
"yes" -> Just True
|
|
"on" -> Just True
|
|
"no" -> Just False
|
|
"true" -> Just True
|
|
"false" -> Just False
|
|
_other -> Nothing
|
|
}
|
|
|
|
|
|
|
|
sectionedFuncForm :: forall f k v m sec.
|
|
( TraversableWithIndex k f
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, RenderMessage UniWorX sec
|
|
, Ord sec
|
|
)
|
|
=> (k -> Maybe sec) -> f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v)
|
|
sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
|
|
where
|
|
funcForm' :: AForm m (f v)
|
|
funcForm' = wFormToAForm $ do
|
|
(res, MergeMap fs) <- runWriterT . ifor mkForm $ \k form
|
|
-> WriterT . fmap (over _2 $ MergeMap . Map.singleton (mkSection k)) . wFormFields $ aFormToWForm form
|
|
|
|
iforM_ fs $ \mSection secfs -> unless (null secfs) $ do
|
|
traverse_ wformSection mSection
|
|
lift $ tell secfs
|
|
|
|
return $ sequenceA res
|
|
|
|
funcFieldView :: (FormResult (f v), Widget) -> MForm m (FormResult (f v), [FieldView UniWorX])
|
|
funcFieldView (res, formView) = do
|
|
mr <- getMessageRender
|
|
fvId <- maybe newIdent return fsId
|
|
let fvLabel = toHtml $ mr fsLabel
|
|
fvTooltip = fmap (toHtml . mr) fsTooltip
|
|
fvRequired = isRequired
|
|
fvErrors
|
|
| FormFailure (err:_) <- res = Just $ toHtml err
|
|
| otherwise = Nothing
|
|
fvInput = $(widgetFile "widgets/fields/funcField")
|
|
return (res, pure FieldView{..})
|
|
|
|
|
|
funcForm :: forall f k v m.
|
|
( TraversableWithIndex k f
|
|
, MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> f (AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (f v)
|
|
funcForm = sectionedFuncForm $ pure (Nothing :: Maybe Void)
|
|
|
|
|
|
|
|
|
|
fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
|
|
fsm = bfs -- TODO: get rid of Bootstrap
|
|
|
|
fsb :: Text -> FieldSettings site -- DEPRECATED
|
|
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors
|
|
|
|
fsUniq :: (Text -> Text) -> Text -> FieldSettings site
|
|
fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }
|
|
|
|
|
|
optionsPersistCryptoId :: forall backend a msg.
|
|
( HasCryptoUUID (Key a) (HandlerFor UniWorX)
|
|
, RenderMessage UniWorX msg
|
|
, YesodPersistBackend UniWorX ~ backend
|
|
, PersistRecordBackend a backend
|
|
, Binary (Key a), Typeable a
|
|
)
|
|
=> [Filter a]
|
|
-> [SelectOpt a]
|
|
-> (a -> msg)
|
|
-> HandlerFor UniWorX (OptionList (Entity a))
|
|
optionsPersistCryptoId filts ords toDisplay = do
|
|
ents <- runDB $ selectList filts ords
|
|
optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
|
|
|
|
mkOptionsE :: forall a r b msg.
|
|
( RenderMessage UniWorX msg
|
|
, E.SqlSelect a r
|
|
)
|
|
=> E.SqlQuery a
|
|
-> (r -> YesodDB UniWorX Text)
|
|
-> (r -> YesodDB UniWorX msg)
|
|
-> (r -> YesodDB UniWorX b)
|
|
-> YesodDB UniWorX (OptionList b)
|
|
mkOptionsE query toExternal toDisplay toInternal = do
|
|
mr <- getMessageRender
|
|
let toOption x = Option <$> (mr <$> toDisplay x) <*> toInternal x <*> toExternal x
|
|
fmap (mkOptionList . toList) . runConduit $
|
|
E.selectSource query .| C.mapM toOption .| C.foldMap Seq.singleton
|
|
|
|
optionsCryptoIdE :: forall backend a msg.
|
|
( HasCryptoUUID (Key a) (HandlerFor UniWorX)
|
|
, RenderMessage UniWorX msg
|
|
, YesodPersistBackend UniWorX ~ backend
|
|
, PersistRecordBackend a backend
|
|
, Binary (Key a), Typeable a
|
|
)
|
|
=> E.SqlQuery (E.SqlExpr (Entity a))
|
|
-> (a -> msg)
|
|
-> HandlerFor UniWorX (OptionList (Entity a))
|
|
optionsCryptoIdE query toDisplay = do
|
|
ents <- runDB $ E.select query
|
|
optionsCryptoIdF ents (return . entityKey) (return . toDisplay . entityVal)
|
|
|
|
optionsCryptoIdF :: forall m mono k msg.
|
|
( HasCryptoUUID k (HandlerFor (HandlerSite m))
|
|
, RenderMessage (HandlerSite m) msg
|
|
, MonoFoldable mono
|
|
, MonadHandler m, HandlerSite m ~ UniWorX
|
|
, Binary k, Typeable k
|
|
)
|
|
=> mono
|
|
-> (Element mono -> m k)
|
|
-> (Element mono -> m msg)
|
|
-> m (OptionList (Element mono))
|
|
optionsCryptoIdF (otoList -> iVals) toExtVal toMsg
|
|
= fmap mkOptionList . forM iVals $ \optionInternalValue -> do
|
|
cID <- encrypt =<< toExtVal optionInternalValue
|
|
optionDisplay <- getMessageRender <*> toMsg optionInternalValue
|
|
return Option
|
|
{ optionDisplay
|
|
, optionExternalValue = toPathPiece (cID :: CryptoUUID k)
|
|
, optionInternalValue
|
|
}
|
|
|
|
|
|
examOccurrenceField :: ( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> ExamId
|
|
-> Field m ExamOccurrenceId
|
|
examOccurrenceField eid
|
|
= hoistField liftHandler . selectField . fmap (fmap entityKey)
|
|
$ optionsPersistCryptoId [ ExamOccurrenceExam ==. eid ] [ Asc ExamOccurrenceName ] examOccurrenceName
|
|
|
|
|
|
formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
|
|
formResultModal res finalDest handler = maybeT_ $ do
|
|
messages <- case res of
|
|
FormMissing -> mzero
|
|
FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
|
|
FormSuccess val -> lift . execWriterT $ handler val
|
|
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
if
|
|
| isModal -> sendResponse $ toJSON messages
|
|
| otherwise -> do
|
|
forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
|
|
redirect finalDest
|
|
|
|
|
|
data MultiUserInvitationMode
|
|
= MUIAlwaysInvite
|
|
| MUILookupAnyUser (Maybe (E.SqlQuery (E.SqlExpr (Entity User))))
|
|
| MUILookupSuggested (SomeMessage UniWorX) (E.SqlQuery (E.SqlExpr (Entity User)))
|
|
|
|
|
|
multiUserInvitationField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> MultiUserInvitationMode
|
|
-> Field m (Set (Either UserEmail UserId))
|
|
multiUserInvitationField mode
|
|
= baseField
|
|
{ fieldView = \theId name attrs val isReq ->
|
|
[whamlet|
|
|
$newline never
|
|
<div .multi-user-invitation-field__wrapper>
|
|
^{fieldView baseField theId name attrs val isReq}
|
|
<p .multi-user-invitation-field__explanation .explanation>
|
|
^{explanation}
|
|
|]
|
|
}
|
|
where
|
|
(onlySuggested, suggestions) = case mode of
|
|
MUIAlwaysInvite -> (True , Nothing)
|
|
MUILookupAnyUser ms -> (False, ms )
|
|
MUILookupSuggested _ s -> (True , Just s )
|
|
baseField = multiUserField onlySuggested suggestions
|
|
|
|
explanation
|
|
| MUILookupSuggested suggestExplain _ <- mode
|
|
= [whamlet|
|
|
$newline never
|
|
_{suggestExplain}
|
|
<br />
|
|
_{MsgMultiUserFieldInvitationExplanation}
|
|
|]
|
|
| onlySuggested
|
|
= i18n MsgMultiUserFieldInvitationExplanationAlways
|
|
| otherwise
|
|
= [whamlet|
|
|
$newline never
|
|
_{MsgMultiUserFieldExplanationAnyUser}
|
|
<br />
|
|
_{MsgMultiUserFieldInvitationExplanation}
|
|
|]
|
|
|
|
multiUserField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Bool -- ^ Only resolve suggested users?
|
|
-> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
|
|
-> Field m (Set (Either UserEmail UserId))
|
|
multiUserField onlySuggested suggestions = Field{..}
|
|
where
|
|
lookupExpr
|
|
| onlySuggested = suggestions
|
|
| otherwise = Just $ E.from return
|
|
|
|
fieldEnctype = UrlEncoded
|
|
fieldView theId name attrs val isReq = do
|
|
val' <- case val of
|
|
Left t -> return t
|
|
Right vs -> Text.intercalate ", " . map CI.original <$> do
|
|
let (emails, uids) = partitionEithers $ Set.toList vs
|
|
rEmails <- case lookupExpr of
|
|
Nothing -> return []
|
|
Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
|
|
dbRes <- liftHandler . runDB . E.select $ do
|
|
user <- lookupExpr'
|
|
E.where_ $ user E.^. UserId E.==. E.val uid
|
|
return $ user E.^. UserEmail
|
|
case dbRes of
|
|
[E.Value email] -> return [email]
|
|
_other -> return []
|
|
return $ emails ++ rEmails
|
|
|
|
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
|
|
|
|
[whamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|
|
|]
|
|
|
|
whenIsJust suggestions $ \suggestions' -> do
|
|
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
|
user <- suggestions'
|
|
return ( E.case_
|
|
[ E.when_ (unique UserDisplayEmail user)
|
|
E.then_ (user E.^. UserDisplayEmail)
|
|
, E.when_ (unique UserEmail user)
|
|
E.then_ (user E.^. UserEmail)
|
|
]
|
|
( E.else_ $ user E.^. UserIdent)
|
|
, user E.^. UserDisplayName
|
|
)
|
|
[whamlet|
|
|
$newline never
|
|
<datalist id=#{datalistId}>
|
|
$forall (email, dName) <- suggestedEmails
|
|
<option value=#{email}>
|
|
#{email} (#{dName})
|
|
|]
|
|
fieldParse (all Text.null -> True) _ = return $ Right Nothing
|
|
fieldParse ts _ = runExceptT . fmap Just $ do
|
|
let ts' = concatMap (Text.splitOn ",") ts
|
|
emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
|
|
fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
|
|
Nothing -> return $ Left email
|
|
Just lookupExpr' -> do
|
|
dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
|
|
user <- lookupExpr'
|
|
E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
|
|
E.||. ( user E.^. UserDisplayEmail `E.ciEq` E.val email
|
|
E.&&. unique UserDisplayEmail user
|
|
)
|
|
E.||. ( user E.^. UserEmail `E.ciEq` E.val email
|
|
E.&&. unique UserEmail user
|
|
)
|
|
return $ user E.^. UserId
|
|
if | Set.null dbRes
|
|
-> return $ Left email
|
|
| [uid] <- Set.toList dbRes
|
|
-> return $ Right uid
|
|
| otherwise
|
|
-> throwE $ SomeMessage MsgAmbiguousEmail
|
|
|
|
unique field user = case lookupExpr of
|
|
Just lookupExpr' -> E.not_ . E.exists $ do
|
|
user' <- lookupExpr'
|
|
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
|
|
E.&&. ( user' E.^. UserIdent `E.ciEq` user E.^. field
|
|
E.||. user' E.^. UserEmail `E.ciEq` user E.^. field
|
|
E.||. user' E.^. UserDisplayEmail `E.ciEq` user E.^. field
|
|
)
|
|
Nothing -> E.true
|
|
|
|
userField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Bool -- ^ Only resolve suggested users?
|
|
-> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
|
|
-> Field m (Either UserEmail UserId)
|
|
userField onlySuggested suggestions = Field{..}
|
|
where
|
|
lookupExpr
|
|
| onlySuggested = suggestions
|
|
| otherwise = Just $ E.from return
|
|
|
|
fieldEnctype = UrlEncoded
|
|
fieldView theId name attrs val isReq = do
|
|
val' <- case val of
|
|
Left t -> return t
|
|
Right v -> case v of
|
|
Right uid -> case lookupExpr of
|
|
Nothing -> return mempty
|
|
Just lookupExpr' -> do
|
|
dbRes <- liftHandler . runDB . E.select $ do
|
|
user <- lookupExpr'
|
|
E.where_ $ user E.^. UserId E.==. E.val uid
|
|
return $ user E.^. UserEmail
|
|
case dbRes of
|
|
[E.Value email] -> return $ CI.original email
|
|
_other -> return mempty
|
|
Left email -> return $ CI.original email
|
|
|
|
datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
|
|
|
|
[whamlet|
|
|
$newline never
|
|
<input id="#{theId}" name="#{name}" *{attrs} type="email" :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
|
|
|]
|
|
|
|
whenIsJust suggestions $ \suggestions' -> do
|
|
suggestedEmails <- fmap (Map.assocs . Map.fromListWith min . map (over _2 E.unValue . over _1 E.unValue)) . liftHandler . runDB . E.select $ do
|
|
user <- suggestions'
|
|
return ( E.case_
|
|
[ E.when_ (unique UserDisplayEmail user)
|
|
E.then_ (user E.^. UserDisplayEmail)
|
|
, E.when_ (unique UserEmail user)
|
|
E.then_ (user E.^. UserEmail)
|
|
]
|
|
( E.else_ $ user E.^. UserIdent)
|
|
, user E.^. UserDisplayName
|
|
)
|
|
[whamlet|
|
|
$newline never
|
|
<datalist id=#{datalistId}>
|
|
$forall (email, dName) <- suggestedEmails
|
|
<option value=#{email}>
|
|
#{email} (#{dName})
|
|
|]
|
|
fieldParse (filter (not . Text.null) -> t : _) _ = runExceptT . fmap Just $ do
|
|
email <- either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . CI.mk . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
|
|
case lookupExpr of
|
|
Nothing -> return $ Left email
|
|
Just lookupExpr' -> do
|
|
dbRes <- fmap (setOf $ folded . _Value). liftHandler . runDB . E.select $ do
|
|
user <- lookupExpr'
|
|
E.where_ $ user E.^. UserIdent `E.ciEq` E.val email
|
|
E.||. ( user E.^. UserDisplayEmail `E.ciEq` E.val email
|
|
E.&&. unique UserDisplayEmail user
|
|
)
|
|
E.||. ( user E.^. UserEmail `E.ciEq` E.val email
|
|
E.&&. unique UserEmail user
|
|
)
|
|
return $ user E.^. UserId
|
|
if | Set.null dbRes
|
|
-> return $ Left email
|
|
| [uid] <- Set.toList dbRes
|
|
-> return $ Right uid
|
|
| otherwise
|
|
-> throwE $ SomeMessage MsgAmbiguousEmail
|
|
fieldParse _ _ = return $ Right Nothing
|
|
|
|
unique field user = case lookupExpr of
|
|
Just lookupExpr' -> E.not_ . E.exists $ do
|
|
user' <- lookupExpr'
|
|
E.where_ $ user' E.^. UserId E.!=. user E.^. UserId
|
|
E.&&. ( user' E.^. UserIdent `E.ciEq` user E.^. field
|
|
E.||. user' E.^. UserEmail `E.ciEq` user E.^. field
|
|
E.||. user' E.^. UserDisplayEmail `E.ciEq` user E.^. field
|
|
)
|
|
Nothing -> E.true
|
|
|
|
|
|
examResultField :: forall m res.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, PathPiece res
|
|
)
|
|
=> Maybe (SomeMessage UniWorX) -> Handler (OptionList (Either Text res -> Bool, Field m res)) -> Field m (ExamResult' res)
|
|
examResultField optMsg mkOl = Field
|
|
{ fieldEnctype = UrlEncoded -- breaks if mkOl contains options with other enctype
|
|
, fieldParse = \ts fs -> do
|
|
ol@OptionList{..} <- liftHandler mkOl
|
|
if
|
|
| res : _ <- mapMaybe (assertM ((||) <$> is _ExamNoShow <*> is _ExamVoided) . fromPathPiece) ts
|
|
-> return . Right $ Just res
|
|
| any null ts
|
|
-> return $ Right Nothing
|
|
| (optPred, innerField) : _ <- mapMaybe olReadExternal ts
|
|
-> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (`notElem` outerOptions ol) $ filter (optPred . Left) ts) fs
|
|
| [] <- ts
|
|
-> return $ Right Nothing
|
|
| t : _ <- ts
|
|
-> return . Left . SomeMessage $ MsgInvalidEntry t
|
|
, fieldView = \theId name attrs val isReq -> do
|
|
innerId <- newIdent
|
|
OptionList{..} <- liftHandler mkOl
|
|
let
|
|
innerVal :: Either Text res
|
|
innerVal = val >>= maybe (Left "") return . preview _ExamAttended
|
|
|
|
matchesPred Option{ optionInternalValue = (optPred, _) } = has (_Right . _ExamAttended . filtered (optPred . Right)) val
|
|
[whamlet|
|
|
$newline never
|
|
<div>
|
|
<select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
|
|
$maybe optMsg' <- guardOnM (not isReq) optMsg
|
|
<option value="" :is _Left val:selected>
|
|
_{optMsg'}
|
|
$forall opt@Option{optionDisplay, optionExternalValue} <- olOptions
|
|
<option value=#{optionExternalValue} :matchesPred opt:selected>
|
|
#{optionDisplay}
|
|
<option value=#{toPathPiece noShowVal} :is (_Right . _ExamNoShow) val:selected>
|
|
_{MsgUtilExamResultNoShow}
|
|
<option value=#{toPathPiece voidedVal} :is (_Right . _ExamVoided) val:selected>
|
|
_{MsgUtilExamResultVoided}
|
|
$forall Option{..} <- olOptions
|
|
<fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value=#{optionExternalValue} style="display: inline-block">
|
|
<legend>
|
|
#{optionDisplay}
|
|
^{fieldView (snd optionInternalValue) innerId name attrs innerVal True}
|
|
|]
|
|
}
|
|
where
|
|
outerOptions OptionList{..} =
|
|
[ ""
|
|
, toPathPiece noShowVal
|
|
, toPathPiece voidedVal
|
|
] ++ [ optionExternalValue | Option{..} <- olOptions ]
|
|
|
|
noShowVal, voidedVal :: ExamResult' res
|
|
noShowVal = ExamNoShow
|
|
voidedVal = ExamVoided
|
|
|
|
examResultGradeField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Maybe (SomeMessage UniWorX) -> Field m ExamResultGrade
|
|
examResultGradeField = flip examResultField $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return $ mkOptionList
|
|
[ Option
|
|
{ optionDisplay = mr MsgUtilExamResultGrade
|
|
, optionExternalValue = "grade"
|
|
, optionInternalValue =
|
|
( const True
|
|
, examGradeField
|
|
)
|
|
}
|
|
]
|
|
|
|
examResultPassedField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Maybe (SomeMessage UniWorX) -> Field m ExamResultPassed
|
|
examResultPassedField = flip examResultField $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return $ mkOptionList
|
|
[ Option
|
|
{ optionDisplay = mr MsgUtilExamResultPass
|
|
, optionExternalValue = "pass"
|
|
, optionInternalValue =
|
|
( const True
|
|
, examPassedField
|
|
)
|
|
}
|
|
]
|
|
|
|
examResultPassedGradeField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Maybe (SomeMessage UniWorX) -> Field m ExamResultPassedGrade
|
|
examResultPassedGradeField = flip examResultField $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
return $ mkOptionList
|
|
[ Option
|
|
{ optionDisplay = mr MsgUtilExamResultGrade
|
|
, optionExternalValue = "grade"
|
|
, optionInternalValue =
|
|
( either (`elem` map toPathPiece grades) (is _Right)
|
|
, hoistField liftHandler . selectField $ fmap Right <$> optionsFinite
|
|
)
|
|
}
|
|
, Option
|
|
{ optionDisplay = mr MsgUtilExamResultPass
|
|
, optionExternalValue = "pass"
|
|
, optionInternalValue =
|
|
( either (`elem` map toPathPiece passResults) (is _Left)
|
|
, hoistField liftHandler . selectField $ fmap Left <$> optionsFinite
|
|
)
|
|
}
|
|
]
|
|
where
|
|
grades :: [ExamGrade]
|
|
grades = universeF
|
|
passResults :: [ExamPassed]
|
|
passResults = universeF
|
|
|
|
examResultModeField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Maybe (SomeMessage UniWorX) -> ExamGradingMode -> Field m ExamResultPassedGrade
|
|
examResultModeField optMsg ExamGradingGrades = convertField (fmap Right) (fmap $ either (review passingGrade) id) $ examResultGradeField optMsg
|
|
examResultModeField optMsg ExamGradingPass = convertField (fmap Left) (fmap $ either id (view passingGrade)) $ examResultPassedField optMsg
|
|
examResultModeField optMsg ExamGradingMixed = examResultPassedGradeField optMsg
|
|
|
|
|
|
examGradeField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Field m ExamGrade
|
|
examGradeField = hoistField liftHandler $ selectField optionsFinite
|
|
|
|
examPassedField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Field m ExamPassed
|
|
examPassedField = hoistField liftHandler $ selectField optionsFinite
|
|
|
|
examPassedGradeField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Field m (Either ExamPassed ExamGrade)
|
|
examPassedGradeField = hoistField liftHandler . selectField $ (<>) <$> (fmap Right <$> optionsFinite) <*> (fmap Left <$> optionsFinite)
|
|
|
|
|
|
examField :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Maybe (SomeMessage UniWorX) -> CourseId -> Field m ExamId
|
|
examField optMsg cId = hoistField liftHandler . selectField' optMsg . fmap (fmap entityKey) $
|
|
optionsPersistCryptoId [ExamCourse ==. cId] [Asc ExamName] examName
|
|
|
|
|
|
data CsvFormatOptions' = CsvFormatOptionsPreset' CsvPreset
|
|
| CsvFormatOptionsCustom'
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriveFinite ''CsvFormatOptions'
|
|
instance PathPiece CsvFormatOptions' where
|
|
toPathPiece = \case
|
|
CsvFormatOptionsPreset' p -> toPathPiece p
|
|
CsvFormatOptionsCustom' -> "custom"
|
|
fromPathPiece t = fromPathPiece t
|
|
<|> guardOn (t == "custom") CsvFormatOptionsCustom'
|
|
instance RenderMessage UniWorX CsvFormatOptions' where
|
|
renderMessage m ls = \case
|
|
CsvFormatOptionsPreset' p -> mr p
|
|
CsvFormatOptionsCustom' -> mr MsgCsvCustom
|
|
where
|
|
mr :: forall msg. RenderMessage UniWorX msg => msg -> Text
|
|
mr = renderMessage m ls
|
|
|
|
csvFormatOptionsForm :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> FieldSettings UniWorX
|
|
-> Maybe CsvFormatOptions
|
|
-> AForm m CsvFormatOptions
|
|
csvFormatOptionsForm fs mPrev = hoistAForm liftHandler . multiActionA csvActs fs $ classifyCsvFormatOptions <$> mPrev
|
|
where
|
|
csvActs :: Map CsvFormatOptions' (AForm Handler CsvFormatOptions)
|
|
csvActs = mapF $ \case
|
|
CsvFormatOptionsPreset' preset
|
|
-> pure $ csvPreset # preset
|
|
CsvFormatOptionsCustom'
|
|
-> multiActionA csvFormatActs (fslI MsgCsvFormatField) $ view _CsvFormat <$> mPrev
|
|
csvFormatActs :: Map CsvFormat (AForm Handler CsvFormatOptions)
|
|
csvFormatActs = mapF $ \case
|
|
FormatCsv
|
|
-> CsvFormatOptions
|
|
<$> apreq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (preview _csvDelimiter =<< mPrev)
|
|
<*> apreq (selectField lineEndOpts) (fslI MsgCsvUseCrLf) (preview _csvUseCrLf =<< mPrev)
|
|
<*> apreq (selectField quoteOpts) (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (preview _csvQuoting =<< mPrev)
|
|
<*> apreq (selectField encodingOpts) (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (preview _csvEncoding =<< mPrev)
|
|
FormatXlsx -> pure CsvXlsxFormatOptions
|
|
|
|
delimiterOpts :: Handler (OptionList Char)
|
|
delimiterOpts = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let
|
|
opts =
|
|
[ (MsgCsvDelimiterNull, '\0')
|
|
, (MsgCsvDelimiterTab, '\t')
|
|
, (MsgCsvDelimiterComma, ',')
|
|
, (MsgCsvDelimiterColon, chr 58)
|
|
, (MsgCsvDelimiterSemicolon, chr 59)
|
|
, (MsgCsvDelimiterBar, '|')
|
|
, (MsgCsvDelimiterSpace, ' ')
|
|
, (MsgCsvDelimiterUnitSep, chr 31)
|
|
]
|
|
olReadExternal t = do
|
|
i <- readMay t
|
|
guard $ i >= 0 && i <= 255
|
|
let c = chr i
|
|
guard $ any ((== c) . view _2) opts
|
|
return c
|
|
olOptions = [ Option (mr msg) c (tshow $ ord c)
|
|
| (msg, c) <- opts
|
|
]
|
|
return OptionList{..}
|
|
|
|
lineEndOpts :: Handler (OptionList Bool)
|
|
lineEndOpts = optionsPathPiece
|
|
[ (MsgCsvCrLf, True )
|
|
, (MsgCsvLf, False)
|
|
]
|
|
|
|
quoteOpts :: Handler (OptionList Quoting)
|
|
quoteOpts = optionsF
|
|
[ QuoteMinimal
|
|
, QuoteAll
|
|
]
|
|
|
|
encodingOpts :: Handler (OptionList DynEncoding)
|
|
encodingOpts = optionsPathPiece
|
|
[ (MsgCsvUTF8, "UTF8")
|
|
, (MsgCsvCP1252, "CP1252")
|
|
]
|
|
|
|
classifyCsvFormatOptions :: CsvFormatOptions -> CsvFormatOptions'
|
|
classifyCsvFormatOptions opts
|
|
| Just preset <- opts ^? csvPreset
|
|
= CsvFormatOptionsPreset' preset
|
|
| otherwise
|
|
= CsvFormatOptionsCustom'
|
|
|
|
csvOptionsForm :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
)
|
|
=> Maybe CsvOptions
|
|
-> AForm m CsvOptions
|
|
csvOptionsForm mPrev = hoistAForm liftHandler $ CsvOptions
|
|
<$> csvFormatOptionsForm (fslI MsgCsvFormatOptions & setTooltip MsgCsvOptionsTip) (csvFormat <$> mPrev)
|
|
<*> apopt checkBoxField (fslI MsgCsvTimestamp & setTooltip MsgCsvTimestampTip) (csvTimestamp <$> mPrev)
|
|
|
|
|
|
courseSelectForm :: forall ident handler.
|
|
( PathPiece ident
|
|
, MonadHandler handler, HandlerSite handler ~ UniWorX
|
|
, MonadThrow handler
|
|
)
|
|
=> E.SqlQuery (E.SqlExpr (Entity Course))
|
|
-> (Entity Course -> Handler Bool)
|
|
-> (forall p. PathPiece p => p -> Maybe (SomeRoute UniWorX))
|
|
-> ident
|
|
-> FieldSettings UniWorX
|
|
-> Bool
|
|
-> Maybe (Set CourseId)
|
|
-> AForm handler (Set CourseId)
|
|
courseSelectForm query coursePred miButtonAction' miIdent' fSettings fRequired mPrev
|
|
= fmap Set.fromList . massInputAccumA miAdd' miCell' miButtonAction' miLayout' miIdent' fSettings fRequired $ Set.toList <$> mPrev
|
|
where
|
|
query' = do
|
|
course <- query
|
|
E.orderBy [ E.desc $ course E.^. CourseTerm
|
|
, E.asc $ course E.^. CourseSchool
|
|
, E.asc $ course E.^. CourseShorthand
|
|
, E.asc $ course E.^. CourseName
|
|
]
|
|
return course
|
|
|
|
miAdd' nudge btn csrf = do
|
|
let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseShorthand courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions
|
|
|
|
(courseRes, addView) <- mpopt (hoistField liftHandler $ selectField courseOptions) (fslI MsgTableCourse & addName (nudge "course")) Nothing
|
|
let res = courseRes <&> \newCourse oldCourses -> pure (Set.toList $ Set.singleton newCourse `Set.difference` Set.fromList oldCourses)
|
|
return (res, $(widgetFile "widgets/massinput/courses/add"))
|
|
miCell' cid = do
|
|
Course{..} <- liftHandler . runDB $ get404 cid
|
|
$(widgetFile "widgets/massinput/courses/cell")
|
|
miLayout' :: MassInputLayout ListLength CourseId ()
|
|
miLayout' lLength _ cellWdgts delButtons addWdgts = $(widgetFile "widgets/massinput/courses/layout")
|
|
|
|
labeledCheckBoxView :: Widget
|
|
-> Text -> Text -> [(Text, Text)] -> Either Text Bool -> Bool -> Widget
|
|
labeledCheckBoxView label theId name attrs val isReq = $(widgetFile "widgets/fields/labeled-checkbox")
|
|
where
|
|
checkBoxView = fieldView (checkBoxField :: Field Handler Bool) theId name attrs val isReq
|
|
|
|
|
|
newtype CourseParticipantStateIsActive = CourseParticipantStateIsActive { getCourseParticipantStateIsActive :: Bool }
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving newtype (Universe, Finite)
|
|
|
|
embedRenderMessageVariant ''UniWorX ''CourseParticipantStateIsActive $ \case
|
|
"True" -> "CourseParticipantStateIsActive"
|
|
"False" -> "CourseParticipantStateIsInactive"
|
|
_ -> error "Unexpected constructor for Bool"
|
|
finitePathPiece ''CourseParticipantStateIsActive
|
|
["inactive", "active"]
|
|
makeWrapped ''CourseParticipantStateIsActive
|
|
|
|
courseParticipantStateIsActiveField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe (SomeMessage UniWorX) -> Field m Bool
|
|
courseParticipantStateIsActiveField optMsg = hoistField liftHandler . isoField (_Wrapped @CourseParticipantStateIsActive) $ radioGroupField optMsg optionsFinite
|
|
|
|
|
|
userOptionsE :: E.SqlQuery (E.SqlExpr (Entity User))
|
|
-> Handler (OptionList UserId)
|
|
userOptionsE = fmap (fmap entityKey) . flip optionsCryptoIdE userDisplayName
|
|
|
|
|
|
data CustomPresetFormOption p
|
|
= CPFONone
|
|
| CPFOPreset p
|
|
| CPFOCustom
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriveFinite ''CustomPresetFormOption
|
|
derivePathPiece ''CustomPresetFormOption (camelToPathPiece' 1) "--"
|
|
|
|
customPresetForm :: forall a custom preset msg.
|
|
( Finite preset, Ord preset, PathPiece preset
|
|
, RenderMessage UniWorX msg
|
|
)
|
|
=> Iso' a (Either custom preset)
|
|
-> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for none option
|
|
-> Maybe (SomeMessage UniWorX, Maybe Widget) -- ^ Label for custom option
|
|
-> (preset -> (msg, Maybe Widget))
|
|
-> (Maybe custom -> AForm Handler custom)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe (Maybe a)
|
|
-> AForm Handler (Maybe a)
|
|
customPresetForm cpL noneOption customOption toOption customForm fs mPrev
|
|
= explainedMultiActionA actionMap options fs $ Just mPrev'
|
|
where
|
|
mPrev' = case mPrev ^? _Just . _Just . cpL of
|
|
Nothing -> CPFONone
|
|
Just (Left _) -> CPFOCustom
|
|
Just (Right p) -> CPFOPreset p
|
|
|
|
options = explainOptionList options' $ hoistMaybe . optionToWidget
|
|
where options' = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let olReadExternal t = do
|
|
opt <- fromPathPiece t
|
|
case opt of
|
|
CPFONone -> opt <$ hoistMaybe noneOption
|
|
CPFOCustom -> opt <$ hoistMaybe customOption
|
|
CPFOPreset _ -> pure opt
|
|
olOptions = do
|
|
optionInternalValue <- universeF
|
|
optionDisplay <- case optionInternalValue of
|
|
CPFONone -> views _1 mr <$> hoistMaybe noneOption
|
|
CPFOCustom -> views _1 mr <$> hoistMaybe customOption
|
|
CPFOPreset p -> return . views _1 mr $ toOption p
|
|
let optionExternalValue = toPathPiece optionInternalValue
|
|
return Option{..}
|
|
return OptionList{..}
|
|
optionToWidget = \case
|
|
CPFONone -> noneOption ^? _Just . _2 . _Just
|
|
CPFOCustom -> customOption ^? _Just . _2 . _Just
|
|
CPFOPreset p -> toOption p ^. _2
|
|
|
|
actionMap :: Map (CustomPresetFormOption preset) (AForm Handler (Maybe a))
|
|
actionMap = Map.fromList $ do
|
|
opt <- universeF
|
|
return . (opt, ) $ case opt of
|
|
CPFONone -> pure Nothing
|
|
CPFOPreset p -> pure . Just $ cpL # Right p
|
|
CPFOCustom -> reviews cpL Just . Left <$> customForm (mPrev ^? _Just . _Just . cpL . _Left)
|
|
|
|
examModeForm :: Maybe ExamMode -> AForm Handler ExamMode
|
|
examModeForm mPrev = examMode
|
|
<$> customPresetForm examSynchronicityEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examSynchronicityPresetWidget) (apreq htmlField (fslI MsgExamModeFormSynchronicity)) (fslI MsgExamModeFormSynchronicity) (examSynchronicity <$> mPrev)
|
|
<*> customPresetForm examOnlineEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examOnlinePresetWidget) (apreq htmlField (fslI MsgExamModeFormOnline)) (fslI MsgExamModeFormOnline) (examOnline <$> mPrev)
|
|
<*> customPresetForm examAidsEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examAidsPresetWidget) (apreq htmlField (fslI MsgExamModeFormAids)) (fslI MsgExamModeFormAids) (examAids <$> mPrev)
|
|
<*> customPresetForm examRequiredEquipmentEither (Just (SomeMessage MsgExamModeFormNone, Nothing)) (Just (SomeMessage MsgExamModeFormCustom, Nothing)) (id &&& Just . examRequiredEquipmentPresetWidget) (apreq htmlField (fslI MsgExamModeFormRequiredEquipment)) (fslI MsgExamModeFormRequiredEquipment & setTooltip MsgExamModeFormRequiredEquipmentIdentificationTip) (examRequiredEquipment <$> mPrev)
|
|
where
|
|
examMode examSynchronicity examOnline examAids examRequiredEquipment = ExamMode{..}
|
|
|
|
examAidsEither :: Iso' ExamAids (Either StoredMarkup ExamAidsPreset)
|
|
examAidsEither = iso examAidsToEither examAidsFromEither
|
|
where examAidsToEither (ExamAidsPreset p) = Right p
|
|
examAidsToEither (ExamAidsCustom c) = Left c
|
|
examAidsFromEither (Right p) = ExamAidsPreset p
|
|
examAidsFromEither (Left c) = ExamAidsCustom c
|
|
examOnlineEither :: Iso' ExamOnline (Either StoredMarkup ExamOnlinePreset)
|
|
examOnlineEither = iso examOnlineToEither examOnlineFromEither
|
|
where examOnlineToEither (ExamOnlinePreset p) = Right p
|
|
examOnlineToEither (ExamOnlineCustom c) = Left c
|
|
examOnlineFromEither (Right p) = ExamOnlinePreset p
|
|
examOnlineFromEither (Left c) = ExamOnlineCustom c
|
|
examSynchronicityEither :: Iso' ExamSynchronicity (Either StoredMarkup ExamSynchronicityPreset)
|
|
examSynchronicityEither = iso examSynchronicityToEither examSynchronicityFromEither
|
|
where examSynchronicityToEither (ExamSynchronicityPreset p) = Right p
|
|
examSynchronicityToEither (ExamSynchronicityCustom c) = Left c
|
|
examSynchronicityFromEither (Right p) = ExamSynchronicityPreset p
|
|
examSynchronicityFromEither (Left c) = ExamSynchronicityCustom c
|
|
examRequiredEquipmentEither :: Iso' ExamRequiredEquipment (Either StoredMarkup ExamRequiredEquipmentPreset)
|
|
examRequiredEquipmentEither = iso examRequiredEquipmentToEither examRequiredEquipmentFromEither
|
|
where examRequiredEquipmentToEither (ExamRequiredEquipmentPreset p) = Right p
|
|
examRequiredEquipmentToEither (ExamRequiredEquipmentCustom c) = Left c
|
|
examRequiredEquipmentFromEither (Right p) = ExamRequiredEquipmentPreset p
|
|
examRequiredEquipmentFromEither (Left c) = ExamRequiredEquipmentCustom c
|
|
|
|
|
|
data AllocationPriority' = AllocationPriorityNumeric' | AllocationPriorityOrdinal'
|
|
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
|
deriving anyclass (Universe, Finite)
|
|
nullaryPathPiece ''AllocationPriority' $ camelToPathPiece' 2 . dropSuffix "'"
|
|
embedRenderMessage ''UniWorX ''AllocationPriority' id
|
|
|
|
classifyAllocationPriority :: AllocationPriority -> AllocationPriority'
|
|
classifyAllocationPriority = \case
|
|
AllocationPriorityNumeric{} -> AllocationPriorityNumeric'
|
|
AllocationPriorityOrdinal{} -> AllocationPriorityOrdinal'
|
|
|
|
allocationPriorityForm :: FieldSettings UniWorX
|
|
-> Maybe AllocationPriority
|
|
-> AForm Handler AllocationPriority
|
|
allocationPriorityForm fs mPrev = multiActionA opts fs $ classifyAllocationPriority <$> mPrev
|
|
where
|
|
opts = flip Map.fromSet (Set.fromList universeF) $ \case
|
|
AllocationPriorityNumeric' -> AllocationPriorityNumeric <$> apreq (checkMap toInts fromInts textField) (fslI MsgAllocationPriorityNumericValues & setTooltip MsgAllocationPriorityNumericValuesTip) (mPrev ^? _Just . _AllocationPriorityNumeric)
|
|
AllocationPriorityOrdinal' -> AllocationPriorityOrdinal <$> apreq (natFieldI MsgAllocationPriorityOrdinalValueNegative) (fslI MsgAllocationPriorityOrdinalValue & setTooltip MsgAllocationPriorityOrdinalValueTip) (mPrev ^? _Just . _AllocationPriorityOrdinal)
|
|
|
|
toInts t = fmap Vector.fromList . runExcept $ do
|
|
let ts = filter (not . Text.null) . map Text.strip $ Text.splitOn "," t
|
|
whenExceptT (null ts) MsgAllocationPriorityNumericNoValues
|
|
forM ts $ \t' -> maybeExceptT (MsgAllocationPriorityNumericNoParse t') . return $ readMay t'
|
|
fromInts = Text.intercalate ", " . map tshow . Vector.toList
|
|
|
|
|
|
roomReferenceFormOpt :: FieldSettings UniWorX
|
|
-> Maybe (Maybe RoomReference)
|
|
-> AForm Handler (Maybe RoomReference)
|
|
roomReferenceFormOpt = roomReferenceForm' . Just $ SomeMessage MsgRoomReferenceNone
|
|
|
|
roomReferenceForm :: FieldSettings UniWorX
|
|
-> Maybe RoomReference
|
|
-> AForm Handler RoomReference
|
|
roomReferenceForm fs mPrev = fmapAForm (maybe FormMissing return =<<) . roomReferenceForm' Nothing fs $ Just <$> mPrev
|
|
|
|
roomReferenceForm' :: Maybe (SomeMessage UniWorX)
|
|
-> FieldSettings UniWorX
|
|
-> Maybe (Maybe RoomReference)
|
|
-> AForm Handler (Maybe RoomReference)
|
|
roomReferenceForm' noneOpt fs mPrev = multiActionAOpts opts opts' fs $ fmap classifyRoomReference <$> mPrev
|
|
where
|
|
opts' = do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
let olOptions = map mkOption . maybe id ((:) . Left) noneOpt $ map Right universeF
|
|
where mkOption (Left noneLbl) = Option
|
|
{ optionDisplay = mr noneLbl
|
|
, optionInternalValue = Nothing
|
|
, optionExternalValue = "room-none"
|
|
}
|
|
mkOption (Right v) = Option
|
|
{ optionDisplay = mr v
|
|
, optionInternalValue = Just v
|
|
, optionExternalValue = toPathPiece v
|
|
}
|
|
olReadExternal t | t == "room-none" = Just Nothing
|
|
| otherwise = Just <$> fromPathPiece t
|
|
return OptionList{..}
|
|
opts = mapF $ \case
|
|
Nothing -> pure Nothing
|
|
Just RoomReferenceSimple' -> wFormToAForm $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
fmap (Just . RoomReferenceSimple) <$> wpreq (textField & cfStrip) (fslI MsgRoomReferenceSimpleText & addPlaceholder (mr MsgRoomReferenceSimpleTextPlaceholder) & maybe id (\n -> addName $ n <> "__text") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefText)
|
|
Just RoomReferenceLink' -> wFormToAForm $ do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
roomRefLink' <- wpreq urlField (fslI MsgRoomReferenceLinkLink & addPlaceholder (mr MsgRoomReferenceLinkLinkPlaceholder) & maybe id (\n -> addName $ n <> "__link") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefLink)
|
|
roomRefInstructions' <- wopt htmlField (fslI MsgRoomReferenceLinkInstructions & addPlaceholder (mr MsgRoomReferenceLinkInstructionsPlaceholder) & maybe id (\n -> addName $ n <> "__instructions") (fsName fs)) (mPrev ^? _Just . _Just . _roomRefInstructions)
|
|
let res = RoomReferenceLink
|
|
<$> roomRefLink'
|
|
<*> roomRefInstructions'
|
|
return $ Just <$> res
|