<commit_before>{-# LANGUAGE ScopedTypeVariables, DeriveGeneric, LambdaCase, OverloadedStrings, RecordWildCards, RecursiveDo, TupleSections #-}

module Config where

import GHCJS.DOM.HTMLInputElement

import Reflex.Dom

import Data.Aeson as A
import Data.Aeson.Types as A
import GHC.Generics
import Control.Applicative
import Data.List
import Data.Function
import Data.Maybe
import Data.Bifunctor
import Data.Monoid
import qualified Data.Text as T
import Data.Map (Map)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.Ord

import Common

-- TODO stop copy-pasting this between client & server

data PluginConfig = PluginConfig
    {
        cfgPluginName :: String,
        cfgPluginConfig :: [ConfigDataInfo]
    } deriving (Generic, Show, Eq)
instance FromJSON PluginConfig

data ConfigDataInfo = ConfigDataInfo
    {
        memberName :: String,
        memberType :: String
    } deriving (Eq, Show, Generic)
instance FromJSON ConfigDataInfo

data ConfigItem = ConfigItem
    {
        configItemName :: String,
        providerName :: String,
        configuration :: A.Object
    } deriving (Eq, Show, Generic)
instance FromJSON ConfigItem
instance ToJSON ConfigItem

data FetchedData = FetchedData
    {
        fetchedConfigDesc :: [PluginConfig],
        fetchedConfigVal  :: [ConfigItem]
    } deriving Show

makeSimpleXhr :: (MonadWidget t m, FromJSON a) => String -> Event t b -> m (Dynamic t (RemoteData a))
makeSimpleXhr url postBuild = do
    req <- performRequestAsync $ const (xhrRequest "GET" url def) <$> postBuild
    holdDyn RemoteDataLoading $ fmap readRemoteData req

configView :: MonadWidget t m => Dynamic t ActiveView -> m ()
configView activeViewDyn = do
    attrsDyn <- mapDyn (\curView -> styleWithHideIf (curView /= ActiveViewConfig)
                                    "height: 100%; padding-right: 10px;") activeViewDyn
    elDynAttr "div" attrsDyn $ do
        -- TODO getPostBuild ... maybe when the tab is loaded instead?
        postBuild <- getPostBuild
        cfgDescDyn <- makeSimpleXhr "/configdesc" postBuild
        cfgValDyn <- makeSimpleXhr "/configVal" postBuild
        readAllDyn <- combineDyn (liftA2 FetchedData) cfgDescDyn cfgValDyn

        rec
            configDataDyn <- foldDyn ($) RemoteDataLoading $ mergeWith (.)
                [
                    fmap const (updated readAllDyn),
                    fmap applyConfigChange configUpdateEvt
                ]

            configUpdateEvt <- displayConfig =<< mapDyn fromRemoteData configDataDyn
        return ()

data ConfigAdd = ConfigAdd ConfigItem deriving Show
data ConfigUpdate = ConfigUpdate
    {
        oldConfigItemName :: String,
        newConfigItem :: ConfigItem
    } deriving Show
data ConfigDelete = ConfigDelete ConfigItem deriving Show

data ConfigChange = ChangeAdd ConfigAdd
                  | ChangeUpdate ConfigUpdate
                  | ChangeDelete ConfigDelete
                  deriving Show

applyConfigChange :: ConfigChange -> RemoteData FetchedData -> RemoteData FetchedData
applyConfigChange (ChangeAdd (ConfigAdd newCi)) (RemoteData (FetchedData desc val)) =
    RemoteData (FetchedData desc (newCi:val))
applyConfigChange (ChangeUpdate (ConfigUpdate oldCiName newCi)) (RemoteData (FetchedData desc val)) =
    RemoteData (FetchedData desc updatedVal)
    where updatedVal = newCi : filter ((/= oldCiName) . configItemName) val
applyConfigChange (ChangeDelete (ConfigDelete ci)) (RemoteData (FetchedData desc val)) =
    RemoteData (FetchedData desc updatedVal)
    where updatedVal = filter (/= ci) val
applyConfigChange _ soFar = soFar

displayConfig :: MonadWidget t m => Dynamic t (Maybe FetchedData)
              -> m (Event t ConfigChange)
displayConfig dynFetchedData = do
    rec
        cfgByProvider <- mapDyn (fromMaybe []) =<< mapDyn (liftA groupByProvider) dynFetchedData
        let addCfgBtn = displayAddCfgButton . maybe [] fetchedConfigDesc
        addCfgEvt <- holdDyn never =<< (dyn =<< mapDyn addCfgBtn dynFetchedData)
        cfgChgEvt <- mapDyn leftmost =<< simpleList cfgByProvider displayConfigSection
    return $ leftmost $ fmap (switch . current) [addCfgEvt, cfgChgEvt]

displayAddCfgButton :: MonadWidget t m => [PluginConfig] -> m (Event t ConfigChange)
displayAddCfgButton pluginConfigs = do
    clickEvts <- elAttr "div" ("width" =: "100%"
                  <> "style" =: ("display: flex; flex-direction: row;"
                                 <> "justify-content: flex-end;"
                                 <> "padding-right: 30px; padding-bottom: 10px")) $
        elAttr "div" ("class" =: "btn-group") $ do
            elAttr "button" ("type" =: "button"
                             <> "class" =: "btn btn-primary dropdown-toggle"
                             <> "data-toggle" =: "dropdown"
                             <> "aria-haspopup" =: "true"
                             <> "aria-expanded" =: "false")
                $ text "Add..."
            elAttr "div" ("class" =: "dropdown-menu dropdown-menu-right") $
                mapM addCfgDropdownBtn pluginConfigs
    addEvts <- zipWithM addCfgPluginAdd pluginConfigs clickEvts
    return (ChangeAdd <$> leftmost addEvts)

addCfgDropdownBtn :: MonadWidget t m => PluginConfig -> m (Event t ())
addCfgDropdownBtn PluginConfig{..} = do
    (pcLnk, _) <- elAttr' "a" ("class" =: "dropdown-item"
                               <> "href" =: "javascript:void(0);") $
        text cfgPluginName
    return (domEvent Click pcLnk)

addCfgPluginAdd :: MonadWidget t m => PluginConfig -> Event t () -> m (Event t ConfigAdd)
addCfgPluginAdd pc clickEvt = do
    let ci = ConfigItem "" "" HashMap.empty
    rec
        dialogInfo <- elAttr "div" ("style" =: "position: absolute") $
            buildModalDialog "Add" (PrimaryBtn "Save")
                clickEvt errorEvt (editConfigItem pc ci)
        let errorEvt = fmapMaybe remoteDataInvalidDesc saveEvt

        editConfigEvt <- performEvent $ fmap
            (const $ do
                  modalResult <- sample $ current $ bodyResult dialogInfo
                  ConfigAdd <$> readDialog modalResult pc)
            $ okBtnEvent dialogInfo
        saveEvt <- saveConfigAdd editConfigEvt
    handleSaveAction dialogInfo saveEvt

groupByProvider :: FetchedData -> [(PluginConfig, [ConfigItem])]
groupByProvider (FetchedData configDesc configVal) =
    fmap (second $ sortBy (comparing configItemName)) $ -- sort config items by name
    fmap (first fromJust) $ filter (isJust . fst) $     -- only keep Just providers.
    fmap (first $ providerByName configDesc) $          -- replace provider name by provider (Maybe)
    buckets providerName configVal                      -- bucket by provider name

providerByName :: [PluginConfig] -> String -> Maybe PluginConfig
providerByName pluginConfigs name = find ((== name) . cfgPluginName) pluginConfigs

type EditConfigItemRender t = (Dynamic t String, Map String (Dynamic t String))

editConfigItem :: MonadWidget t m => PluginConfig -> ConfigItem -> m (EditConfigItemRender t)
editConfigItem PluginConfig{..} ConfigItem{..} =
    el "form" $ do
        srcNameInput <- elAttr "fieldset" ("class" =: "form-group") $
            fieldEntry "sourceName" "Enter source name:" configItemName
        fieldInputs  <- Map.fromList <$> mapM (editConfigDataInfo configuration) cfgPluginConfig
        return (srcNameInput, fieldInputs)

editConfigDataInfo :: MonadWidget t m => A.Object -> ConfigDataInfo -> m (String, Dynamic t String)
editConfigDataInfo obj ConfigDataInfo{..} = do
    -- TODO different display based on member type: String, Text, ByteString, FilePath, FolderPath, Password
    let fieldValue = readObjectField memberName obj
    field <- case memberType of
        "Password" -> passwordEntry memberName memberName fieldValue
        _ -> fieldEntry memberName memberName fieldValue
    return (memberName, field)

fieldEntry :: MonadWidget t m => String -> String -> String -> m (Dynamic t String)
fieldEntry fieldId desc fieldValue = do
    elAttr "label" ("for" =: fieldId) $ text desc
    _textInput_value <$> textInput (def
        & textInputConfig_attributes .~ constDyn ("id" =: fieldId <> "class" =: "form-control")
        & textInputConfig_initialValue .~ fieldValue)

-- TODO display warning on top of popup that warnings are stored in plain text
passwordEntry :: MonadWidget t m => String -> String -> String -> m (Dynamic t String)
passwordEntry fieldId desc fieldValue = do
    elAttr "label" ("for" =: fieldId) $ text desc
    elAttr "div" ("class" =: "input-group") $ do
        rec
            attrsDyn <- forDyn showPaswd
                (\p -> "class" =: "form-control"
                       <> "id" =: fieldId
                       <> "value" =: fieldValue
                       <> "type" =: if p then "password" else "text")
            (inputField, _) <- elDynAttr' "input" attrsDyn $ return ()
            showPaswd <- foldDyn ($) True $ leftmost [fmap (const not) padlockEvt]
            (padlock, _) <- elAttr' "div" ("class" =: "input-group-addon") $ do
                padlockContents <- forDyn showPaswd (\case; True -> "&#128274;"; False -> "&#128275;")
                elDynHtmlAttr' "span" ("style" =: "cursor: pointer") padlockContents<commit_msg>warning that passwords are stored in plain text<commit_after>{-# LANGUAGE ScopedTypeVariables, DeriveGeneric, LambdaCase, OverloadedStrings, RecordWildCards, RecursiveDo, TupleSections #-}

module Config where

import GHCJS.DOM.HTMLInputElement

import Reflex.Dom

import Data.Aeson as A
import Data.Aeson.Types as A
import GHC.Generics
import Control.Applicative
import Data.List
import Data.Function
import Data.Maybe
import Data.Bifunctor
import Data.Monoid
import qualified Data.Text as T
import Data.Map (Map)
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Map as Map
import Control.Monad
import Control.Monad.IO.Class
import qualified Data.ByteString.Lazy as BS
import Data.Char
import Data.Ord

import Common

-- TODO stop copy-pasting this between client & server

data PluginConfig = PluginConfig
    {
        cfgPluginName :: String,
        cfgPluginConfig :: [ConfigDataInfo]
    } deriving (Generic, Show, Eq)
instance FromJSON PluginConfig

data ConfigDataInfo = ConfigDataInfo
    {
        memberName :: String,
        memberType :: String
    } deriving (Eq, Show, Generic)
instance FromJSON ConfigDataInfo

data ConfigItem = ConfigItem
    {
        configItemName :: String,
        providerName :: String,
        configuration :: A.Object
    } deriving (Eq, Show, Generic)
instance FromJSON ConfigItem
instance ToJSON ConfigItem

data FetchedData = FetchedData
    {
        fetchedConfigDesc :: [PluginConfig],
        fetchedConfigVal  :: [ConfigItem]
    } deriving Show

makeSimpleXhr :: (MonadWidget t m, FromJSON a) => String -> Event t b -> m (Dynamic t (RemoteData a))
makeSimpleXhr url postBuild = do
    req <- performRequestAsync $ const (xhrRequest "GET" url def) <$> postBuild
    holdDyn RemoteDataLoading $ fmap readRemoteData req

configView :: MonadWidget t m => Dynamic t ActiveView -> m ()
configView activeViewDyn = do
    attrsDyn <- mapDyn (\curView -> styleWithHideIf (curView /= ActiveViewConfig)
                                    "height: 100%; padding-right: 10px;") activeViewDyn
    elDynAttr "div" attrsDyn $ do
        -- TODO getPostBuild ... maybe when the tab is loaded instead?
        postBuild <- getPostBuild
        cfgDescDyn <- makeSimpleXhr "/configdesc" postBuild
        cfgValDyn <- makeSimpleXhr "/configVal" postBuild
        readAllDyn <- combineDyn (liftA2 FetchedData) cfgDescDyn cfgValDyn

        rec
            configDataDyn <- foldDyn ($) RemoteDataLoading $ mergeWith (.)
                [
                    fmap const (updated readAllDyn),
                    fmap applyConfigChange configUpdateEvt
                ]

            configUpdateEvt <- displayConfig =<< mapDyn fromRemoteData configDataDyn
        return ()

data ConfigAdd = ConfigAdd ConfigItem deriving Show
data ConfigUpdate = ConfigUpdate
    {
        oldConfigItemName :: String,
        newConfigItem :: ConfigItem
    } deriving Show
data ConfigDelete = ConfigDelete ConfigItem deriving Show

data ConfigChange = ChangeAdd ConfigAdd
                  | ChangeUpdate ConfigUpdate
                  | ChangeDelete ConfigDelete
                  deriving Show

applyConfigChange :: ConfigChange -> RemoteData FetchedData -> RemoteData FetchedData
applyConfigChange (ChangeAdd (ConfigAdd newCi)) (RemoteData (FetchedData desc val)) =
    RemoteData (FetchedData desc (newCi:val))
applyConfigChange (ChangeUpdate (ConfigUpdate oldCiName newCi)) (RemoteData (FetchedData desc val)) =
    RemoteData (FetchedData desc updatedVal)
    where updatedVal = newCi : filter ((/= oldCiName) . configItemName) val
applyConfigChange (ChangeDelete (ConfigDelete ci)) (RemoteData (FetchedData desc val)) =
    RemoteData (FetchedData desc updatedVal)
    where updatedVal = filter (/= ci) val
applyConfigChange _ soFar = soFar

displayConfig :: MonadWidget t m => Dynamic t (Maybe FetchedData)
              -> m (Event t ConfigChange)
displayConfig dynFetchedData = do
    rec
        cfgByProvider <- mapDyn (fromMaybe []) =<< mapDyn (liftA groupByProvider) dynFetchedData
        let addCfgBtn = displayAddCfgButton . maybe [] fetchedConfigDesc
        addCfgEvt <- holdDyn never =<< (dyn =<< mapDyn addCfgBtn dynFetchedData)
        cfgChgEvt <- mapDyn leftmost =<< simpleList cfgByProvider displayConfigSection
    return $ leftmost $ fmap (switch . current) [addCfgEvt, cfgChgEvt]

displayAddCfgButton :: MonadWidget t m => [PluginConfig] -> m (Event t ConfigChange)
displayAddCfgButton pluginConfigs = do
    clickEvts <- elAttr "div" ("width" =: "100%"
                  <> "style" =: ("display: flex; flex-direction: row;"
                                 <> "justify-content: flex-end;"
                                 <> "padding-right: 30px; padding-bottom: 10px")) $
        elAttr "div" ("class" =: "btn-group") $ do
            elAttr "button" ("type" =: "button"
                             <> "class" =: "btn btn-primary dropdown-toggle"
                             <> "data-toggle" =: "dropdown"
                             <> "aria-haspopup" =: "true"
                             <> "aria-expanded" =: "false")
                $ text "Add..."
            elAttr "div" ("class" =: "dropdown-menu dropdown-menu-right") $
                mapM addCfgDropdownBtn pluginConfigs
    addEvts <- zipWithM addCfgPluginAdd pluginConfigs clickEvts
    return (ChangeAdd <$> leftmost addEvts)

addCfgDropdownBtn :: MonadWidget t m => PluginConfig -> m (Event t ())
addCfgDropdownBtn PluginConfig{..} = do
    (pcLnk, _) <- elAttr' "a" ("class" =: "dropdown-item"
                               <> "href" =: "javascript:void(0);") $
        text cfgPluginName
    return (domEvent Click pcLnk)

addCfgPluginAdd :: MonadWidget t m => PluginConfig -> Event t () -> m (Event t ConfigAdd)
addCfgPluginAdd pc clickEvt = do
    let ci = ConfigItem "" "" HashMap.empty
    rec
        dialogInfo <- elAttr "div" ("style" =: "position: absolute") $
            buildModalDialog "Add" (PrimaryBtn "Save")
                clickEvt errorEvt (editConfigItem pc ci)
        let errorEvt = fmapMaybe remoteDataInvalidDesc saveEvt

        editConfigEvt <- performEvent $ fmap
            (const $ do
                  modalResult <- sample $ current $ bodyResult dialogInfo
                  ConfigAdd <$> readDialog modalResult pc)
            $ okBtnEvent dialogInfo
        saveEvt <- saveConfigAdd editConfigEvt
    handleSaveAction dialogInfo saveEvt

groupByProvider :: FetchedData -> [(PluginConfig, [ConfigItem])]
groupByProvider (FetchedData configDesc configVal) =
    fmap (second $ sortBy (comparing configItemName)) $ -- sort config items by name
    fmap (first fromJust) $ filter (isJust . fst) $     -- only keep Just providers.
    fmap (first $ providerByName configDesc) $          -- replace provider name by provider (Maybe)
    buckets providerName configVal                      -- bucket by provider name

providerByName :: [PluginConfig] -> String -> Maybe PluginConfig
providerByName pluginConfigs name = find ((== name) . cfgPluginName) pluginConfigs

type EditConfigItemRender t = (Dynamic t String, Map String (Dynamic t String))

editConfigItem :: MonadWidget t m => PluginConfig -> ConfigItem -> m (EditConfigItemRender t)
editConfigItem PluginConfig{..} ConfigItem{..} = do
    when (isJust $ find (== "Password") (memberType <$> cfgPluginConfig)) $
        elAttr "div" ("class" =: "alert alert-warning" <> "role" =: "alert") $
            el "strong" (text "Warning") >>
                text " passwords are stored in plain text in the configuration file!"
    el "form" $ do
        srcNameInput <- elAttr "fieldset" ("class" =: "form-group") $
            fieldEntry "sourceName" "Enter source name:" configItemName
        fieldInputs  <- Map.fromList <$> mapM (editConfigDataInfo configuration) cfgPluginConfig
        return (srcNameInput, fieldInputs)

editConfigDataInfo :: MonadWidget t m => A.Object -> ConfigDataInfo -> m (String, Dynamic t String)
editConfigDataInfo obj ConfigDataInfo{..} = do
    -- TODO different display based on member type: String, Text, ByteString, FilePath, FolderPath, Password
    let fieldValue = readObjectField memberName obj
    field <- case memberType of
        "Password" -> passwordEntry memberName memberName fieldValue
        _ -> fieldEntry memberName memberName fieldValue
    return (memberName, field)

fieldEntry :: MonadWidget t m => String -> String -> String -> m (Dynamic t String)
fieldEntry fieldId desc fieldValue = do
    elAttr "label" ("for" =: fieldId) $ text desc
    _textInput_value <$> textInput (def
        & textInputConfig_attributes .~ constDyn ("id" =: fieldId <> "class" =: "form-control")
        & textInputConfig_initialValue .~ fieldValue)

passwordEntry :: MonadWidget t m => String -> String -> String -> m (Dynamic t String)
passwordEntry fieldId desc fieldValue = do
    elAttr "label" ("for" =: fieldId) $ text desc
    elAttr "div" ("class" =: "input-group") $ do
        rec
            attrsDyn <- forDyn showPaswd
                (\p -> "class" =: "form-control"
                       <> "id" =: fieldId
                       <> "value" =: fieldValue
                       <> "type" =: if p then "password" else "text")
            (inputField, _) <- elDynAttr' "input" attrsDyn $ return ()
            showPaswd <- foldDyn ($) True $ leftmost [fmap (const not) padlockEvt]
            (padlock, _) <- elAttr' "div" ("class" =: "input-group-addon") $ do
                padlockContents <- forDyn showPaswd (\case; True -> "&#128274;"; False -> "&#128275;")
                elDynHtmlAttr' "span" ("style" =: "cursor: pointer") padlockContents
{'fraction_non_alphanumeric': 0.09859525437996527, 'fraction_numerical': 0.0027358341663597623, 'mean_word_length': 2.7736748064324, 'pattern_counts': {'":': 0, '<': 111, '<?xml version=': 0, '>': 119, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 8, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4585508', 'n_tokens_mistral': 5491, 'n_tokens_neox': 5257, 'n_words': 1623}