fradrive/src/Utils/Form.hs

{-# OPTIONS_GHC -fno-warn-deprecations #-}

module Utils.Form where

import ClassyPrelude.Yesod hiding (addMessage, cons, Proxy(..), identifyForm)
import Settings

import Utils.Parameters

-- import Text.Blaze (toMarkup) -- for debugging
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(..))

import Data.List ((!!))

import Control.Lens

import Web.PathPieces

import Data.UUID

import Utils.Message
import Utils.PathPiece

import Data.Proxy

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

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

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

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

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

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


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

addAttr :: Text -> Text -> FieldSettings site -> FieldSettings site
addAttr attr valu fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
  where
    newAttrs :: [(Text,Text)] -> [(Text,Text)]
    newAttrs [] = [(attr, valu)]
    newAttrs (p@(a,v) : t)
      | attr==a   = (a, T.append valu $ cons ' ' v) : t
      | otherwise = p : newAttrs t

addAttrs :: Text -> [Text] -> FieldSettings site -> FieldSettings site
addAttrs attr valus fs = fs { fsAttrs = newAttrs $ fsAttrs fs }
  where
    newAttrs :: [(Text, Text)] -> [(Text, Text)]
    newAttrs [] = [(attr, T.intercalate " " valus)]
    newAttrs (p@(a,v) : t)
      | attr==a   = ( a, T.intercalate " " $ v : valus ) : t
      | otherwise = p : newAttrs t

addClass :: Text -> FieldSettings site -> FieldSettings site
addClass = addAttr "class"

addClasses :: [Text] -> FieldSettings site -> FieldSettings site
addClasses = addAttrs "class"

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

addNameClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addNameClass gName gClass fs = fs { fsName = Just gName, fsAttrs = ("class",gClass) : fsAttrs fs }

addIdClass :: Text -> Text -> FieldSettings site -> FieldSettings site
addIdClass gId gClass fs = fs { fsId = Just gId, fsAttrs = ("class",gClass) : fsAttrs fs }


setClass :: FieldSettings site -> Text -> FieldSettings site -- deprecated
setClass fs c = fs { fsAttrs = ("class",c) : fsAttrs fs }

setNameClass :: FieldSettings site -> Text -> Text -> FieldSettings site -- deprecated
setNameClass fs gName gClass = fs { fsName = Just gName
                                  , fsAttrs = ("class",gClass) : fsAttrs fs
                                  }

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

addDatalist :: (PathPiece (Element vals), MonoFoldable vals, Monad m) => WidgetT (HandlerSite m) IO vals -> Field m a -> Field m a
addDatalist mValues field = field
  { fieldView = \fId fName fAttrs fRes fReq -> do
      listId <- newIdent
      values <- map toPathPiece . otoList <$> mValues
      fieldView field fId fName (("list", listId) : fAttrs) fRes fReq
      [whamlet|
        $newline never
        <datalist ##{listId}>
          $forall value <- values
            <option value=#{value}>
      |]
  }

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

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

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

addAutosubmit :: FieldSettings site -> FieldSettings site
addAutosubmit = addAttr "data-autosubmit" ""

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

data FormIdentifier
  = FIDcourse
  | FIDcourseRegister
  | FIDsheet
  | FIDsubmission
  | FIDsettings
  | FIDcorrectors
  | FIDcorrectorTable
  | FIDcorrection
  | FIDcorrectionsUpload
  | FIDcorrectionUpload
  | FIDSystemMessageAdd
  | FIDSystemMessageTable
  | FIDSystemMessageModify
  | FIDSystemMessageModifyTranslation UUID
  | FIDSystemMessageAddTranslation
  | FIDDBTableFilter
  | FIDDBTablePagesize
  | FIDDBTable
  | FIDDelete
  | FIDCourseRegister
  | FIDuserRights
  | FIDbuttonForm
  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)

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

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

autosubmitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosubmit

-- | just Html for a Submit-Button
submitButtonView :: forall site . Button site ButtonSubmit => WidgetT site IO ()
submitButtonView = do
  let bField :: Field (HandlerT site IO) ButtonSubmit
      bField = buttonField BtnSubmit
  btnId <- newIdent
  fieldView bField btnId "" mempty (Right BtnSubmit) False


-------------------
-- 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 (CI.mk . fromList . unpack) (pack . toList . CI.original) textField

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
                , Show 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{..} <- liftHandlerT 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{..} <- liftHandlerT 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")

optionsFinite :: ( MonadHandler m
                 , Finite a
                 , RenderMessage site a
                 , HandlerSite m ~ site
                 , PathPiece a
                 )
              => m (OptionList a)
optionsFinite = do
  mr <- getMessageRender
  let
    mkOption a = Option
      { optionDisplay       = mr a
      , optionInternalValue = a
      , optionExternalValue = toPathPiece a
      }
  return . mkOptionList $ mkOption <$> universeF

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



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


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 form = do
  res <- runInputGetResult form
  return $ case res of
    FormSuccess suc -> Just suc
    _other -> Nothing
runInputPostMaybe form = do
  res <- runInputPostResult form
  return $ case res of
    FormSuccess suc -> Just suc
    _other -> Nothing
runInputMaybe form = runMaybeT $ MaybeT (runInputPostMaybe form) <|> MaybeT (runInputGetMaybe form)

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

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

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

apreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> AForm m a
-- ^ Pseudo required
apreq f fs mx = formToAForm $ do
  mr <- getMessageRender
  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (pure . (\fv -> fv { fvRequired = True } )) <$> mopt f fs (Just <$> mx)

mpreq :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
      => Field m a -> FieldSettings site -> Maybe a -> MForm m (FormResult a, FieldView site)
mpreq f fs mx = do
  mr <- getMessageRender
  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> 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 $ do
  mr <- getMessageRender
  over _1 (maybe (FormFailure [mr MsgValueRequired]) return =<<) . over _2 (\fv -> fv { fvRequired = True } ) <$> mopt f fs (Just <$> mx)