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

import Utils.Form

import Handler.Utils.Form.Types

import Handler.Utils.DateTime

import Import
import qualified Data.Char as Char
import qualified Data.Text as Text
import qualified Data.CaseInsensitive as CI

-- import Yesod.Core
import qualified Data.Text as T
-- import Yesod.Form.Types
import Yesod.Form.Functions (parseHelper)
import Yesod.Form.Bootstrap3

import Handler.Utils.Zip
import qualified Data.Conduit.List as C

import qualified Database.Esqueleto as E

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

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

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

import Data.Scientific (Scientific)
import Data.Ratio
import Text.Read (readMaybe)
import Data.Either (partitionEithers)

import Utils.Lens

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

import Data.Proxy

import qualified Text.Email.Validate as Email

----------------------------
-- Buttons (new version ) --
----------------------------
-- NOTE: ButtonSubmit is defined in Utils.Form !


data ButtonDelete = BtnDelete
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonDelete
instance Finite ButtonDelete

nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1

embedRenderMessage ''UniWorX ''ButtonDelete id
instance Button UniWorX ButtonDelete where
  btnClasses BtnDelete = [BCIsButton, BCDanger]

data ButtonSave = BtnSave
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonSave
instance Finite ButtonSave

-- | Save-Button as AForm
saveButton :: (Button (HandlerSite m) ButtonSave, MonadHandler m) => AForm m ()
saveButton = combinedButtonFieldF_ (Proxy @ButtonSave) ""



nullaryPathPiece ''ButtonSave $ camelToPathPiece' 1

embedRenderMessage ''UniWorX ''ButtonSave id
instance Button UniWorX ButtonSave where
  btnClasses BtnSave = [BCIsButton, BCPrimary]

data ButtonRegister = BtnRegister | BtnDeregister
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonRegister
instance Finite ButtonRegister

nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1

embedRenderMessage ''UniWorX ''ButtonRegister id
instance Button UniWorX ButtonRegister where
  btnClasses BtnRegister   = [BCIsButton, BCPrimary]
  btnClasses BtnDeregister = [BCIsButton, BCDanger]

data ButtonHijack = BtnHijack
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonHijack
instance Finite ButtonHijack

nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1

embedRenderMessage ''UniWorX ''ButtonHijack id
instance Button UniWorX ButtonHijack where
  btnClasses BtnHijack = [BCIsButton, BCDefault]

data ButtonSubmitDelete = BtnSubmit' | BtnDelete'
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)

instance Universe ButtonSubmitDelete
instance Finite ButtonSubmitDelete

embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'"
instance Button UniWorX ButtonSubmitDelete where
  btnClasses BtnSubmit' = [BCIsButton, BCPrimary]
  btnClasses BtnDelete' = [BCIsButton, BCDanger]

  btnValidate _ BtnSubmit' = True
  btnValidate _ BtnDelete' = False

nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"


-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
-- data LinkButton = LinkButton (Route UniWorX)
--   deriving (Enum, Eq, Ord, Bounded, Read, Show)
--
-- instance PathPiece LinkButton where
--     LinkButton route = ???

linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton lbl cls url = do
  url' <- toTextUrl url
  [whamlet|
    $newline never
    <a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
      ^{lbl}
  |]

--------------------------
-- Interactive fieldset --
--------------------------

multiAction :: forall action a.
               ( RenderMessage UniWorX action, PathPiece action, Ord action, Eq action )
            => Map action (AForm (HandlerT UniWorX IO) a)
            -> FieldSettings UniWorX
            -> Maybe action
            -> (Html -> MForm Handler (FormResult a, [FieldView UniWorX]))
multiAction acts fs@FieldSettings{..} defAction csrf = do
  mr <- getMessageRender

  let
    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
  (actionRes, actionView) <- mreq (selectField $ return options) fs defAction
  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts

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

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

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

multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
             => Map action (AForm (HandlerT UniWorX IO) a)
             -> FieldSettings UniWorX
             -> Maybe action
             -> AForm Handler a
multiActionA acts fSettings defAction = formToAForm $ multiAction acts fSettings defAction mempty

multiActionW :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
             => Map action (AForm Handler a)
             -> FieldSettings UniWorX
             -> Maybe action
             -> WForm Handler (FormResult a)
multiActionW acts fSettings defAction = aFormToWForm $ multiActionA acts fSettings defAction

multiActionM :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
             => Map action (AForm (HandlerT UniWorX IO) a)
             -> FieldSettings UniWorX
             -> Maybe action
             -> (Html -> MForm Handler (FormResult a, Widget))
multiActionM acts fSettings defAction = renderAForm FormStandard $ multiActionA acts fSettings defAction

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

-- | add some additional text immediately after the field widget; probably not a good idea to use
annotateField :: ToWidget (HandlerSite m) wgt => wgt -> Field m a -> Field m a
annotateField ann field@Field{fieldView=fvf} =
  let fvf' idt nmt atts ei bl =
        [whamlet|
          ^{fvf idt nmt atts ei bl}
          ^{ann}
        |]
  in field { fieldView=fvf'}

-- ciField moved to Utils.Form

routeField :: ( Monad m
              , HandlerSite m ~ UniWorX
              ) => Field m (Route UniWorX)
routeField = checkMMap (return . maybe (Left MsgInvalidRoute) Right . fromPathPiece) toPathPiece textField

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

natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = checkBool (>= 0) msg intField

natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") intField

natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
natIntField = natField

posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = checkBool (> 0) (T.append  d " muss eine positive Zahl sein.") intField

-- | Field to request integral number > 'm'
minIntField :: (Monad m, Integral i, Show i, RenderMessage (HandlerSite m) FormMessage) => i -> Text -> Field m i
minIntField m d = checkBool (> m) (T.concat [d," muss größer als ", T.pack $ show m, " sein."]) intField

pointsField :: (Monad m, HandlerSite m ~ UniWorX) => Field m Points --TODO allow fractions
pointsField = checkBool (>= 0) MsgPointsNotPositive Field{..}
  where
    fieldEnctype = UrlEncoded
    fieldView theId name attrs val isReq
      = [whamlet|
          $newline never
          <input id=#{theId} name=#{name} *{attrs} type=number step="0.01" :isReq:required value=#{either id tshow val}>
        |]
    fieldParse = parseHelper $ \t -> do
      sci <- maybe (Left $ MsgInvalidNumber t) Right (readMaybe $ unpack t :: Maybe Scientific)
      return . fromRational $ round (sci * 100) % 100

pointsFieldMax :: (Monad m, HandlerSite m ~ UniWorX) => Maybe Points -> Field m Points --TODO allow fractions
pointsFieldMax Nothing = pointsField
pointsFieldMax (Just maxp) = checkBool (<= maxp) (MsgPointsTooHigh maxp) pointsField

matriculationField :: Monad m => RenderMessage (HandlerSite m) FormMessage => Field m Text
matriculationField = textField -- no restrictions, since not everyone has a matriculation and pupils need special tags here

termsActiveField :: Field Handler TermId
termsActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName

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

termsSetField :: [TermId] -> Field Handler TermId
termsSetField tids = selectField $ optionsPersistKey [TermName <-. (unTermKey <$> tids)] [Desc TermStart] termName
-- termsSetField tids = selectFieldList [(unTermKey t, t)| t <- tids ]

termsActiveOrSetField :: [TermId] -> Field Handler TermId
termsActiveOrSetField tids = selectField $ optionsPersistKey ([TermActive ==.True] ||. [TermName <-. terms]) [Desc TermStart] termName
  where terms = map unTermKey tids
-- termActiveOld :: Field Handler TermIdentifier
-- termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName

termNewField :: Field Handler TermIdentifier
termNewField = checkMMap (return.termFromText) termToText textField

schoolField :: Field Handler SchoolId
schoolField = selectField $ optionsPersistKey [] [Asc SchoolName] schoolName

schoolFieldEnt :: Field Handler (Entity School)
schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName

schoolFieldFor :: [SchoolId] -> Field Handler SchoolId
schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName

-- | Select one of the user's primary active courses, or from a given list of StudyFeatures (regardless of user)
studyFeaturesPrimaryFieldFor :: [StudyFeaturesId] -> Maybe UserId -> Field Handler (Maybe StudyFeaturesId)
studyFeaturesPrimaryFieldFor oldFeatures mbuid = selectField $ do
    -- we need a join, so we cannot just use optionsPersistCryptoId
    rawOptions <- runDB $ E.select $ E.from $ \(feature `E.InnerJoin` degree `E.InnerJoin` field) -> do
        E.on     $   feature E.^. StudyFeaturesField  E.==. field  E.^. StudyTermsId
        E.on     $   feature E.^. StudyFeaturesDegree E.==. degree E.^. StudyDegreeId
        E.where_ $ ((feature E.^. StudyFeaturesId) `E.in_` E.valList oldFeatures)
              E.||. isPrimaryActiveUserStudyFeature feature
        return (feature E.^. StudyFeaturesId, degree, field)
    MsgRenderer mr <- getMsgRenderer
    mkOptionList . nonEmptyOptions (mr MsgNoPrimaryStudyField) <$> mapM (procOptions mr) rawOptions
  where
    isPrimaryActiveUserStudyFeature feature = case mbuid of
      Nothing    -> E.val False
      (Just uid) -> feature E.^. StudyFeaturesUser  E.==. E.val uid
              E.&&. feature E.^. StudyFeaturesValid E.==. E.val True
              E.&&. feature E.^. StudyFeaturesType  E.==. E.val FieldPrimary

    procOptions :: (StudyDegreeTerm -> Text) -> (E.Value StudyFeaturesId, Entity StudyDegree, Entity StudyTerms) -> Handler (Option (Maybe StudyFeaturesId))
    procOptions mr (E.Value sfid, Entity _dgid sdegree, Entity _stid sterm) = do
      cfid <- encrypt sfid
      return Option
        { optionDisplay = mr $ StudyDegreeTerm sdegree sterm
        , optionInternalValue = Just sfid
        , optionExternalValue = toPathPiece (cfid :: CryptoID UUID StudyFeaturesId)
        }

    nonEmptyOptions :: Text -> [Option (Maybe StudyFeaturesId)] -> [Option (Maybe StudyFeaturesId)]
    nonEmptyOptions emptyOpt opts
      | null opts = [ Option
          { optionDisplay       = emptyOpt
          , optionInternalValue = Nothing
          , optionExternalValue = "NoPrimaryStudyField"
          } ]
      | otherwise = opts


uploadModeField :: Field Handler UploadMode
uploadModeField = selectField optionsFinite

submissionModeForm :: Maybe SubmissionMode -> AForm Handler SubmissionMode
submissionModeForm prev = multiActionA actions (fslI MsgSheetSubmissionMode) $ classifySubmissionMode <$> prev
  where
    uploadModeForm = apreq uploadModeField (fslI MsgSheetUploadMode) (preview (_Just . _submissionModeUser . _Just) $ prev)

    actions :: Map SubmissionModeDescr (AForm Handler SubmissionMode)
    actions = Map.fromList
      [ ( SubmissionModeNone
        , pure $ SubmissionMode False Nothing
        )
      , ( SubmissionModeCorrector
        , pure $ SubmissionMode True  Nothing
        )
      , ( SubmissionModeUser
        , SubmissionMode False . Just <$> uploadModeForm
        )
      , ( SubmissionModeBoth
        , SubmissionMode True  . Just <$> uploadModeForm
        )
      ]

pseudonymWordField :: Field Handler PseudonymWord
pseudonymWordField = checkMMap doCheck CI.original $ textField & addDatalist (return $ map CI.original pseudonymWordlist)
  where
    doCheck (CI.mk -> w)
      | Just w' <- find (== w) pseudonymWordlist
      = return $ Right w'
      | otherwise
      = return . Left $ MsgUnknownPseudonymWord (CI.original w)

zipFileField :: Bool -- ^ Unpack zips?
             -> Field Handler (Source Handler File)
zipFileField doUnpack = Field{..}
  where
    fieldEnctype = Multipart
    fieldParse _ files
      | [f] <- files = return . Right . Just $ bool (yieldM . acceptFile) sourceFiles doUnpack f
      | null files   = return $ Right Nothing
      | otherwise    = return . Left $ SomeMessage MsgOnlyUploadOneFile
    fieldView fieldId fieldName attrs _ req =
      [whamlet|
        $newline never
        <input type=file ##{fieldId} *{attrs} name=#{fieldName} :req:required>
      |]

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

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

instance Universe SheetGrading'
instance Finite SheetGrading'

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


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

instance Universe SheetType'
instance Finite SheetType'

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


data SheetGroup' = NoGroups' | Arbitrary' | RegisteredGroups'
  deriving (Eq, Ord, Read, Show, Enum, Bounded)

instance Universe SheetGroup'
instance Finite SheetGroup'

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

sheetGradingAFormReq :: FieldSettings UniWorX -> Maybe SheetGrading -> AForm Handler SheetGrading
sheetGradingAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
  where
    selOptions = Map.fromList
      [ ( Points',     Points     <$> maxPointsReq )
      , ( PassPoints', PassPoints <$> maxPointsReq <*> passPointsReq )
      , ( PassBinary', pure PassBinary)
      ]
    classify' :: SheetGrading -> SheetGrading'
    classify' = \case
      Points     {} -> Points'
      PassPoints {} -> PassPoints'
      PassBinary {} -> PassBinary'

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


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

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

sheetGroupAFormReq :: FieldSettings UniWorX -> Maybe SheetGroup -> AForm Handler SheetGroup
sheetGroupAFormReq fs template = multiActionA selOptions fs (classify' <$> template)
  where
    selOptions = Map.fromList
      [ ( Arbitrary', Arbitrary
          <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
        )
      , ( RegisteredGroups', pure RegisteredGroups )
      , ( NoGroups', pure NoGroups )
      ]
    classify' :: SheetGroup -> SheetGroup'
    classify' = \case
      Arbitrary _ -> Arbitrary'
      RegisteredGroups -> RegisteredGroups'
      NoGroups -> NoGroups'


{-
dayTimeField :: FieldSettings UniWorX -> Maybe UTCTime -> Form Handler UTCTime
dayTimeField fs mutc = do
    let (mbDay,mbTime) = case mutcs of
          Nothing    -> return (Nothing,Nothing)
          (Just utc) ->

    (dayResult, dayView) <- mreq dayField fs

    (result, view) <- (,) <$> dayField <*> timeField
  where
    (mbDay,mbTime)
      | (Just utc) <- mutc =
          let lt = utcToLocalTime ??? utcs
          in  (Just $ localDay lt, Just $ localTimeOfDay lt)
      | otherwise = (Nothing,Nothing)
-}

localTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m LocalTime
localTimeField = Field
    { fieldParse = parseHelperGen readTime
    , fieldView = \theId name attrs val isReq -> do
        val' <- either id id <$> traverse (formatTime' fieldTimeFormat) val
        [whamlet|
          $newline never
          <input id="#{theId}" name="#{name}" *{attrs} type="datetime-local" :isReq:required value="#{val'}">
        |]
    , fieldEnctype = UrlEncoded
    }
  where
    fieldTimeFormat :: String
    --fieldTimeFormat = "%e.%m.%y %k:%M"
    fieldTimeFormat = "%Y-%m-%dT%H:%M"

    -- `defaultTimeLocale` is okay here, since `fieldTimeFormat` does not contain any
    readTime :: Text -> Either UniWorXMessage LocalTime
    readTime t =
      case parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
        Just lTime -> Right lTime
        Nothing    -> Left MsgInvalidDateTimeFormat

utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
utcTimeField = checkMMap (return . localTimeToUTC') utcToLocalTime localTimeField
  where
    localTimeToUTC' l = case localTimeToUTC l of
      LTUUnique{_ltuResult} -> Right _ltuResult
      LTUNone{}             -> Left MsgIllDefinedUTCTime
      LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
      

langField :: Bool -- ^ Only allow values from `appLanguages`
          -> Field (HandlerT UniWorX IO) Lang
langField False = checkBool (all ((&&) <$> not . null <*> T.all Char.isAlpha) . T.splitOn "-") MsgInvalidLangFormat $ textField & addDatalist (return $ toList appLanguages)
langField True = selectField . optionsPairs . map (MsgLanguage &&& id) $ toList appLanguages

jsonField :: ( ToJSON a, FromJSON a
             , MonadHandler m
             , RenderMessage (HandlerSite m) UniWorXMessage
             , RenderMessage (HandlerSite m) FormMessage
             )
          => Bool {-^ Hidden? -}
          -> Field m a
jsonField hide = Field{..}
  where
    inputType :: Text
    inputType
      | hide      = "hidden"
      | otherwise = "text"
    fieldParse [v] [] = return . bimap (SomeMessage . MsgJSONFieldDecodeFailure) Just . eitherDecodeStrict' $ encodeUtf8 v
    fieldParse [] [] = return $ Right Nothing
    fieldParse _ _ = return . Left $ SomeMessage MsgValueRequired
    fieldView theId name attrs val isReq = liftWidgetT [whamlet|
      <input id=#{theId} name=#{name} *{attrs} type=#{inputType} :isReq:required value=#{either fromStrict encodeToLazyText val}>
    |]
    fieldEnctype = UrlEncoded

secretJsonField :: ( ToJSON a, FromJSON a
                   , MonadHandler m
                   , HandlerSite m ~ UniWorX
                   )
                => Field m a
secretJsonField = Field{..}
  where
    fieldParse [v] [] = bimap (\_ -> SomeMessage MsgSecretJSONFieldDecryptFailure) 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
      [whamlet|
        <input id=#{theId} name=#{name} *{attrs} type=hidden value=#{either id id val'}>
      |]
    fieldEnctype = UrlEncoded

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




funcForm :: forall k v m.
            ( Finite k, Ord k
            , MonadHandler m
            , HandlerSite m ~ UniWorX
            )
         => (k -> AForm m v) -> FieldSettings UniWorX -> Bool -> AForm m (k -> v)
funcForm mkForm FieldSettings{fsName = _, fsAttrs = _, ..} isRequired = formToAForm $ funcFieldView =<< renderAForm FormStandard funcForm' mempty
  where
    funcForm' :: AForm m (k -> v)
    funcForm' = fmap (!) . sequenceA . Map.fromSet mkForm $ Set.fromList universeF
    funcFieldView :: (FormResult (k -> v), Widget) -> MForm m (FormResult (k -> v), [FieldView UniWorX])
    funcFieldView (res, fvInput) = do
      mr <- getMessageRender
      let fvLabel = toHtml $ mr fsLabel
          fvTooltip = fmap (toHtml . mr) fsTooltip
          fvRequired = isRequired
          fvErrors
            | FormFailure (err:_) <- res = Just $ toHtml err
            | otherwise = Nothing
      fvId <- maybe newIdent return fsId
      return (res, pure FieldView{..})
    -- areq nsField (fslI MsgNotificationSettings) (stgNotficationSettings <$> template)




fsm :: RenderMessage UniWorX msg => msg -> FieldSettings UniWorX -- DEPRECATED
fsm = bfs -- TODO: get rid of Bootstrap

fsb :: Text -> FieldSettings site -- DEPRECATED
fsb = bfs -- Just to avoid annoying Ambiguous Type Errors

fsUniq :: (Text -> Text) -> Text -> FieldSettings site
fsUniq mkUnique seed = "" { fsName = Just $ mkUnique seed }


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

formResultModal :: (MonadHandler m, RedirectUrl (HandlerSite m) route) => FormResult a -> route -> (a -> WriterT [Message] m ()) -> m ()
formResultModal res finalDest handler = maybeT_ $ do
  messages <- case res of
    FormMissing -> mzero
    FormFailure errs -> mapM_ (addMessage Error . toHtml) errs >> mzero
    FormSuccess val -> lift . execWriterT $ handler val

  isModal <- hasCustomHeader HeaderIsModal
  if
    | isModal   -> sendResponse $ toJSON messages
    | otherwise -> do
        forM_ messages $ \Message{..} -> addMessage messageStatus messageContent
        redirect finalDest

multiUserField :: forall m.
                  ( MonadHandler m
                  , HandlerSite m ~ UniWorX
                  )
               => Bool -- ^ Only resolve suggested users?
               -> Maybe (E.SqlQuery (E.SqlExpr (Entity User))) -- ^ Suggested users
               -> Field m (Set (Either UserEmail UserId))
multiUserField onlySuggested suggestions = Field{..}
  where
    lookupExpr
      | onlySuggested = suggestions
      | otherwise     = Just $ E.from return
    
    fieldEnctype = UrlEncoded
    fieldView theId name attrs val isReq = do
      val' <- case val of
        Left t -> return t
        Right vs -> Text.intercalate ", " . map CI.original <$> do
          let (emails, uids) = partitionEithers $ Set.toList vs
          rEmails <- case lookupExpr of
            Nothing -> return []
            Just lookupExpr' -> fmap concat . forM uids $ \uid -> do
              dbRes <- liftHandlerT . runDB . E.select $ do
                user <- lookupExpr'
                E.where_ $ user E.^. UserId E.==. E.val uid
                return $ user E.^. UserEmail
              case dbRes of
                [E.Value email] -> return [email]
                _other -> return []
          return $ emails ++ rEmails

      datalistId <- maybe (return $ error "Not to be used") (const newIdent) suggestions
      
      [whamlet|
        $newline never
        <input id="#{theId}" name="#{name}" *{attrs} type="email" multiple :isReq:required="" value="#{val'}" :isJust suggestions:list=#{datalistId}>
      |]

      whenIsJust suggestions $ \suggestions' -> do
        suggestedEmails <- fmap (Set.fromList . map E.unValue) . liftHandlerT . runDB . E.select $ do
          user <- suggestions'
          return $ user E.^. UserEmail
        [whamlet|
          $newline never
          <datalist id=#{datalistId}>
            $forall email <- suggestedEmails
              <option value=#{email}>
        |]
    fieldParse (all Text.null -> True) _ = return $ Right Nothing 
    fieldParse ts _ = runExceptT . fmap Just $ do
      let ts' = concatMap (Text.splitOn ",") ts
      emails <- forM ts' $ \t -> either (\errStr -> throwE . SomeMessage $ MsgInvalidEmail [st|#{t} (#{errStr})|]) (return . decodeUtf8 . Email.toByteString) $ Email.validate (encodeUtf8 t)
      fmap Set.fromList . forM emails $ \(CI.mk -> email) -> case lookupExpr of
        Nothing -> return $ Left email
        Just lookupExpr' -> do
            dbRes <- liftHandlerT . runDB . E.select $ do
              user <- lookupExpr'
              E.where_ $ user E.^. UserEmail E.==. E.val email
              return $ user E.^. UserId
            case dbRes of
              [] -> return $ Left email
              [E.Value uid] -> return $ Right uid
              _other -> fail "Ambiguous e-mail addr"