Commented out broken Viz tests

Commented out broken Viz tests

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Test.Selenium.Notebook.Viz (test, actualCanvasScreenshot) where

import Prelude

import Control.Monad.Eff.Random (randomInt)
import Control.Monad.Eff.Class (liftEff)
import Data.List (length, List(..), fromList, filter, null, (!!))
import Data.Maybe (isJust, isNothing, Maybe(..), maybe, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.Foldable (foldl, traverse_)
import Data.Monoid (mempty)
import Data.Function (on)
import qualified Data.Set as S

import Selenium.Types
import Selenium.Monad
import Selenium.ActionSequence hiding (sequence)

import Test.Config
import Test.Selenium.ActionSequence (selectAll, sendDelete, sendEnter)
import Test.Selenium.Monad
import Test.Selenium.Log
import Test.Selenium.Common
import Test.Selenium.Notebook.Getters
import Test.Selenium.Notebook.Contexts
import qualified Test.Selenium.Notebook.Common as C
import qualified Config as SDConfig

import Utils (s2i)
import Utils.Random

checkNextVizCell :: Check Unit
checkNextVizCell = do
  waitNextVizCell >>= sequence <<< leftClick
  await "Viz cell has not been created"
    $ map (eq 2 <<< length) getCells
  successMsg "Ok, next cell viz works"

checkSetHeightWidth :: Check Unit
checkSetHeightWidth = withSmallZipsAllChart do
  widthInput <- waitVizWidthInput
  heightInput <- waitVizHeightInput

  w <- liftEff $ randomInt 100 400
  h <- liftEff $ randomInt 100 400

  modifierKey <- getModifierKey

  sequence do
    leftClick widthInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show w

    leftClick heightInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show h

  await "Dimensions has not been setted" do
    dims <- getDims
    pure
       $ dims.w == pure w
      && dims.h == pure h
  successMsg "Ok, dimensions setted"

  where
  getDims = do
    canvas <- waitCanvas
    { w: _, h: _ }
      <$> (s2i <$> getCssValue canvas "width")
      <*> (s2i <$> getCssValue canvas "height")

switchToPie :: Check Unit
switchToPie = do
  getChartSwitchers >>= sequence <<< leftClick <<< _.pie
  await "Pie switch doesn't work" pieShown

switchToLine :: Check Unit
switchToLine = do
 getChartSwitchers >>= sequence <<< leftClick <<< _.line
 await "Line switch doesn't work" lineShown

switchToBar :: Check Unit
switchToBar = do
 getChartSwitchers >>= sequence <<< leftClick <<< _.bar
 await "Bar switch doesn't work" barShown

checkSwitchers :: Check Unit
checkSwitchers = withFlatVizChart do
  pieDisplayed <- pieShown
  if pieDisplayed
    then successMsg "Ok, initial chart type -- pie"
    else errorMsg "Incorrect initial chart type"

  switchToLine
  successMsg "pie -> line"

  switchToBar
  successMsg "line -> bar"

  switchToPie
  successMsg "bar -> pie"

  switchToBar
  successMsg "pie -> bar"

  switchToLine
  successMsg "bar -> line"

  switchToPie
  successMsg "line -> pie"

checkAlert :: Check Unit
checkAlert = withFlatVizMeasures do
  config <- getConfig
  tryRepeatedlyTo $ byCss config.vizSelectors.alert >>= findExact
  successMsg "ok, alert found"

checkOptions :: Check Unit
checkOptions = withFlatVizChart do
  config <- getConfig
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  successMsg "Ok, pie chart options are correct"

  switchToLine
  await "incorrect line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions
  successMsg "Ok, line chart options are correct"

  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  successMsg "Ok, bar chart options are correct"

-- Don't know how to name it better.
-- This test will look if after switching options in
-- category -> series1 -> series2
-- measure1 -> measure2
-- dimension -> series1 -> series2
-- are filtered
checkOptionUniqueness :: Check Unit
checkOptionUniqueness = withFlatVizChart do
  config <- getConfig

  sectionMsg "check pie uniqueness"
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check bar uniqueness"
  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check line uniqueness"
  switchToLine
  await "incorrec line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions

  checkCategoryUniqueness getDimensionInput getSeriesOneInput getSeriesTwoInput
  checkMeasureUniqueness

checkMeasureUniqueness :: Check Unit
checkMeasureUniqueness = do
  config <- getConfig
  mOne <- getMeasureOneInput
  mTwo <- getMeasureTwoInput

  toSelectOne <- filterAndGetValue mOne mTwo "measures"
  toSelectTwo <- getRandomOption mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne toSelectTwo
  await "Options has not been dropped"
    $ map (/= toSelectTwo) $ getSelectValue mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne config.vizOptions.clearSelection
  await "Option should be disabled"
    $ map not $ isEnabled mTwo
  successMsg "Ok, measure uniqueness"

checkCategoryUniqueness :: Check Element -> Check Element -> Check Element -> Check Unit
checkCategoryUniqueness catM serOneM serTwoM = do
  config <- getConfig
  cat <- catM
  seriesOne <- serOneM
  seriesTwo <- serTwoM

  toSelectCat <- filterAndGetValue cat seriesOne "category"
  toSelectSerOne <- filterAndGetValue seriesOne seriesTwo "series one"

  toSelectSerTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne toSelectSerTwo
  await "Options has not been dropped (one -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo
  successMsg "Ok, select value dropped"

  fillSelect cat toSelectSerTwo
  await "Options has not been dropped (root -> one)"
    $ map (/= toSelectSerOne) $ getSelectValue seriesOne
  successMsg "Ok, dependent selects values are dropped"

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat toSelectSerTwo
  await "Optoins has not been dropped (root -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne config.vizOptions.clearSelection
  await "Select should be disabled (series two)"
    $ map not $ isEnabled seriesTwo

  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat config.vizOptions.clearSelection
  await "Select should be disabled (series one, series two)" do
    one <- isEnabled seriesOne
    two <- isEnabled seriesTwo
    pure $ not one && not two
  successMsg "Ok, dependent selects are disabled"

  successMsg "OK, category uniqueness"

filterAndGetValue :: Element -> Element -> String -> Check String
filterAndGetValue parent child msg = do
  toSelect <- getRandomOption parent
  fillSelect parent toSelect
  await ("Options are not filtered (" <> msg <> ")") do
    parentOptions <- optionTxts parent
    childOptions <- optionTxts child
    pure $ on eq S.fromList parentOptions (Cons toSelect childOptions)
  successMsg $ "Ok, select filtering works (" <> msg <> ")"
  pure toSelect

getSelectValue :: Element -> Check String
getSelectValue el = do
  val <- getAttribute el "value"
  getOptions (pure el) >>= foldl (foldFn val) (pure mempty)
  where
  foldFn :: String -> Check String -> Element -> Check String
  foldFn selectedVal mStr el = do
    val <- getAttribute el "value"
    if val == selectedVal
      then getInnerHtml el
      else mStr

getRandomOption :: Element -> Check String
getRandomOption el = do
  config <- getConfig
  await "there is no options"
    $ map ((> 2) <<< length) $ getOptions $ pure el
  getOptions (pure el)
    >>= traverse getInnerHtml
    >>= randomInM <<< filter (not <<< eq config.vizOptions.clearSelection)
    >>= \x -> if x == mempty
              then errorMsg "empty option list"
              else pure x
fillSelect :: Element -> String -> Check Unit
fillSelect el txt =
  sequence do
    leftClick el
    sendKeys txt
    sendEnter

fillSelectRandom :: Element -> Check Unit
fillSelectRandom el = do
  opt <- getRandomOption el
  fillSelect el opt

optionTxts :: Element -> Check (List String)
optionTxts el = getOptions (pure el) >>= traverse getInnerHtml

checkOptionAutoSelect :: Check Unit
checkOptionAutoSelect = do
  config <- getConfig
  withFlatVizOneOption do
    switchToPie
    waitPieOrBarFullyDisabled "bar"
    pOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect pie options"
      $ pOpts == config.vizOptions.flatVizOneOption.pie

    switchToBar
    waitPieOrBarFullyDisabled "pie"
    bOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect bar options"
      $ bOpts == config.vizOptions.flatVizOneOption.bar

    switchToLine
    waitForDisabled "line"
      $ [ getSeriesOneInput
        , getSeriesTwoInput
        , getDimensionInput
        , getMeasureOneInput
        , getMeasureTwoInput
        ]
    lOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect line options"
      $ lOpts == config.vizOptions.flatVizOneOption.line
  successMsg "Ok, options are correct when there is one series and one measure"
  where
  waitForDisabled msg getters =
    await ("Error: Incorrect states of selects, they must be disabled (" <> msg <> ")")
    $ foldl (\b x -> conj <$> b <*> (map not $ x >>= isEnabled)) (pure true)
    $ getters
  waitPieOrBarFullyDisabled msg =
    waitForDisabled msg
    $ [ getSeriesOneInput
      , getSeriesTwoInput
      , getMeasureOneInput
      , getCategoryInput
      ]

checkOptionSave :: Check Unit
checkOptionSave = do
  checkOptionSaveBarOrPie switchToBar "bar"
  checkOptionSaveBarOrPie switchToPie "pie"
  checkOptionSaveLine

checkOptionSaveLine :: Check Unit
checkOptionSaveLine = withFlatVizChart do
  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueDimension <- filterAndGetValue dimension seriesOne "dimension"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo valueSeriesTwo
  valueMeasureOne <- filterAndGetValue measureOne measureTwo "measure"
  valueMeasureTwo <- getRandomOption measureTwo
  fillSelect measureTwo valueMeasureTwo

  let assertion = do
        d <- assertSelected getDimensionInput valueDimension
        m1 <- assertSelected getMeasureOneInput valueMeasureOne
        m2 <- assertSelected getMeasureTwoInput valueMeasureTwo
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ d && m1 && m2 && s1 && s2

  switchToPie
  switchToLine
  await "Error: line options have not been saved" assertion

  switchToBar
  switchToLine
  await "Error: line options have not been saved" assertion

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switchToLine
  await "Error: line options saved but not permanently" assertion
  successMsg "Ok, line options saved"

assertSelected :: Check Element -> String -> Check Boolean
assertSelected getSelect value =
  map (eq value) $ getSelect >>= getSelectValue

checkOptionSaveBarOrPie :: Check Unit -> String -> Check Unit
checkOptionSaveBarOrPie switcher msg = withFlatVizChart do
  switcher
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  let assertion = do
        c <- assertSelected getCategoryInput valueCategory
        m <- assertSelected getMeasureOneInput valueMeasure
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ c && m && s1 && s2

  switchToBar
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToLine
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToPie
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  successMsg $ "Ok, chart options have been saved (" <> msg <> ")"

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switcher
  getCurrentEditor
  await "Error: saved, but not permanently" assertion
  successMsg $ "Ok, chart options have been saved permanently (" <> msg <> ")"

checkTrashingVizCell :: Check Unit
checkTrashingVizCell = withFlatVizChart do
  config <- getConfig
  vizCell <- getCell 1
  byCss config.cell.trash
    >>= childExact vizCell
    >>= sequence <<< leftClick

  checkThatOneCellRemaining
  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR
  checkThatOneCellRemaining
  successMsg "Ok, trash button works"
  where
  checkThatOneCellRemaining =
    await "Error: cell has not been deleted" do
      map (eq one <<< length) getCells

checkRunRefreshEmbed :: Check Unit
checkRunRefreshEmbed = withFlatVizChart do
  switchToPie
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  saveInitialScreenshot

  findPlayButton >>= sequence <<< leftClick

  await "Error: chart has not been rendered (pie)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  saveInitialScreenshot
  switchToBar

  categoryBar <- getCategoryInput
  measureBar <- getMeasureOneInput
  valueCategoryBar <- getRandomOption categoryBar
  valueMeasureBar <- getRandomOption measureBar
  fillSelect categoryBar valueCategoryBar
  fillSelect measureBar valueMeasureBar

  await "Error: chart has not been rendered (bar)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  switchToLine

  saveInitialScreenshot
  dimension <- getDimensionInput
  measureLine <- getMeasureOneInput
  valueDimension <- getRandomOption categoryBar
  valueMeasureLine <- getRandomOption measureBar
  fillSelect dimension valueDimension
  fillSelect measureLine valueMeasureLine

  await "Error: chart has not been rendered (line)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  successMsg "Ok, embed/run works"

checkScreenshotsDiffer :: Check Boolean
checkScreenshotsDiffer = do
  config <- getConfig
  if config.collectingScreenshots
    then pure true
    else do
    config <- getConfig
    saveActualScreenshot
    map not $ screenshotsEqual config.screenshot.initial

checkElementScreensDiffer :: Check Element -> Check Boolean
checkElementScreensDiffer checkEl = do
  config <- getConfig
  checkEl >>= actualElementScreenshot
  map not $ screenshotsEqual config.screenshot.initial

checkAggregation :: Check Unit
checkAggregation = withFlatVizOneOption do
  aggConfig <- map (_.screenshot >>> _.aggregation) getConfig

  switchToLine
  traverse_ (checkOneAggregation aggConfig.line "line") tpls

  switchToBar
  traverse_ (checkOneAggregation aggConfig.bar "bar") tpls

  switchToPie
  traverse_ (checkOneAggregation aggConfig.pie "pie") tpls
  successMsg "Ok, aggregation works"
  where
  tpls :: Array (Tuple (Check Unit) String)
  tpls = [ Tuple setProductAggregation "product"
         , Tuple setSumAggregation "sum"
         , Tuple setMinAggregation "min"
         , Tuple setMaxAggregation "max"
         , Tuple setAverageAggregation "average"
         ]

  checkOneAggregation :: String -> String -> Tuple (Check Unit) String -> Check Unit
  checkOneAggregation pathToExpected chartMark (Tuple setAgg aggMark) = do
    setAgg
    await ("Error: aggregation (" <> chartMark <> " - " <> aggMark <> ")") do
      actualCanvasScreenshot
      screenshotsEqual $ pathToExpected <> aggMark <> ".png"

setAggregation :: String -> Check Unit
setAggregation val = do
  sel <- getAggregationSelect
  option <- getAggregationOption sel val
  sequence do
    leftClick sel
    leftClick option
    sendEnter

setSumAggregation :: Check Unit
setSumAggregation =
  getConfig >>= _.vizAggregation >>> _.sum >>> setAggregation

setProductAggregation :: Check Unit
setProductAggregation =
  getConfig >>= _.vizAggregation >>> _.product >>> setAggregation

setMinAggregation :: Check Unit
setMinAggregation =
  getConfig >>= _.vizAggregation >>> _.min >>> setAggregation

setMaxAggregation :: Check Unit
setMaxAggregation =
  getConfig >>= _.vizAggregation >>> _.max >>> setAggregation

setAverageAggregation :: Check Unit
setAverageAggregation =
  getConfig >>= _.vizAggregation >>> _.average >>> setAggregation

checkCharts :: Check Unit
checkCharts = withFlatVizChart do
  config <- map (_.screenshot >>> _.charts) getConfig
  toSet <- map (_.vizOptions >>> _.set) getConfig
  switchToPie
  barOrPie "pie" config.pie

  switchToBar
  barOrPie "bar" config.bar

  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput
  fillSelect dimension toSet.dimension
  fillSelect measureOne toSet.measureOne
  await "Error: incorrect chart (line - category)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "category.png"
  fillSelect measureTwo toSet.measureTwo
  await "Error: incorrect chart (line - measure)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "measure.png"
  fillSelect seriesOne toSet.seriesOne
  await "Error: incorrect chart (line - series1)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series1.png"
  fillSelect seriesTwo toSet.seriesTwo
  await "Error: incorrect chart (line - series2)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series2.png"

  successMsg "Ok, charts are correct"
  where
  barOrPie :: String -> String -> Check Unit
  barOrPie label basePath = do
    toSet <- map (_.vizOptions >>> _.set) getConfig
    category <- getCategoryInput
    measure <- getMeasureOneInput
    seriesOne <- getSeriesOneInput
    seriesTwo <- getSeriesTwoInput

    fillSelect category toSet.category
    fillSelect measure toSet.measureOne
    await ("Error: incorrect chart (" <> label <> ") - category)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "category.png"

    fillSelect seriesOne toSet.seriesOne
    await ("Error: incorrect chart (" <> label <> ") - series1)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series1.png"

    fillSelect seriesTwo toSet.seriesTwo
    await ("Error: incorrect chart (" <> label <> ") - series2)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series2.png"

actualCanvasScreenshot :: Check Unit
actualCanvasScreenshot = do
  config <- getConfig
  if config.collectingScreenshots
    then do
    waitTime 5000
    waitCanvas >>= flip elementScreenshot config.tmpFileForScreenshots
    else
    waitCanvas >>= actualElementScreenshot

test :: Check Unit
test = do
  config <- getConfig

  sectionMsg "check next viz cell (search)"
  withSmallZipsSearchedAll $ checkNextVizCell

  sectionMsg "check next viz cell (explore)"
  withSmallZipsOpened $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check set height/width"
  checkSetHeightWidth

  sectionMsg "check hide/show"
  withSmallZipsAllChart do
    config <- getConfig
    cell <- getCell 1
    C.checkHideShowCell cell config.cell.vizEditor

  sectionMsg "check switchers"
  checkSwitchers

  sectionMsg "alert when no available types"
  checkAlert

  sectionMsg "check availbale select options"
  checkOptions

  sectionMsg "check option filters"
  checkOptionUniqueness

  sectionMsg "check option auto select"
  checkOptionAutoSelect

  --sectionMsg "check option save"
  --checkOptionSave

  sectionMsg "trash viz cell"
  checkTrashingVizCell

  sectionMsg "run/refresh/embed"
  checkRunRefreshEmbed

  sectionMsg "aggregation"
  checkAggregation

  sectionMsg "check charts"
  checkCharts

{-
Copyright 2015 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Test.Selenium.Notebook.Viz (test, actualCanvasScreenshot) where

import Prelude

import Control.Monad.Eff.Random (randomInt)
import Control.Monad.Eff.Class (liftEff)
import Data.List (length, List(..), fromList, filter, null, (!!))
import Data.Maybe (isJust, isNothing, Maybe(..), maybe, fromMaybe)
import Data.Maybe.Unsafe (fromJust)
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Data.Foldable (foldl, traverse_)
import Data.Monoid (mempty)
import Data.Function (on)
import qualified Data.Set as S

import Selenium.Types
import Selenium.Monad
import Selenium.ActionSequence hiding (sequence)

import Test.Config
import Test.Selenium.ActionSequence (selectAll, sendDelete, sendEnter)
import Test.Selenium.Monad
import Test.Selenium.Log
import Test.Selenium.Common
import Test.Selenium.Notebook.Getters
import Test.Selenium.Notebook.Contexts
import qualified Test.Selenium.Notebook.Common as C
import qualified Config as SDConfig

import Utils (s2i)
import Utils.Random

checkNextVizCell :: Check Unit
checkNextVizCell = do
  waitNextVizCell >>= sequence <<< leftClick
  await "Viz cell has not been created"
    $ map (eq 2 <<< length) getCells
  successMsg "Ok, next cell viz works"

checkSetHeightWidth :: Check Unit
checkSetHeightWidth = withSmallZipsAllChart do
  widthInput <- waitVizWidthInput
  heightInput <- waitVizHeightInput

  w <- liftEff $ randomInt 100 400
  h <- liftEff $ randomInt 100 400

  modifierKey <- getModifierKey

  sequence do
    leftClick widthInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show w

    leftClick heightInput
    selectAll modifierKey
    sendDelete
    sendKeys $ show h

  await "Dimensions has not been setted" do
    dims <- getDims
    pure
       $ dims.w == pure w
      && dims.h == pure h
  successMsg "Ok, dimensions setted"

  where
  getDims = do
    canvas <- waitCanvas
    { w: _, h: _ }
      <$> (s2i <$> getCssValue canvas "width")
      <*> (s2i <$> getCssValue canvas "height")

switchToPie :: Check Unit
switchToPie = do
  getChartSwitchers >>= sequence <<< leftClick <<< _.pie
  await "Pie switch doesn't work" pieShown

switchToLine :: Check Unit
switchToLine = do
 getChartSwitchers >>= sequence <<< leftClick <<< _.line
 await "Line switch doesn't work" lineShown

switchToBar :: Check Unit
switchToBar = do
 getChartSwitchers >>= sequence <<< leftClick <<< _.bar
 await "Bar switch doesn't work" barShown

checkSwitchers :: Check Unit
checkSwitchers = withFlatVizChart do
  pieDisplayed <- pieShown
  if pieDisplayed
    then successMsg "Ok, initial chart type -- pie"
    else errorMsg "Incorrect initial chart type"

  switchToLine
  successMsg "pie -> line"

  switchToBar
  successMsg "line -> bar"

  switchToPie
  successMsg "bar -> pie"

  switchToBar
  successMsg "pie -> bar"

  switchToLine
  successMsg "bar -> line"

  switchToPie
  successMsg "line -> pie"

checkAlert :: Check Unit
checkAlert = withFlatVizMeasures do
  config <- getConfig
  tryRepeatedlyTo $ byCss config.vizSelectors.alert >>= findExact
  successMsg "ok, alert found"

checkOptions :: Check Unit
checkOptions = withFlatVizChart do
  config <- getConfig
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  successMsg "Ok, pie chart options are correct"

  switchToLine
  await "incorrect line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions
  successMsg "Ok, line chart options are correct"

  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  successMsg "Ok, bar chart options are correct"

-- Don't know how to name it better.
-- This test will look if after switching options in
-- category -> series1 -> series2
-- measure1 -> measure2
-- dimension -> series1 -> series2
-- are filtered
checkOptionUniqueness :: Check Unit
checkOptionUniqueness = withFlatVizChart do
  config <- getConfig

  sectionMsg "check pie uniqueness"
  switchToPie
  await "incorrect pie options"
    $ map (eq config.vizOptions.flatVizAll.pie) getCurrentChartOptions
  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check bar uniqueness"
  switchToBar
  await "incorrect bar options"
    $ map (eq config.vizOptions.flatVizAll.bar) getCurrentChartOptions

  checkCategoryUniqueness getCategoryInput getSeriesOneInput getSeriesTwoInput

  sectionMsg "check line uniqueness"
  switchToLine
  await "incorrec line options"
    $ map (eq config.vizOptions.flatVizAll.line) getCurrentChartOptions

  checkCategoryUniqueness getDimensionInput getSeriesOneInput getSeriesTwoInput
  checkMeasureUniqueness

checkMeasureUniqueness :: Check Unit
checkMeasureUniqueness = do
  config <- getConfig
  mOne <- getMeasureOneInput
  mTwo <- getMeasureTwoInput

  toSelectOne <- filterAndGetValue mOne mTwo "measures"
  toSelectTwo <- getRandomOption mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne toSelectTwo
  await "Options has not been dropped"
    $ map (/= toSelectTwo) $ getSelectValue mTwo

  fillSelect mTwo toSelectTwo
  fillSelect mOne config.vizOptions.clearSelection
  await "Option should be disabled"
    $ map not $ isEnabled mTwo
  successMsg "Ok, measure uniqueness"

checkCategoryUniqueness :: Check Element -> Check Element -> Check Element -> Check Unit
checkCategoryUniqueness catM serOneM serTwoM = do
  config <- getConfig
  cat <- catM
  seriesOne <- serOneM
  seriesTwo <- serTwoM

  toSelectCat <- filterAndGetValue cat seriesOne "category"
  toSelectSerOne <- filterAndGetValue seriesOne seriesTwo "series one"

  toSelectSerTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne toSelectSerTwo
  await "Options has not been dropped (one -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo
  successMsg "Ok, select value dropped"

  fillSelect cat toSelectSerTwo
  await "Options has not been dropped (root -> one)"
    $ map (/= toSelectSerOne) $ getSelectValue seriesOne
  successMsg "Ok, dependent selects values are dropped"

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat toSelectSerTwo
  await "Optoins has not been dropped (root -> two)"
    $ map (/= toSelectSerTwo) $ getSelectValue seriesTwo

  fillSelect cat toSelectCat
  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect seriesOne config.vizOptions.clearSelection
  await "Select should be disabled (series two)"
    $ map not $ isEnabled seriesTwo

  fillSelect seriesOne toSelectSerOne
  fillSelect seriesTwo toSelectSerTwo
  fillSelect cat config.vizOptions.clearSelection
  await "Select should be disabled (series one, series two)" do
    one <- isEnabled seriesOne
    two <- isEnabled seriesTwo
    pure $ not one && not two
  successMsg "Ok, dependent selects are disabled"

  successMsg "OK, category uniqueness"

filterAndGetValue :: Element -> Element -> String -> Check String
filterAndGetValue parent child msg = do
  toSelect <- getRandomOption parent
  fillSelect parent toSelect
  await ("Options are not filtered (" <> msg <> ")") do
    parentOptions <- optionTxts parent
    childOptions <- optionTxts child
    pure $ on eq S.fromList parentOptions (Cons toSelect childOptions)
  successMsg $ "Ok, select filtering works (" <> msg <> ")"
  pure toSelect

getSelectValue :: Element -> Check String
getSelectValue el = do
  val <- getAttribute el "value"
  getOptions (pure el) >>= foldl (foldFn val) (pure mempty)
  where
  foldFn :: String -> Check String -> Element -> Check String
  foldFn selectedVal mStr el = do
    val <- getAttribute el "value"
    if val == selectedVal
      then getInnerHtml el
      else mStr

getRandomOption :: Element -> Check String
getRandomOption el = do
  config <- getConfig
  await "there is no options"
    $ map ((> 2) <<< length) $ getOptions $ pure el
  getOptions (pure el)
    >>= traverse getInnerHtml
    >>= randomInM <<< filter (not <<< eq config.vizOptions.clearSelection)
    >>= \x -> if x == mempty
              then errorMsg "empty option list"
              else pure x
fillSelect :: Element -> String -> Check Unit
fillSelect el txt =
  sequence do
    leftClick el
    sendKeys txt
    sendEnter

fillSelectRandom :: Element -> Check Unit
fillSelectRandom el = do
  opt <- getRandomOption el
  fillSelect el opt

optionTxts :: Element -> Check (List String)
optionTxts el = getOptions (pure el) >>= traverse getInnerHtml

checkOptionAutoSelect :: Check Unit
checkOptionAutoSelect = do
  config <- getConfig
  withFlatVizOneOption do
    switchToPie
    waitPieOrBarFullyDisabled "bar"
    pOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect pie options"
      $ pOpts == config.vizOptions.flatVizOneOption.pie

    switchToBar
    waitPieOrBarFullyDisabled "pie"
    bOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect bar options"
      $ bOpts == config.vizOptions.flatVizOneOption.bar

    switchToLine
    waitForDisabled "line"
      $ [ getSeriesOneInput
        , getSeriesTwoInput
        , getDimensionInput
        , getMeasureOneInput
        , getMeasureTwoInput
        ]
    lOpts <- getCurrentChartOptions
    assertBoolean "Error: incorrect line options"
      $ lOpts == config.vizOptions.flatVizOneOption.line
  successMsg "Ok, options are correct when there is one series and one measure"
  where
  waitForDisabled msg getters =
    await ("Error: Incorrect states of selects, they must be disabled (" <> msg <> ")")
    $ foldl (\b x -> conj <$> b <*> (map not $ x >>= isEnabled)) (pure true)
    $ getters
  waitPieOrBarFullyDisabled msg =
    waitForDisabled msg
    $ [ getSeriesOneInput
      , getSeriesTwoInput
      , getMeasureOneInput
      , getCategoryInput
      ]

checkOptionSave :: Check Unit
checkOptionSave = do
  checkOptionSaveBarOrPie switchToBar "bar"
  checkOptionSaveBarOrPie switchToPie "pie"
  checkOptionSaveLine

checkOptionSaveLine :: Check Unit
checkOptionSaveLine = withFlatVizChart do
  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueDimension <- filterAndGetValue dimension seriesOne "dimension"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  fillSelect seriesTwo valueSeriesTwo
  valueMeasureOne <- filterAndGetValue measureOne measureTwo "measure"
  valueMeasureTwo <- getRandomOption measureTwo
  fillSelect measureTwo valueMeasureTwo

  let assertion = do
        d <- assertSelected getDimensionInput valueDimension
        m1 <- assertSelected getMeasureOneInput valueMeasureOne
        m2 <- assertSelected getMeasureTwoInput valueMeasureTwo
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ d && m1 && m2 && s1 && s2

  switchToPie
  switchToLine
  await "Error: line options have not been saved" assertion

  switchToBar
  switchToLine
  await "Error: line options have not been saved" assertion

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switchToLine
  await "Error: line options saved but not permanently" assertion
  successMsg "Ok, line options saved"

assertSelected :: Check Element -> String -> Check Boolean
assertSelected getSelect value =
  map (eq value) $ getSelect >>= getSelectValue

checkOptionSaveBarOrPie :: Check Unit -> String -> Check Unit
checkOptionSaveBarOrPie switcher msg = withFlatVizChart do
  switcher
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  let assertion = do
        c <- assertSelected getCategoryInput valueCategory
        m <- assertSelected getMeasureOneInput valueMeasure
        s1 <- assertSelected getSeriesOneInput valueSeriesOne
        s2 <- assertSelected getSeriesTwoInput valueSeriesTwo
        pure $ c && m && s1 && s2

  switchToBar
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToLine
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  switchToPie
  switcher
  await ("Error: Hasn't been saved (" <> msg <> ")") assertion

  successMsg $ "Ok, chart options have been saved (" <> msg <> ")"

  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR

  switcher
  getCurrentEditor
  await "Error: saved, but not permanently" assertion
  successMsg $ "Ok, chart options have been saved permanently (" <> msg <> ")"

checkTrashingVizCell :: Check Unit
checkTrashingVizCell = withFlatVizChart do
  config <- getConfig
  vizCell <- getCell 1
  byCss config.cell.trash
    >>= childExact vizCell
    >>= sequence <<< leftClick

  checkThatOneCellRemaining
  waitTime $ SDConfig.autosaveTick * 2
  reloadAndSpyXHR
  checkThatOneCellRemaining
  successMsg "Ok, trash button works"
  where
  checkThatOneCellRemaining =
    await "Error: cell has not been deleted" do
      map (eq one <<< length) getCells

checkRunRefreshEmbed :: Check Unit
checkRunRefreshEmbed = withFlatVizChart do
  switchToPie
  category <- getCategoryInput
  measure <- getMeasureOneInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput

  valueCategory <- filterAndGetValue category seriesOne "category"
  valueSeriesOne <- filterAndGetValue seriesOne seriesTwo "series"
  valueSeriesTwo <- getRandomOption seriesTwo
  valueMeasure <- getRandomOption measure

  fillSelect seriesTwo valueSeriesTwo
  fillSelect measure valueMeasure

  saveInitialScreenshot

  findPlayButton >>= sequence <<< leftClick

  await "Error: chart has not been rendered (pie)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  saveInitialScreenshot
  switchToBar

  categoryBar <- getCategoryInput
  measureBar <- getMeasureOneInput
  valueCategoryBar <- getRandomOption categoryBar
  valueMeasureBar <- getRandomOption measureBar
  fillSelect categoryBar valueCategoryBar
  fillSelect measureBar valueMeasureBar

  await "Error: chart has not been rendered (bar)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  switchToLine

  saveInitialScreenshot
  dimension <- getDimensionInput
  measureLine <- getMeasureOneInput
  valueDimension <- getRandomOption categoryBar
  valueMeasureLine <- getRandomOption measureBar
  fillSelect dimension valueDimension
  fillSelect measureLine valueMeasureLine

  await "Error: chart has not been rendered (line)"
    $ checkScreenshotsDiffer
  C.checkEmbedButton

  successMsg "Ok, embed/run works"

checkScreenshotsDiffer :: Check Boolean
checkScreenshotsDiffer = do
  config <- getConfig
  if config.collectingScreenshots
    then pure true
    else do
    config <- getConfig
    saveActualScreenshot
    map not $ screenshotsEqual config.screenshot.initial

checkElementScreensDiffer :: Check Element -> Check Boolean
checkElementScreensDiffer checkEl = do
  config <- getConfig
  checkEl >>= actualElementScreenshot
  map not $ screenshotsEqual config.screenshot.initial

checkAggregation :: Check Unit
checkAggregation = withFlatVizOneOption do
  aggConfig <- map (_.screenshot >>> _.aggregation) getConfig

  switchToLine
  traverse_ (checkOneAggregation aggConfig.line "line") tpls

  switchToBar
  traverse_ (checkOneAggregation aggConfig.bar "bar") tpls

  switchToPie
  traverse_ (checkOneAggregation aggConfig.pie "pie") tpls
  successMsg "Ok, aggregation works"
  where
  tpls :: Array (Tuple (Check Unit) String)
  tpls = [ Tuple setProductAggregation "product"
         , Tuple setSumAggregation "sum"
         , Tuple setMinAggregation "min"
         , Tuple setMaxAggregation "max"
         , Tuple setAverageAggregation "average"
         ]

  checkOneAggregation :: String -> String -> Tuple (Check Unit) String -> Check Unit
  checkOneAggregation pathToExpected chartMark (Tuple setAgg aggMark) = do
    setAgg
    await ("Error: aggregation (" <> chartMark <> " - " <> aggMark <> ")") do
      actualCanvasScreenshot
      screenshotsEqual $ pathToExpected <> aggMark <> ".png"

setAggregation :: String -> Check Unit
setAggregation val = do
  sel <- getAggregationSelect
  option <- getAggregationOption sel val
  sequence do
    leftClick sel
    leftClick option
    sendEnter

setSumAggregation :: Check Unit
setSumAggregation =
  getConfig >>= _.vizAggregation >>> _.sum >>> setAggregation

setProductAggregation :: Check Unit
setProductAggregation =
  getConfig >>= _.vizAggregation >>> _.product >>> setAggregation

setMinAggregation :: Check Unit
setMinAggregation =
  getConfig >>= _.vizAggregation >>> _.min >>> setAggregation

setMaxAggregation :: Check Unit
setMaxAggregation =
  getConfig >>= _.vizAggregation >>> _.max >>> setAggregation

setAverageAggregation :: Check Unit
setAverageAggregation =
  getConfig >>= _.vizAggregation >>> _.average >>> setAggregation

checkCharts :: Check Unit
checkCharts = withFlatVizChart do
  config <- map (_.screenshot >>> _.charts) getConfig
  toSet <- map (_.vizOptions >>> _.set) getConfig
  switchToPie
  barOrPie "pie" config.pie

  switchToBar
  barOrPie "bar" config.bar

  switchToLine
  dimension <- getDimensionInput
  measureOne <- getMeasureOneInput
  measureTwo <- getMeasureTwoInput
  seriesOne <- getSeriesOneInput
  seriesTwo <- getSeriesTwoInput
  fillSelect dimension toSet.dimension
  fillSelect measureOne toSet.measureOne
  await "Error: incorrect chart (line - category)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "category.png"
  fillSelect measureTwo toSet.measureTwo
  await "Error: incorrect chart (line - measure)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "measure.png"
  fillSelect seriesOne toSet.seriesOne
  await "Error: incorrect chart (line - series1)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series1.png"
  fillSelect seriesTwo toSet.seriesTwo
  await "Error: incorrect chart (line - series2)" do
    actualCanvasScreenshot
    screenshotsEqual $ config.line <> "series2.png"

  successMsg "Ok, charts are correct"
  where
  barOrPie :: String -> String -> Check Unit
  barOrPie label basePath = do
    toSet <- map (_.vizOptions >>> _.set) getConfig
    category <- getCategoryInput
    measure <- getMeasureOneInput
    seriesOne <- getSeriesOneInput
    seriesTwo <- getSeriesTwoInput

    fillSelect category toSet.category
    fillSelect measure toSet.measureOne
    await ("Error: incorrect chart (" <> label <> ") - category)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "category.png"

    fillSelect seriesOne toSet.seriesOne
    await ("Error: incorrect chart (" <> label <> ") - series1)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series1.png"

    fillSelect seriesTwo toSet.seriesTwo
    await ("Error: incorrect chart (" <> label <> ") - series2)") do
      actualCanvasScreenshot
      screenshotsEqual $ basePath <> "series2.png"

actualCanvasScreenshot :: Check Unit
actualCanvasScreenshot = do
  config <- getConfig
  if config.collectingScreenshots
    then do
    waitTime 5000
    waitCanvas >>= flip elementScreenshot config.tmpFileForScreenshots
    else
    waitCanvas >>= actualElementScreenshot

test :: Check Unit
test = do
  config <- getConfig

  sectionMsg "check next viz cell (search)"
  withSmallZipsSearchedAll $ checkNextVizCell

  sectionMsg "check next viz cell (explore)"
  withSmallZipsOpened $ checkNextVizCell

  sectionMsg "check next viz cell (query)"
  withSmallZipsQueriedAll $ checkNextVizCell

  sectionMsg "check set height/width"
  checkSetHeightWidth

  sectionMsg "check hide/show"
  withSmallZipsAllChart do
    config <- getConfig
    cell <- getCell 1
    C.checkHideShowCell cell config.cell.vizEditor

  sectionMsg "check switchers"
  checkSwitchers

  sectionMsg "alert when no available types"
  checkAlert

  sectionMsg "check availbale select options"
  checkOptions

  sectionMsg "check option filters"
  checkOptionUniqueness

  sectionMsg "check option auto select"
  checkOptionAutoSelect

  sectionMsg "check option save"
  checkOptionSave

  sectionMsg "trash viz cell"
  checkTrashingVizCell

  sectionMsg "run/refresh/embed"
  checkRunRefreshEmbed

  sectionMsg "aggregation"
  checkAggregation

  sectionMsg "check charts"
  checkCharts


Fix path used for runQuery

Fix path used for runQuery

module Controller.Notebook.Cell.Query where

import Control.Plus (empty)
import Controller.Notebook.Cell.JTableContent (queryToJTable)
import Controller.Notebook.Common (I())
import Data.Maybe (Maybe(), fromMaybe)
import Model.Notebook.Cell (Cell(), _Query, _content, _output)
import Model.Notebook.Port (_PortResource)
import Model.Resource (Resource(), parent, root)
import Optic.Core ((^.), (..))
import Optic.Fold ((^?))
import qualified Model.Notebook.Cell.Query as Qu

runQuery :: forall e. Cell -> I e
runQuery cell = fromMaybe empty $ queryToJTable cell input <$> path <*> output
  where
  output :: Maybe Resource
  output = cell ^? _output .. _PortResource

  path :: Maybe Resource
  path = parent <<< parent <$> output

  input :: String
  input = cell ^. _content .. _Query .. Qu._input

module Controller.Notebook.Cell.Query where

import Control.Plus (empty)
import Controller.Notebook.Cell.JTableContent (queryToJTable)
import Controller.Notebook.Common (I())
import Data.Maybe (Maybe(), maybe)
import Model.Notebook.Cell (Cell(), _Query, _content, _output)
import Model.Notebook.Port (_PortResource)
import Model.Resource (Resource(), root)
import Optic.Core ((^.), (..))
import Optic.Fold ((^?))
import qualified Model.Notebook.Cell.Query as Qu

runQuery :: forall e. Cell -> I e
runQuery cell = maybe empty (queryToJTable cell input root) output
  where
  output :: Maybe Resource
  output = cell ^? _output .. _PortResource

  input :: String
  input = cell ^. _content .. _Query .. Qu._input


Improve documentation & formatting

Improve documentation & formatting

Every exposed symbol should be documented now.

-- | This module contains various types and functions to allow you to spawn and
-- | interact with child processes.
-- |
-- | It is intended to be imported qualified, as follows:
-- |
-- | ```purescript
-- | import Node.ChildProcess (ChildProcess, CHILD_PROCESS)
-- | import Node.ChildProcess as ChildProcess
-- | ```
-- |
-- | The [Node.js documentation](https://nodejs.org/api/child_process.html)
-- | forms the basis for this module and has in-depth documentation about
-- | runtime behaviour.
module Node.ChildProcess
  ( Handle
  , ChildProcess
  , stdin
  , stdout
  , stderr
  , pid
  , connected
  , kill
  , send
  , disconnect
  , Error
  , toStandardError
  , Exit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , SpawnOptions
  , defaultSpawnOptions
  , exec
  , execFile
  , ExecOptions
  , ExecResult
  , defaultExecOptions
  , execSync
  , execFileSync
  , ExecSyncOptions
  , defaultExecSyncOptions
  , fork
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Nullable (Nullable, toNullable, toMaybe)
import Data.Posix (Pid, Gid, Uid)
import Data.Posix.Signal (Signal)
import Data.Posix.Signal as Signal
import Effect (Effect)
import Effect.Exception as Exception
import Effect.Exception.Unsafe (unsafeThrow)
import Foreign (Foreign)
import Foreign.Object (Object)
import Node.Buffer (Buffer)
import Node.FS as FS
import Node.Stream (Readable, Writable, Stream)
import Unsafe.Coerce (unsafeCoerce)

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: Type

-- | Opaque type returned by `spawn`, `fork` and `exec`.
-- | Needed as input for most methods in this module.
newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin :: Nullable (Writable ())
  , stdout :: Nullable (Readable ())
  , stderr :: Nullable (Readable ())
  , pid :: Pid
  , connected :: Boolean
  , kill :: String -> Unit
  , send :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: Effect Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: ChildProcess -> Writable ()
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: ChildProcess -> Readable ()
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: ChildProcess -> Readable ()
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

-- | Indicates whether it is still possible to send and receive
-- | messages from the child process.
connected :: ChildProcess -> Effect Boolean
connected (ChildProcess cp) = mkEffect \_ -> cp.connected

-- | Send messages to the (`nodejs`) child process.
-- |
-- | See the [node documentation](https://nodejs.org/api/child_process.html#child_process_subprocess_send_message_sendhandle_options_callback)
-- | for in-depth documentation.
send
  :: forall props
   . { | props }
  -> Handle
  -> ChildProcess
  -> Effect Boolean
send msg handle (ChildProcess cp) = mkEffect \_ -> runFn2 cp.send msg handle

-- | Closes the IPC channel between parent and child.
disconnect :: ChildProcess -> Effect Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. In the same way as the
-- | [unix kill(2) system call](https://linux.die.net/man/2/kill),
-- | sending a signal to a child process won't necessarily kill it.
-- |
-- | The resulting effects of this function depend on the process
-- | and the signal. They can vary from system to system.
-- | The child process might emit an `"error"` event if the signal
-- | could not be delivered.
kill :: Signal -> ChildProcess -> Effect Unit
kill sig (ChildProcess cp) = mkEffect \_ -> cp.kill (Signal.toString sig)

mkEffect :: forall a. (Unit -> a) -> Effect a
mkEffect = unsafeCoerce

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data Exit
  = Normally Int
  | BySignal Signal

instance showExit :: Show Exit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

mkExit :: Nullable Int -> Nullable String -> Exit
mkExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkExit: Invalid arguments"
  where
  fromCode = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

-- | Handle the `"exit"` signal.
onExit
  :: ChildProcess
  -> (Exit -> Effect Unit)
  -> Effect Unit
onExit = mkOnExit mkExit

foreign import mkOnExit
  :: (Nullable Int -> Nullable String -> Exit)
  -> ChildProcess
  -> (Exit -> Effect Unit)
  -> Effect Unit

-- | Handle the `"close"` signal.
onClose
  :: ChildProcess
  -> (Exit -> Effect Unit)
  -> Effect Unit
onClose = mkOnClose mkExit

foreign import mkOnClose
  :: (Nullable Int -> Nullable String -> Exit)
  -> ChildProcess
  -> (Exit -> Effect Unit)
  -> Effect Unit

-- | Handle the `"message"` signal.
onMessage
  :: ChildProcess
  -> (Foreign -> Maybe Handle -> Effect Unit)
  -> Effect Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage
  :: forall a
   . Maybe a
  -> (a -> Maybe a)
  -> ChildProcess
  -> (Foreign -> Maybe Handle -> Effect Unit)
  -> Effect Unit

-- | Handle the `"disconnect"` signal.
foreign import onDisconnect
  :: ChildProcess
  -> Effect Unit
  -> Effect Unit

-- | Handle the `"error"` signal.
foreign import onError
  :: ChildProcess
  -> (Error -> Effect Unit)
  -> Effect Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn
  :: String
  -> Array String
  -> SpawnOptions
  -> Effect ChildProcess
spawn cmd args = spawnImpl cmd args <<< convertOpts
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl
  :: forall opts
   . String
  -> Array String
  -> { | opts }
  -> Effect ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

-- | Configuration of `spawn`. Fields set to `Nothing` will use
-- | the node defaults.
type SpawnOptions =
  { cwd :: Maybe String
  , stdio :: Array (Maybe StdIOBehaviour)
  , env :: Maybe (Object String)
  , detached :: Boolean
  , uid :: Maybe Uid
  , gid :: Maybe Gid
  }

-- | A default set of `SpawnOptions`. Everything is set to `Nothing`,
-- | `detached` is `false` and `stdio` is `ChildProcess.pipe`.
defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | Similar to `spawn`, except that this variant will:
-- | * run the given command with the shell,
-- | * buffer output, and wait until the process has exited before calling the
-- |   callback.
-- |
-- | Note that the child process will be killed if the amount of output exceeds
-- | a certain threshold (the default is defined by Node.js).
exec
  :: String
  -> ExecOptions
  -> (ExecResult -> Effect Unit)
  -> Effect ChildProcess
exec cmd opts callback =
  execImpl cmd (convertExecOptions opts) \err stdout' stderr' ->
    callback
      { error: toMaybe err
      , stdout: stdout'
      , stderr: stderr'
      }

foreign import execImpl
  :: String
  -> ActualExecOptions
  -> (Nullable Exception.Error -> Buffer -> Buffer -> Effect Unit)
  -> Effect ChildProcess

-- | Like `exec`, except instead of using a shell, it passes the arguments
-- | directly to the specified command.
execFile
  :: String
  -> Array String
  -> ExecOptions
  -> (ExecResult -> Effect Unit)
  -> Effect ChildProcess
execFile cmd args opts callback =
  execFileImpl cmd args (convertExecOptions opts) \err stdout' stderr' ->
    callback
      { error: toMaybe err
      , stdout: stdout'
      , stderr: stderr'
      }

foreign import execFileImpl
  :: String
  -> Array String
  -> ActualExecOptions
  -> (Nullable Exception.Error -> Buffer -> Buffer -> Effect Unit)
  -> Effect ChildProcess

foreign import data ActualExecOptions :: Type

convertExecOptions :: ExecOptions -> ActualExecOptions
convertExecOptions opts = unsafeCoerce
  { cwd: fromMaybe undefined opts.cwd
  , env: fromMaybe undefined opts.env
  , timeout: fromMaybe undefined opts.timeout
  , maxBuffer: fromMaybe undefined opts.maxBuffer
  , killSignal: fromMaybe undefined opts.killSignal
  , uid: fromMaybe undefined opts.uid
  , gid: fromMaybe undefined opts.gid
  }

-- | Configuration of `exec`. Fields set to `Nothing`
-- | will use the node defaults.
type ExecOptions =
  { cwd :: Maybe String
  , env :: Maybe (Object String)
  , timeout :: Maybe Number
  , maxBuffer :: Maybe Int
  , killSignal :: Maybe Signal
  , uid :: Maybe Uid
  , gid :: Maybe Gid
  }

-- | A default set of `ExecOptions`. Everything is set to `Nothing`.
defaultExecOptions :: ExecOptions
defaultExecOptions =
  { cwd: Nothing
  , env: Nothing
  , timeout: Nothing
  , maxBuffer: Nothing
  , killSignal: Nothing
  , uid: Nothing
  , gid: Nothing
  }

-- | The combined output of a process calld with `exec`.
type ExecResult =
  { stderr :: Buffer
  , stdout :: Buffer
  , error :: Maybe Exception.Error
  }

-- | Generally identical to `exec`, with the exception that
-- | the method will not return until the child process has fully closed.
-- | Returns: The stdout from the command.
execSync
  :: String
  -> ExecSyncOptions
  -> Effect Buffer
execSync cmd opts =
  execSyncImpl cmd (convertExecSyncOptions opts)

foreign import execSyncImpl
  :: String
  -> ActualExecSyncOptions
  -> Effect Buffer

-- | Generally identical to `execFile`, with the exception that
-- | the method will not return until the child process has fully closed.
-- | Returns: The stdout from the command.
execFileSync
  :: String
  -> Array String
  -> ExecSyncOptions
  -> Effect Buffer
execFileSync cmd args opts =
  execFileSyncImpl cmd args (convertExecSyncOptions opts)

foreign import execFileSyncImpl
  :: String
  -> Array String
  -> ActualExecSyncOptions
  -> Effect Buffer

foreign import data ActualExecSyncOptions :: Type

convertExecSyncOptions :: ExecSyncOptions -> ActualExecSyncOptions
convertExecSyncOptions opts = unsafeCoerce
  { cwd: fromMaybe undefined opts.cwd
  , input: fromMaybe undefined opts.input
  , stdio: toActualStdIOOptions opts.stdio
  , env: fromMaybe undefined opts.env
  , timeout: fromMaybe undefined opts.timeout
  , maxBuffer: fromMaybe undefined opts.maxBuffer
  , killSignal: fromMaybe undefined opts.killSignal
  , uid: fromMaybe undefined opts.uid
  , gid: fromMaybe undefined opts.gid
  }

type ExecSyncOptions =
  { cwd :: Maybe String
  , input :: Maybe String
  , stdio :: Array (Maybe StdIOBehaviour)
  , env :: Maybe (Object String)
  , timeout :: Maybe Number
  , maxBuffer :: Maybe Int
  , killSignal :: Maybe Signal
  , uid :: Maybe Uid
  , gid :: Maybe Gid
  }

defaultExecSyncOptions :: ExecSyncOptions
defaultExecSyncOptions =
  { cwd: Nothing
  , input: Nothing
  , stdio: pipe
  , env: Nothing
  , timeout: Nothing
  , maxBuffer: Nothing
  , killSignal: Nothing
  , uid: Nothing
  , gid: Nothing
  }

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork
  :: String
  -> Array String
  -> Effect ChildProcess

-- | An error which occurred inside a child process.
type Error =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Convert a ChildProcess.Error to a standard Error, which can then be thrown
-- | inside an Effect or Aff computation (for example).
toStandardError :: Error -> Exception.Error
toStandardError = unsafeCoerce

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r. Stream r)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share `stdin` with `stdin`, `stdout` with `stdout`,
-- | and `stderr` with `stderr`.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

-- Helpers

foreign import data ActualStdIOBehaviour :: Type

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe -> c "pipe"
  Ignore -> c "ignore"
  ShareFD x -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)

-- | This module contains various types and functions to allow you to spawn and
-- | interact with child processes.
-- |
-- | It is intended to be imported qualified, as follows:
-- |
-- | ```purescript
-- | import Node.ChildProcess (ChildProcess, CHILD_PROCESS)
-- | import Node.ChildProcess as ChildProcess
-- | ```
-- |
-- | The [Node.js documentation](https://nodejs.org/api/child_process.html)
-- | will probably also be useful to read if you want to use this module.
module Node.ChildProcess
  ( Handle
  , ChildProcess
  , stderr
  , stdout
  , stdin
  , pid
  , connected
  , kill
  , send
  , disconnect
  , Error
  , toStandardError
  , Exit(..)
  , onExit
  , onClose
  , onDisconnect
  , onMessage
  , onError
  , spawn
  , SpawnOptions
  , defaultSpawnOptions
  , exec
  , execFile
  , ExecOptions
  , ExecResult
  , defaultExecOptions
  , execSync
  , execFileSync
  , ExecSyncOptions
  , defaultExecSyncOptions
  , fork
  , StdIOBehaviour(..)
  , pipe
  , inherit
  , ignore
  ) where

import Prelude

import Control.Alt ((<|>))
import Data.Function.Uncurried (Fn2, runFn2)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Nullable (Nullable, toNullable, toMaybe)
import Data.Posix (Pid, Gid, Uid)
import Data.Posix.Signal (Signal)
import Data.Posix.Signal as Signal
import Effect (Effect)
import Effect.Exception as Exception
import Effect.Exception.Unsafe (unsafeThrow)
import Foreign (Foreign)
import Foreign.Object (Object)
import Node.Buffer (Buffer)
import Node.FS as FS
import Node.Stream (Readable, Writable, Stream)
import Unsafe.Coerce (unsafeCoerce)

-- | A handle for inter-process communication (IPC).
foreign import data Handle :: Type

newtype ChildProcess = ChildProcess ChildProcessRec

runChildProcess :: ChildProcess -> ChildProcessRec
runChildProcess (ChildProcess r) = r

-- | Note: some of these types are lies, and so it is unsafe to access some of
-- | these record fields directly.
type ChildProcessRec =
  { stdin :: Nullable (Writable ())
  , stdout :: Nullable (Readable ())
  , stderr :: Nullable (Readable ())
  , pid :: Pid
  , connected :: Boolean
  , kill :: String -> Unit
  , send :: forall r. Fn2 { | r} Handle Boolean
  , disconnect :: Effect Unit
  }

-- | The standard input stream of a child process. Note that this is only
-- | available if the process was spawned with the stdin option set to "pipe".
stdin :: ChildProcess -> Writable ()
stdin = unsafeFromNullable (missingStream "stdin") <<< _.stdin <<< runChildProcess

-- | The standard output stream of a child process. Note that this is only
-- | available if the process was spawned with the stdout option set to "pipe".
stdout :: ChildProcess -> Readable ()
stdout = unsafeFromNullable (missingStream "stdout") <<< _.stdout <<< runChildProcess

-- | The standard error stream of a child process. Note that this is only
-- | available if the process was spawned with the stderr option set to "pipe".
stderr :: ChildProcess -> Readable ()
stderr = unsafeFromNullable (missingStream "stderr") <<< _.stderr <<< runChildProcess

missingStream :: String -> String
missingStream str =
  "Node.ChildProcess: stream not available: " <> str <> "\nThis is probably "
  <> "because you passed something other than Pipe to the stdio option when "
  <> "you spawned it."

foreign import unsafeFromNullable :: forall a. String -> Nullable a -> a

-- | The process ID of a child process. Note that if the process has already
-- | exited, another process may have taken the same ID, so be careful!
pid :: ChildProcess -> Pid
pid = _.pid <<< runChildProcess

connected :: ChildProcess -> Effect Boolean
connected (ChildProcess cp) = mkEffect \_ -> cp.connected

send :: forall props. { | props } -> Handle -> ChildProcess -> Effect Boolean
send msg handle (ChildProcess cp) = mkEffect \_ -> runFn2 cp.send msg handle

disconnect :: ChildProcess -> Effect Unit
disconnect = _.disconnect <<< runChildProcess

-- | Send a signal to a child process. In the same way as the
-- | [unix kill(2) system call](https://linux.die.net/man/2/kill),
-- | sending a signal to a child process won't necessarily kill it.
-- |
-- | The resulting effects of this function depend on the process
-- | and the signal and can vary from system to system.
-- | The child process might emit an "error" event if the signal
-- | could not be delivered.
kill :: Signal -> ChildProcess -> Effect Unit
kill sig (ChildProcess cp) = mkEffect \_ -> cp.kill (Signal.toString sig)

mkEffect :: forall a. (Unit -> a) -> Effect a
mkEffect = unsafeCoerce

-- | Specifies how a child process exited; normally (with an exit code), or
-- | due to a signal.
data Exit
  = Normally Int
  | BySignal Signal

instance showExit :: Show Exit where
  show (Normally x) = "Normally " <> show x
  show (BySignal sig) = "BySignal " <> show sig

mkExit :: Nullable Int -> Nullable String -> Exit
mkExit code signal =
  case fromCode code <|> fromSignal signal of
    Just e -> e
    Nothing -> unsafeThrow "Node.ChildProcess.mkExit: Invalid arguments"
  where
  fromCode = toMaybe >>> map Normally
  fromSignal = toMaybe >=> Signal.fromString >>> map BySignal

onExit :: ChildProcess -> (Exit -> Effect Unit) -> Effect Unit
onExit = mkOnExit mkExit

foreign import mkOnExit
  :: (Nullable Int -> Nullable String -> Exit)
  -> ChildProcess
  -> (Exit -> Effect Unit)
  -> Effect Unit

onClose :: ChildProcess -> (Exit -> Effect Unit) -> Effect Unit
onClose = mkOnClose mkExit

foreign import mkOnClose
  :: (Nullable Int -> Nullable String -> Exit)
  -> ChildProcess
  -> (Exit -> Effect Unit)
  -> Effect Unit

onMessage :: ChildProcess -> (Foreign -> Maybe Handle -> Effect Unit) -> Effect Unit
onMessage = mkOnMessage Nothing Just

foreign import mkOnMessage
  :: forall a
   . Maybe a
  -> (a -> Maybe a)
  -> ChildProcess
  -> (Foreign -> Maybe Handle -> Effect Unit)
  -> Effect Unit

foreign import onDisconnect :: ChildProcess -> Effect Unit -> Effect Unit
foreign import onError :: ChildProcess -> (Error -> Effect Unit) -> Effect Unit

-- | Spawn a child process. Note that, in the event that a child process could
-- | not be spawned (for example, if the executable was not found) this will
-- | not throw an error. Instead, the `ChildProcess` will be created anyway,
-- | but it will immediately emit an 'error' event.
spawn :: String -> Array String -> SpawnOptions -> Effect ChildProcess
spawn cmd args = spawnImpl cmd args <<< convertOpts
  where
  convertOpts opts =
    { cwd: fromMaybe undefined opts.cwd
    , stdio: toActualStdIOOptions opts.stdio
    , env: toNullable opts.env
    , detached: opts.detached
    , uid: fromMaybe undefined opts.uid
    , gid: fromMaybe undefined opts.gid
    }

foreign import spawnImpl :: forall opts. String -> Array String -> { | opts } -> Effect ChildProcess

-- There's gotta be a better way.
foreign import undefined :: forall a. a

type SpawnOptions =
  { cwd :: Maybe String
  , stdio :: Array (Maybe StdIOBehaviour)
  , env :: Maybe (Object String)
  , detached :: Boolean
  , uid :: Maybe Uid
  , gid :: Maybe Gid
  }

defaultSpawnOptions :: SpawnOptions
defaultSpawnOptions =
  { cwd: Nothing
  , stdio: pipe
  , env: Nothing
  , detached: false
  , uid: Nothing
  , gid: Nothing
  }

-- | Similar to `spawn`, except that this variant will:
-- | * run the given command with the shell,
-- | * buffer output, and wait until the process has exited before calling the
-- |   callback.
-- |
-- | Note that the child process will be killed if the amount of output exceeds
-- | a certain threshold (the default is defined by Node.js).
exec
  :: String
  -> ExecOptions
  -> (ExecResult -> Effect Unit)
  -> Effect ChildProcess
exec cmd opts callback =
  execImpl cmd (convertExecOptions opts) \err stdout' stderr' ->
    callback
      { error: toMaybe err
      , stdout: stdout'
      , stderr: stderr'
      }

foreign import execImpl
  :: String
  -> ActualExecOptions
  -> (Nullable Exception.Error -> Buffer -> Buffer -> Effect Unit)
  -> Effect ChildProcess

-- | Like `exec`, except instead of using a shell, it passes the arguments
-- | directly to the specified command.
execFile
  :: String
  -> Array String
  -> ExecOptions
  -> (ExecResult -> Effect Unit)
  -> Effect ChildProcess
execFile cmd args opts callback =
  execFileImpl cmd args (convertExecOptions opts) \err stdout' stderr' ->
    callback
      { error: toMaybe err
      , stdout: stdout'
      , stderr: stderr'
      }

foreign import execFileImpl
  :: String
  -> Array String
  -> ActualExecOptions
  -> (Nullable Exception.Error -> Buffer -> Buffer -> Effect Unit)
  -> Effect ChildProcess

foreign import data ActualExecOptions :: Type

convertExecOptions :: ExecOptions -> ActualExecOptions
convertExecOptions opts = unsafeCoerce
  { cwd: fromMaybe undefined opts.cwd
  , env: fromMaybe undefined opts.env
  , timeout: fromMaybe undefined opts.timeout
  , maxBuffer: fromMaybe undefined opts.maxBuffer
  , killSignal: fromMaybe undefined opts.killSignal
  , uid: fromMaybe undefined opts.uid
  , gid: fromMaybe undefined opts.gid
  }

type ExecOptions =
  { cwd :: Maybe String
  , env :: Maybe (Object String)
  , timeout :: Maybe Number
  , maxBuffer :: Maybe Int
  , killSignal :: Maybe Signal
  , uid :: Maybe Uid
  , gid :: Maybe Gid
  }

defaultExecOptions :: ExecOptions
defaultExecOptions =
  { cwd: Nothing
  , env: Nothing
  , timeout: Nothing
  , maxBuffer: Nothing
  , killSignal: Nothing
  , uid: Nothing
  , gid: Nothing
  }

type ExecResult =
  { stderr :: Buffer
  , stdout :: Buffer
  , error :: Maybe Exception.Error
  }

-- | Generally identical to `exec`, with the exception that
-- | the method will not return until the child process has fully closed.
-- | Returns: The stdout from the command.
execSync
  :: String
  -> ExecSyncOptions
  -> Effect Buffer
execSync cmd opts =
  execSyncImpl cmd (convertExecSyncOptions opts)

foreign import execSyncImpl
  :: String
  -> ActualExecSyncOptions
  -> Effect Buffer

-- | Generally identical to `execFile`, with the exception that
-- | the method will not return until the child process has fully closed.
-- | Returns: The stdout from the command.
execFileSync
  :: String
  -> Array String
  -> ExecSyncOptions
  -> Effect Buffer
execFileSync cmd args opts =
  execFileSyncImpl cmd args (convertExecSyncOptions opts)

foreign import execFileSyncImpl
  :: String
  -> Array String
  -> ActualExecSyncOptions
  -> Effect Buffer

foreign import data ActualExecSyncOptions :: Type

convertExecSyncOptions :: ExecSyncOptions -> ActualExecSyncOptions
convertExecSyncOptions opts = unsafeCoerce
  { cwd: fromMaybe undefined opts.cwd
  , input: fromMaybe undefined opts.input
  , stdio: toActualStdIOOptions opts.stdio
  , env: fromMaybe undefined opts.env
  , timeout: fromMaybe undefined opts.timeout
  , maxBuffer: fromMaybe undefined opts.maxBuffer
  , killSignal: fromMaybe undefined opts.killSignal
  , uid: fromMaybe undefined opts.uid
  , gid: fromMaybe undefined opts.gid
  }

type ExecSyncOptions =
  { cwd :: Maybe String
  , input :: Maybe String
  , stdio :: Array (Maybe StdIOBehaviour)
  , env :: Maybe (Object String)
  , timeout :: Maybe Number
  , maxBuffer :: Maybe Int
  , killSignal :: Maybe Signal
  , uid :: Maybe Uid
  , gid :: Maybe Gid
  }

defaultExecSyncOptions :: ExecSyncOptions
defaultExecSyncOptions =
  { cwd: Nothing
  , input: Nothing
  , stdio: pipe
  , env: Nothing
  , timeout: Nothing
  , maxBuffer: Nothing
  , killSignal: Nothing
  , uid: Nothing
  , gid: Nothing
  }

-- | A special case of `spawn` for creating Node.js child processes. The first
-- | argument is the module to be run, and the second is the argv (command line
-- | arguments).
foreign import fork :: String -> Array String -> Effect ChildProcess

-- | An error which occurred inside a child process.
type Error =
  { code :: String
  , errno :: String
  , syscall :: String
  }

-- | Convert a ChildProcess.Error to a standard Error, which can then be thrown
-- | inside an Effect or Aff computation (for example).
toStandardError :: Error -> Exception.Error
toStandardError = unsafeCoerce

-- | Behaviour for standard IO streams (eg, standard input, standard output) of
-- | a child process.
-- |
-- | * `Pipe`: creates a pipe between the child and parent process, which can
-- |   then be accessed as a `Stream` via the `stdin`, `stdout`, or `stderr`
-- |   functions.
-- | * `Ignore`: ignore this stream. This will cause Node to open /dev/null and
-- |   connect it to the stream.
-- | * `ShareStream`: Connect the supplied stream to the corresponding file
-- |    descriptor in the child.
-- | * `ShareFD`: Connect the supplied file descriptor (which should be open
-- |   in the parent) to the corresponding file descriptor in the child.
data StdIOBehaviour
  = Pipe
  | Ignore
  | ShareStream (forall r. Stream r)
  | ShareFD FS.FileDescriptor

-- | Create pipes for each of the three standard IO streams.
pipe :: Array (Maybe StdIOBehaviour)
pipe = map Just [Pipe, Pipe, Pipe]

-- | Share stdin with stdin, stdout with stdout, and stderr with stderr.
inherit :: Array (Maybe StdIOBehaviour)
inherit = map Just
  [ ShareStream process.stdin
  , ShareStream process.stdout
  , ShareStream process.stderr
  ]

foreign import process :: forall props. { | props }

-- | Ignore all streams.
ignore :: Array (Maybe StdIOBehaviour)
ignore = map Just [Ignore, Ignore, Ignore]

foreign import data ActualStdIOBehaviour :: Type

toActualStdIOBehaviour :: StdIOBehaviour -> ActualStdIOBehaviour
toActualStdIOBehaviour b = case b of
  Pipe -> c "pipe"
  Ignore -> c "ignore"
  ShareFD x -> c x
  ShareStream stream -> c stream
  where
  c :: forall a. a -> ActualStdIOBehaviour
  c = unsafeCoerce

type ActualStdIOOptions = Array (Nullable ActualStdIOBehaviour)

toActualStdIOOptions :: Array (Maybe StdIOBehaviour) -> ActualStdIOOptions
toActualStdIOOptions = map (toNullable <<< map toActualStdIOBehaviour)