-- SPDX-FileCopyrightText: 2023 Felix Hamann <felix.hamann@campus.lmu.de>,Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Sarah Vaupel <vaupel.sarah@campus.lmu.de>,Steffen Jost <jost@cip.ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>,Wolfgang Witt <Wolfgang.Witt@campus.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-} -- `WidgetT`, `HandlerT`

module Utils.Form where

import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass, mreq, areq, wreq, urlField)
import Yesod.Auth (YesodAuth(maybeAuthId))

import Data.Kind (Type, Constraint)
import qualified Yesod.Form as Yesod
import Yesod.Core.Instances ()
import Settings

import Utils.Parameters
import Utils.Lens

import Text.Blaze (Markup)
import qualified Text.Blaze.Internal as Blaze (null)
import qualified Data.Text as T
import qualified Data.Char as C

import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Universe

import Data.List (nub, (!!))
import Data.Map.Lazy ((!))
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set

import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Writer.Class (MonadWriter(..), censor)
import Control.Monad.State.Class (MonadState(..))
import qualified Control.Monad.State.Class as State
import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST)
import Control.Monad.Trans.State (runStateT, evalStateT)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import qualified Control.Monad.Trans.Writer.Lazy as Lazy (WriterT)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Base
import Control.Monad.Catch (MonadCatch)

import Control.Monad.Random.Class (uniform, uniformMay, getRandom, getRandomR, getRandomRs, weighted)

import Web.PathPieces

import Data.UUID hiding (toText)

import Data.Ratio ((%))
import Data.Fixed
import Data.Scientific
import Data.Time.Clock (NominalDiffTime, nominalDay)

import Utils
import Utils.Frontend.Notification
-- import Utils.Message
-- import Utils.PathPiece
-- import Utils.Route

import Data.Proxy

import Data.Monoid (Endo(..), Sum(..))

import Network.URI (URI, parseURI, uriToString)

import Data.Either (fromRight)

import qualified Database.Esqueleto.Legacy as E

import Handler.Utils.Random

import qualified Data.Binary as Binary

import qualified Data.ByteString.Base64.URL as Base64 (encodeUnpadded)
import qualified Data.ByteString as BS


------------
-- Fields --
------------

_olOptions :: Traversal' (OptionList a) (Option a)
_olOptions f = \case
  x@OptionList{} -> (\olOptions -> x{olOptions}) <$> traverse f (olOptions x)
  x@OptionListGrouped{} -> (\olOptionsGrouped -> x{olOptionsGrouped}) <$> traverseOf (traverse . _2 . traverse) f (olOptionsGrouped x)

_olOptionsGrouped :: Traversal' (OptionList a) (Text, [Option a])
_olOptionsGrouped f = \case
  x@OptionList{} -> pure x
  x@OptionListGrouped{} -> (\olOptionsGrouped -> x{olOptionsGrouped}) <$> traverse f (olOptionsGrouped x)

_olReadExternal :: Lens' (OptionList a) (Text -> Maybe a)
_olReadExternal f = \case
  x@OptionList{} -> (\olReadExternal -> x{olReadExternal}) <$> f (olReadExternal x)
  x@OptionListGrouped{} -> (\olReadExternalGrouped -> x{olReadExternalGrouped}) <$> f (olReadExternalGrouped x)

-- if a field is required, but none should be there
noField :: Monad m => Field m a
noField = Field{..}
  where
    fieldParse _ _        = return $ Right Nothing
    fieldView  _ _ _ _ _  = mempty
    fieldEnctype          = UrlEncoded

-- | Field to inject comments into forms, also see aformMessage
commentField :: (Monad m, RenderMessage (HandlerSite m) a) => a -> Field m ()
commentField msg = Field {..}
  where
    fieldParse _ _ = return $ Right $ Just ()
    fieldView  _ _ _ _ _  = msg2widget msg
    fieldEnctype          = UrlEncoded

--------------------
-- Field Settings --
--------------------

fsl ::  Text -> FieldSettings site
fsl lbl
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = []
                  }

fslI :: RenderMessage site msg => msg -> FieldSettings site
fslI lbl
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = []
                  }

fslp ::  Text -> Text -> FieldSettings site
fslp lbl placeholder
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = [("placeholder", placeholder)]
                  }

fslpI :: RenderMessage site msg => msg -> Text -> FieldSettings site
fslpI lbl placeholder
  = FieldSettings { fsLabel    = SomeMessage lbl
                  , fsTooltip  = Nothing
                  , fsId       = Nothing
                  , fsName     = Nothing
                  , fsAttrs    = [("placeholder", placeholder)]
                  }


-- NOTE: see Utils.insertAttrs for inserting/merging generic [[(Text,Text)] attributes

addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }

addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs = insertAttr attr valu $ fsAttrs fs }
  where
    valu = T.intercalate " " valus

data DatepickerPosition = DPLeft | DPRight | DPTop | DPBottom deriving (Eq,Ord,Enum,Bounded,Read,Show)

instance Universe DatepickerPosition
instance Finite DatepickerPosition

nullaryPathPiece ''DatepickerPosition $ camelToPathPiece' 1

addDatepickerPositionAttr :: DatepickerPosition -> FieldSettings site -> FieldSettings site
addDatepickerPositionAttr = addAttr "data-datepicker-position" . toPathPiece

addPlaceholder :: Text -> FieldSettings site -> FieldSettings site
addPlaceholder placeholder fs = fs { fsAttrs = (placeholderAttr, placeholder) : filter ((/= placeholderAttr) . fst) (fsAttrs fs) }
  where
    placeholderAttr = "placeholder"

addClass :: PathPiece c => c -> FieldSettings site -> FieldSettings site
addClass = over _fsAttrs . Yesod.addClass . toPathPiece

addClasses :: (MonoFoldable mono, PathPiece (Element mono)) => mono -> FieldSettings site -> FieldSettings site
addClasses = appEndo . foldMap (Endo . addClass)

addName :: PathPiece p => p -> FieldSettings site -> FieldSettings site
addName nm fs = fs { fsName = Just $ toPathPiece nm }

addId :: PathPiece p => p -> FieldSettings site -> FieldSettings site
addId fid fs = fs { fsId = Just $ toPathPiece fid }

setTooltip :: RenderMessage site msg => msg -> FieldSettings site -> FieldSettings site
setTooltip msg fs = fs { fsTooltip = Just $ SomeMessage msg }

addDatalist :: MonadHandler m => HandlerT (HandlerSite m) IO (OptionList a) -> Field m a -> Field m a
addDatalist mkOptions field = field
  { fieldView = \fId fName fAttrs fRes fReq -> do
      listId <- newIdent

      fieldView field fId fName (("list", listId) : fAttrs) fRes fReq

      options <- liftHandler $ toListOf _olOptions <$> mkOptions
      [whamlet|
        $newline never
        <datalist ##{listId}>
          $forall Option{optionDisplay, optionExternalValue} <- options
            <option value=#{optionExternalValue}>
              #{optionDisplay}
      |]
  , fieldParse = fieldParse'
  }
  where
    fieldParse' [t] [] = do
      readExt <- liftHandler $ olReadExternal <$> mkOptions
      case readExt t of
        Just v  -> return . Right $ Just v
        Nothing -> fieldParse field [t] []
    fieldParse' ts fs = fieldParse field ts fs

noValidate :: FieldSettings site -> FieldSettings site
noValidate = addAttr "formnovalidate" ""

noAutocomplete :: FieldSettings site -> FieldSettings site
noAutocomplete = addAttr "autocomplete" "off"

inputDisabled :: FieldSettings site -> FieldSettings site
inputDisabled = addAttr "disabled" ""

inputReadonly :: FieldSettings site -> FieldSettings site
inputReadonly = addAttr "readonly" ""

addAutosubmit :: FieldSettings site -> FieldSettings site
addAutosubmit = addAttr "uw-auto-submit-input" ""

-- | Asynchronous Submit, e.g. use with forms in modals
asyncSubmitAttr :: (Text,Text)
asyncSubmitAttr = ("uw-async-form", "")

---------------
-- FieldView --
---------------

addFieldViewTooltipWidget :: (MonadHandler m, Yesod (HandlerSite m))
                          => WidgetFor (HandlerSite m) ()
                          -> FieldView (HandlerSite m) -> m (FieldView (HandlerSite m))
addFieldViewTooltipWidget wgt fv = do
  renderUrl <- getUrlRenderParams
  PageContent{..} <- liftHandler $ widgetToPageContent wgt
  let addPC = do
        when (pageTitle /= mempty) $
          setTitle pageTitle
        toWidgetHead $ pageHead renderUrl
  return $ fv
    & _fvTooltip ?~ pageBody renderUrl
    & _fvInput <>~ addPC

------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
------------------------------------------------

data FormIdentifier
  = FIDcourse
  | FIDcourseRegister
  | FIDsheet
  | FIDmaterial
  | FIDCourseNews
  | FIDCourseEvent
  | FIDCourseFavouriteToggle
  | FIDsubmission
  | FIDsettings
  | FIDcorrectors
  | FIDcorrectorTable
  | FIDcorrection
  | FIDcorrectionsUpload
  | FIDcorrectionUpload
  | FIDSystemMessageAdd
  | FIDSystemMessageTable
  | FIDSystemMessageModify
  | FIDSystemMessageModifyTranslation UUID
  | FIDSystemMessageAddTranslation
  | FIDDBTableFilter Text
  | FIDDBTablePagesize Text
  | FIDDBTableCsvExport Text
  | FIDDBTableCsvImport Text
  | FIDDBTableCsvImportConfirm Text
  | FIDDelete
  | FIDPrintAcknowledge
  | FIDCourseRegister | FIDCourseRegisterConfirm
  | FIDuserRights
  | FIDUserSystemFunctions
  | FIDcUserNote
  | FIDcRegField
  | FIDcRegButton
  | FIDAdminDemo
  | FIDUserDelete
  | FIDCommunication
  | FIDAssignSubmissions
  | FIDUserAuthMode | FIDUserAssimilate | FIDUserRights | FIDUserAuthentication
  | FIDAllUsersAction
  | FIDThisUserAction
  | FIDLanguage
  | FIDExamAutoOccurrenceCalculate | FIDExamAutoOccurrenceConfirm | FIDExamAutoOccurrenceNudge UUID | FIDExamAutoOccurrenceIgnoreRoom UUID
  | FIDTestDownload
  | FIDLmsLetter
  | FIDAvsQueryPerson
  | FIDAvsQueryStatus
  | FIDAvsQueryContact
  | FIDAvsCreateUser
  | FIDAvsQueryLicenceDiffs
  | FIDAvsQueryLicence
  | FIDAvsSetLicence
  | FIDBtnAvsImportUnknown
  | FIDBtnAvsRevokeUnknown
  | FIDHijackUser
  | FIDAddSupervisor
  | FIDFirmUserChangeRequest
  | FIDFirmAction
  | FIDUnreachableUsersAction
  deriving (Eq, Ord, Read, Show)

instance PathPiece FormIdentifier where
  fromPathPiece = readFromPathPiece
  toPathPiece = showToPathPiece


identifyForm' :: (MonadLogger m, PathPiece ident, Eq ident)
              => Lens' x (FormResult a)
              -> ident -- ^ Form identification
              -> (Html -> MForm m (x, widget))
              -> (Html -> MForm m (x, widget))
identifyForm' resLens identVal form fragment = do
    -- Create hidden <input>.
    let fragment' =
          [shamlet|
            $newline never
            <input .form-identifier type=hidden name=#{toPathPiece PostFormIdentifier} value=#{toPathPiece identVal}>
            #{fragment}
          |]

    -- Check if we got its value back.
    identVal' <- lookupGlobalPostParamForm PostFormIdentifier
    let hasIdent = identVal' == Just identVal

    $logDebugS "identifyForm'" $ tshow (toPathPiece <$> identVal', toPathPiece identVal, hasIdent)

    -- Run the form proper (with our hidden <input>).  If the
    -- data is missing, then do not provide any params to the
    -- form, which will turn its result into FormMissing.  Also,
    -- doing this avoids having lots of fields with red errors.
    let eraseParams | not hasIdent = local (\(_, h, l) -> (Nothing, h, l))
                    | otherwise    = id
    bool (set (mapped . _1 . resLens) FormMissing . eraseParams) id hasIdent $ form fragment'

identifyForm :: (MonadLogger m, PathPiece ident, Eq ident) => ident -> (Html -> MForm m (FormResult a, widget)) -> (Html -> MForm m (FormResult a, widget))
identifyForm = identifyForm' id


{- Hinweise zur Erinnerung:
  - identForm primär, wenn es mehr als ein Formular pro Handler gibt
  - nur einmal pro makeForm reicht
-}

----------------------------
-- Buttons (new version ) --
----------------------------

-- Bemerke: Back Button Widget implementierbar durch <button onclick="history.back()">_{MsgGenericBack}

data family ButtonClass site :: Type

class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
  btnLabel :: a -> WidgetT site IO ()

  default btnLabel :: RenderMessage site a => a -> WidgetT site IO ()
  btnLabel = toWidget <=< ap getMessageRender . return

  btnValidate :: forall p. p site -> a -> Bool
  btnValidate _ _ = True                          -- False will attach html attribute "formnovalidate", so that browsers do not validate the form data

  btnClasses :: a -> [ButtonClass site]
  btnClasses _ = []

data ButtonMessage = MsgAmbiguousButtons
                   | MsgWrongButtonValue
                   | MsgMultipleButtonValues
                   | MsgBtnFormOutdated
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

-- | Default button for submitting. Required in Foundation for Login, other Buttons defined in Handler.Utils.Form
data ButtonSubmit = BtnSubmit
  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe ButtonSubmit
instance Finite ButtonSubmit

nullaryPathPiece ''ButtonSubmit $ camelToPathPiece' 1

buttonField :: forall a m.
             ( Button (HandlerSite m) a
             , MonadHandler m
             ) => a -> Field m a
-- | Already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field{..}
  where
    fieldEnctype = UrlEncoded

    fieldView :: FieldViewFunc m a
    fieldView fid name attrs _val _ = let
      validate = btnValidate (Proxy @(HandlerSite m)) btn
      classes :: [ButtonClass (HandlerSite m)]
      classes = btnClasses btn
      in [whamlet|
        $newline never
        <button class=#{unwords $ map toPathPiece classes} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{btnLabel btn}
      |]

    fieldParse []    [] = return $ Right Nothing
    fieldParse [str] []
      | str == toPathPiece btn = return . Right $ Just btn
      | otherwise  = return . Left $ SomeMessage MsgWrongButtonValue
    fieldParse _ _ = return . Left $ SomeMessage MsgMultipleButtonValues

combinedButtonField :: forall a m.
                     ( Button (HandlerSite m) a
                     , MonadHandler m
                     ) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonField bs FieldSettings{..} = formToAForm $ do
  mr <- getMessageRender
  fvId <- maybe newIdent return fsId
  name <- maybe newFormIdent return fsName
  (ress, fvs) <- fmap unzip . for bs $ \b -> mopt (buttonField b) ("" { fsId = Just $ fvId <> "__" <> toPathPiece b
                                                                      , fsName = Just $ name <> "__" <> toPathPiece b
                                                                      , fsAttrs
                                                                      }) Nothing
  return ( sequenceA ress
         , pure FieldView
             { fvLabel = toHtml $ mr fsLabel
             , fvTooltip = fmap (toHtml . mr) fsTooltip
             , fvId
             , fvInput =
                 [whamlet|
                   $newline never
                   <div .buttongroup>
                     ^{foldMap fvInput fvs}
                 |]
             , fvErrors = bool Nothing (Just $ foldMap (fromMaybe mempty . fvErrors) fvs) $ any (isJust . fvErrors) fvs
             , fvRequired = False
             }
         )

combinedButtonFieldF :: forall m a.
                      ( Button (HandlerSite m) a
                      , Finite a
                      , MonadHandler m
                      ) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonFieldF = combinedButtonField (universeF :: [a])

-- | Ensures that only a single button press is accepted at once
disambiguateButtons :: forall m a.
                     ( MonadHandler m
                     , RenderMessage (HandlerSite m) ButtonMessage
                     ) => AForm m [Maybe a] -> AForm m a
disambiguateButtons = traverseAForm $ \case
  (catMaybes -> [bRes]) -> return $ FormSuccess bRes
  (catMaybes -> []    ) -> return FormMissing
  _other                -> formFailure [MsgAmbiguousButtons]

combinedButtonField_ :: forall a m.
                      ( Button (HandlerSite m) a
                      , MonadHandler m
                      ) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonField_ = (void .) . combinedButtonField

combinedButtonFieldF_ :: forall m a p.
                       ( Button (HandlerSite m) a
                       , MonadHandler m
                       , Finite a
                       ) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a

-- | Submit-Button as AForm, also see submitButtonView below
submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) ""

-- | just Html for a Submit-Button
submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO ()
submitButtonView = buttonView BtnSubmit

buttonView :: forall site button. Button site button => button -> WidgetT site IO ()
buttonView btn = do
  let bField :: Field (HandlerT site IO) button
      bField = buttonField btn
  btnId <- newIdent
  fieldView bField btnId "" mempty (Right btn) False


-- | generate a form that only shows a finite amount of buttons
buttonForm :: (MonadHandler m, Button (HandlerSite m) a, Finite a) => Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
buttonForm = buttonForm' universeF

-- | like `buttonForm`, but for a given list of buttons, i.e. a subset or for buttons outside the Finite typeclass
buttonForm' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
buttonForm' btns = buttonForm'' btns ""

-- | like `buttonForm'`, but for a given list of FieldSettings
buttonForm'' :: (MonadHandler m, Button (HandlerSite m) a) => [a] -> FieldSettings (HandlerSite m) -> Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ())
buttonForm'' btns settings csrf = do
  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns settings
  return (res, [whamlet|
      $newline never
      #{csrf}
      $forall bView <- fViews
        ^{fvWidget bView}
    |])

withButtonForm' :: (MonadHandler m, Button (HandlerSite m) btn)
                => [btn]
                -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
                -> (Html -> MForm m (FormResult (a, btn), WidgetT (HandlerSite m) IO ()))
withButtonForm' = withButtonFormM' . const . return

withButtonFormComb' :: (MonadHandler m, Button (HandlerSite m) btn)
                    => (FormResult a -> FormResult btn -> FormResult b)
                    -> [btn]
                    -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
                    -> (Html -> MForm m (FormResult b, WidgetT (HandlerSite m) IO ()))
withButtonFormComb' f = withButtonFormCombM' f . const . return

withButtonFormM' :: (MonadHandler m, Button (HandlerSite m) btn)
                 => (FormResult a -> MForm m [btn])
                 -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
                 -> (Html -> MForm m (FormResult (a, btn), WidgetT (HandlerSite m) IO ()))
withButtonFormM' = withButtonFormCombM' (\x btn -> (,) <$> x <*> btn)

withButtonFormCombM' :: (MonadHandler m, Button (HandlerSite m) btn)
                     => (FormResult a -> FormResult btn -> FormResult b)
                     -> (FormResult a -> MForm m [btn])
                     -> (Html -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
                     -> (Html -> MForm m (FormResult b, WidgetT (HandlerSite m) IO ()))
withButtonFormCombM' combF mkBtns innerForm csrf = do
  (innerRes, innerView) <- innerForm csrf
  btns <- mkBtns innerRes
  (buttonRes, btnView) <- buttonForm' btns mempty
  return (combF innerRes buttonRes, innerView <> btnView)

-- | buttons-only form complete with widget-generation and evaluation; return type determines buttons shown.
runButtonForm ::(PathPiece ident, Eq ident, RenderMessage site FormMessage,
                Button site ButtonSubmit, Button site a, Finite a)
  => ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonForm fid = do
  currentRoute <- getCurrentRoute
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid buttonForm
  let btnForm = wrapForm btnWdgt def  { formAction = SomeRoute <$> currentRoute
                                      , formEncoding = btnEnctype
                                      , formSubmit = FormNoSubmit
                                      }
  res <- formResultMaybe btnResult (return . Just)
  return (btnForm, res)

-- | like `runButtonForm` but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
runButtonForm' :: ( PathPiece ident, Eq ident, RenderMessage site FormMessage
                  , Button site ButtonSubmit, Button site a)
  => [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonForm' btns fid = do
  currentRoute <- getCurrentRoute
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ buttonForm' btns
  let btnForm = wrapForm btnWdgt def  { formAction = SomeRoute <$> currentRoute
                                      , formEncoding = btnEnctype
                                      , formSubmit = FormNoSubmit
                                      }
  res <- formResultMaybe btnResult (return . Just)
  return (btnForm, res)


-- | like runButtonForm, but may include a hash value enclosed in a hidden field to ensure
--   that the button press still applies to the correct situation
runButtonFormHash ::( PathPiece ident, Eq ident, RenderAFormSite site
                    , Button site ButtonSubmit, Button site a, Finite a, Hashable h)
  => h -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonFormHash (hash -> hVal) fid = do
  currentRoute <- getCurrentRoute
  let bForm = disambiguateButtons $ combinedButtonFieldF ""
      hForm = aopt hiddenField "" $ Just $ Just hVal
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
    flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
  let btnForm = wrapForm btnWdgt def  { formAction    = SomeRoute <$> currentRoute
                                      , formEncoding  = btnEnctype
                                      , formSubmit    = FormNoSubmit
                                      }
  res <- formResultMaybe btnResult $ \case
    (btn, Just rVal) | hVal == rVal -> return $ Just btn  -- hash value from hidden field must be present and matching
    _ -> do
      addMessageI Error MsgBtnFormOutdated
      whenIsJust currentRoute redirect                    -- redirect is needed to reset hidden-field value
      return Nothing
  return (btnForm, res)

-- | like runButtonFormHash, but showing only a given list of buttons, especially for buttons that are not in the Finite typeclass.
runButtonFormHash' :: ( PathPiece ident, Eq ident, RenderAFormSite site
                      , Button site ButtonSubmit, Button site a, Hashable h)
  => h -> [a] -> ident -> HandlerT site IO (WidgetT site IO (), Maybe a)
runButtonFormHash' (hash -> hVal) btns fid = do
  currentRoute <- getCurrentRoute
  let bForm = disambiguateButtons $ combinedButtonField btns ""
      hForm = aopt hiddenField "" $ Just $ Just hVal
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm fid $ \html ->
    flip (renderAForm FormStandard) html $ (,) <$> bForm <*> hForm
  let btnForm = wrapForm btnWdgt def  { formAction    = SomeRoute <$> currentRoute
                                      , formEncoding  = btnEnctype
                                      , formSubmit    = FormNoSubmit
                                      }
  res <- formResultMaybe btnResult $ \case
    (btn, Just rVal) | hVal == rVal -> return $ Just btn  -- hash value from hidden field must be present and matching
    _ -> do
      addMessageI Error MsgBtnFormOutdated
      whenIsJust currentRoute redirect                    -- redirect is needed to reset hidden-field value
      return Nothing
  return (btnForm, res)


-------------------
-- Custom Fields --
-------------------

-- | empty field that has no view and always succeeds, useful for form sections having only a label
noinputField :: Monad m => Field m ()
noinputField = Field  { fieldEnctype = UrlEncoded
                      , fieldParse = const $ const $ return $ Right $ Just ()
                      , fieldView  = \_theId _name _attrs _val _isReq -> mempty
                      }

ciField :: ( Textual t
           , CI.FoldCase t
           , Monad m
           , RenderMessage (HandlerSite m) FormMessage
           ) => Field m (CI t)
ciField = convertField repack repack textField & cfCI

pathPieceField :: ( PathPiece a
                  , Monad m
                  , RenderMessage (HandlerSite m) FormMessage
                  ) => Field m a
pathPieceField = checkMMap (\t -> return . maybe (Left $ MsgInvalidEntry t) Right $ fromPathPiece t) toPathPiece textField

reorderField :: ( MonadHandler m
                , HandlerSite m ~ site
                , Eq a
                ) => HandlerT site IO (OptionList a) -> Field m [a]
-- ^ Allow the user to enter a /permutation/ of the given options (every option must occur exactly once in the result)
reorderField optList = Field{..}
  where
    fieldEnctype = UrlEncoded
    fieldParse [] _ = return $ Right Nothing
    fieldParse optlist _ = do
      (options, readExternal) <- ((,) <$> toListOf _olOptions <*> view _olReadExternal) <$> liftHandler optList -- TODO: support grouped?
      let
        olNum = fromIntegral $ length options
        selOptions = Map.fromList $ do
          i <- [1..olNum]
          (readMay -> Just (n :: Word), '.' : extVal) <- break (== '.') . unpack <$> optlist
          guard $ i == n
          Just val <- return . readExternal $ pack extVal
          return (i, val)
      return $ if
        | Map.keysSet selOptions == Set.fromList [1..olNum]
          -> Right . Just $ map (selOptions !) [1..olNum]
        | otherwise
          -> Left "Not a valid permutation"
    fieldView theId name attrs val isReq = do
      options <- toListOf _olOptions <$> liftHandler optList
      let
        isSel n = (==) (fromRight (map optionInternalValue options) val !! pred n) . optionInternalValue
        nums = map (id &&& withNum theId) [1..length options]
        withNum t n = tshow n <> "." <> t
      $(widgetFile "widgets/permutation/permutation")

optionsPathPiece :: ( MonadHandler m
                    , HandlerSite m ~ site
                    , MonoFoldable mono
                    , Element mono ~ (msg, val)
                    , RenderMessage site msg
                    , PathPiece val
                    )
                 => mono -> m (OptionList val)
optionsPathPiece (otoList -> opts) = do
  mr <- getMessageRender
  let
    mkOption (m, a) = Option
      { optionDisplay       = mr m
      , optionInternalValue = a
      , optionExternalValue = toPathPiece a
      }
  return . mkOptionList $ mkOption <$> opts

optionsF :: ( MonadHandler m
            , RenderMessage site (Element mono)
            , HandlerSite m ~ site
            , PathPiece (Element mono)
            , MonoFoldable mono
            )
         => mono -> m (OptionList (Element mono))
optionsF = optionsPathPiece . map (id &&& id) . otoList

optionsFinite :: ( MonadHandler m
                 , Finite a
                 , RenderMessage site a
                 , HandlerSite m ~ site
                 , PathPiece a
                 )
              => m (OptionList a)
optionsFinite = optionsF universeF

optionsE :: forall record site msg.
            ( RenderMessage site msg
            , PersistRecordBackend record SqlBackend
            , YesodPersist site
            , E.SqlBackendCanRead (YesodPersistBackend site)
            , PathPiece (Key record)
            )
         => E.SqlQuery (E.SqlExpr (Entity record))
         -> (record -> msg)
         -> HandlerFor site (OptionList (Entity record))
optionsE query toMsg = mkOptionList <$> do
  mr <- getMessageRender
  pairs <- runDB $ E.select query
  return . flip map pairs $ \ent@Entity{..} -> Option
    { optionDisplay = mr $ toMsg entityVal
    , optionInternalValue = ent
    , optionExternalValue = toPathPiece entityKey
    }


fractionalField :: forall m a.
                   ( RealFrac a
                   , Monad m
                   , RenderMessage (HandlerSite m) FormMessage
                   ) => Field m a
-- | Form `Field` for any `Fractional` number
--
-- Use more specific `Field`s (i.e. `fixedPrecField`) whenever they exist
fractionalField = Field{..}
  where
    scientific' :: Iso' a Scientific
    scientific' = iso (fromRational . toRational) (fromRational . toRational)

    fieldEnctype = UrlEncoded
    fieldView theId name attrs (fmap $ view scientific' -> val) isReq
      = [whamlet|
          $newline never
          <input id=#{theId} name=#{name} *{attrs} type=number step=any :isReq:required value=#{either id (pack . formatScientific Fixed Nothing) val}>
        |]
    fieldParse = parseHelper $ \t ->
      maybe (Left $ MsgInvalidNumber (t<>"HERE")) (Right . review scientific') (readMay t :: Maybe Scientific)

fixedPrecField :: forall m p.
                  ( Monad m
                  , RenderMessage (HandlerSite m) FormMessage
                  , HasResolution p
                  ) => Field m (Fixed p)
fixedPrecField = fixedPrecMinMaxField Nothing Nothing

fixedPrecMinMaxField :: forall m p.
                  ( Monad m
                  , RenderMessage (HandlerSite m) FormMessage
                  , HasResolution p
                  ) => Maybe (Fixed p) -> Maybe (Fixed p) -> Field m (Fixed p)
fixedPrecMinMaxField lower upper = Field{..}
  where
    resolution' :: Integer
    resolution' = resolution $ Proxy @p

    showF = showFixed True
    step  = showFixed True (fromRational $ 1 % resolution' :: Fixed p)

    fieldEnctype = UrlEncoded
    fieldView theId name attrs val isReq
      = [whamlet|
          $newline never
          <input id=#{theId} name=#{name} *{attrs} type=number step=#{step} :hasMin:min="#{showF vMin}" :hasMax:max="#{showF vMax}" :isReq:required value=#{either id (pack . showFixed True) val}>
        |]
    fieldParse = parseHelper $ \t -> do
      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMay t :: Maybe Scientific)
      return . fromRational $ round (sci * fromIntegral resolution') % resolution'
    (hasMin, vMin) = maybe (False, 0) (True,) lower
    (hasMax, vMax) = maybe (False, 0) (True,) upper


rationalField :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => Field m Rational
rationalField = fractionalField

-- | Sepcify lower bound via HTML5 min attribute, may not work in older browser, so better use `Handler.Utils.Form.minIntField` (which in turn calls this function)
intMinField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Field m i
intMinField lower = intMinMaxField (Just lower) Nothing

-- | Sepcify lower/upper bounds via HTML5 min attribute, may not work in older browser, so better use `Handler.Utils.Form.minIntField` (which in turn calls this function)
intMinMaxField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => Maybe i -> Maybe i -> Field m i
intMinMaxField lower upper = intF{ fieldView=newView }
  where
    intF@Field{ fieldView=oldView } = intField
    newView theId name attrs = oldView theId name (newAttrs <> attrs)
    newAttrs = [ (a,tshow v) | (a,Just v) <- [("min", lower),("max", upper)] ]

daysField :: (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m NominalDiffTime
daysField = convertField fromDays toDays fractionalField
    where
      toDays   = (/ nominalDay)
      fromDays = (* nominalDay)


data SecretJSONFieldException = SecretJSONFieldDecryptFailure
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
instance Exception SecretJSONFieldException

secretJsonField' :: ( ToJSON a, FromJSON a
                    , MonadHandler m
                    , MonadSecretBox (ExceptT EncodedSecretBoxException m)
                    , MonadSecretBox (WidgetT (HandlerSite m) IO)
                    , RenderMessage (HandlerSite m) FormMessage
                    , RenderMessage (HandlerSite m) SecretJSONFieldException
                    )
                 => FieldViewFunc m Text -> Field m a
secretJsonField' fieldView' = Field{..}
  where
    fieldParse [v] [] = bimap (\_ -> SomeMessage SecretJSONFieldDecryptFailure) Just <$> runExceptT (encodedSecretBoxOpen v)
    fieldParse [] [] = return $ Right Nothing
    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
    fieldView theId name attrs val isReq = do
      val' <- traverse (encodedSecretBox SecretBoxShort) val
      fieldView' theId name attrs val' isReq
    fieldEnctype = UrlEncoded

secretJsonField :: forall m a.
                   ( ToJSON a, FromJSON a
                   , MonadHandler m
                   , MonadSecretBox (ExceptT EncodedSecretBoxException m)
                   , MonadSecretBox (WidgetT (HandlerSite m) IO)
                   , RenderMessage (HandlerSite m) FormMessage
                   , RenderMessage (HandlerSite m) SecretJSONFieldException
                   )
                => Field m a
secretJsonField = secretJsonField' $ fieldView (hiddenField :: Field m Text)

guardField :: Functor m => (a -> Bool) -> Field m a -> Field m a
guardField p field = field { fieldParse = \ts fs -> fieldParse field ts fs <&> \case
                               Right (Just x)
                                 | p x       -> Right $ Just x
                                 | otherwise -> Right   Nothing
                               other -> other
                           }

checkMap :: (Monad m, RenderMessage (HandlerSite m) msg) => (a -> Either msg b) -> (b -> a) -> Field m a -> Field m b
checkMap f = checkMMap (return . f)

cfStrip :: (Functor m, Textual t) => Field m t -> Field m t
cfStrip = guardField (not . T.null . repack) . convertField (repack . T.strip . repack) id

cfCI :: (Functor m, CI.FoldCase s) => Field m s -> Field m (CI s)
cfCI = convertField CI.mk CI.original

cfCommaSeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split (==',')) (T.intercalate ", " . Set.toList)

cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", " . Set.toList)
  where anySeparator :: Char -> Bool
        anySeparator c = C.isSeparator c || c == ',' || c == ';'

-- Version that splits conditionally whether or not a separator is found:
-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
--   where splitConditionally :: Text -> [Text]
--         splitConditionally t
--           | ';' `telem` t = T.split (==';') t
--           | ',' `telem` t = T.split (==',') t
--           | otherwise  = T.split C.isSeparator t
--         -- Our version of Data.Text does not yet support T.elem
--         telem :: Char -> Text -> Bool
--         telem c = T.any (==c)


-- cfAnySeparatedSet :: (Functor m) => Field m Text -> Field m (Set Text)
-- cfAnySeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (assertM' (not . T.null) . T.strip) . splitConditionally) (T.intercalate "; " . Set.toList)
--   where splitConditionally :: Text -> [Text]
--         splitConditionally t
--           | ';' `telem` t = T.split (==';') t
--           | ',' `telem` t = T.split (==',') t
--           | otherwise  = T.split C.isSeparator t
--         -- Our version of Data.Text does not yet support T.elem
--         telem :: Char -> Text -> Bool
--         telem c = T.any (==c)

-- -- TODO: consider using package ordered-containers?
-- cfAnySeparatedList :: (Functor m) => Field m Text -> Field m [Text]
-- cfAnySeparatedList = guardField (not . null) . convertField (mapMaybe (assertM' (not . T.null) . T.strip) . T.split anySeparator) (T.intercalate ", ")
--   where anySeparator :: Char -> Bool
--         anySeparator c = C.isSeparator c || c == ',' || c == ';'

isoField :: Functor m => AnIso' a b -> Field m a -> Field m b
isoField (cloneIso -> fieldIso) = convertField (view fieldIso) (review fieldIso)

-- | Also see non-monadic `Yesod.Form.Functions.convertField`
convertFieldM :: forall m a b. Monad m => (a -> m b) -> (b -> a) -> Field m a -> Field m b
convertFieldM = checkMMap . ((fmap Right .) :: (a -> m b) -> (a -> m (Either (SomeMessage (HandlerSite m)) b)))


selectField' :: ( Eq a
                , RenderMessage (HandlerSite m) FormMessage
                , MonadHandler m
                )
             => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
             -> HandlerT (HandlerSite m) IO (OptionList a)
             -> Field m a
-- ^ Like @selectField@, but with more control over the @Nothing@-Option, if Field is optional
selectField' optMsg mkOpts = Field{..}
  where
    fieldEnctype = UrlEncoded

    fieldParse []    _ = return $ Right Nothing
    fieldParse (s:_) _
      | s == ""     = return $ Right Nothing
      | otherwise = do
          readExternal <- view _olReadExternal <$> liftHandler mkOpts
          return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ readExternal s

    fieldView theId name attrs val isReq = do
      opts <- liftHandler mkOpts
      let
        rendered = case val of
          Left  _ -> ""
          Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) (opts ^.. _olOptions)

        isSel Nothing    = rendered `notElem` map optionExternalValue (opts ^.. _olOptions)
        isSel (Just opt) = rendered == optionExternalValue opt
      [whamlet|
        $newline never
        <select ##{theId} name=#{name} *{attrs} :isReq:required>
          $maybe optMsg' <- assertM (const $ not isReq) optMsg
            <option value="" :isSel Nothing:selected>
              _{optMsg'}
          $case opts
            $of OptionList{olOptions}
              $forall opt <- olOptions
                <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
                  #{optionDisplay opt}
            $of OptionListGrouped{olOptionsGrouped}
              $forall (groupLbl, iOpts) <- olOptionsGrouped
                <optgroup label=#{groupLbl}>
                  $forall opt <- iOpts
                    <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
                      #{optionDisplay opt}
      |]

multiSelectField' :: ( Eq a
                , RenderMessage (HandlerSite m) FormMessage
                , MonadHandler m
                )
             => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
             -> HandlerT (HandlerSite m) IO (OptionList a)
             -> Field m [a]
-- ^ Like @multiSelectField@, but it can handle OptionListGrouped and also offers more control over the @Nothing@-Option, if Field is optional
multiSelectField' optMsg mkOpts = Field{..}
  where
    fieldEnctype = UrlEncoded

    fieldParse []      _ = return $ Right Nothing
    fieldParse optlist _ = do
      let optlist' = filter notNull optlist
      readExternal <- view _olReadExternal <$> liftHandler mkOpts
      return $ case mapM readExternal optlist' of
        Nothing -> Left $ SomeMessage $ MsgInvalidEntry $ T.intercalate ", " optlist'
        res     -> Right res

    fieldView theId name attrs val isReq = do
      opts <- liftHandler mkOpts
      let
        rendered = case val of
          Left  _  -> []
          Right xs -> [optionExternalValue o | o <- opts ^.. _olOptions, x <- xs, x == optionInternalValue o]
        isSel Nothing    = ClassyPrelude.Yesod.null rendered
        isSel (Just opt) = optionExternalValue opt `elem` rendered
      [whamlet|
        $newline never
        <select ##{theId} name=#{name} multiple *{attrs} :isReq:required>
          $maybe optMsg' <- assertM (const $ not isReq) optMsg
            <option value="" :isSel Nothing:selected>
              _{optMsg'}
          $case opts
            $of OptionList{olOptions}
              $forall opt <- olOptions
                <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
                  #{optionDisplay opt}
            $of OptionListGrouped{olOptionsGrouped}
              $forall (groupLbl, iOpts) <- olOptionsGrouped
                <optgroup label=#{groupLbl}>
                  $forall opt <- iOpts
                    <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
                      #{optionDisplay opt}
      |]

radioField' :: ( Eq a
               , RenderMessage (HandlerSite m) FormMessage
               , MonadHandler m
               )
            => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
            -> HandlerT (HandlerSite m) IO (OptionList a)
            -> Field m a
-- ^ Like @radioField@, but with more control over the @Nothing@-Option, if Field is optional
radioField' optMsg mkOpts = Field{..}
  where
    fieldEnctype = UrlEncoded

    fieldParse []    _ = return $ Right Nothing
    fieldParse (s:_) _
      | s == ""     = return $ Right Nothing
      | otherwise = do
          readExternal <- view _olReadExternal <$> liftHandler mkOpts
          return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ readExternal s

    fieldView theId name attrs val isReq = do
      options <- toListOf _olOptions <$> liftHandler mkOpts -- TODO: Support grouped?
      let
        rendered = case val of
          Left  _ -> ""
          Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) options

        isSel Nothing    = rendered `notElem` map optionExternalValue options
        isSel (Just opt) = rendered == optionExternalValue opt
      [whamlet|
        $newline never
        <div ##{theId}>
          $maybe optMsgM <- assertM (const $ not isReq) optMsg
            <label .radio for=#{theId}->
              <div>
                <input id=#{theId}- type=radio name=#{name} value="" :isSel Nothing:checked *{attrs}>
                _{optMsgM}

          $forall opt <- options
            <label .radio for=#{theId}-#{optionExternalValue opt}>
              <div>
                <input id=#{theId}-#{optionExternalValue opt} type=radio name=#{name} value=#{optionExternalValue opt} :isSel (Just opt):checked *{attrs}>
                #{optionDisplay opt}
      |]

radioGroupField :: ( Eq a
                   , RenderMessage (HandlerSite m) FormMessage
                   , MonadHandler m
                   )
                => Maybe (SomeMessage (HandlerSite m)) -- ^ Caption used for @Nothing@-Option, if Field is optional and whether to show such an option
                -> HandlerT (HandlerSite m) IO (OptionList a)
                -> Field m a
radioGroupField optMsg mkOpts = Field{..}
  where
    fieldEnctype = UrlEncoded

    fieldParse []    _ = return $ Right Nothing
    fieldParse (s:_) _
      | s == ""     = return $ Right Nothing
      | otherwise = do
          readExternal <- view _olReadExternal <$> liftHandler mkOpts
          return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ readExternal s

    fieldView theId name attrs val isReq = do
      options <- toListOf _olOptions <$> liftHandler mkOpts -- TODO: Support grouped?
      let
        rendered = case val of
          Left  _ -> ""
          Right a -> maybe "" optionExternalValue $ find ((== a) . optionInternalValue) options

        isSel Nothing    = rendered `notElem` map optionExternalValue options
        isSel (Just opt) = rendered == optionExternalValue opt
      [whamlet|
        $newline never
        <div .radio-group ##{theId}>
          $maybe optMsgM <- assertM (const $ not isReq) optMsg
            <div .radio>
              <input id=#{theId}- type=radio name=#{name} value="" :isSel Nothing:checked *{attrs}>
              <label for=#{theId}->
                _{optMsgM}

          $forall opt <- options
            <div .radio>
              <input id=#{theId}-#{optionExternalValue opt} type=radio name=#{name} value=#{optionExternalValue opt} :isSel (Just opt):checked *{attrs}>
              <label for=#{theId}-#{optionExternalValue opt}>
                #{optionDisplay opt}
      |]

data UrlFieldMessage = UrlFieldCouldNotParseAbsolute
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite)

urlField' :: ( Monad m
             , RenderMessage (HandlerSite m) UrlFieldMessage
             , RenderMessage (HandlerSite m) FormMessage
             )
          => (URI -> a) -> (a -> Text)
          -> Field m a
urlField' fromURI toText = checkMap (maybe (Left UrlFieldCouldNotParseAbsolute) (Right . fromURI) . parseURI . unpack) toText Yesod.urlField

urlField :: ( Monad m
            , RenderMessage (HandlerSite m) UrlFieldMessage
            , RenderMessage (HandlerSite m) FormMessage
            )
         => Field m URI
urlField = urlField' id $ pack . ($ mempty) . uriToString id

urlFieldText :: ( Monad m
                , RenderMessage (HandlerSite m) UrlFieldMessage
                , RenderMessage (HandlerSite m) FormMessage
                )
             => Field m Text
urlFieldText = urlField' (pack . ($ mempty) . uriToString id) id


-----------
-- Forms --
-----------

data FormSubmitType = FormNoSubmit | FormSubmit | FormDualSubmit | FormAutoSubmit
    deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)

instance Universe FormSubmitType
instance Finite FormSubmitType

data FormSettings site = forall p. PathPiece p => FormSettings
      { formMethod     :: StdMethod
      , formAction     :: Maybe (SomeRoute site)
      , formEncoding   :: Enctype
      , formAttrs      :: [(Text, Text)]
      , formSubmit     :: FormSubmitType
      , formAnchor     :: Maybe p
      }

instance Default (FormSettings site) where
  def = FormSettings
    { formMethod   = POST
    , formAction   = Nothing
    , formEncoding = UrlEncoded
    , formAttrs    = []
    , formSubmit   = FormSubmit
    , formAnchor   = Nothing :: Maybe Text
    }

wrapForm :: Button site ButtonSubmit => WidgetT site IO () -> FormSettings site -> WidgetT site IO ()
wrapForm = wrapForm' BtnSubmit

wrapForm' :: Button site button => button -> WidgetT site IO () -> FormSettings site -> WidgetT site IO ()
wrapForm' btn formWidget FormSettings{..} = do
  formId <- maybe newIdent (return . toPathPiece) formAnchor
  formActionUrl <- traverse toTextUrl formAction
  let hasAction = isJust formActionUrl
  $(widgetFile "widgets/form/form")


-------------------
-- Form Renderer --
-------------------

-- | Use this type to pass information to the form template
data FormLayout = FormStandard | FormLogin -- ^ Like `FormStandard` but without honeypots
                | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport | FormDBTableCsvExport
                | FormWorkflowDataset
                | FormVertical
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic)
  deriving anyclass (Universe, Finite)

data AFormMessage = MsgAFormFieldRequiredTip
                  | MsgAFormFieldWorkflowDatasetTip
                  | MsgAFormHoneypotWebsite | MsgAFormHoneypotWebsiteTip | MsgAFormHoneypotWebsitePlaceholder
                  | MsgAFormHoneypotEmail | MsgAFormHoneypotEmailTip | MsgAFormHoneypotEmailPlaceholder
                  | MsgAFormHoneypotName | MsgAFormHoneypotNameTip | MsgAFormHoneypotNamePlaceholder
                  | MsgAFormHoneypotComment | MsgAFormHoneypotCommentPlaceholder
                  | MsgAFormHoneypotFilled
  deriving (Eq, Ord, Read, Show, Generic)

_HoneypotFieldId :: Prism' Text ()
_HoneypotFieldId = only $ tshow '_HoneypotFieldId

type RenderAFormSite :: Type -> Constraint
type RenderAFormSite site = ( RenderMessage site AFormMessage
                            , RenderMessage site UrlFieldMessage
                            , MonadSecretBox (HandlerFor site)
                            , MonadSecretBox (MaybeT (RWST (Maybe (Env, FileEnv), site, [Lang]) Enctype Ints (Lazy.WriterT [FieldView site] (HandlerFor site))))
                            , YesodAuth site, HasAppSettings site
                            )

renderAForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> FormRender m a
renderAForm formLayout aform' fragment = do
  (res, ($ []) -> fieldViews') <- aFormToForm aform
  doHoneypots <- doFormHoneypots
  honeypotSecrets' <- liftHandler honeypotSecrets
  fieldViews <- liftHandler . secretBoxCSPRNGT (encodeUtf8 $ tshow ('renderAForm, "fieldViews")) (Binary.encode $ fieldViews' ^.. folded . _fvId) . forM fieldViews' . runStateT $ do
    isHoneypot <- and2M (pure doHoneypots) $ is _Just <$> preuse (_fvId . _HoneypotFieldId)
    when isHoneypot $
      _fvId <~ lift (lift newIdent)
    honeypotHiddenSecret <- uniform . toNullable $ honeypotSecrets' Map.! isHoneypot
    lift . lift $ (honeypotHiddenSecret, ) <$> newIdent
  let formHasRequiredFields = any fvRequired fieldViews'
      widget = $(widgetFile "widgets/aform/aform")
  return (res, widget)
  where
    isFormVertical = formLayout == FormVertical
    isFormWorkflowDataset = formLayout == FormWorkflowDataset

    aform = case formLayout of
      FormLogin -> aform'
      _other -> aformHoneypot aform'

renderWForm :: (MonadHandler m, RenderAFormSite (HandlerSite m)) => FormLayout -> WForm m (FormResult a) -> -- Form a   -- (Synonym unavailable here)
  (Markup -> MForm m (FormResult a, WidgetT (HandlerSite m) IO ()))
renderWForm formLayout = renderAForm formLayout . wFormToAForm

renderFieldViews :: RenderAFormSite site
                 => FormLayout -> [FieldView site] -> WidgetT site IO ()
renderFieldViews layout
  = view _1 <=< generateFormPost
  . lmap (const mempty)
  . renderWForm layout
  . (FormSuccess () <$)
  . lift . tell

-- | special id to identify form section headers, see 'aformSection' and 'formSection'
--   currently only treated by form generation through 'renderAForm'
idFormSectionNoinput :: Text
idFormSectionNoinput = "form-section-noinput"

-- | special id to identify form messages, see 'aformMessage' and 'formMessage'
--   currently only treated by form generation through 'renderAForm'
idFormMessageNoinput :: Text
idFormMessageNoinput = "form-message-noinput"

-- | Generates a form having just a form-section-header and no input title.
--   Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
--   Usage:
--   @
--      (,) <$  formSection MsgInt
--          <*> areq intField "int here" Nothing
--          <*  formSection MsgDouble
--          <*> areq doubleField "double there " Nothing
--          <*  submitButton
--   @
--   If tooltips or other attributes are required, see 'formSection\'' instead.
aformSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> AForm m ()
aformSection = formToAForm . fmap (second pure) . formSection

wformSection :: (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> WForm m ()
wformSection = void . aFormToWForm . aformSection

formSection :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site msg) => msg -> MForm m (FormResult (), FieldView site)
formSection formSectionTitle = do
    mr <- getMessageRender
    return (FormSuccess (), FieldView
      { fvLabel    = toHtml $ mr formSectionTitle
      , fvTooltip  = Nothing
      , fvId       = idFormSectionNoinput
      , fvErrors   = Nothing
      , fvRequired = False
      , fvInput    = mempty
      })

fvWidget :: FieldView site -> WidgetFor site ()
fvWidget FieldView{..} = $(widgetFile "widgets/field-view/field-view")


doFormHoneypots :: ( MonadHandler m
                   , HasAppSettings (HandlerSite m)
                   , YesodAuth (HandlerSite m)
                   )
                => m Bool
doFormHoneypots = and2M
  (getsYesod . views _appBotMitigations $ Set.member SettingBotMitigationUnauthorizedFormHoneypots)
  (is _Nothing <$> maybeAuthId)

honeypotSecrets :: ( MonadSecretBox m
                   , MonadThrow m
                   )
                => m (Map Bool (NonNull (Set Text)))
honeypotSecrets = secretBoxCSPRNGPure (encodeUtf8 $ tshow 'honeypotSecrets) (Binary.encode secretsNum) $ do
  idents <- take (2 * secretsNum) . nub <$> randomInfiniteList randomIdent
  let (hpIdents, noHPIdents) = splitAt secretsNum idents
  return . mapF $ impureNonNull . Set.fromList . bool noHPIdents hpIdents
  where
    secretsNum = 10

    randomIdent = decodeUtf8 . Base64.encodeUnpadded . BS.pack <$> replicateM 18 getRandom


aformHoneypot :: forall m a.
                 ( RenderAFormSite (HandlerSite m)
                 , MonadHandler m
                 ) => AForm m a -> AForm m a
aformHoneypot (aFormToWForm -> wform) = wFormToAForm . maybeT wform $ do
  guardM doFormHoneypots

  (res, fields) <- lift $ wFormFields wform

  guard $ hasn't (folded . _fvId . _HoneypotFieldId) fields

  MsgRenderer mr <- getMsgRenderer
  hoist (hoist $ hoist liftHandler) . secretBoxCSPRNGT (encodeUtf8 $ tshow 'aformHoneypot) (Binary.encode $ map (fvId &&& fvRequired) fields) $ do
    k <- getRandomR @_ @Double (0, 1)
    poss <- getRandomRs (0, length fields)
    let honeypotCount = 2 + round (realToFrac (fromIntegral (length fields) * honeypotProportion) * k)
        honeypotPoss = fmap getSum . Map.fromListWith (<>) . map (, Sum 1) . take honeypotCount $ 0 : length fields : poss

    hpFailure <- lift $ formFailure [MsgAFormHoneypotFilled]
    let
      toHpRes :: forall a'. FormResult (Maybe a') -> FormResult ()
      toHpRes hpRes = bool hpFailure (FormSuccess ()) (has (_FormSuccess . _Nothing) hpRes)

    fmap ((res <*) . fold) . flip evalStateT Set.empty . forM (zip [0..] $ map Just fields ++ [Nothing]) $ \(i, formField) -> do
      hpRes <- fmap (fold @[FormResult ()]) . replicateM (Map.findWithDefault 0 i honeypotPoss) . hoist (hoist $ hoist censorHoneypot) $ do
        let
          chooseName :: Set Text -> _ (Maybe Text)
          chooseName options = do
            chosenNames <- State.get
            name <- uniformMay $ options `Set.difference` chosenNames
            for_ name $ State.modify' . Set.insert
            return name
        join $ weighted
          [ ( do
                name <- chooseName $ Set.fromList ["website", "url"]
                fmap toHpRes . lift . lift . lift $ wopt urlField
                  (   fslI MsgAFormHoneypotWebsite
                    & setTooltip (mr MsgAFormHoneypotWebsiteTip)
                    & addPlaceholder (mr MsgAFormHoneypotWebsitePlaceholder)
                    & honeypotAttrs
                    & maybe id addName name
                  ) Nothing
            , 5
            )
          , ( do
                name <- chooseName $ Set.fromList ["email", "e-mail"]
                fmap toHpRes . lift . lift . lift $ wopt emailField
                  (   fslI MsgAFormHoneypotEmail
                    & setTooltip (mr MsgAFormHoneypotEmailTip)
                    & addPlaceholder (mr MsgAFormHoneypotEmailPlaceholder)
                    & honeypotAttrs
                    & maybe id addName name
                  ) Nothing
            , 2
            )
          , ( do
                name <- chooseName $ Set.singleton "name"
                fmap toHpRes . lift . lift . lift $ wopt textField
                  (   fslI MsgAFormHoneypotName
                    & setTooltip (mr MsgAFormHoneypotNameTip)
                    & addPlaceholder (mr MsgAFormHoneypotNamePlaceholder)
                    & honeypotAttrs
                    & maybe id addName name
                  ) Nothing
            , 1
            )
          , ( do
                name <- chooseName $ Set.singleton "comment"
                fmap toHpRes . lift . lift . lift $ wopt textareaField
                  (   fslI MsgAFormHoneypotComment
                    & addPlaceholder (mr MsgAFormHoneypotCommentPlaceholder)
                    & honeypotAttrs
                    & maybe id addName name
                  ) Nothing
            , 1
            )
          ]
      for_ formField $ lift . lift . lift . lift . tell . pure

      return hpRes
  where
    honeypotProportion :: Rational
    honeypotProportion = 1 % 3

    censorHoneypot :: forall a'. WForm (HandlerFor (HandlerSite m)) a' -> WForm (HandlerFor (HandlerSite m)) a'
    censorHoneypot = hoist $ censor (set (mapped . _fvId) $ _HoneypotFieldId # () :: [FieldView (HandlerSite m)] -> [FieldView (HandlerSite m)])

    honeypotAttrs = addAttr "tabindex" "-1" . noAutocomplete


-------------------
-- Special Forms --
-------------------

-- | Alternative implementation for 'aformSection' in a more standard that
--  allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
aformSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) => FieldSettings site -> AForm m ()
aformSection' = formToAForm . fmap (second pure) . formSection'

-- | Alternative implementation for 'formSection' in a more standard that
--  allows tooltips and arbitrary attributs. Section header must be given through `fsLabel`
formSection' :: (MonadHandler m, site ~ HandlerSite m, RenderMessage site FormMessage) =>
   FieldSettings site  -> MForm m (FormResult (), FieldView site) -- TODO: WIP, delete
formSection' formSectionTitleSettings = Yesod.mreq noinputField sectionSettings Nothing
  where
    sectionSettings = formSectionTitleSettings { fsId = Just idFormSectionNoinput }


-- | Similar to aformSection, generates a form having just a view widget, but no input.
--   Currently only correctly rendered by 'renderAForm' and mforms using 'widget/form.hamlet'
--   Usage:
--   @
--      (,) <$  formMessage (Message Info html1)
--          <*> areq intField "int here" Nothing
--          <*  formSection (Message Warning html2)
--          <*> areq doubleField "double there " Nothing
--          <*  submitButton
--   @

aformMessage :: (MonadHandler m) => Message -> AForm m ()
aformMessage = formToAForm . fmap (second pure) . formMessage

wformMessage :: (MonadHandler m) => Message -> WForm m ()
wformMessage = void . aFormToWForm . aformMessage

formMessage :: (MonadHandler m) => Message -> MForm m (FormResult (), FieldView site)
formMessage msg = do
  return (FormSuccess (), FieldView
    { fvLabel    = mempty
    , fvTooltip  = Nothing
    , fvId       = idFormMessageNoinput
    , fvErrors   = Nothing
    , fvRequired = False
    , fvInput    = notification NotificationNarrow msg
    })

---------------------
-- Form evaluation --
---------------------

traverseAForm :: forall m a b. Monad m => (a -> m (FormResult b)) -> (AForm m a -> AForm m b)
traverseAForm adj (AForm f) = AForm $ \mr env ints -> do
  ret@(res, _, _, _) <- f mr env ints
  case res of
    FormFailure errs
      -> return $ ret & _1 .~ FormFailure errs
    FormMissing
      -> return $ ret & _1 .~ FormMissing
    FormSuccess a -> do
      a' <- adj a
      return $ ret & _1 .~ a'

formFailure :: forall msg m a.
             ( MonadHandler m
             , RenderMessage (HandlerSite m) msg
             ) => [msg] -> m (FormResult a)
formFailure errs' = do
  mr <- getMessageRender
  return . FormFailure $ map mr errs'

-- | Turn form errors into alerts, but otherwise do nothing at all
formFailure2Alerts :: MonadHandler m => FormResult a -> m ()
formFailure2Alerts = flip formResult $ const $ return ()

-- | Turns errors into alerts, ignores missing forms and applies processing function
formResult :: MonadHandler m => FormResult a -> (a -> m ()) -> m ()
formResult res f = void . formResultMaybe res $ \x -> Nothing <$ f x

formResultMaybe :: MonadHandler m => FormResult a -> (a -> m (Maybe b)) -> m (Maybe b)
formResultMaybe (FormFailure errs) _ = do
  forM_ errs $ \err -> do
    $logDebugS "formResultMaybe" err
    addMessage Error $ toHtml err
  return Nothing
formResultMaybe  FormMissing       _ = return Nothing
formResultMaybe (FormSuccess res)  f = f res

formResult' :: FormResult a -> Maybe a
formResult'  FormMissing    = Nothing
formResult' (FormFailure _) = Nothing
formResult' (FormSuccess x) = Just x

runInputGetMaybe, runInputPostMaybe, runInputMaybe :: MonadHandler m => FormInput m a -> m (Maybe a)
runInputGetMaybe = fmap formResult' . runInputGetResult
runInputPostMaybe = fmap formResult' . runInputPostResult
runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form)

runInputResult :: MonadHandler m => FormInput m a -> m (FormResult a)
runInputResult form = do
  postRes <- runInputPostResult form
  getRes  <- runInputGetResult form
  return $ case (postRes, getRes) of
    (FormSuccess a, _) -> FormSuccess a
    (_, FormSuccess b) -> FormSuccess b
    (postRes', _)      -> postRes'

runInput :: (MonadHandler m, RenderMessage (HandlerSite m) FormMessage) => FormInput m a -> m a
runInput = runInputResult >=> \case
  FormFailure errs -> invalidArgs errs
  FormMissing      -> invalidArgsI [MsgValueRequired]
  FormSuccess a    -> return a

hoistAForm :: HandlerSite m ~ HandlerSite n => (forall a. m a -> n a) -> AForm m b -> AForm n b
hoistAForm f (AForm g) = AForm (\x y z ->f $ g x y z)

hoistField :: HandlerSite m ~ HandlerSite n => (forall a. m a -> n a) -> Field m b -> Field n b
hoistField f Field{..} = Field
  { fieldParse = \x y -> f $ fieldParse x y
  , fieldView
  , fieldEnctype
  }

prismAForm :: Monad m => Prism' s a -> Maybe s ->  (Maybe a -> AForm m a) -> AForm m s
-- ^ @Monad m => Prism' s a -> (Maybe a -> AForm m a) -> (Maybe s -> AForm m s)@
prismAForm p outer form = review p <$> form inner
  where
    inner = outer >>= preview p

newtype FormValidator r m a = FormValidator { unFormValidator :: RWST () [SomeMessage (HandlerSite m)] r m a }

deriving newtype instance Functor m => Functor (FormValidator r m)
deriving newtype instance Monad m => Applicative (FormValidator r m)
deriving newtype instance Monad m => Monad (FormValidator r m)
deriving newtype instance Monad m => MonadState r (FormValidator r m)
deriving newtype instance MonadFix m => MonadFix (FormValidator r m)
deriving newtype instance MonadResource m => MonadResource (FormValidator r m)
deriving newtype instance MonadThrow m => MonadThrow (FormValidator r m)
deriving newtype instance MonadCatch m => MonadCatch (FormValidator r m)
deriving newtype instance MonadIO m => MonadIO (FormValidator r m)
deriving newtype instance MonadLogger m => MonadLogger (FormValidator r m)
instance MonadBase b m => MonadBase b (FormValidator r m) where
  liftBase = lift . liftBase
instance MonadTrans (FormValidator r) where
  lift = FormValidator . lift

instance MonadHandler m => MonadHandler (FormValidator r m) where
  type HandlerSite (FormValidator r m) = HandlerSite m
  type SubHandlerSite (FormValidator r m) = SubHandlerSite m
  liftHandler = lift . liftHandler
  liftSubHandler = lift . liftSubHandler

validateForm :: MonadHandler m
             => FormValidator a m ()
             -> (Markup -> MForm m (FormResult a, xml))
             -> (Markup -> MForm m (FormResult a, xml))
validateForm valF form csrf = do
  (res, xml) <- form csrf
  res' <- for res $ lift . execRWST (unFormValidator valF) ()
  (, xml) <$> case res' of
    FormSuccess (x, []  ) -> return $ FormSuccess x
    FormSuccess (_, msgs) -> formFailure msgs
    FormMissing           -> return FormMissing
    FormFailure errs      -> return $ FormFailure errs

validateFormDB :: ( MonadHandler m
                  , YesodPersist (HandlerSite m)
                  )
               => FormValidator a (YesodDB (HandlerSite m)) ()
               -> (Markup -> MForm m (FormResult a, xml))
               -> (Markup -> MForm m (FormResult a, xml))
validateFormDB (FormValidator valF) = validateForm . FormValidator $ hoist (liftHandler . runDB) valF

validateAForm :: MonadHandler m
              => FormValidator a m ()
              -> AForm m a
              -> AForm m a
validateAForm valF form = formToAForm . over (mapped . _2) ($ []) $ validateForm valF (const $ aFormToForm form) mempty

tellValidationError :: ( MonadHandler m
                       , RenderMessage (HandlerSite m) msg
                       )
                    => msg -> FormValidator r m ()
tellValidationError = FormValidator . tell . pure . SomeMessage

guardValidation :: ( MonadHandler m
                   , RenderMessage (HandlerSite m) msg
                   )
                => msg -- ^ Message describing violation
                -> Bool -- ^ @False@ iff constraint is violated
                -> FormValidator r m ()
guardValidation msg isValid = unless isValid $ tellValidationError msg

guardValidationM :: ( MonadHandler m
                    , RenderMessage (HandlerSite m) msg
                    )
                 => msg -> m Bool -> FormValidator r m ()
guardValidationM = (. lift) . (=<<) . guardValidation

-- | like `guardValidation`, but issues a warning instead
warnValidation :: ( MonadHandler m
                   , RenderMessage (HandlerSite m) msg
                   )
                => msg -- ^ Message describing violation
                -> Bool -- ^ @False@ iff constraint is violated
                -> FormValidator r m ()
warnValidation msg isValid = unless isValid $ addMessageI Warning msg


-----------------------
-- Form Manipulation --
-----------------------

aFormToWForm :: (MonadHandler m, HandlerSite m ~ site) => AForm m a -> WForm m (FormResult a)
aFormToWForm = mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm

mFormToWForm' :: (MonadHandler m, HandlerSite m ~ site)
              => MForm m (a, [FieldView site])
              -> WForm m a
mFormToWForm' = mapRWST $ \f -> do
  ((a, vs), ints, enctype) <- lift f
  writer ((a, ints, enctype), vs)

infixl 4 `fmapAForm`

fmapAForm :: Functor m => (FormResult a -> FormResult b) -> (AForm m a -> AForm m b)
fmapAForm f (AForm act) = AForm $ \app env ints -> over _1 f <$> act app env ints

wFormFields :: Monad m => WForm m a -> WForm m (a, [FieldView (HandlerSite m)])
-- ^ Suppress side effect of appending `FieldView`s and instead add them to the result
wFormFields = mapRWST (fmap (\((a, s, w'), w) -> ((a, w), s, w')) . censor (const mempty) . listen)


wSetTooltip :: Monad m => Maybe Html -> WForm m a -> WForm m a
wSetTooltip tip = hoist (censoring _head $ set _fvTooltip tip)

aSetTooltip :: MonadHandler m => Maybe Html -> AForm m a -> AForm m a
aSetTooltip tip = wFormToAForm . wSetTooltip tip . aFormToWForm

---------------------------------------------
-- Special variants of @mopt@, @mreq@, ... --
---------------------------------------------


data ValueRequired site = forall msg. RenderMessage site msg => ValueRequired msg

formResultUnOpt :: forall a site msg.
                   ( RenderMessage site msg
                   , RenderMessage site (ValueRequired site)
                   )
                => MsgRendererS site -> msg -> FormResult (Maybe a) -> FormResult a
formResultUnOpt (MsgRenderer mr) label = \case
  FormFailure errs     -> FormFailure errs
  FormMissing          -> FormMissing
  FormSuccess Nothing  -> FormFailure . pure $ mr (ValueRequired label :: ValueRequired site)
  FormSuccess (Just x) -> FormSuccess x


mreq :: forall m a.
        ( MonadHandler m
        , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
        )
     => Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> MForm m (FormResult a, FieldView (HandlerSite m))
mreq f fs@FieldSettings{..} = mreqMsg f fs $ ValueRequired fsLabel

wreq :: forall m a.
        ( MonadHandler m
        , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
        )
     => Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> WForm m (FormResult a)
wreq f fs@FieldSettings{..} = wreqMsg f fs $ ValueRequired fsLabel

areq :: forall m a.
        ( MonadHandler m
        , RenderMessage (HandlerSite m) (ValueRequired (HandlerSite m))
        )
     => Field m a -> FieldSettings (HandlerSite m) -> Maybe a -> AForm m a
areq f fs@FieldSettings{..} = areqMsg f fs $ ValueRequired fsLabel


mforced :: (site ~ HandlerSite m, MonadHandler m)
        => Field m a -> FieldSettings site -> a -> MForm m (FormResult a, FieldView site)
mforced Field{..} FieldSettings{..} val = do
  tell fieldEnctype
  name <- maybe newFormIdent return fsName
  theId <- lift $ maybe newIdent return fsId
  mr <- getMessageRender
  let fsAttrs' = fsAttrs <> [("disabled", "")]
  return ( FormSuccess val
         , FieldView
           { fvLabel = toHtml $ mr fsLabel
           , fvTooltip = toHtml <$> fmap mr fsTooltip
           , fvId = theId
           , fvInput = fieldView theId name fsAttrs' (Right val) False
           , fvErrors = Nothing
           , fvRequired = False
           }
         )

mforcedOpt :: MonadHandler m
           => Field m a
           -> FieldSettings (HandlerSite m)
           -> Maybe a
           -> MForm m (FormResult (Maybe a), FieldView (HandlerSite m))
mforcedOpt Field{..} FieldSettings{..} mVal = do
  tell fieldEnctype
  name <- maybe newFormIdent return fsName
  theId <- lift $ maybe newIdent return fsId
  mr <- getMessageRender
  let fsAttrs' = fsAttrs <> [("disabled", "")]
  return ( FormSuccess mVal
         , FieldView
           { fvLabel = toHtml $ mr fsLabel
           , fvTooltip = toHtml <$> fmap mr fsTooltip
           , fvId = theId
           , fvInput = fieldView theId name fsAttrs' (maybe (Left "") Right mVal) False
           , fvErrors = Nothing
           , fvRequired = False
           }
         )


aforced :: (HandlerSite m ~ site, MonadHandler m)
        => Field m a -> FieldSettings site -> a -> AForm m a
aforced field settings val = formToAForm $ over _2 pure <$> mforced field settings val

wforced :: MonadHandler m
        => Field m a -> FieldSettings (HandlerSite m) -> a -> WForm m (FormResult a)
wforced field settings val = mFormToWForm $ mforced field settings val

mforcedJust :: (site ~ HandlerSite m, MonadHandler m)
            => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
mforcedJust f fs (Just fDef) = mforced f fs fDef
mforcedJust _ _   Nothing    = error "mforcedJust called with Nothing"

aforcedJust :: (site ~ HandlerSite m, MonadHandler m)
            => Field m a -> FieldSettings site -> Maybe a -> AForm m a
aforcedJust f fs (Just fDef) = aforced f fs fDef
aforcedJust _ _   Nothing    = error "aforcedJust called with Nothing"

wforcedJust :: (site ~ HandlerSite m, MonadHandler m)
            => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wforcedJust f fs (Just fDef) = wforced f fs fDef
wforcedJust _ _   Nothing    = error "wforcedJust called with Nothing"


mpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
-- ^ Pseudo required
--
-- `FieldView` has `fvRequired` set to `True` and @FormSuccess Nothing@ is cast to `FormFailure`.
-- Otherwise acts exactly like `mopt`. Note that a shortcut to mreq for isJust mx does create problems mit checkBoxField
mpreq f fs@FieldSettings{..} mx = do
  mr <- getMessageRender
  (res, fv') <- mpreq' f fs $ Just <$> mx
  return $ case res of
    FormSuccess (Just res')
      -> (FormSuccess res', fv')
    FormSuccess Nothing
      -> let errMsg = mr $ ValueRequired fsLabel
          in ( FormFailure [errMsg]
             , fv' { fvErrors = Just
                       [shamlet|
                         $newline never
                         $maybe pErr <- fvErrors fv'
                           #{pErr}
                           <br />
                         #{errMsg}
                       |]
                   }
             )
    FormFailure errs
      -> (FormFailure errs, fv')
    FormMissing
      -> (FormMissing, fv')

apreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
apreq f fs mx = formToAForm $ over _2 pure <$> mpreq f fs mx

wpreq :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpreq f fs mx = mFormToWForm $ mpreq f fs mx


mpreq' :: (HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe (Maybe a) -> MForm m (FormResult (Maybe a), FieldView site)
-- ^ Pseudo required
--
-- `FieldView` has `fvRequired` set to `True`.
-- Otherwise acts exactly like `mopt`.
mpreq' f fs mx = do
  (res, fv) <- mopt f fs mx
  return (res, fv { fvRequired = True })

apreq' :: (HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe (Maybe a) -> AForm m (Maybe a)
apreq' f fs mx = formToAForm $ over _2 pure <$> mpreq' f fs mx

wpreq' :: (HandlerSite m ~ site, MonadHandler m)
       => Field m a -> FieldSettings site -> Maybe (Maybe a) -> WForm m (FormResult (Maybe a))
wpreq' f fs mx = mFormToWForm $ mpreq' f fs mx


mpopt :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
-- ^ Pseudo optional
--
-- `FieldView` has `fvRequired` set to `False`
-- Otherwise acts exactly like `mreq`.
mpopt f fs mx = set (_2 . _fvRequired) False <$> mreq f fs mx

apopt :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
apopt f fs mx = formToAForm $ over _2 pure <$> mpopt f fs mx

wpopt :: (RenderMessage site (ValueRequired site), HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> WForm m (FormResult a)
wpopt f fs mx = mFormToWForm $ mpopt f fs mx