fradrive-old/src/Utils/Form.hs

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Utils.Form where

import ClassyPrelude.Yesod hiding (addMessage, addMessageI, cons, Proxy(..), identifyForm, addClass)
import qualified Yesod.Form.Functions 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 Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.Universe

import Data.Map.Lazy ((!))
import qualified Data.Map.Lazy as Map
import qualified Data.Set as Set

import Control.Monad.Trans.Maybe (MaybeT(..))
import Control.Monad.Reader.Class (MonadReader(..))
import Control.Monad.Writer.Class (MonadWriter(..), censor)
import Control.Monad.State.Class (MonadState(..))
import Control.Monad.Trans.RWS (RWST, execRWST, mapRWST)
import Control.Monad.Trans.Except (ExceptT, runExceptT)
import Control.Monad.Fix (MonadFix)
import Control.Monad.Morph (MFunctor(..))
import Control.Monad.Base

import Data.List ((!!))

import Web.PathPieces

import Data.UUID

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

import Utils
-- import Utils.Message
-- import Utils.PathPiece
-- import Utils.Route

import Data.Proxy

import Text.HTML.SanitizeXSS (sanitizeBalance)
import Text.Blaze (preEscapedText)
import Text.Blaze.Html.Renderer.Pretty (renderHtml)

import Data.Monoid (Endo(..))




--------------------
-- 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 $ 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", "")


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

data FormIdentifier
  = FIDcourse
  | FIDcourseRegister
  | FIDsheet
  | FIDmaterial
  | FIDCourseNews
  | FIDCourseEvent
  | FIDsubmission
  | FIDsettings
  | FIDcorrectors
  | FIDcorrectorTable
  | FIDcorrection
  | FIDcorrectionsUpload
  | FIDcorrectionUpload
  | FIDSystemMessageAdd
  | FIDSystemMessageTable
  | FIDSystemMessageModify
  | FIDSystemMessageModifyTranslation UUID
  | FIDSystemMessageAddTranslation
  | FIDDBTableFilter
  | FIDDBTablePagesize
  | FIDDBTable
  | FIDDBTableCsvExport
  | FIDDBTableCsvImport
  | FIDDBTableCsvImportConfirm
  | FIDDelete
  | FIDCourseRegister
  | FIDuserRights
  | FIDcUserNote
  | FIDcRegField
  | FIDcRegButton
  | FIDAdminDemo
  | FIDUserDelete
  | FIDCommunication
  | FIDAssignSubmissions
  | FIDUserAuthMode
  | FIDAllUsersAction
  | FIDLanguage
  deriving (Eq, Ord, Read, Show)

instance PathPiece FormIdentifier where
  fromPathPiece = readFromPathPiece
  toPathPiece = showToPathPiece


identifyForm' :: (Monad 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|
            <input .form-identifier type=hidden name=#{toPathPiece PostFormIdentifier} value=#{toPathPiece identVal}>
            #{fragment}
          |]

    -- Check if we got its value back.
    hasIdent <- (== Just identVal) <$> lookupGlobalPostParamForm PostFormIdentifier

    -- 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
    fmap (over (_1 . resLens) $ bool (const FormMissing) id hasIdent) . eraseParams $ form fragment'

identifyForm :: (Monad 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 ) --
----------------------------

data family ButtonClass site :: *

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

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

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

-- | 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, Typeable)

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 = 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 :: (Button site a, Finite a) => Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site 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' :: Button site a => [a] -> Html -> MForm (HandlerT site IO) (FormResult a, WidgetT site IO ())
buttonForm' btns csrf = do
  (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonField btns ""
  return (res, [whamlet|
      $newline never
      #{csrf}
      $forall bView <- fViews
        ^{fvInput bView}
    |])

-- | 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)


-------------------
-- 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
      OptionList{..} <- liftHandler optList
      let
        olNum = fromIntegral $ length olOptions
        selOptions = Map.fromList $ do
          i <- [1..olNum]
          (readMay -> Just (n :: Word), '.' : extVal) <- break (== '.') . unpack <$> optlist
          guard $ i == n
          Just val <- return . olReadExternal $ pack extVal
          return (i, val)
      return $ if
        | Map.keysSet selOptions == Set.fromList [1..olNum]
          -> Right . Just $ map (selOptions !) [1..fromIntegral olNum]
        | otherwise
          -> Left "Not a valid permutation"
    fieldView theId name attrs val isReq = do
      OptionList{..} <- liftHandler optList
      let
        isSel n = (==) (either (const $ map optionInternalValue olOptions) id val !! pred n) . optionInternalValue
        nums = map (id &&& withNum theId) [1..length olOptions]
        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

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 val isReq = oldView theId name (newAttrs <> attrs) val isReq
    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, Typeable)
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)

htmlFieldSmall :: forall m. (Monad m, RenderMessage (HandlerSite m) FormMessage) => Field m Html
htmlFieldSmall = checkMMap sanitize (pack . renderHtml) textField
  where
    sanitize :: Text -> m (Either FormMessage Html)
    sanitize = return . Right . preEscapedText . sanitizeBalance

fileFieldMultiple :: Monad m => Field m [FileInfo]
fileFieldMultiple = Field
  { fieldParse = \_ files -> return $ case files of
      [] -> Right Nothing
      fs -> Right $ Just fs
  , fieldView = \id' name attrs _ isReq ->
      [whamlet|
        $newline never
        <input type="file" uw-file-input id=#{id'} name=#{name} *{attrs} multiple :isReq:required="required">
      |]
  , fieldEnctype = Multipart
  }

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

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


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
          OptionList{olReadExternal} <- liftHandler mkOpts
          return . maybe (Left . SomeMessage $ MsgInvalidEntry s) (Right . Just) $ olReadExternal s

    fieldView theId name attrs val isReq = do
      OptionList{olOptions} <- liftHandler mkOpts
      let
        rendered = case val of
          Left  _ -> ""
          Right a -> maybe "" optionExternalValue . listToMaybe $ filter ((== a) . optionInternalValue) olOptions

        isSel Nothing    = not $ rendered `elem` map optionExternalValue 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'}
          $forall opt <- olOptions
            <option value=#{optionExternalValue opt} :isSel (Just opt):selected>
              #{optionDisplay opt}
      |]


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

data FormSubmitType = FormNoSubmit | FormSubmit | FormDualSubmit | FormAutoSubmit
    deriving (Eq, Ord, Enum, Bounded, Read, Show, Typeable, 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
      } deriving (Typeable)

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
  $(widgetFile "widgets/form/form")


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

-- | Use this type to pass information to the form template
data FormLayout = FormStandard | FormDBTableFilter | FormDBTablePagesize | FormDBTableCsvImport | FormDBTableCsvExport

data AFormMessage = MsgAFormFieldRequiredTip

renderAForm :: (RenderMessage (HandlerSite m) AFormMessage, Monad m) => FormLayout -> FormRender m a
renderAForm formLayout aform fragment = do
  (res, ($ []) -> fieldViews) <- aFormToForm aform
  let formHasRequiredFields = any fvRequired fieldViews
      widget = $(widgetFile "widgets/aform/aform")
  return (res, widget)

renderWForm :: (RenderMessage (HandlerSite m) AFormMessage, MonadHandler 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 :: ( RenderMessage site AFormMessage
                    , RenderMessage site FormMessage
                    )
                 => FormLayout -> [FieldView site] -> WidgetT site IO ()
renderFieldViews layout
  = join
  . fmap (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
      })

-------------------
-- 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 = 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 Message{..} = do
  return (FormSuccess (), FieldView
    { fvLabel    = mempty
    , fvTooltip  = Nothing
    , fvId       = idFormMessageNoinput
    , fvErrors   = Nothing
    , fvRequired = False
    , fvInput    = [whamlet|
                     $newline never
                     <div .notification .notification-#{toPathPiece messageStatus} .fa-#{maybe defaultIcon iconText messageIcon}>
                       <div .notification__content>
                         #{messageContent}
                   |]
    })
  where
    defaultIcon = case messageStatus of
      Success -> "check-circle"
      Info    -> "info-circle"
      Warning -> "exclamation-circle"
      Error   -> "exclamation-triangle"

---------------------
-- 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) _ = Nothing <$ forM_ errs (addMessage Error . toHtml)
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 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

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 => AForm m a -> WForm m (FormResult a)
aFormToWForm = mapRWST mFormToWForm' . over (mapped . _2) ($ []) . aFormToForm
  where
    mFormToWForm' 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)

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

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 FormMessage, 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`.
mpreq f fs mx = do
  mr <- getMessageRender
  (res, fv) <- mopt f fs (Just <$> mx)
  let fv' = fv { fvRequired = True }
  return $ case res of
    FormSuccess (Just res')
      -> (FormSuccess res', fv')
    FormSuccess Nothing
      -> (FormFailure [mr MsgValueRequired], fv' { fvErrors = Just . toHtml $ mr MsgValueRequired })
    FormFailure errs
      -> (FormFailure errs, fv')
    FormMissing
      -> (FormMissing, fv')

apreq :: (RenderMessage site FormMessage, 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 FormMessage, 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


mpopt :: (RenderMessage site FormMessage, 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 FormMessage, 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 FormMessage, 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