module Handler.Utils.Form
  ( module Handler.Utils.Form
  , module Handler.Utils.Form.MassInput
  , module Utils.Form
  , MonadWriter(..)
  ) where

import Utils.Form

import Handler.Utils.Form.Types

import Handler.Utils.DateTime

import Import
import Data.Char (chr, ord)
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.List as C

import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E

import Data.Set (Set)
import qualified Data.Set as Set

import Data.Map (Map, (!))
import qualified Data.Map as Map

import Control.Monad.Trans.Writer (execWriterT, WriterT)
import Control.Monad.Trans.Except (throwE, runExceptT)
import Control.Monad.Writer.Class
import Control.Monad.Error.Class (MonadError(..))

import Data.Either (partitionEithers)

import Data.Aeson (eitherDecodeStrict')
import Data.Aeson.Text (encodeToLazyText)

import qualified Text.Email.Validate as Email

import Yesod.Core.Types (FileInfo(..))

import System.FilePath (isExtensionOf)
import Data.Text.Lens (unpacked)

import Data.Char (isDigit)
import Text.Blaze (toMarkup)

import Handler.Utils.Form.MassInput

----------------------------
-- 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.)
-- data LinkButton = LinkButton (Route UniWorX)
--   deriving (Enum, Eq, Ord, Bounded, Read, Show)
--
-- instance PathPiece LinkButton where
--     LinkButton route = ???

linkButton :: Widget -> Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton defWdgt lbl cls url = do
  access <- evalAccess (urlRoute url) False
  case access of
    Unauthorized _ -> defWdgt
    _other -> do
      url' <- toTextUrl url
      [whamlet|
        $newline never
        <a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
          ^{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
  
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 fs@FieldSettings{..} defAction csrf = do
  (actionRes, actionView) <- minp (selectField . optionsF $ Map.keysSet acts) fs defAction
  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts

  let actionResults = view _1 <$> results
      actionViews = Map.foldrWithKey accViews [] results

      accViews :: forall b. action -> (b, [FieldView UniWorX]) -> [FieldView UniWorX] -> [FieldView UniWorX]
      accViews act = flip mappend . over (mapped . _fvInput) (\w -> $(widgetFile "widgets/multi-action/multi-action")) . snd

  return ((actionResults Map.!) =<< actionRes, over _fvInput (mappend $ toWidget csrf) actionView : actionViews)

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

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

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


------------
-- 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|
          ^{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

-- | Variant that simply removes leading and trailing white space
htmlField' :: Field Handler Html
htmlField' = htmlField
  { fieldParse = \vs fis -> fieldParse htmlField (map Text.strip vs) fis
  }

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 limit = pointsFieldMinMax (Just 0) limit

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 [] [Asc TermName] 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 :: Maybe UploadMode -> AForm Handler UploadMode
uploadModeForm prev = multiActionA actions (fslI MsgSheetUploadMode) (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 . _unpackZips))
          <*> aopt extensionRestrictionField (fslI MsgUploadModeExtensionRestriction & setTooltip MsgUploadModeExtensionRestrictionTip) ((prev ^? _Just . _extensionRestriction) <|> fmap Just defaultExtensionRestriction)
        )
      , ( 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 & setTooltip MsgMassInputTip) True (preProcess <$> prev ^? _Just . _specificFiles)
      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 ("" & addName (nudge "label")) $ specificFileLabel <$> mPrevUF
          (nameRes, nameView) <- mpreq textField ("" & addName (nudge "name")) $ specificFileName <$> mPrevUF
          (reqRes, reqView) <- mpreq checkBoxField ("" & addName (nudge "required")) $ specificFileRequired <$> mPrevUF

          return ( UploadSpecificFile <$> labelRes <*> nameRes <*> reqRes
                 , $(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 = 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 = multiActionA actions (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 (prev ^? _Just . _submissionModeUser . _Just)
        )
      , ( SubmissionModeBoth
        , SubmissionMode True  . Just <$> uploadModeForm (prev ^? _Just . _submissionModeUser . _Just)
        )
      ]

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' <- sequence $ map (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)


type FileUploads = ConduitT () (Either FileId File) Handler ()
  

specificFileField :: UploadSpecificFile -> Field Handler FileUploads 
specificFileField UploadSpecificFile{..} = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse _ files
      | [f] <- files
      = return . Right . Just $ yieldM (acceptFile f) .| modifyFileTitle (const $ unpack specificFileName) .| C.map Right
      | null files   = return $ Right Nothing
      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
    fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/specificFileField")

    extensions = fileNameExtensions specificFileName
    acceptRestricted = not $ null extensions
    accept = Text.intercalate "," . map ("." <>) $ extensions


zipFileField :: Bool -- ^ Unpack zips?
             -> Maybe (NonNull (Set Extension)) -- ^ Restrictions on file extensions
             -> Field Handler FileUploads 
zipFileField doUnpack permittedExtensions = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse _ files
      | [f@FileInfo{..}] <- files
      , maybe True (anyOf (re _nullable . folded . unpacked) ((flip isExtensionOf `on` CI.foldCase) $ unpack fileName)) permittedExtensions || doUnpack
      = return . Right . Just $ bool (yieldM . fmap Right . acceptFile) ((.| C.map Right) . sourceFiles) doUnpack f
      | null files   = return $ Right Nothing
      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
    fieldView fieldId fieldName attrs _ req = $(widgetFile "widgets/zipFileField")

    zipExtensions = mimeExtensions typeZip

    acceptRestricted = isJust permittedExtensions
    accept = Text.intercalate "," . map ("." <>) $ bool [] (Set.toList zipExtensions) doUnpack ++ toListOf (_Just . re _nullable . folded) permittedExtensions

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 unpackZips extensionRestriction) (mkFs unpackZips) Nothing
  UploadSpecific{..}
    -> mergeFileSources <$> sequenceA (map specificFileForm . Set.toList $ toNullable specificFiles)
  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 (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.mapMaybe (preview _Left) .| C.foldMap Set.singleton

multiFileField :: Handler (Set FileId) -- ^ Set of files that may be submitted by id-reference
               -> Field Handler FileUploads 
multiFileField permittedFiles' = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse vals files = return . Right . Just $ do
      pVals <- lift permittedFiles'
      let
        decrypt' :: CryptoUUIDFile -> Handler (Maybe FileId)
        decrypt' = fmap (either (\(_ :: CryptoIDError) -> Nothing) Just) . try . decrypt
      yieldMany vals
        .| C.filter (/= unpackZips)
        .| C.map fromPathPiece .| C.catMaybes
        .| C.mapMaybeM decrypt'
        .| C.filter (`elem` pVals)
        .| C.map Left
      let
        handleFile :: FileInfo -> ConduitT () File Handler ()
        handleFile
          | doUnpack  = sourceFiles
          | otherwise = yieldM . acceptFile
      mapM_ handleFile files .| C.map Right
      where
        doUnpack = unpackZips `elem` vals
    fieldView fieldId fieldName _attrs val req = do
      pVals <- handlerToWidget permittedFiles'
      sentVals <- for val $ \src -> handlerToWidget . sourceToList $ src .| takeLefts
      let
        toFUI (E.Value fuiId', E.Value fuiTitle) = do
          fuiId <- encrypt fuiId'
          fuiHtmlId <- newIdent
          let fuiChecked
                | Right sentVals' <- sentVals = fuiId' `elem` sentVals'
                | otherwise = True
          return FileUploadInfo{..}
        autoUnzipInfo = [whamlet| _{MsgAutoUnzipInfo} |]
      fileInfos' <- mapM toFUI <=< handlerToWidget . runDB . E.select . E.from $ \file -> do
          E.where_ $ file E.^. FileId `E.in_` E.valList (setToList pVals)
          E.orderBy [E.asc $ file E.^. FileTitle]
          return (file E.^. FileId, file E.^. FileTitle)
      let fileInfos = sortOn fuiTitle fileInfos'
      $(widgetFile "widgets/multiFileField")
    unpackZips :: Text
    unpackZips = "unpack-zip"
    takeLefts :: Monad m => ConduitT (Either b a) b m ()
    takeLefts = awaitForever $ \case
      Right _ -> return ()
      Left  r -> yield r

data SheetGrading' = Points' | PassPoints' | PassBinary'
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Universe SheetGrading'
instance Finite SheetGrading'

nullaryPathPiece ''SheetGrading' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetGrading' ("SheetGrading" <>)


data SheetType' = Normal' | Bonus' | Informational' | NotGraded'
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Universe SheetType'
instance Finite SheetType'

nullaryPathPiece ''SheetType' (camelToPathPiece . dropSuffix "'")
embedRenderMessage ''UniWorX ''SheetType' ("SheetType" <>)


data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
  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)
      ]
    classify' :: SheetGrading -> SheetGrading'
    classify' = \case
      Points     {} -> Points'
      PassPoints {} -> PassPoints'
      PassBinary {} -> PassBinary'

    maxPointsReq  = apreq pointsField (fslI MsgSheetGradingMaxPoints)     (template >>= preview _maxPoints)
    passPointsReq = apreq pointsField (fslI MsgSheetGradingPassingPoints) (template >>= preview _passingPoints)


sheetTypeAFormReq :: FieldSettings UniWorX -> Maybe SheetType -> AForm Handler SheetType
sheetTypeAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
  where
    selOptions = Map.fromList
      [ ( Normal', Normal <$> gradingReq )
      , ( Bonus' , Bonus  <$> gradingReq )
      , ( Informational', Informational <$> gradingReq  )
      , ( NotGraded', pure NotGraded )
      ]
    gradingReq = sheetGradingAFormReq (fslI MsgSheetGrading
        & setTooltip MsgSheetGradingInfo) (template >>= preview _grading)

    classify' :: SheetType -> SheetType'
    classify' = \case
      Bonus  {} -> Bonus'
      Normal {} -> Normal'
      Informational {} -> Informational'
      NotGraded -> NotGraded'

sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
  where
    selOptions = Map.fromList
      [ ( Arbitrary', Arbitrary
          <$> apreq (natFieldI MsgGroupSizeNotNatural) (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
        )
      , ( RegisteredGroups', pure RegisteredGroups )
      , ( NoGroups', pure NoGroups )
      ]
    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
  where langCheck (T.splitOn "-" -> lParts)
          = all ((&&) <$> not . null <*> T.all Char.isAlpha) lParts
         && not (null lParts)
langField True = selectField appLanguagesOpts

jsonField :: ( ToJSON a, FromJSON a
             , MonadHandler m
             , RenderMessage (HandlerSite m) UniWorXMessage
             , RenderMessage (HandlerSite m) FormMessage
             )
          => Bool {-^ Hidden? -}
          -> Field m a
jsonField hide = Field{..}
  where
    inputType :: Text
    inputType
      | hide      = "hidden"
      | otherwise = "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 = liftWidget [whamlet|
      <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
    |]
    fieldEnctype = UrlEncoded

boolField :: ( MonadHandler m
             , HandlerSite m ~ UniWorX
             )
          => Maybe (SomeMessage UniWorX) -> Field m Bool
boolField mkNone = Field
  { fieldParse = \e _ -> return $ boolParser e
  , fieldView = \theId name attrs val isReq -> $(widgetFile "widgets/fields/bool")
  , fieldEnctype = UrlEncoded
  }
  where
    boolParser [] = Right Nothing
    boolParser (x:_) = case x of
      "" -> Right Nothing
      "none" -> Right Nothing
      "yes" -> Right $ Just True
      "on" -> Right $ Just True
      "no" -> Right $ Just False
      "true" -> Right $ Just True
      "false" -> Right $ Just False
      t -> Left $ SomeMessage $ MsgInvalidBool t
    showVal = either $ const False




sectionedFuncForm  :: forall k v m sec.
                      ( Finite k, Ord k
                      , MonadHandler m
                      , HandlerSite m ~ UniWorX
                      , RenderMessage UniWorX sec
                      , Ord sec
                      )
                   => (k -> Maybe sec) -> (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
sectionedFuncForm mkSection mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
  where
    funcForm' :: AForm m (k -> v)
    funcForm' = Set.fromList universeF
              & foldr (\v -> Map.unionWith Set.union $ Map.singleton (mkSection v) (Set.singleton v)) Map.empty
              & fmap (Map.fromSet mkForm)
              & fmap sequenceA
              & Map.foldrWithKey accSections (pure Map.empty)
              & fmap (!)
    accSections mSection optsForm acc = wFormToAForm $ do
      (res, fs) <- wFormFields $ aFormToWForm optsForm
      if
        | not $ null fs
        , Just section <- mSection
          -> wformSection section
        | otherwise
          -> return ()
      lift $ tell fs
      aFormToWForm $ Map.union <$> wFormToAForm (pure res) <*> acc
  
    funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> 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{..})
    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)


funcForm :: forall k v m.
            ( Finite k, Ord k
            , MonadHandler m
            , HandlerSite m ~ UniWorX
            )
         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm = sectionedFuncForm $ const (Nothing :: Maybe Text)




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 site backend a msg.
                          ( YesodPersist site
                          , PersistQueryRead backend
                          , HasCryptoUUID (Key a) (HandlerFor site)
                          , RenderMessage site msg
                          , YesodPersistBackend site ~ backend
                          , PersistRecordBackend a backend
                          )
                       => [Filter a]
                       -> [SelectOpt a]
                       -> (a -> msg)
                       -> HandlerFor site (OptionList (Entity a))
optionsPersistCryptoId filts ords toDisplay = fmap mkOptionList $ do
  mr <- getMessageRender
  pairs <- runDB $ selectList filts ords
  cPairs <- forM pairs $ \e@(Entity key _) -> (,) <$> encrypt key <*> pure e
  return $ map (\(cId, e@(Entity _key value)) -> Option
                 { optionDisplay = mr (toDisplay value)
                 , optionInternalValue = e
                 , optionExternalValue = toPathPiece (cId :: CryptoID UUID (Key a))
                 }) cPairs

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

userMatriculationField :: forall m.
                          ( MonadHandler m
                          , HandlerSite m ~ UniWorX
                          )
                       => Field m [Entity User]
userMatriculationField = Field{..}
  where
    fieldEnctype = UrlEncoded
    fieldView theId name attrs val isReq = do
      let val' = val <&> Text.intercalate ", " . mapMaybe (userMatrikelnummer . entityVal)
      [whamlet|
        $newline never
        <input id="#{theId}" name="#{name}" *{attrs} type="text" :isReq:required="" value="#{either id id val'}">
      |]
    fieldParse (all Text.null -> True) _ = return $ Right Nothing
    fieldParse ts _ = runExceptT . fmap Just $ do
      let ts' = concatMap (Text.splitOn ",") ts
      forM ts' $ \matr -> do
        dbRes <- liftHandler . runDB . E.select . E.from $ \user -> do
          E.where_ $ E.strip (user E.^. UserMatrikelnummer) `E.ciEq` E.just (E.val $ Text.strip matr)
          return user
        case dbRes of
          [user]
            -> return user
          []
            -> throwE . SomeMessage $ MsgUserMatriculationNotFound matr
          _other
            -> throwE . SomeMessage $ MsgUserMatriculationAmbiguous matr


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 $ (user E.^. UserEmail, 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.^. UserEmail E.==. E.val email
              return $ user E.^. UserId
            if | Set.null dbRes
                 -> return $ Left email
               | [uid] <- Set.toList dbRes
                 -> return $ Right uid
               | otherwise
                 -> throwE $ SomeMessage MsgAmbiguousEmail

examResultField :: forall m res.
                   ( MonadHandler m
                   , HandlerSite m ~ UniWorX
                   , PathPiece res
                   )
                => Field m res -> Field m (ExamResult' res)
examResultField innerField = Field
  { fieldEnctype = UrlEncoded <> fieldEnctype innerField
  , fieldParse = \ts fs -> if
      | [t] <- ts
      , Just res <- fromPathPiece t
      , is _ExamNoShow res || is _ExamVoided res
        -> return . Right $ Just res
      | otherwise
        -> fmap (fmap ExamAttended) <$> fieldParse innerField (filter (not . (`elem` ["attended", "no-show", "voided"])) ts) fs
  , fieldView = \theId name attrs val isReq -> do
      innerId <- newIdent
      let
        val' :: ExamResult' (Either Text res)
        val' = either (ExamAttended . Left) (fmap Right) val
        innerVal :: Either Text res
        innerVal = val >>= maybe (Left "") return . preview _ExamAttended
      [whamlet|
        $newline never
        <div>
          <select id=#{theId} name=#{name} *{attrs} :isReq:required style="display: inline-block">
            <option value="attended" :is _ExamAttended val':selected>_{MsgExamResultAttended}
            <option value="no-show" :is _ExamNoShow val':selected>_{MsgExamResultNoShow}
            <option value="voided" :is _ExamVoided val':selected>_{MsgExamResultVoided}
          <fieldset uw-interactive-fieldset .interactive-fieldset__target data-conditional-input=#{theId} data-conditional-value="attended" style="display: inline-block">
            ^{fieldView innerField innerId name attrs innerVal False}
      |]
  }

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


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)
