fradrive-old/src/Handler/Admin.hs

module Handler.Admin where

import Import
import Handler.Utils
import Handler.Utils.Form.MassInput
import Jobs

import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)

import Control.Monad.Trans.Except

-- import Data.Time
-- import qualified Data.Text as T
-- import Data.Function ((&))
-- import Yesod.Form.Bootstrap3

import Database.Persist.Sql (fromSqlKey)

import qualified Data.Text as Text
import Data.Char (isDigit)

import qualified Data.Map as Map
import qualified Data.Set as Set

-- import Colonnade hiding (fromMaybe)
-- import Yesod.Colonnade

-- import qualified Data.UUID.Cryptographic as UUID

import Control.Monad.Trans.Writer (mapWriterT)

-- BEGIN - Buttons needed only here
data ButtonCreate = CreateMath | CreateInf  -- Dummy for Example
  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCreate
instance Finite ButtonCreate

nullaryPathPiece ''ButtonCreate camelToPathPiece

instance Button UniWorX ButtonCreate where
  btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
  btnLabel CreateInf  = "Informatik"

  btnClasses CreateMath = [BCIsButton, BCInfo]
  btnClasses CreateInf  = [BCIsButton, BCPrimary]
-- END Button needed here

emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
emailTestForm = (,)
            <$> areq emailField (fslI MsgMailTestFormEmail) Nothing
            <*> ( MailContext
                  <$> (MailLanguages <$> areq (reorderField appLanguagesOpts) (fslI MsgMailTestFormLanguages) Nothing)
                  <*> (toMailDateTimeFormat
                        <$> areq (selectField $ dateTimeFormatOptions SelFormatDateTime) (fslI MsgDateTimeFormat) Nothing
                        <*> areq (selectField $ dateTimeFormatOptions SelFormatDate) (fslI MsgDateFormat) Nothing
                        <*> areq (selectField $ dateTimeFormatOptions SelFormatTime) (fslI MsgTimeFormat) Nothing
                      )
                )
            <*  submitButton
  where
    toMailDateTimeFormat dt d t = \case
      SelFormatDateTime -> dt
      SelFormatDate -> d
      SelFormatTime -> t

makeDemoForm :: Int -> Form (Int,Bool,Double)
makeDemoForm n = identifyForm ("adminTestForm" :: Text) $ \html -> do
    (result, widget) <- flip (renderAForm FormStandard) html $ (,,)
        <$> areq (minIntField n "Zahl") (fromString $ "Ganzzahl > " ++ show n) Nothing
        <*  aformSection MsgFormBehaviour
        <*> areq checkBoxField "Muss nächste Zahl größer sein?" (Just True)
        <*> areq doubleField "Fliesskommazahl" Nothing
        <*  submitButton
    return $ case result of
      FormSuccess fsres
        | errorMsgs <- validateResult fsres
        , not $ null errorMsgs -> (FormFailure errorMsgs, widget)
      _otherwise -> (result, widget)
  where
    validateResult :: (Int,Bool,Double) -> [Text]
    validateResult (i,True,d) | fromIntegral i >= d = [tshow d <> " ist nicht größer als " <> tshow i, "Zweite Fehlermeldung", "Dritte Fehlermeldung"]
    validateResult _other = []


getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
getAdminTestR = postAdminTestR
postAdminTestR = do
  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm ("buttons" :: Text) (buttonForm :: Form ButtonCreate)
  case btnResult of
    (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
    (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"
    FormMissing -> return ()
    _other -> addMessage Warning "KEIN Knopf erkannt"

  ((emailResult, emailWidget), emailEnctype) <- runFormPost . identifyForm ("email" :: Text) $ renderAForm FormStandard emailTestForm
  formResultModal emailResult AdminTestR $ \(email, ls) -> do
    jId <- mapWriterT runDB $ do
      jId <- queueJob $ JobSendTestEmail email ls
      tell . pure $ Message Success [shamlet|Email-test gestartet (Job ##{tshow (fromSqlKey jId)})|]
      return jId
    writeJobCtl $ JobCtlPerform jId

  let emailWidget' = [whamlet|
        <form method=post action=@{AdminTestR} enctype=#{emailEnctype} data-ajax-submit>
          ^{emailWidget}
      |]


  let demoFormAction (_i,_b,_d) = addMessage Info "All ok."
  ((demoResult, formWidget),formEnctype) <- runFormPost $ makeDemoForm 7
  formResult demoResult demoFormAction
  let actionUrl = AdminTestR
  let showDemoResult = [whamlet|
          $maybe (i,b,d) <- formResult' demoResult
            Received values:
              <ul>
                <li>#{show i}
                <li>#{show b}
                <li>#{show d}
          $nothing
            No form values received, due to #
            $# Using formResult' above means that we usually to not distinguish the following two cases here, sind formResult does this already:
            $case demoResult
              $of FormSuccess _
                $# Already dealt with above, to showecase usage of formResult' as normally done.
                success, which should not happen here.
              $of FormMissing
                Form data missing, probably empty.
              $of FormFailure msgs
                <ul>
                  $forall m <- msgs
                    <li>#{m}
        |]

  let
    -- | Make a form for adding a point/line/plane/hyperplane/... (in this case: cell)
    --
    -- This /needs/ to replace all occurances of @mreq@ with @mpreq@ (no fields should be /actually/ required)
    mkAddForm :: ListPosition -- ^ Approximate position of the add-widget
              -> Natural -- ^ Dimension Index, outermost dimension ist 0 i.e. if dimension is 3 hyperplane-adders get passed 0, planes get passed 1, lines get 2, and points get 3
              -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
              -> FieldView UniWorX -- ^ Submit-Button for this add-widget
              -> Maybe (Form (ListLength -> (ListPosition, Int))) -- ^ Nothing iff adding further cells in this position/dimension makes no sense; returns callback to determine index of new cell and data needed to initialize cell
    mkAddForm 0 0 nudge submitBtn = Just $ \csrf -> do
      (addRes, addView) <- mpreq textField ("" & addName (nudge "text")) Nothing
      let addRes' = fromMaybe 0 . readMay . Text.filter isDigit <$> addRes
      return ((\dat l -> (fromIntegral l, dat)) <$> addRes', toWidget csrf >> fvInput addView >> fvInput submitBtn)
    mkAddForm _pos _dim _ _ = error "Dimension and Position is always 0 for our 1-dimensional form"
    -- | Make a single massInput-Cell
    --
    -- This /needs/ to use @nudge@ and deterministic field naming (this allows for correct value-shifting when cells are deleted)
    mkCellForm :: ListPosition -- ^ Position of this cell
               -> Int -- ^ Data needed to initialize the cell (see return of @mkAddForm@)
               -> Maybe Int -- ^ Initial cell result from Argument to `massInput`
               -> (Text -> Text) -- ^ Nudge deterministic field ids so they're unique
               -> Form Int
    mkCellForm _pos initial previous nudge csrf = do
      (intRes, intView) <- mreq intField ("" & addName (nudge "int")) $ previous <|> Just initial
      return (intRes, toWidget csrf >> fvInput intView)
    -- | How does the shape (`ListLength`) change if a certain cell is deleted?
    deleteCell :: ListLength -- ^ Current shape
               -> ListPosition -- ^ Coordinate to delete
               -> MaybeT (MForm (HandlerT UniWorX IO)) (Map ListPosition ListPosition) -- ^ Monadically compute a set of new positions and their associated old positions
    deleteCell l pos
      | l >= 2 = return . Map.fromSet (\pos' -> bool pos' (succ pos') $ pos' >= pos) $ Set.fromList [0..fromIntegral (l - 2)]
      | otherwise = return Map.empty
    -- | Make a decision on whether an add widget should be allowed to further cells, given the current @liveliness@ (i.e. before performing the addition)
    allowAdd :: ListPosition -> Natural -> ListLength -> Bool
    allowAdd _ _ l = l < 7
    
  ((miResult, (fvInput -> miForm)), miEnc) <- runFormPost . identifyForm ("massinput" :: Text) $ massInput (MassInput mkAddForm mkCellForm deleteCell allowAdd) "" True Nothing


  let locallyDefinedPageHeading = [whamlet|Admin TestPage for Uni2work|]
  siteLayout locallyDefinedPageHeading $ do
  -- defaultLayout $ do
    setTitle "Uni2work Admin Testpage"
    $(widgetFile "adminTest")

    [whamlet|<h2>Formular Demonstration|]
    $(widgetFile "formPage")
    showDemoResult

    [whamlet|
      <h2>Mass-Input
      <form enctype=#{miEnc} method=POST>
        ^{miForm}
        ^{submitButtonView}
      $case miResult
        $of FormMissing
        $of FormFailure errs
          <ul>
            $forall err <- errs
              <li>#{err}
        $of FormSuccess res
          <p style="white-space:pre-wrap; font-family:monospace;">
            #{tshow res}
    |]


getAdminErrMsgR, postAdminErrMsgR :: Handler Html
getAdminErrMsgR = postAdminErrMsgR
postAdminErrMsgR = do
  ((ctResult, ctView), ctEncoding) <- runFormPost . renderAForm FormStandard $
        (unTextarea <$> areq textareaField (fslpI MsgErrMsgCiphertext "Ciphertext") Nothing)
    <*  submitButton

  plaintext <- formResultMaybe ctResult $ exceptT (\err -> Nothing <$ addMessageI Error err) (return . Just) . (encodedSecretBoxOpen :: Text -> ExceptT EncodedSecretBoxException Handler Value)

  defaultLayout
    [whamlet|
      $maybe t <- plaintext
        <pre style="white-space:pre-wrap; font-family:monospace">
          #{encodePrettyToTextBuilder t}

      <form action=@{AdminErrMsgR} method=post enctype=#{ctEncoding}>
        ^{ctView}
    |]