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 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 Data.Set as Set

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 :: 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' minp justAct fs@FieldSettings{..} defActive csrf = do
  (doRes, doView) <- minp 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)

optionalActionA :: AForm Handler a
                -> FieldSettings UniWorX
                -> Maybe Bool
                -> AForm Handler (Maybe a)
optionalActionA = optionalActionA' 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

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 $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName

termsAllowedField :: Field Handler TermId
termsAllowedField = selectField $ do
  mayEditTerm <- isAuthorized TermEditR True
  let termFilter | Authorized <- mayEditTerm = []
                 | otherwise = [TermActive ==. True]
  optionsPersistKey termFilter [Desc TermStart] termName

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 $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
  where terms = map unTermKey tids
-- 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 MsgSheetSubmissionMode) $ 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 MsgExamBonusRule) $ 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
            <$> 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 MsgExamGradingRule) $ 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
      opts@FileField{..} <- liftHandler mkOpts

      mIdent <- fmap getFirst . flip foldMapM vals $ \v ->
        fmap First . runMaybeT . exceptTMaybe $ encodedSecretBoxOpen v

      let uploadedFilenames = fileName <$> bool (take 1) id fieldMultiple 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
                                  || (    bool (\n h -> h == pure n) elem fieldMultiple fTitle (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 -> Field Handler FileUploads
specificFileField UploadSpecificFile{..} = convertField (.| fixupFileTitles) id . genericFileField $ 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.empty
  , 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 = genericFileField $ return FileField
  { fieldIdent = Nothing
  , fieldUnpackZips = FileFieldUserOption True doUnpack
  , fieldMultiple = doUnpack
  , fieldRestrictExtensions = permittedExtensions
  , fieldAdditionalFiles = _FileReferenceFileReferenceTitleMap # Map.empty
  , fieldMaxFileSize = Nothing
  , fieldAllEmptyOk = emptyOk
  }

fileUploadForm :: Bool -- ^ Required?
               -> (Bool -> FieldSettings UniWorX) -- ^ given @unpackZips@ generate `FieldSettings` in the case of `UploadAny`
               -> UploadMode -> AForm Handler (Maybe FileUploads)
fileUploadForm isReq mkFs = \case
  NoUpload
    -> pure Nothing
  UploadAny{..}
    -> bool aopt (\f fs _ -> Just <$> areq f fs Nothing) isReq (zipFileField uploadUnpackZips uploadExtensionRestriction uploadEmptyOk) (mkFs uploadUnpackZips) Nothing
  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 $ fmap Just d) (\f fs d -> Just <$> areq f fs d) (specificFileRequired && isReq) (specificFileField spec) (fsl specificFileLabel) Nothing

    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 UniWorXMessage LocalTime
    readTime t =
      case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
        Just lTime -> Right lTime
        Nothing    -> Left 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) UniWorXMessage
             , RenderMessage (HandlerSite m) FormMessage
             )
          => 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) UniWorXMessage
             , RenderMessage (HandlerSite m) FormMessage
             )
          => 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)
                          , KnownSymbol (CryptoIDNamespace UUID (Key a))
                          , RenderMessage UniWorX msg
                          , YesodPersistBackend UniWorX ~ backend
                          , PersistRecordBackend a backend
                          , PathPiece (Key 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)

optionsCryptoIdE :: forall backend a msg.
                    ( HasCryptoUUID (Key a) (HandlerFor UniWorX)
                    , KnownSymbol (CryptoIDNamespace UUID (Key a))
                    , RenderMessage UniWorX msg
                    , YesodPersistBackend UniWorX ~ backend
                    , PersistRecordBackend a backend
                    , PathPiece (Key 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 m
                    , KnownSymbol (CryptoIDNamespace UUID k)
                    , RenderMessage (HandlerSite m) msg
                    , MonoFoldable mono
                    , MonadHandler m
                    , PathPiece 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>
              _{MsgExamResultNoShow}
            <option value=#{toPathPiece voidedVal} :is (_Right . _ExamVoided) val:selected>
              _{MsgExamResultVoided}
          $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 MsgExamResultGrade
      , 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 MsgExamResultPass
      , 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 MsgExamResultGrade
      , optionExternalValue = "grade"
      , optionInternalValue =
          ( either (`elem` map toPathPiece grades) (is _Right)
          , hoistField liftHandler . selectField $ fmap Right <$> optionsFinite
          )
      }
    , Option
      { optionDisplay = mr MsgExamResultPass
      , 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'
        -> CsvFormatOptions
             <$> areq (selectField delimiterOpts) (fslI MsgCsvDelimiter) (csvDelimiter <$> mPrev)
             <*> areq (selectField lineEndOpts)   (fslI MsgCsvUseCrLf) (csvUseCrLf <$> mPrev)
             <*> areq (selectField quoteOpts)     (fslI MsgCsvQuoting & setTooltip MsgCsvQuotingTip) (csvQuoting <$> mPrev)
             <*> areq (selectField encodingOpts)  (fslI MsgCsvEncoding & setTooltip MsgCsvEncodingTip) (csvEncoding <$> mPrev)

    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.^. CourseName
                ]
      return course

    miAdd' nudge btn csrf = do
      let courseOptions = optionsCryptoIdE query' (\Course{..} -> MsgCourseOption courseTerm courseSchool courseName) >>= fmap (fmap entityKey . mkOptionList) . filterM (coursePred . optionInternalValue) . olOptions

      (courseRes, addView) <- mpopt (hoistField liftHandler $ selectField courseOptions) (fslI MsgCourse & 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
