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 hiding (cons)
import qualified Data.Char as Char

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.Except (runExceptT)
import Control.Monad.Writer.Class

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

import Utils.Lens

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


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

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 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}
  |]


-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
buttonForm :: (Button UniWorX a, Finite a) => Form a
buttonForm csrf = do
   (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
   return (res, [whamlet|
       $newline never
       #{csrf}
       $forall bView <- fViews
         ^{fvInput bView}
     |])


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

-- ciField moved to Utils.Form

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

natFieldI :: (Monad m, Integral i, RenderMessage (HandlerSite m) msg, RenderMessage (HandlerSite m) FormMessage) => msg -> Field m i
natFieldI msg = 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

submissionModeField :: Field Handler SheetSubmissionMode
submissionModeField = selectField optionsFinite

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 fs selOptions (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 fs selOptions (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 FieldSettings{..} template = formToAForm $ do
  let
    selOptions = Map.fromList
      [ ( Arbitrary', Arbitrary
          <$> apreq (natField "Gruppengröße") (fslI MsgSheetGroupMaxGroupsize & noValidate) (preview _maxParticipants =<< template)
        )
      , ( RegisteredGroups', pure RegisteredGroups )
      , ( NoGroups', pure NoGroups )
      ]
  (res, selView) <- multiAction selOptions (classify' <$> template)

  fvId <- maybe newIdent return fsId
  MsgRenderer mr <- getMsgRenderer

  return (res,
    [ FieldView
      { fvLabel = toHtml $ mr fsLabel
      , fvTooltip = toHtml . mr <$> fsTooltip
      , fvId
      , fvInput = selView
      , fvErrors = case res of
          FormFailure [e] -> Just $ toHtml e
          _ -> Nothing
      , fvRequired = True
      }
    ])

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


utcTimeField :: (MonadHandler m, HandlerSite m ~ UniWorX) => Field m UTCTime
-- StackOverflow: dayToUTC <$> (areq (jqueryDayField def {...}) settings Nothing)
-- Browser returns LocalTime
utcTimeField = 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 UTCTime
    readTime t =
      case localTimeToUTC <$> parseTimeM True defaultTimeLocale fieldTimeFormat (T.unpack t) of
        Just LTUUnique{_ltuResult} -> Right _ltuResult
        Just LTUNone{}             -> Left MsgIllDefinedUTCTime
        Just LTUAmbiguous{}        -> Left MsgAmbiguousUTCTime
        Nothing                    -> Left MsgInvalidDateTimeFormat

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

multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
            => Map action (AForm (HandlerT UniWorX IO) a)
            -> Maybe action
            -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
multiAction acts defAction = do
  mr <- getMessageRender
  let
    options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
  (actionRes, actionView) <- mreq (selectField $ return options) "" defAction
  results <- mapM (fmap (over _2 ($ [])) . aFormToForm) acts
  let mToWidget (_, []) = return Nothing
      mToWidget aForm = Just . snd <$> renderAForm FormStandard (formToAForm $ return aForm) mempty
  widgets <- mapM mToWidget results
  let actionWidgets = Map.foldrWithKey accWidget [] widgets
      accWidget _act Nothing = id
      accWidget act (Just w) = cons $(widgetFile "widgets/multi-action/multi-action")
      actionResults = Map.map fst results
  return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multi-action/multi-action-collect"))

multiActionA :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
            => FieldSettings UniWorX
            -> Map action (AForm (HandlerT UniWorX IO) a)
            -> Maybe action
            -> AForm (HandlerT UniWorX IO) a
multiActionA FieldSettings{..} acts defAction = formToAForm $ do
  (res, selView) <- multiAction acts defAction

  fvId <- maybe newIdent return fsId
  MsgRenderer mr <- getMsgRenderer

  return (res,
    [ FieldView
      { fvLabel = toHtml $ mr fsLabel
      , fvTooltip = toHtml . mr <$> fsTooltip
      , fvId
      , fvInput = selView
      , fvErrors = case res of
          FormFailure [e] -> Just $ toHtml e
          _ -> Nothing
      , fvRequired = True
      }
    ])

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