Fix warnings in tests

Fix warnings in 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.File where

import Prelude
import Control.Bind ((=<<))
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Trans (lift)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Core (toArray)
import Data.Argonaut.JCursor (toPrims)
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.Maybe.Unsafe (fromJust)
import Data.Either (Either(..), either)
import Data.Foldable (foldl, elem)
import Data.Traversable (traverse)
import Data.List (List(), length, reverse, filter, null, fromList, (!!))
import Selenium.Types
import Selenium.ActionSequence hiding (sequence)
import Selenium.Monad
import Selenium.Combinators (checker, awaitUrlChanged, tryToFind)
import Selenium (showLocator)
import Node.FS.Aff
import Node.Encoding (Encoding(UTF8))

import Test.Config
import SlamData.FileSystem.Routing (Routes(..), routing)
import SlamData.FileSystem.Routing.Search (searchPath)
import Routing (matchHash)
import Data.Array as Arr
import Data.String.Regex as R
import Data.String as Str
import Data.Set as S
import SlamData.Config as SDCfg
import SlamData.Config.Version as Version
import Test.Selenium.ActionSequence
import Test.Selenium.Common
import Test.Selenium.Monad
import Test.Selenium.Log

foreign import data MODULE :: !

click' :: Element -> Check Unit
click' = sequence <<< leftClick

home :: Check Unit
home = do
  getConfig >>= get <<< _.slamdataUrl
  fileComponentLoaded

findOpenItem :: String -> Check Element
findOpenItem name = tryRepeatedlyTo $ findExact =<< byXPath xPath
  where
  xPath = "//a[text()='" ++ name ++ "']"

loseItem :: String -> Check Unit
loseItem name = tryRepeatedlyTo $ loseElement =<< byXPath xPath
  where
  xPath = "//*[text()='" ++ name ++ "']"

findItem :: String -> Check Element
findItem name =
  tryRepeatedlyTo $ findExact =<< byXPath (selectXPath `xPathOr` deselectXPath)
  where
  selectXPath = "//*[@aria-label='Select " ++ name ++ "']"
  deselectXPath = "//*[@aria-label='Deselect " ++ name ++ "']"
  xPathOr x y = x ++ "|" ++ y

selectFile :: String -> Check Unit
selectFile filename = click' =<< findSingle =<< byCss (selectFileCss filename)
  where
  selectFileCss filename = "*[aria-label='Select " ++ filename ++ "']"

findTestDb :: Check Element
findTestDb = do
  config <- getConfig
  findItem config.database.name

findOpenTestDb :: Check Element
findOpenTestDb = do
  config <- getConfig
  findOpenItem config.database.name

findUploadedItem :: Check Element
findUploadedItem = do
  config <- getConfig
  findItem config.move.name

type MountConfigR =
  { host :: String
  , port :: Int
  }

mountConfigFromConfig :: Check MountConfigR
mountConfigFromConfig = do
  config <- getConfig
  pure { host : config.mongodb.host
       , port : config.mongodb.port
       }

mountDatabaseWithMountConfig :: MountConfigR -> Check Unit
mountDatabaseWithMountConfig mountConfig = do
  home
  getMountDatabaseButton >>= sequence <<< leftClick
  waitModalShown
  mac <- isMac
  chrome <- isChrome
  if mac && chrome
    then fieldByField
    else copyPaste

  where
  connectionUri :: Config -> String
  connectionUri config =
    "mongodb://"
    ++ mountConfig.host
    ++ ":"
    ++ show mountConfig.port

  fieldByField :: Check Unit
  fieldByField = tryRepeatedlyTo do
    warnMsg $ "This test doesn't check correctness of copy/paste.\n"
      <> "It's known bug of selenium/chrome/mac combination that modifier keys\n"
      <> "doesn't work"
    config <- getConfig
    nameField <- getNameField
    portField <- getPortField
    hostField <- getHostField
    pathField <- getPathField
    saveButton <- getSaveButton
    sequence do
      leftClick nameField
      keys config.mount.name
      leftClick portField
      keys $ show mountConfig.port
      leftClick hostField
      keys mountConfig.host
      leftClick pathField
      keys config.database.name
      leftClick saveButton

  copyPaste :: Check Unit
  copyPaste = tryRepeatedlyTo do
    config <- getConfig
    uriField <- getUriField
    nameField <- getNameField
    saveButton <- getSaveButton
    modifierKey <- getModifierKey
    sequence do
      leftClick nameField
      keys $ connectionUri config
      selectAll modifierKey
      copy modifierKey
      selectAll modifierKey
      keys config.mount.name

      leftClick uriField
      paste modifierKey

      leftClick saveButton

  getSaveButton :: Check Element
  getSaveButton = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.saveButton >>= findExact

  getUriField :: Check Element
  getUriField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.uriField >>= findExact

  getNameField :: Check Element
  getNameField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.nameField >>= findExact

  getPathField :: Check Element
  getPathField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.pathField >>= findExact

  getPortField :: Check Element
  getPortField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.portField >>= findExact

  getHostField :: Check Element
  getHostField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.hostField >>= findExact

  getMountDatabaseButton :: Check Element
  getMountDatabaseButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.mountDatabase

goodMountDatabase :: Check Unit
goodMountDatabase = do
  sectionMsg "MOUNT TEST DATABASE"
  mountConfigFromConfig
    >>= mountDatabaseWithMountConfig

  config <- getConfig
  tryRepeatedlyTo expectMountShown

  where
  expectMountShown :: Check Unit
  expectMountShown = do
    config <- getConfig
    void $ findItem config.mount.name

badMountDatabase :: Check Unit
badMountDatabase = do
  sectionMsg "BAD MOUNT TEST DATABASE"
  config <- getConfig
  badMountConfig
    >>= mountDatabaseWithMountConfig
  warningBox <- getElementByCss config.configureMount.warningBox "no warning box"
  -- wait for any old validation messages to disappear
  wait (checker $ not <$> isDisplayed warningBox) config.selenium.waitTime
  -- wait for the server error to appear
  wait (checker $ isDisplayed warningBox) 8000

  tryRepeatedlyTo
    $ getElementByCss config.configureMount.cancelButton "no cancel button"
    >>= sequence <<< leftClick
  waitModalDismissed
  where
    badMountConfig :: Check MountConfigR
    badMountConfig = do
      mountConfig <- mountConfigFromConfig
      pure $ mountConfig { port = mountConfig.port - 1 }

unmountDatabase :: Check Unit
unmountDatabase = do
  sectionMsg "UNMOUNT TEST DATABASE"
  home
  config <- getConfig
  click' =<< findItem config.mount.name
  click' =<< itemGetDeleteIcon =<< findItem config.mount.name
  loseItem config.mount.name
  successMsg "successfully unmounted"

checkMountedDatabase :: Check Unit
checkMountedDatabase = do
  sectionMsg "CHECK TEST DATABASE IS MOUNTED"
  enterMount
  void $ findTestDb
  successMsg "test database found"

checkConfigureMount :: Check Unit
checkConfigureMount = do
  sectionMsg "CHECK CONFIGURE MOUNT DIALOG"
  enterMount

  button <- getConfigureMountButton
  successMsg "got configure-mount button"
  sequence $ leftClick button

  config <- getConfig
  waitModalShown
  successMsg "configure-mount dialog shown"

  -- make sure a no-op edit doesn't result in a validation error
  usernameField <- getElementByCss config.configureMount.usernameField "no usernameField field"

  modifierKey <- getModifierKey
  sequence do
    leftClick usernameField
    sendBackspaces 100
    keys "hello"
    undo modifierKey

  getElementByCss config.configureMount.saveButton "no save button"
    >>= isEnabled
    >>= assertBoolean "save button should be enabled"

  where
  getConfigureMountButton :: Check Element
  getConfigureMountButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.configureMount

getItemToolbar :: Check { listGroupItem :: Element, itemToolbar :: Element}
getItemToolbar = do
  config <- getConfig
  listGroupItem <- getElementByCss config.item.main "there is no list-group-item"
  byCss config.item.toolbar
    >>= findChild listGroupItem
    >>= maybe toolbarErrorMsg (\tb -> pure { listGroupItem : listGroupItem, itemToolbar : tb })
  where
    toolbarErrorMsg = errorMsg "there is no toolbar in list-group-item"

checkItemToolbar :: Check Unit
checkItemToolbar = do
  sectionMsg "CHECK ITEM TOOLBAR"
  enterMount
  -- W/o this it will show toolbar
  sequence $ mouseToLocation {x: zero, y: zero}
  { listGroupItem : groupItem, itemToolbar : toolbar } <- getItemToolbar

  apathize do
    assertBoolean "toolbar should not be displayed" <<< not =<< isDisplayed toolbar
    successMsg "toolbar is hidden"
    sequence $ hover groupItem
    assertBoolean "hovered toolbar should be visible" =<< isDisplayed toolbar
    successMsg "hovered toolbar is visible"
  apathize do
    style <- getCssValue groupItem "background-color"
    sequence $ leftClick groupItem
    newStyle <- getCssValue groupItem "background-color"
    assertBoolean "background-color should have been changed after click'" $ newStyle /= style
    successMsg "background-color has been changed after click'"

checkURL :: Check Unit
checkURL = do
  sectionMsg "CHECKING URL"
  home
  getCurrentUrl >>= getHashFromURL >>= checkHash

  where
  checkHash :: Routes -> Check Unit
  checkHash (Salted sort search salt) = do
    successMsg "hash is correct"
    if searchPath search == Just "/"
      then successMsg "search path is correct"
      else errorMsg "incorrect search path"
  checkHash _ =
    errorMsg "need additional redirects"

enterMount :: Check Unit
enterMount = do
  home
  url <- getCurrentUrl
  config <- getConfig
  click' =<< findOpenItem config.mount.name
  wait (awaitUrlChanged url) config.selenium.waitTime
  fileComponentLoaded

goDown :: Check Unit
goDown = do
  sectionMsg "CHECKING GO DOWN"

  enterMount
  url <- getCurrentUrl
  oldHash <- either (const $ errorMsg "incorrect initial hash in goDown") pure $ matchHash routing (dropHash url)
  checkOldHash url oldHash

  where
  checkOldHash url old@(Salted oldSort oldSearch oldSalt) = do
    click' =<< findOpenTestDb
    config <- getConfig
    wait (awaitUrlChanged url) config.selenium.waitTime
    fileComponentLoaded
    getCurrentUrl >>= getHashFromURL >>= checkHashes old
  checkOldHash _ _ = errorMsg "weird initial hash in goDown"

  checkHashes (Salted oldSort oldSearch oldSalt) (Salted sort search salt) = do
    config <- getConfig
    if (oldSalt == salt) &&
       (oldSort == sort) &&
       ((searchPath search) == (Just $ "/" <> config.mount.name <> "/" <> config.database.name <> "/"))
      then successMsg "correct hash after goDown"
      else errorMsg $ "incorrect hash after goDown " <> (fromMaybe "" $ searchPath search)
  checkHashes _ _ = do
    errorMsg "weird hash after goDown"

checkBreadcrumbs :: Check Unit
checkBreadcrumbs = do
  sectionMsg "BREADCRUMBS"
  home
  texts <- bTexts
  config <- getConfig
  assertBoolean "incorrect root breadcrumb" $ elem config.breadcrumbs.home texts
  successMsg "correct root breadcrumb"

  goDown
  nTexts <- bTexts
  assertBoolean "incorrect root breadcrumb after goDown" $ elem config.breadcrumbs.home texts
  assertBoolean "breadcrumbs are not updated" $ elem config.database.name nTexts
  successMsg "breadcrumbs are updated"

  homeBreadcrumb <- getHomeBreadcrumb
  sequence $ leftClick homeBreadcrumb
  fileComponentLoaded
  checkURL
  successMsg "Ok, went home after click' on root breadcrumb"

  where
  getHomeBreadcrumb :: Check Element
  getHomeBreadcrumb =
    anchors
      >>= foldl foldMFn (pure Nothing)
      >>= maybe errHome pure

  errHome = errorMsg "There is no Home breadcrumb: since you have already checked that it exists, there is probably error in test"

  breadcrumbs :: Check Element
  breadcrumbs = do
    config <- getConfig
    getElementByCss config.breadcrumbs.main "There is no breadcrumbs"

  anchors :: Check (List Element)
  anchors = do
    bs <- breadcrumbs
    config <- getConfig
    byCss config.breadcrumbs.text
      >>= findChildren bs

  bTexts :: Check (List String)
  bTexts = anchors >>= traverse getInnerHtml

  foldMFn :: Check (Maybe Element) -> Element -> Check (Maybe Element)
  foldMFn cMe el = cMe >>= \me ->
    case me of
      Just el -> pure $ pure el
      Nothing -> do
        html <- getInnerHtml el
        config <- getConfig
        if config.breadcrumbs.home == html
          then pure $ pure el
          else pure Nothing

getItemTexts :: Check (List String)
getItemTexts = do
    config <- getConfig
    locator <- byCss config.sort.main
    els <- findElements locator
    if length els == 0
       then throwError $ error $ "No elements found using locator " ++ showLocator locator
       else pure unit
    (extractText <$>) <$> traverse getInnerHtml els
  where
  extractText =
    R.replace (R.regex "<i.+>.*</i>" R.noFlags) ""

sorting :: Check Unit
sorting = do
  sectionMsg "SORTING CHECK"
  goDown
  texts <- getItemTexts
  getCurrentUrl >>= getHashFromURL >>= checkHash texts
  where
  checkHash :: List String -> Routes -> Check Unit
  checkHash texts (Salted sort search salt) = do
    config <- getConfig
    sortButton <- getElementByCss config.sort.button "there is no sort button"
    click' sortButton
    fileComponentLoaded
    nTexts <- getItemTexts
    if reverse nTexts == texts
      then successMsg "OK, sort works"
      else errorMsg "Sorting doesn't work"
  checkHash _ _ = errorMsg "need additional redirects in sorting"

fileUpload :: Check Unit
fileUpload = do
  sectionMsg "FILE UPLOAD"
  config <- getConfig
  successMsg "went down"
  oldItems <- S.fromList <$> getItemTexts
  script """
  var els = document.getElementsByTagName('i');
  for (var i = 0; i < els.length; i++) {
    if (/hidden-file-input/.test(els[i].className)) {
      els[i].className = "";
    }
  }
  """
  uploadInput <- getElementByCss config.upload.input "There is no upload input"
  sendKeysEl config.upload.filePath uploadInput
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  navigateBack
  fileComponentLoaded

  tryRepeatedlyTo do
    items <- S.fromList <$> getItemTexts
    if S.isEmpty $ S.difference items oldItems
      then errorMsg "items has not changed after upload"
      else successMsg "new items added after upload"

shareFile :: Check Unit
shareFile = do
  sectionMsg "SHARE FILE"
  goDown
  config <- getConfig
  selectFile config.move.name
  click' =<< itemGetShareIcon =<< findUploadedItem
  waitModalShown
  successMsg "Share modal dialog appeared"
  urlFieldLocator <- byCss config.share.urlField
  urlField <- findSingle urlFieldLocator
  urlValue <- getAttribute urlField attr >>= maybe (attrFail urlFieldLocator attr) pure
  get urlValue
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, share link led to notebook"
    where
    attr = "value"
    itemGetShareIcon :: Element -> Check Element
    itemGetShareIcon item = do
      config <- getConfig
      tryRepeatedlyTo $ byAriaLabel config.share.markShare >>= childExact item

searchForUploadedFile :: Check Unit
searchForUploadedFile = do
  sectionMsg "SEARCH"
  home
  config <- getConfig
  searchInput <- getElementByCss config.search.searchInput "no search input field"
  url <- getCurrentUrl
  let filename = fromMaybe config.upload.filePath
                 $ Arr.last $ Str.split "/" config.upload.filePath
  searchButton <- getElementByCss config.search.searchButton "no search button"
  sequence $ do
    leftClick searchInput
    keys filename

  searchButton <- getElementByCss config.search.searchButton "no search button"
  sequence $ leftClick searchButton
  wait (awaitUrlChanged url) config.selenium.waitTime
  wait (awaitItemWithPhrase filename) config.selenium.waitTime
  successMsg "Searched for and found item"

awaitItemWithPhrase :: String -> Check Boolean
awaitItemWithPhrase phrase = checker $ do
  texts <- attempt getItemTexts
  pure $ case texts of
    Left _ -> false
    Right texts -> not $ null $ filter (contains phrase) texts

  where
    contains :: String -> String -> Boolean
    contains phrase = R.test (R.regex phrase R.noFlags)

awaitInNotebook :: Check Boolean
awaitInNotebook = checker $ do
  url <- getCurrentUrl
  rgx <- nbRegex
  successMsg $ "URL: " ++ url
  pure $ R.test rgx url

  where
    nbRegex = do
      config <- getConfig
      let phrase = "notebook.html#/explore/" <> config.mount.name <> "/" <> config.database.name
      pure $ R.regex phrase R.noFlags

itemGetDeleteIcon :: Element -> Check Element
itemGetDeleteIcon item = do
  config <- getConfig
  tryRepeatedlyTo $ byAriaLabel config.move.markDelete >>= childExact item

-- | Activate the item's toolbar and click' a button/icon in it
itemClickToolbarIcon :: Element -> Element -> Check Unit
itemClickToolbarIcon item icon = do
  config <- getConfig
  sequence $ leftClick item
  wait (checker $ isDisplayed icon) config.selenium.waitTime
  sequence $ leftClick icon

trashCheck :: Check Unit
trashCheck = do
  sectionMsg "TRASH CHECK"
  goDown
  expectTrashFileToBeHidden
  successMsg "Trash is hidden"
  click' =<< getShowHideButton
  expectTrashFileToBePresented
  click' =<< findOpenItem SDCfg.trashFolder
  fileComponentLoaded
  deletedItem <- findDeletedItem
  successMsg "Deleted item found"

  where
  expectTrashFileToBeHidden = loseItem SDCfg.trashFolder
  expectTrashFileToBePresented = void $ findItem SDCfg.trashFolder

  getShowHideButton :: Check Element
  getShowHideButton = do
    config <- getConfig
    tryRepeatedlyTo $ findExact =<< byAriaLabel config.toolbar.showHide

  findDeletedItem :: Check Element
  findDeletedItem = do
    config <- getConfig
    findItem config.move.other

createFolder :: Check Unit
createFolder = do
  sectionMsg "NEW FOLDER CHECK"
  goDown
  loseItem SDCfg.newFolderName
  click' =<< getNewFolderButton
  click' =<< findOpenItem SDCfg.newFolderName
  tryRepeatedlyTo $ getCurrentUrl >>= getHashFromURL >>= checkHash

  where

  getNewFolderButton :: Check Element
  getNewFolderButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.newFolder

  checkHash :: Routes -> Check Unit
  checkHash (Salted sort search salt) = do
    config <- getConfig
    let expectedPath = "/" <> config.mount.name <> "/" <> config.database.name <> "/" <> SDCfg.newFolderName <> "/"
    let actualPath = searchPath search
    if actualPath == (Just expectedPath)
      then successMsg "ok, hash correct"
      else throwError $ error $
        "hash incorrect in created folder; expected '"
         <> expectedPath
         <> "', but got '"
         <> show actualPath
         <> "'."
  checkHash _ = errorMsg "incorrect hash"

createNotebookAndThen :: Check Unit -> Check Unit
createNotebookAndThen andThen = do
  goDown
  config <- getConfig
  sequence <<< leftClick =<< getNewNotebookButton
  attempt (wait notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")
  andThen
  where
  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.newNotebook

  notebookCheck :: Check Boolean
  notebookCheck = checker $ R.test (R.regex "notebook.html" R.noFlags) <$> getCurrentUrl

createNotebook :: Check Unit
createNotebook = do
  sectionMsg "NEW NOTEBOOK CHECK"
  createNotebookAndThen do
    navigateBack
    fileComponentLoaded
    newNotebook <- getNewNotebook
    successMsg "OK, new notebook found in parent directory"

  where
  getNewNotebook :: Check Element
  getNewNotebook = findItem SDCfg.newNotebookName

checkTitle :: Check Unit
checkTitle = do
  windowTitle <- getTitle
  if Str.contains Version.slamDataVersion windowTitle
    then successMsg "Title contains version"
    else errorMsg $ "Title (" ++ windowTitle ++ ") doesn't contain version"

moveDelete :: String -> Check Unit -> String -> String -> Check Unit
moveDelete msg setUp src tgt = do
  sectionMsg $ "check move/delete " <> msg
  setUp
  config <- getConfig
  selectFile src
  click' =<< (itemGetMoveIcon =<< findItem src )
  waitModalShown
  tryRepeatedlyTo
    $ getElementByCss config.move.nameField "no rename field"
    >>= editNameField

  tryRepeatedlyTo
    $ getElementByCss config.move.submit "no submit button"
    >>= sequence <<< leftClick

  findItem tgt
  successMsg $ "ok, successfully renamed (" <> msg <> ")"

  selectFile tgt
  click' =<< (itemGetDeleteIcon =<< findItem tgt)
  tryRepeatedlyTo $ loseItem tgt
  successMsg $ "ok, successfully deleted (" <> msg <> ")"
  where
  itemGetMoveIcon :: Element -> Check Element
  itemGetMoveIcon item = do
    config <- getConfig
    tryRepeatedlyTo $ byAriaLabel config.move.markMove >>= childExact item

  editNameField :: Element -> Check Unit
  editNameField nameField = do
    config <- getConfig
    modifierKey <- getModifierKey
    sequence do
      leftClick nameField
      sendBackspaces 100
      keys tgt

moveDeleteDatabase :: Check Unit
moveDeleteDatabase = do
  config <- getConfig
  moveDelete "database" home config.mount.name config.mount.otherName

moveDeleteFolder :: Check Unit
moveDeleteFolder = do
  config <- getConfig
  moveDelete "folder" goDown SDCfg.newFolderName config.move.other

moveDeleteNotebook :: Check Unit
moveDeleteNotebook = do
  config <- getConfig
  moveDelete "notebook" goDown SDCfg.newNotebookName config.move.other

moveDeleteFile:: Check Unit
moveDeleteFile = do
  config <- getConfig
  moveDelete "file" goDown config.move.name config.move.other

downloadResource :: Check Unit
downloadResource = do
  sectionMsg "Download resource, smoke tests"
  enterMount
  goDown
  config <- getConfig
  tryRepeatedlyTo do
    btn <- getToolbarDownloadButton
    sequence $ leftClick btn
  waitModalShown
  successMsg "Ok, global download dialog shown"
  cancelDownload
  successMsg "Ok, global download dialog hidden"
  tryRepeatedlyTo do
    item <- getDownloadItem
    sequence $ hover item
    getItemDownloadButton item >>= sequence <<< leftClick
  waitModalShown
  successMsg "Ok, item download dialog shown"
  tryRepeatedlyTo do
    val <- getSourceInput >>= flip getAttribute "value"
    assertBoolean "Error, value should be equal to resource path"
      $ Just "/test-mount/testDb/smallZips" == val
  successMsg "Ok, correct source value"
  proceedDownload
  content <- readDownloaded
  checkCSV "\n" "," content >>= assertBoolean "Error: incorrect csv file"
  successMsg "Ok, csv is correct"
  rmDownloaded
  tryRepeatedlyTo do
    click' =<< getRowDelimiterInput
    sequence $ sendBackspaces 10
    sequence $ keys "*"
    click' =<< getColDelimiterInput
    sequence $ sendBackspaces 10
    sequence $ keys ";"
    proceedDownload
  semicolonContent <- readDownloaded
  checkCSV "*" ";" semicolonContent
    >>= assertBoolean "Error: incorrect csv file (after delimiters change)"
  successMsg "Ok, delimiters set correctly"
  rmDownloaded
  tryRepeatedlyTo $ getJsonTab >>= sequence <<< leftClick
  proceedDownload
  warnMsg "Note, application/json can't be autodownloaded"
  mainHandle <- getWindowHandle

  tryRepeatedlyTo do
    handles <- getAllWindowHandles
    -- This is benigh. We use newTab to download file.
    switchTo $ fromJust $ handles !! 1
  jsonContent <- tryRepeatedlyTo $ byCss "pre" >>= findExact >>= getText
  checkJson jsonContent >>= assertBoolean "Error: incorrect json"
  closeWindow
  switchTo mainHandle
  successMsg "Ok, correct json file"
  getMutliLineRadio >>= sequence <<< leftClick
  proceedDownload
  jsonMLContent <- readDownloaded
  checkMultiLineJson jsonMLContent
    >>= assertBoolean "Error: incorrect multiline json"
  successMsg "Ok, multiline json file"
  rmDownloaded
  where
  getToolbarDownloadButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.download

  cancelDownload = do
    config <- getConfig
    btn <- tryToFind $ byAriaLabel config.download.cancel
    sequence $ leftClick btn
    waitModalDismissed

  proceedDownload = do
    config <- getConfig
    btn <- tryToFind $ byAriaLabel config.download.proceed
    sequence $ leftClick btn

  getDownloadItem = do
    config <- getConfig
    findItem config.download.item
  getItemDownloadButton item = do
    config <- getConfig
    tryRepeatedlyTo $ byAriaLabel config.toolbar.download >>= childExact item

  getSourceInput = do
    config <- getConfig
    byCss config.download.sourceInputSelector >>= findExact

  getTargetInput = do
    config <- getConfig
    byCss config.download.targetInputSelector >>= findExact

  getRowDelimiterInput = do
    config <- getConfig
    byXPath config.download.rowDelimiterInputSelector >>= findExact

  getColDelimiterInput = do
    config <- getConfig
    byXPath config.download.colDelimiterInputSelector >>= findExact

  getJsonTab = do
    config <- getConfig
    byXPath config.download.jsonTabSelector >>= findExact

  getMutliLineRadio = do
    config <- getConfig
    byXPath config.download.multiLineJsonRadioSelector >>= findExact

  readDownloaded = tryRepeatedlyTo do
    config <- getConfig
    await "File has not been downloaded" do
      files <- lift $ readdir config.download.folder
      pure $ isJust $ Arr.elemIndex config.download.item files
    res <- lift $ readTextFile UTF8
           $ config.download.folder <> "/" <> config.download.item
    if res == ""
      then throwError $ error "empty file content"
      else pure res

  checkCSV rowSep colSep content = do
    config <- map _.download getConfig
    let lines = Arr.filter (not <<< eq "") $ Str.split rowSep content
        cells = Arr.filter (not <<< eq "") $ lines >>= Str.split colSep
    -- one for headers
    pure $ (Arr.length lines) == (config.rowCount + one)
      && (Arr.length cells) == (config.rowCount + one) * config.colCount

  rmDownloaded = do
    config <- getConfig
    lift $ unlink $ config.download.folder
      <> "/" <> config.download.item
    files <- lift $ readdir config.download.folder
    if isJust $ Arr.elemIndex config.download.item files
      then rmDownloaded
      else pure unit

  checkJson content = do
    config <- map _.download getConfig
    pure $ either (const false) id do
      json <- jsonParser content
      arr <- maybe (Left "it's not an array") Right $ toArray json
      let tplList = arr >>= toPrims >>> fromList
      pure $ Arr.length arr == config.rowCount
        &&  Arr.length tplList == config.rowCount * config.colCount

  checkMultiLineJson content = do
    config <- map _.download getConfig
    let arr = Arr.filter (not <<< eq "") $ Str.split "\n" content
        tplList = (either (const []) id $ traverse jsonParser arr)
                >>= toPrims >>> fromList
    pure $ Arr.length arr == config.rowCount
      && Arr.length tplList == config.rowCount * config.colCount

test :: Check Unit
test = do
  home
  startSpying
  badMountDatabase
  goodMountDatabase
  moveDeleteDatabase
  goodMountDatabase
  unmountDatabase
  goodMountDatabase
  checkMountedDatabase
  checkConfigureMount
  checkItemToolbar
  checkURL
  goDown
  checkBreadcrumbs
  sorting
  fileUpload
  searchForUploadedFile
  shareFile
  moveDeleteFile
  trashCheck
  checkTitle
  createFolder
  moveDeleteFolder
--  createNotebook
--  moveDeleteNotebook
  downloadResource

{-
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.File where

import Prelude
import Control.Bind ((=<<))
import Control.Alt ((<|>))
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Trans (lift)
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Core (toArray)
import Data.Argonaut.JCursor (toPrims)
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust, isNothing)
import Data.Maybe.Unsafe (fromJust)
import Data.Either (Either(..), either)
import Data.Foldable (foldl, elem)
import Data.Traversable (traverse)
import Data.List (List(), length, reverse, filter, null, fromList, (!!))
import Selenium.Types
import Selenium.MouseButton
import Selenium.ActionSequence hiding (sequence)
import Selenium.Monad
import Selenium.Combinators (checker, awaitUrlChanged, waitUntilJust, tryToFind)
import Selenium (showLocator)
import Node.FS.Aff
import Node.Encoding (Encoding(UTF8))

import Test.Config
import SlamData.FileSystem.Routing (Routes(..), routing)
import SlamData.FileSystem.Routing.Search (searchPath)
import Routing (matchHash)
import Data.Array as Arr
import Data.String.Regex as R
import Data.String as Str
import Data.Set as S
import SlamData.Config as SDCfg
import SlamData.Config.Version as Version
import Test.Selenium.ActionSequence
import Test.Selenium.Common
import Test.Selenium.Monad
import Test.Selenium.Log

foreign import data MODULE :: !

click' :: Element -> Check Unit
click' = sequence <<< leftClick

home :: Check Unit
home = do
  getConfig >>= get <<< _.slamdataUrl
  fileComponentLoaded

findOpenItem :: String -> Check Element
findOpenItem name = tryRepeatedlyTo $ findExact =<< byXPath xPath
  where
  xPath = "//a[text()='" ++ name ++ "']"

loseItem :: String -> Check Unit
loseItem name = tryRepeatedlyTo $ loseElement =<< byXPath xPath
  where
  xPath = "//*[text()='" ++ name ++ "']"

findItem :: String -> Check Element
findItem name =
  tryRepeatedlyTo $ findExact =<< byXPath (selectXPath `xPathOr` deselectXPath)
  where
  selectXPath = "//*[@aria-label='Select " ++ name ++ "']"
  deselectXPath = "//*[@aria-label='Deselect " ++ name ++ "']"
  xPathOr x y = x ++ "|" ++ y

selectFile :: String -> Check Unit
selectFile filename = click' =<< findSingle =<< byCss (selectFileCss filename)
  where
  selectFileCss filename = "*[aria-label='Select " ++ filename ++ "']"

findTestDb :: Check Element
findTestDb = do
  config <- getConfig
  findItem config.database.name

findOpenTestDb :: Check Element
findOpenTestDb = do
  config <- getConfig
  findOpenItem config.database.name

findUploadedItem :: Check Element
findUploadedItem = do
  config <- getConfig
  findItem config.move.name

type MountConfigR =
  { host :: String
  , port :: Int
  }

mountConfigFromConfig :: Check MountConfigR
mountConfigFromConfig = do
  config <- getConfig
  pure { host : config.mongodb.host
       , port : config.mongodb.port
       }

mountDatabaseWithMountConfig :: MountConfigR -> Check Unit
mountDatabaseWithMountConfig mountConfig = do
  home
  getMountDatabaseButton >>= sequence <<< leftClick
  waitModalShown
  mac <- isMac
  chrome <- isChrome
  if mac && chrome
    then fieldByField
    else copyPaste

  where
  connectionUri :: Config -> String
  connectionUri config =
    "mongodb://"
    ++ mountConfig.host
    ++ ":"
    ++ show mountConfig.port

  fieldByField :: Check Unit
  fieldByField = tryRepeatedlyTo do
    warnMsg $ "This test doesn't check correctness of copy/paste.\n"
      <> "It's known bug of selenium/chrome/mac combination that modifier keys\n"
      <> "doesn't work"
    config <- getConfig
    nameField <- getNameField
    portField <- getPortField
    hostField <- getHostField
    pathField <- getPathField
    saveButton <- getSaveButton
    sequence do
      leftClick nameField
      keys config.mount.name
      leftClick portField
      keys $ show mountConfig.port
      leftClick hostField
      keys mountConfig.host
      leftClick pathField
      keys config.database.name
      leftClick saveButton

  copyPaste :: Check Unit
  copyPaste = tryRepeatedlyTo do
    config <- getConfig
    uriField <- getUriField
    nameField <- getNameField
    saveButton <- getSaveButton
    modifierKey <- getModifierKey
    sequence do
      leftClick nameField
      keys $ connectionUri config
      selectAll modifierKey
      copy modifierKey
      selectAll modifierKey
      keys config.mount.name

      leftClick uriField
      paste modifierKey

      leftClick saveButton

  getSaveButton :: Check Element
  getSaveButton = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.saveButton >>= findExact

  getUriField :: Check Element
  getUriField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.uriField >>= findExact

  getNameField :: Check Element
  getNameField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.nameField >>= findExact

  getPathField :: Check Element
  getPathField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.pathField >>= findExact

  getPortField :: Check Element
  getPortField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.portField >>= findExact

  getHostField :: Check Element
  getHostField = do
    config <- getConfig
    tryRepeatedlyTo $ byCss config.configureMount.hostField >>= findExact

  getMountDatabaseButton :: Check Element
  getMountDatabaseButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.mountDatabase

goodMountDatabase :: Check Unit
goodMountDatabase = do
  sectionMsg "MOUNT TEST DATABASE"
  mountConfigFromConfig
    >>= mountDatabaseWithMountConfig

  config <- getConfig
  tryRepeatedlyTo expectMountShown

  where
  expectMountShown :: Check Unit
  expectMountShown = do
    config <- getConfig
    void $ findItem config.mount.name

badMountDatabase :: Check Unit
badMountDatabase = do
  sectionMsg "BAD MOUNT TEST DATABASE"
  config <- getConfig
  badMountConfig
    >>= mountDatabaseWithMountConfig
  warningBox <- getElementByCss config.configureMount.warningBox "no warning box"
  -- wait for any old validation messages to disappear
  wait (checker $ not <$> isDisplayed warningBox) config.selenium.waitTime
  -- wait for the server error to appear
  wait (checker $ isDisplayed warningBox) 8000

  tryRepeatedlyTo
    $ getElementByCss config.configureMount.cancelButton "no cancel button"
    >>= sequence <<< leftClick
  waitModalDismissed
  where
    badMountConfig :: Check MountConfigR
    badMountConfig = do
      mountConfig <- mountConfigFromConfig
      pure $ mountConfig { port = mountConfig.port - 1 }

unmountDatabase :: Check Unit
unmountDatabase = do
  sectionMsg "UNMOUNT TEST DATABASE"
  home
  config <- getConfig
  click' =<< findItem config.mount.name
  click' =<< itemGetDeleteIcon =<< findItem config.mount.name
  loseItem config.mount.name
  successMsg "successfully unmounted"

checkMountedDatabase :: Check Unit
checkMountedDatabase = do
  sectionMsg "CHECK TEST DATABASE IS MOUNTED"
  enterMount
  void $ findTestDb
  successMsg "test database found"

checkConfigureMount :: Check Unit
checkConfigureMount = do
  sectionMsg "CHECK CONFIGURE MOUNT DIALOG"
  enterMount

  button <- getConfigureMountButton
  successMsg "got configure-mount button"
  sequence $ leftClick button

  config <- getConfig
  waitModalShown
  successMsg "configure-mount dialog shown"

  -- make sure a no-op edit doesn't result in a validation error
  usernameField <- getElementByCss config.configureMount.usernameField "no usernameField field"

  modifierKey <- getModifierKey
  sequence do
    leftClick usernameField
    sendBackspaces 100
    keys "hello"
    undo modifierKey

  getElementByCss config.configureMount.saveButton "no save button"
    >>= isEnabled
    >>= assertBoolean "save button should be enabled"

  where
  getConfigureMountButton :: Check Element
  getConfigureMountButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.configureMount

getItemToolbar :: Check { listGroupItem :: Element, itemToolbar :: Element}
getItemToolbar = do
  config <- getConfig
  listGroupItem <- getElementByCss config.item.main "there is no list-group-item"
  byCss config.item.toolbar
    >>= findChild listGroupItem
    >>= maybe toolbarErrorMsg (\tb -> pure { listGroupItem : listGroupItem, itemToolbar : tb })
  where
    toolbarErrorMsg = errorMsg "there is no toolbar in list-group-item"

checkItemToolbar :: Check Unit
checkItemToolbar = do
  sectionMsg "CHECK ITEM TOOLBAR"
  enterMount
  -- W/o this it will show toolbar
  sequence $ mouseToLocation {x: zero, y: zero}
  { listGroupItem : groupItem, itemToolbar : toolbar } <- getItemToolbar

  apathize do
    assertBoolean "toolbar should not be displayed" <<< not =<< isDisplayed toolbar
    successMsg "toolbar is hidden"
    sequence $ hover groupItem
    assertBoolean "hovered toolbar should be visible" =<< isDisplayed toolbar
    successMsg "hovered toolbar is visible"
  apathize do
    style <- getCssValue groupItem "background-color"
    sequence $ leftClick groupItem
    newStyle <- getCssValue groupItem "background-color"
    assertBoolean "background-color should have been changed after click'" $ newStyle /= style
    successMsg "background-color has been changed after click'"

checkURL :: Check Unit
checkURL = do
  sectionMsg "CHECKING URL"
  home
  getCurrentUrl >>= getHashFromURL >>= checkHash

  where
  checkHash :: Routes -> Check Unit
  checkHash (Salted sort search salt) = do
    successMsg "hash is correct"
    if searchPath search == Just "/"
      then successMsg "search path is correct"
      else errorMsg "incorrect search path"
  checkHash _ =
    errorMsg "need additional redirects"

enterMount :: Check Unit
enterMount = do
  home
  url <- getCurrentUrl
  config <- getConfig
  click' =<< findOpenItem config.mount.name
  wait (awaitUrlChanged url) config.selenium.waitTime
  fileComponentLoaded

goDown :: Check Unit
goDown = do
  sectionMsg "CHECKING GO DOWN"

  enterMount
  url <- getCurrentUrl
  oldHash <- either (const $ errorMsg "incorrect initial hash in goDown") pure $ matchHash routing (dropHash url)
  checkOldHash url oldHash

  where
  checkOldHash url old@(Salted oldSort oldSearch oldSalt) = do
    click' =<< findOpenTestDb
    config <- getConfig
    wait (awaitUrlChanged url) config.selenium.waitTime
    fileComponentLoaded
    getCurrentUrl >>= getHashFromURL >>= checkHashes old
  checkOldHash _ _ = errorMsg "weird initial hash in goDown"

  checkHashes (Salted oldSort oldSearch oldSalt) (Salted sort search salt) = do
    config <- getConfig
    if (oldSalt == salt) &&
       (oldSort == sort) &&
       ((searchPath search) == (Just $ "/" <> config.mount.name <> "/" <> config.database.name <> "/"))
      then successMsg "correct hash after goDown"
      else errorMsg $ "incorrect hash after goDown " <> (fromMaybe "" $ searchPath search)
  checkHashes _ _ = do
    errorMsg "weird hash after goDown"

checkBreadcrumbs :: Check Unit
checkBreadcrumbs = do
  sectionMsg "BREADCRUMBS"
  home
  texts <- bTexts
  config <- getConfig
  assertBoolean "incorrect root breadcrumb" $ elem config.breadcrumbs.home texts
  successMsg "correct root breadcrumb"

  goDown
  nTexts <- bTexts
  assertBoolean "incorrect root breadcrumb after goDown" $ elem config.breadcrumbs.home texts
  assertBoolean "breadcrumbs are not updated" $ elem config.database.name nTexts
  successMsg "breadcrumbs are updated"

  homeBreadcrumb <- getHomeBreadcrumb
  sequence $ leftClick homeBreadcrumb
  fileComponentLoaded
  checkURL
  successMsg "Ok, went home after click' on root breadcrumb"

  where
  getHomeBreadcrumb :: Check Element
  getHomeBreadcrumb =
    anchors
      >>= foldl foldMFn (pure Nothing)
      >>= maybe errHome pure

  errHome = errorMsg "There is no Home breadcrumb: since you have already checked that it exists, there is probably error in test"

  breadcrumbs :: Check Element
  breadcrumbs = do
    config <- getConfig
    getElementByCss config.breadcrumbs.main "There is no breadcrumbs"

  anchors :: Check (List Element)
  anchors = do
    bs <- breadcrumbs
    config <- getConfig
    byCss config.breadcrumbs.text
      >>= findChildren bs

  bTexts :: Check (List String)
  bTexts = anchors >>= traverse getInnerHtml

  foldMFn :: Check (Maybe Element) -> Element -> Check (Maybe Element)
  foldMFn cMe el = cMe >>= \me ->
    case me of
      Just el -> pure $ pure el
      Nothing -> do
        html <- getInnerHtml el
        config <- getConfig
        if config.breadcrumbs.home == html
          then pure $ pure el
          else pure Nothing

getItemTexts :: Check (List String)
getItemTexts = do
    config <- getConfig
    locator <- byCss config.sort.main
    els <- findElements locator
    if length els == 0
       then throwError $ error $ "No elements found using locator " ++ showLocator locator
       else pure unit
    (extractText <$>) <$> traverse getInnerHtml els
  where
  extractText =
    R.replace (R.regex "<i.+>.*</i>" R.noFlags) ""

sorting :: Check Unit
sorting = do
  sectionMsg "SORTING CHECK"
  goDown
  texts <- getItemTexts
  getCurrentUrl >>= getHashFromURL >>= checkHash texts
  where
  checkHash :: List String -> Routes -> Check Unit
  checkHash texts (Salted sort search salt) = do
    config <- getConfig
    sortButton <- getElementByCss config.sort.button "there is no sort button"
    click' sortButton
    fileComponentLoaded
    nTexts <- getItemTexts
    if reverse nTexts == texts
      then successMsg "OK, sort works"
      else errorMsg "Sorting doesn't work"
  checkHash _ _ = errorMsg "need additional redirects in sorting"

fileUpload :: Check Unit
fileUpload = do
  sectionMsg "FILE UPLOAD"
  config <- getConfig
  successMsg "went down"
  oldItems <- S.fromList <$> getItemTexts
  script """
  var els = document.getElementsByTagName('i');
  for (var i = 0; i < els.length; i++) {
    if (/hidden-file-input/.test(els[i].className)) {
      els[i].className = "";
    }
  }
  """
  uploadInput <- getElementByCss config.upload.input "There is no upload input"
  sendKeysEl config.upload.filePath uploadInput
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  navigateBack
  fileComponentLoaded

  tryRepeatedlyTo do
    items <- S.fromList <$> getItemTexts
    if S.isEmpty $ S.difference items oldItems
      then errorMsg "items has not changed after upload"
      else successMsg "new items added after upload"

shareFile :: Check Unit
shareFile = do
  sectionMsg "SHARE FILE"
  goDown
  config <- getConfig
  selectFile config.move.name
  click' =<< itemGetShareIcon =<< findUploadedItem
  waitModalShown
  successMsg "Share modal dialog appeared"
  urlFieldLocator <- byCss config.share.urlField
  urlField <- findSingle urlFieldLocator
  urlValue <- getAttribute urlField attr >>= maybe (attrFail urlFieldLocator attr) pure
  get urlValue
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, share link led to notebook"
    where
    attr = "value"
    itemGetShareIcon :: Element -> Check Element
    itemGetShareIcon item = do
      config <- getConfig
      tryRepeatedlyTo $ byAriaLabel config.share.markShare >>= childExact item

searchForUploadedFile :: Check Unit
searchForUploadedFile = do
  sectionMsg "SEARCH"
  home
  config <- getConfig
  searchInput <- getElementByCss config.search.searchInput "no search input field"
  url <- getCurrentUrl
  let filename = fromMaybe config.upload.filePath
                 $ Arr.last $ Str.split "/" config.upload.filePath
  searchButton <- getElementByCss config.search.searchButton "no search button"
  sequence $ do
    leftClick searchInput
    keys filename

  searchButton <- getElementByCss config.search.searchButton "no search button"
  sequence $ leftClick searchButton
  wait (awaitUrlChanged url) config.selenium.waitTime
  wait (awaitItemWithPhrase filename) config.selenium.waitTime
  successMsg "Searched for and found item"

awaitItemWithPhrase :: String -> Check Boolean
awaitItemWithPhrase phrase = checker $ do
  texts <- attempt getItemTexts
  pure $ case texts of
    Left _ -> false
    Right texts -> not $ null $ filter (contains phrase) texts

  where
    contains :: String -> String -> Boolean
    contains phrase = R.test (R.regex phrase R.noFlags)

awaitInNotebook :: Check Boolean
awaitInNotebook = checker $ do
  url <- getCurrentUrl
  rgx <- nbRegex
  successMsg $ "URL: " ++ url
  pure $ R.test rgx url

  where
    nbRegex = do
      config <- getConfig
      let phrase = "notebook.html#/explore/" <> config.mount.name <> "/" <> config.database.name
      pure $ R.regex phrase R.noFlags

itemGetDeleteIcon :: Element -> Check Element
itemGetDeleteIcon item = do
  config <- getConfig
  tryRepeatedlyTo $ byAriaLabel config.move.markDelete >>= childExact item

-- | Activate the item's toolbar and click' a button/icon in it
itemClickToolbarIcon :: Element -> Element -> Check Unit
itemClickToolbarIcon item icon = do
  config <- getConfig
  sequence $ leftClick item
  wait (checker $ isDisplayed icon) config.selenium.waitTime
  sequence $ leftClick icon

trashCheck :: Check Unit
trashCheck = do
  sectionMsg "TRASH CHECK"
  goDown
  expectTrashFileToBeHidden
  successMsg "Trash is hidden"
  click' =<< getShowHideButton
  expectTrashFileToBePresented
  click' =<< findOpenItem SDCfg.trashFolder
  fileComponentLoaded
  deletedItem <- findDeletedItem
  successMsg "Deleted item found"

  where
  expectTrashFileToBeHidden = loseItem SDCfg.trashFolder
  expectTrashFileToBePresented = void $ findItem SDCfg.trashFolder

  getShowHideButton :: Check Element
  getShowHideButton = do
    config <- getConfig
    tryRepeatedlyTo $ findExact =<< byAriaLabel config.toolbar.showHide

  findDeletedItem :: Check Element
  findDeletedItem = do
    config <- getConfig
    findItem config.move.other

createFolder :: Check Unit
createFolder = do
  sectionMsg "NEW FOLDER CHECK"
  goDown
  loseItem SDCfg.newFolderName
  click' =<< getNewFolderButton
  click' =<< findOpenItem SDCfg.newFolderName
  tryRepeatedlyTo $ getCurrentUrl >>= getHashFromURL >>= checkHash

  where

  getNewFolderButton :: Check Element
  getNewFolderButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.newFolder

  checkHash :: Routes -> Check Unit
  checkHash (Salted sort search salt) = do
    config <- getConfig
    let expectedPath = "/" <> config.mount.name <> "/" <> config.database.name <> "/" <> SDCfg.newFolderName <> "/"
    let actualPath = searchPath search
    if actualPath == (Just expectedPath)
      then successMsg "ok, hash correct"
      else throwError $ error $
        "hash incorrect in created folder; expected '"
         <> expectedPath
         <> "', but got '"
         <> show actualPath
         <> "'."
  checkHash _ = errorMsg "incorrect hash"

createNotebookAndThen :: Check Unit -> Check Unit
createNotebookAndThen andThen = do
  goDown
  config <- getConfig
  sequence <<< leftClick =<< getNewNotebookButton
  attempt (wait notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")
  andThen
  where
  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.newNotebook

  notebookCheck :: Check Boolean
  notebookCheck = checker $ R.test (R.regex "notebook.html" R.noFlags) <$> getCurrentUrl

createNotebook :: Check Unit
createNotebook = do
  sectionMsg "NEW NOTEBOOK CHECK"
  createNotebookAndThen do
    navigateBack
    fileComponentLoaded
    newNotebook <- getNewNotebook
    successMsg "OK, new notebook found in parent directory"

  where
  getNewNotebook :: Check Element
  getNewNotebook = findItem SDCfg.newNotebookName

checkTitle :: Check Unit
checkTitle = do
  windowTitle <- getTitle
  if Str.contains Version.slamDataVersion windowTitle
    then successMsg "Title contains version"
    else errorMsg $ "Title (" ++ windowTitle ++ ") doesn't contain version"

moveDelete :: String -> Check Unit -> String -> String -> Check Unit
moveDelete msg setUp src tgt = do
  sectionMsg $ "check move/delete " <> msg
  setUp
  config <- getConfig
  selectFile src
  click' =<< (itemGetMoveIcon =<< findItem src )
  waitModalShown
  tryRepeatedlyTo
    $ getElementByCss config.move.nameField "no rename field"
    >>= editNameField

  tryRepeatedlyTo
    $ getElementByCss config.move.submit "no submit button"
    >>= sequence <<< leftClick

  findItem tgt
  successMsg $ "ok, successfully renamed (" <> msg <> ")"

  selectFile tgt
  click' =<< (itemGetDeleteIcon =<< findItem tgt)
  tryRepeatedlyTo $ loseItem tgt
  successMsg $ "ok, successfully deleted (" <> msg <> ")"
  where
  itemGetMoveIcon :: Element -> Check Element
  itemGetMoveIcon item = do
    config <- getConfig
    tryRepeatedlyTo $ byAriaLabel config.move.markMove >>= childExact item

  editNameField :: Element -> Check Unit
  editNameField nameField = do
    config <- getConfig
    modifierKey <- getModifierKey
    sequence do
      leftClick nameField
      sendBackspaces 100
      keys tgt

moveDeleteDatabase :: Check Unit
moveDeleteDatabase = do
  config <- getConfig
  moveDelete "database" home config.mount.name config.mount.otherName

moveDeleteFolder :: Check Unit
moveDeleteFolder = do
  config <- getConfig
  moveDelete "folder" goDown SDCfg.newFolderName config.move.other

moveDeleteNotebook :: Check Unit
moveDeleteNotebook = do
  config <- getConfig
  moveDelete "notebook" goDown SDCfg.newNotebookName config.move.other

moveDeleteFile:: Check Unit
moveDeleteFile = do
  config <- getConfig
  moveDelete "file" goDown config.move.name config.move.other

downloadResource :: Check Unit
downloadResource = do
  sectionMsg "Download resource, smoke tests"
  enterMount
  goDown
  config <- getConfig
  tryRepeatedlyTo do
    btn <- getToolbarDownloadButton
    sequence $ leftClick btn
  waitModalShown
  successMsg "Ok, global download dialog shown"
  cancelDownload
  successMsg "Ok, global download dialog hidden"
  tryRepeatedlyTo do
    item <- getDownloadItem
    sequence $ hover item
    getItemDownloadButton item >>= sequence <<< leftClick
  waitModalShown
  successMsg "Ok, item download dialog shown"
  tryRepeatedlyTo do
    val <- getSourceInput >>= flip getAttribute "value"
    assertBoolean "Error, value should be equal to resource path"
      $ Just "/test-mount/testDb/smallZips" == val
  successMsg "Ok, correct source value"
  proceedDownload
  content <- readDownloaded
  checkCSV "\n" "," content >>= assertBoolean "Error: incorrect csv file"
  successMsg "Ok, csv is correct"
  rmDownloaded
  tryRepeatedlyTo do
    click' =<< getRowDelimiterInput
    sequence $ sendBackspaces 10
    sequence $ keys "*"
    click' =<< getColDelimiterInput
    sequence $ sendBackspaces 10
    sequence $ keys ";"
    proceedDownload
  semicolonContent <- readDownloaded
  checkCSV "*" ";" semicolonContent
    >>= assertBoolean "Error: incorrect csv file (after delimiters change)"
  successMsg "Ok, delimiters set correctly"
  rmDownloaded
  tryRepeatedlyTo $ getJsonTab >>= sequence <<< leftClick
  proceedDownload
  warnMsg "Note, application/json can't be autodownloaded"
  mainHandle <- getWindowHandle

  tryRepeatedlyTo do
    handles <- getAllWindowHandles
    -- This is benigh. We use newTab to download file.
    switchTo $ fromJust $ handles !! 1
  jsonContent <- tryRepeatedlyTo $ byCss "pre" >>= findExact >>= getText
  checkJson jsonContent >>= assertBoolean "Error: incorrect json"
  closeWindow
  switchTo mainHandle
  successMsg "Ok, correct json file"
  getMutliLineRadio >>= sequence <<< leftClick
  proceedDownload
  jsonMLContent <- readDownloaded
  checkMultiLineJson jsonMLContent
    >>= assertBoolean "Error: incorrect multiline json"
  successMsg "Ok, multiline json file"
  rmDownloaded
  where
  getToolbarDownloadButton = do
    config <- getConfig
    tryToFind $ byAriaLabel config.toolbar.download

  cancelDownload = do
    config <- getConfig
    btn <- tryToFind $ byAriaLabel config.download.cancel
    sequence $ leftClick btn
    waitModalDismissed

  proceedDownload = do
    config <- getConfig
    btn <- tryToFind $ byAriaLabel config.download.proceed
    sequence $ leftClick btn

  getDownloadItem = do
    config <- getConfig
    findItem config.download.item
  getItemDownloadButton item = do
    config <- getConfig
    tryRepeatedlyTo $ byAriaLabel config.toolbar.download >>= childExact item

  getSourceInput = do
    config <- getConfig
    byCss config.download.sourceInputSelector >>= findExact

  getTargetInput = do
    config <- getConfig
    byCss config.download.targetInputSelector >>= findExact

  getRowDelimiterInput = do
    config <- getConfig
    byXPath config.download.rowDelimiterInputSelector >>= findExact

  getColDelimiterInput = do
    config <- getConfig
    byXPath config.download.colDelimiterInputSelector >>= findExact

  getJsonTab = do
    config <- getConfig
    byXPath config.download.jsonTabSelector >>= findExact

  getMutliLineRadio = do
    config <- getConfig
    byXPath config.download.multiLineJsonRadioSelector >>= findExact

  readDownloaded = tryRepeatedlyTo do
    config <- getConfig
    await "File has not been downloaded" do
      files <- lift $ readdir config.download.folder
      pure $ isJust $ Arr.elemIndex config.download.item files
    res <- lift $ readTextFile UTF8
           $ config.download.folder <> "/" <> config.download.item
    if res == ""
      then throwError $ error "empty file content"
      else pure res

  checkCSV rowSep colSep content = do
    config <- map _.download getConfig
    let lines = Arr.filter (not <<< eq "") $ Str.split rowSep content
        cells = Arr.filter (not <<< eq "") $ lines >>= Str.split colSep
    -- one for headers
    pure $ (Arr.length lines) == (config.rowCount + one)
      && (Arr.length cells) == (config.rowCount + one) * config.colCount

  rmDownloaded = do
    config <- getConfig
    lift $ unlink $ config.download.folder
      <> "/" <> config.download.item
    files <- lift $ readdir config.download.folder
    if isJust $ Arr.elemIndex config.download.item files
      then rmDownloaded
      else pure unit

  checkJson content = do
    config <- map _.download getConfig
    pure $ either (const false) id do
      json <- jsonParser content
      arr <- maybe (Left "it's not an array") Right $ toArray json
      let tplList = arr >>= toPrims >>> fromList
      pure $ Arr.length arr == config.rowCount
        &&  Arr.length tplList == config.rowCount * config.colCount

  checkMultiLineJson content = do
    config <- map _.download getConfig
    let arr = Arr.filter (not <<< eq "") $ Str.split "\n" content
        tplList = (either (const []) id $ traverse jsonParser arr)
                >>= toPrims >>> fromList
    pure $ Arr.length arr == config.rowCount
      && Arr.length tplList == config.rowCount * config.colCount

test :: Check Unit
test = do
  home
  startSpying
  badMountDatabase
  goodMountDatabase
  moveDeleteDatabase
  goodMountDatabase
  unmountDatabase
  goodMountDatabase
  checkMountedDatabase
  checkConfigureMount
  checkItemToolbar
  checkURL
  goDown
  checkBreadcrumbs
  sorting
  fileUpload
  searchForUploadedFile
  shareFile
  moveDeleteFile
  trashCheck
  checkTitle
  createFolder
  moveDeleteFolder
--  createNotebook
--  moveDeleteNotebook
  downloadResource


WIP Logged in status with UserCredentials

module Test.AuthDataSpec (authDataSpec) where

import Prelude
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (describe, it, pending, Spec())
import Test.Spec.Assertions (shouldEqual)
import Data.Foreign
import Data.Foreign.Class
import Data.Either
import Data.Maybe
import Data.Generic

type TweetSpec = forall eff. Spec (eff) Unit
-- convert authdata (from twitter to start with) to a purescript authdata record
-- sample data at https://boiling-heat-7831.firebaseapp.com/authspike.html
newtype UserCredentials = UserCredentials {
          provider :: String
          , uid :: String
          , token :: String
          , auth :: {}
          , expires :: Int
          }

record :: UserCredentials
record = UserCredentials { provider: "twitter", uid: "twitter:16594263", token: "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", auth: {}, expires: 1454431083 }

-- twitter has: displayName: "Willem van den Ende, id: 165 etc, username: mostalive, profileImageUrl
-- and accessToken and accessTokenSecret. not sure if we need those.
-- auth has : {provider: "twitter", uid : "twitter:16etc"}

-- ProviderUserProfile = TwitterProfile TwitterProfileRecord | GoogleProfile GoogleProfileRecord | etc

data AuthenticationStatus = LoggedOut | LoggedIn UserCredentials -- | LoggedIn UserCredentials ProviderUserProfile

derive instance genericUserCredentials :: Generic UserCredentials

instance showUserCredentials :: Show UserCredentials where
  show = gShow

instance eqUserCredentials :: Eq UserCredentials where
  eq = gEq

derive instance authenticationStatusIsGeneric :: Generic AuthenticationStatus

instance authenticationShow :: Show AuthenticationStatus where
  show = gShow

instance authenticationeq :: Eq AuthenticationStatus where
  eq = gEq

instance authenticationStatusIsForeign :: IsForeign AuthenticationStatus where
  read value | isNull value  = return LoggedOut
  read value = do
    provider <- readProp "provider" value
    uid <- readProp "uid" value
    token <- readProp "token" value
    expires <- readProp "expires" value
    let auth = {}
    return $ LoggedIn (UserCredentials {provider, uid, token, auth, expires })

authDataSpec :: TweetSpec
authDataSpec = do

  describe "Authentication status" do
   it "parses null to LoggedOut" do
      let nullStatus = readJSON "null" :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` LoggedOut
   it "parses a record to LoggedIn" do
      let nullStatus = readJSON twitterLoggedInJson :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` (LoggedIn record)

-- approximation. The empty objects have a lot of provider specific data in them
-- e.g. the 'twitter' field has user profile picture etc. different for google etc.
-- so watch out when building a parser for that part.
twitterLoggedInJson = """{ "provider": "twitter", "uid": "twitter:16594263", "twitter": {}, "token": "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", "auth": {}, "expires": 1454431083 }"""

module Test.AuthDataSpec (authDataSpec) where

import Prelude
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Test.Spec (describe, it, pending, Spec())
import Test.Spec.Assertions (shouldEqual)
import Data.Foreign
import Data.Foreign.Class
import Data.Either
import Data.Maybe
import Data.Generic

type TweetSpec = forall eff. Spec (eff) Unit
-- convert authdata (from twitter to start with) to a purescript authdata record
-- sample data at https://boiling-heat-7831.firebaseapp.com/authspike.html

record :: { provider :: String, uid :: String, twitter :: {}
          , token :: String
          , auth :: {}
          , expires :: Int
          }
record = { provider: "twitter", uid: "twitter:16594263", twitter: {}, token: "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", auth: {}, expires: 1454431083 }

-- twitter has: displayName: "Willem van den Ende, id: 165 etc, username: mostalive, profileImageUrl
-- and accessToken and accessTokenSecret. not sure if we need those.
-- auth has : {provider: "twitter", uid : "twitter:16etc"}

-- ProviderUserProfile = TwitterProfile TwitterProfileRecord | GoogleProfile GoogleProfileRecord | etc

data AuthenticationStatus = LoggedOut | LoggedIn -- | LoggedIn UserCredentials ProviderUserProfile

derive instance authenticationStatusIsGeneric :: Generic AuthenticationStatus

instance authenticationShow :: Show AuthenticationStatus where
  show = gShow

instance authenticationeq :: Eq AuthenticationStatus where
  eq = gEq

instance authenticationStatusIsForeign :: IsForeign AuthenticationStatus where
  read value | isNull value  = return LoggedOut
  read value = return LoggedIn

authDataSpec :: TweetSpec
authDataSpec = do

  describe "Authentication status" do
   it "parses null to LoggedOut" do
      let nullStatus = readJSON "null" :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` LoggedOut
   it "parses a record to LoggedIn" do
      let nullStatus = readJSON twitterLoggedInJson :: Either ForeignError AuthenticationStatus
      case nullStatus of
        Left e -> throwError $ error $ show e
        Right s -> s `shouldEqual` LoggedIn

-- approximation. The empty objects have a lot of provider specific data in them (the 'twitter' field has user profile picture etc
twitterLoggedInJson = """{ "provider": "twitter", "uid": "twitter:16594263", "twitter": {}, "token": "eyJ0eXAiOiJKV1QiLCJhbGciOiJIUzI1NiJ…", "auth": {}, "expires": 1454431083 }"""


Don't export FFI stuff

Don't export FFI stuff

module Data.JSON
  ( JSON(..)
  , JSONParser(JSONParser)
  , ReadJSON
  , runParser
  , readJSON
  , readJSONArrayItem
  , readJSONProp
  , parseJSON
  ) where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad

foreign import data JSON :: *

foreign import fromString
  "function fromString (str) { \
  \  try { \
  \    return _ps.Data_Either.Right(JSON.parse(str)); \
  \  } catch (e) { \
  \    return _ps.Data_Either.Left(e.toString()); \
  \  } \
  \}" :: String -> Either String JSON

foreign import readPrimType
  "function readPrimType (typeName) { \
  \  return function (value) { \
  \    if (toString.call(value) == '[object ' + typeName + ']') { \
  \      return _ps.Data_Either.Right(value);\
  \    } \
  \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
  \  }; \
  \}" :: forall a. String -> JSON -> Either String a

foreign import readMaybe
  "function readMaybe (value) { \
  \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
  \}" :: forall a. JSON -> Maybe JSON

foreign import readProp
  "function readProp (k) { \
  \  return function (obj) { \
  \    return _ps.Data_Either.Right(obj[k]);\
  \  }; \
  \}" :: forall a. String -> JSON -> Either String JSON

foreign import showJSONImpl
  "function showJSONImpl (obj) { \
  \  return JSON.stringify(obj); \
  \}" :: JSON -> String

instance showJSON :: Prelude.Show JSON where
  show = showJSONImpl

data JSONParser a = JSONParser (JSON -> Either String a)

runParser :: forall a. JSONParser a -> JSON -> Either String a
runParser (JSONParser p) x = p x

instance monadJSONParser :: Prelude.Monad JSONParser where
  return x = JSONParser \_ -> Right x
  (>>=) (JSONParser p) f = JSONParser \x -> case p x of
      Left err -> Left err
      Right x' -> runParser (f x') x

instance applicativeJSONParser :: Prelude.Applicative JSONParser where
  pure x = JSONParser \_ -> Right x
  (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorJSONParser :: Prelude.Functor JSONParser where
  (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

class ReadJSON a where
  readJSON :: JSONParser a

instance readJSONString :: ReadJSON String where
  readJSON = JSONParser $ readPrimType "String"

instance readJSONNumber :: ReadJSON Number where
  readJSON = JSONParser $ readPrimType "Number"

instance readJSONBoolean :: ReadJSON Boolean where
  readJSON = JSONParser $ readPrimType "Boolean"

instance readJSONArray :: (ReadJSON a) => ReadJSON [a] where
  readJSON = (JSONParser $ readPrimType "Array") >>= \xs -> JSONParser \_ ->
    readJSONArrayItem `mapM` (zip (range 0 (length xs)) xs)

readJSONArrayItem :: forall a. (ReadJSON a) => Tuple Number JSON -> Either String a
readJSONArrayItem (Tuple i x) = case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err

instance readJSONMaybe :: (ReadJSON a) => ReadJSON (Maybe a) where
  readJSON = (JSONParser $ Right <<< readMaybe) >>= \x -> JSONParser \_ ->
    case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
readJSONProp p = (JSONParser \x -> readProp p x) >>= \x -> JSONParser \_ ->
  case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

parseJSON :: forall a. (ReadJSON a) => String -> Either String a
parseJSON json = fromString json >>= runParser readJSON

module Data.JSON where

import Prelude
import Data.Array
import Data.Either
import Data.Maybe
import Data.Tuple
import Control.Monad

foreign import data JSON :: *

foreign import fromString "function fromString (str) { \
                          \  try { \
                          \    return _ps.Data_Either.Right(JSON.parse(str)); \
                          \  } catch (e) { \
                          \    return _ps.Data_Either.Left(e.toString()); \
                          \  } \
                          \}" :: String -> Either String JSON

foreign import readPrimType "function readPrimType (typeName) { \
                            \  return function (value) { \
                            \    if (toString.call(value) == '[object ' + typeName + ']') { \
                            \      return _ps.Data_Either.Right(value);\
                            \    } \
                            \    return _ps.Data_Either.Left('Value is not a ' + typeName + ''); \
                            \  }; \
                            \}" :: forall a. String -> JSON -> Either String a

foreign import readMaybe "function readMaybe (value) { \
                         \  return value === undefined || value === null ? _ps.Data_Maybe.Nothing : _ps.Data_Maybe.Just(value); \
                         \}" :: forall a. JSON -> Maybe JSON

foreign import readProp "function readProp (k) { \
                        \  return function (obj) { \
                        \    return _ps.Data_Either.Right(obj[k]);\
                        \  }; \
                        \}" :: forall a. String -> JSON -> Either String JSON

foreign import showJSONImpl "function showJSONImpl (obj) { \
                            \  return JSON.stringify(obj); \
                            \}" :: JSON -> String

instance showJSON :: Prelude.Show JSON where
  show = showJSONImpl

data JSONParser a = JSONParser (JSON -> Either String a)

runParser :: forall a. JSONParser a -> JSON -> Either String a
runParser (JSONParser p) x = p x

instance monadJSONParser :: Prelude.Monad JSONParser where
  return x = JSONParser \_ -> Right x
  (>>=) (JSONParser p) f = JSONParser \x -> case p x of
      Left err -> Left err
      Right x' -> runParser (f x') x

instance applicativeJSONParser :: Prelude.Applicative JSONParser where
  pure x = JSONParser \_ -> Right x
  (<*>) (JSONParser f) (JSONParser p) = JSONParser \x -> case f x of
      Left err -> Left err
      Right f' -> f' <$> p x

instance functorJSONParser :: Prelude.Functor JSONParser where
  (<$>) f (JSONParser p) = JSONParser \x -> f <$> p x

class ReadJSON a where
  readJSON :: JSONParser a

instance readJSONString :: ReadJSON String where
  readJSON = JSONParser $ readPrimType "String"

instance readJSONNumber :: ReadJSON Number where
  readJSON = JSONParser $ readPrimType "Number"

instance readJSONBoolean :: ReadJSON Boolean where
  readJSON = JSONParser $ readPrimType "Boolean"

instance readJSONArray :: (ReadJSON a) => ReadJSON [a] where
  readJSON = (JSONParser $ readPrimType "Array") >>= \xs -> JSONParser \_ ->
    readJSONArrayItem `mapM` (zip (range 0 (length xs)) xs)

readJSONArrayItem :: forall a. (ReadJSON a) => Tuple Number JSON -> Either String a
readJSONArrayItem (Tuple i x) = case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading item at index " ++ (show i) ++ ":\n" ++ err

instance readJSONMaybe :: (ReadJSON a) => ReadJSON (Maybe a) where
  readJSON = (JSONParser $ Right <<< readMaybe) >>= \x -> JSONParser \_ ->
    case x of
      Just x' -> runParser readJSON x' >>= return <<< Just
      Nothing -> return Nothing

readJSONProp :: forall a. (ReadJSON a) => String -> JSONParser a
readJSONProp p = (JSONParser \x -> readProp p x) >>= \x -> JSONParser \_ ->
  case runParser readJSON x of
    Right result -> Right result
    Left err -> Left $ "Error reading property '" ++ p ++ "':\n" ++ err

parseJSON :: forall a. (ReadJSON a) => String -> Either String a
parseJSON json = do
  obj <- fromString json
  runParser readJSON obj


Remove Scope module

Remove Scope module

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Scope
-- Copyright   :  (c) Phil Freeman 2013
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Utility functions for working with names in scope
--
-----------------------------------------------------------------------------

module Language.PureScript.Scope (
    usedNamesDecl,
    usedNamesValue,
    usedNamesBinder,
    usedNamesCaseAlternative,
    usedNamesDoNotationElement,
    unusedNames
  ) where

import Data.Tuple5
import Data.Array (nub)
import Data.Either
import Data.Maybe
import Data.List (List(..), (\\), enumFrom)

import Language.PureScript.Declarations
import Language.PureScript.Names

usedNames :: Tuple5 (Declaration -> [Ident]) (Value -> [Ident]) (Binder -> [Ident]) (CaseAlternative -> [Ident]) (DoNotationElement -> [Ident])
usedNames = everythingOnValues (++) f g h (const []) (const [])
  where
  f :: Declaration -> [Ident]
  f (ValueDeclaration name _ _ _ _) = [name]
  f _ = []

  g :: Value -> [Ident]
  g (Abs (Left arg) _) = [arg]
  g (Var (Qualified Nothing name)) = [name]
  g _ = []

  h :: Binder -> [Ident]
  h (VarBinder name) = [name]
  h _ = []

-- |
-- Gather all used names appearing inside a declaration
--
usedNamesDecl :: Declaration -> [Ident]
usedNamesDecl = case usedNames of
	Tuple5 f _ _ _ _ -> nub <<< f

-- |
-- Gather all used names appearing inside a value
--
usedNamesValue :: Value -> [Ident]
usedNamesValue = case usedNames of
	Tuple5 _ f _ _ _ -> nub <<< f

-- |
-- Gather all used names appearing inside a binder
--
usedNamesBinder :: Binder -> [Ident]
usedNamesBinder = case usedNames of
	Tuple5 _ _ f _ _ -> nub <<< f

-- |
-- Gather all used names appearing inside a case alternative
--
usedNamesCaseAlternative :: CaseAlternative -> [Ident]
usedNamesCaseAlternative = case usedNames of
	Tuple5 _ _ _ f _ -> nub <<< f

-- |
-- Gather all used names appearing inside a do notation element
--
usedNamesDoNotationElement :: DoNotationElement -> [Ident]
usedNamesDoNotationElement = case usedNames of
	Tuple5 _ _ _ _ f -> nub <<< f

-- |
-- Generate a set of names which are unused inside a value, of the form @_{n}@ for an integer @n@
--
unusedNames :: [Ident] -> List Ident
unusedNames allNames =
  let
    varNames = Ident <<< ((++) "_") <<< show <$> enumFrom 1
  in
    varNames \\ allNames


Language.PureScript.Sugar

Language.PureScript.Sugar

-----------------------------------------------------------------------------
--
-- Module      :  Language.PureScript.Sugar
-- Copyright   :  (c) Phil Freeman 2013-14
-- License     :  MIT
--
-- Maintainer  :  Phil Freeman <paf31@cantab.net>
-- Stability   :  experimental
-- Portability :
--
-- |
-- Desugaring passes
--
-----------------------------------------------------------------------------

module Language.PureScript.Sugar (desugar) where

import Data.Either

import Control.Monad
import Control.Monad.Trans

import Language.PureScript.Declarations
import Language.PureScript.Errors
import Language.PureScript.Supply

{-
import Language.PureScript.Sugar.Operators
import Language.PureScript.Sugar.DoNotation
import Language.PureScript.Sugar.CaseDeclarations
import Language.PureScript.Sugar.TypeDeclarations
import Language.PureScript.Sugar.TypeClasses
import Language.PureScript.Sugar.Names
-}

import Language.PureScript.Sugar.BindingGroups

-- |
-- The desugaring pipeline proceeds as follows:
--
--  * Introduce type synonyms for type class dictionaries
--
--  * Rebracket user-defined binary operators
--
--  * Desugar do-notation using the @Prelude.Monad@ type class
--
--  * Desugar top-level case declarations into explicit case expressions
--
--  * Desugar type declarations into value declarations with explicit type annotations
--
--  * Group mutually recursive value and data declarations into binding groups.
--
--  * Qualify any unqualified names and types
--
desugar :: [Module] -> SupplyT (Either ErrorStack) [Module]
desugar = {- map removeSignedLiterals
          >>> mapM desugarDoModule
          >=> desugarCasesModule
          >=> lift . (desugarTypeDeclarationsModule
                      >=> desugarImports
                      >=> rebracket)
          >=> desugarTypeClasses
          >=> -} lift <<< createBindingGroupsModule


Added isPrime from p. 44 ex. 1

Added isPrime from p. 44 ex. 1

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, length, map, null, range)
import Data.Array.Unsafe (head, last, tail)
import Control.MonadPlus (guard)
import Debug.Trace

-- re-implement the `length` function as `size`
size :: forall a. [a] -> Number
size arr =
  if null arr
     then 0
     else 1 + size (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

positives :: forall a. [Number] -> [Number]
positives arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

--factors :: Number -> [[Number]]
--factors n = filter (\pair -> product pair == n) (pairs n)

factors :: Number -> [[Number]]
factors n = do
  i <- (1..n)
  j <- (i..n)
  guard $ i * j == n
  return [i, j]

isPrime :: Number -> Boolean
isPrime n = length (factors n) == 1

main = do
  let array = (1..10)
  --print $ size array
  --print $ fact 10
  --print $ fib 10
  --print $ square array
  --print $ positives (-5..5)
  --print $ pairs 3
  --print $ factors 10
  print $ isPrime 13
  print $ isPrime 14

module Data.Recursion where
import Data.Maybe
import Data.Array (concatMap, filter, map, null)
import Data.Array.Unsafe (head, last, tail)
import Debug.Trace

-- re-implement the `length` function as `size`
size :: forall a. [a] -> Number
size arr =
  if null arr
     then 0
     else 1 + size (tail arr)

fact :: Number -> Number
fact 0 = 1
fact n = n * fact (n - 1)

fib :: Number -> Number
fib 0 = 1
fib 1 = 1
fib n = fib (n - 1) + fib (n - 2)

(..) :: Number -> Number -> [Number]
(..) = Data.Array.range

isEven :: Number -> Boolean
isEven 0 = true
isEven 1 = false
isEven n = isEven (n % 2)

countEven :: forall a. [Number] -> Number
countEven [] = 0
countEven arr =
  if isEven $ head arr
     then 1 + (countEven $ tail arr)
     else 0 + (countEven $ tail arr)

square :: forall a. [Number] -> [Number]
square arr = map (\n -> n * n) arr

infix 1 <$?>

(<$?>) fn arr = filter fn arr

positives :: forall a. [Number] -> [Number]
positives arr = (\n -> n >= 0) <$?> arr

product :: forall a. [Number] -> Number
product pair = (head pair) * (last pair)

pairs :: Number -> [[Number]]
pairs n = concatMap (\i -> map (\j -> [i, j]) (i..n)) (1..n)

--factors :: Number -> [[Number]]
--factors n = filter (\pair -> product pair == n) (pairs n)

factors :: Number -> [[Number]]
factors n = filter (\xs -> product xs == n) $ do
  i <- 1 .. n
  j <- i .. n
  --return [i, j]
  [[i, j]]

main = do
  let array = (1..10)
  print $ size array
  print $ fact 10
  print $ fib 10
  print $ square array
  print $ positives (-5..5)
  print $ pairs 3
  print $ factors 10


Fix #80: Avoid overflowing stack when parsing query params

module Node.Express.Internal.QueryString
    ( Param(..)
    , parse
    , getOne
    , getAll
    ) where

import Prelude

import Control.Monad.Trampoline (runTrampoline)
import Data.Array (head, many, mapMaybe, some)
import Data.Either (Either(..))
import Data.List (List, toUnfoldable)
import Data.Maybe (Maybe(..))
import Data.String (fromCharArray)
import Text.Parsing.Parser (ParserT, parseErrorMessage, runParserT)
import Text.Parsing.Parser.Combinators (sepBy)
import Text.Parsing.Parser.String (class StringLike, satisfy, string)

data Param = Param String String

instance showParam :: Show Param where
    show (Param name val) = "(" <> show name <> " -> " <> show val <> ")"

instance eqParam :: Eq Param where
    eq (Param n1 v1) (Param n2 v2) = (n1 == n2) && (v1 == v2)

getOne :: (Array Param) -> String -> Maybe String
getOne params key = head $ getAll params key

getAll :: (Array Param) -> String -> (Array String)
getAll params key =
    mapMaybe (\(Param name val) -> if name == key then Just val else Nothing) params

parse :: String -> Either String (Array Param)
parse str = case runTrampoline $ runParserT str queryString of
    Left err -> Left $ parseErrorMessage err
    Right result -> Right $ toUnfoldable result

queryString :: ∀ m i. Monad m => StringLike i => ParserT i m (List Param)
queryString = sepBy param (string "&")

param :: ∀ m i. Monad m => StringLike i => ParserT i m Param
param = do
    name <- liftM1 (decode <<< fromCharArray) $ some $ satisfy (\s -> s /= '=')
    _ <- string "="
    val  <- liftM1 (decode <<< fromCharArray) $ many $ satisfy (\s -> s /= '&')
    pure $ Param name val

foreign import decode :: String -> String

module Node.Express.Internal.QueryString
    ( Param(..)
    , parse
    , getOne
    , getAll
    ) where

import Prelude
import Data.Array (head, many, mapMaybe, some)
import Data.List (List, toUnfoldable)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.String (fromCharArray)
import Text.Parsing.Parser (Parser, parseErrorMessage, runParser)
import Text.Parsing.Parser.Combinators (sepBy)
import Text.Parsing.Parser.String (satisfy, string)

data Param = Param String String

instance showParam :: Show Param where
    show (Param name val) = "(" <> show name <> " -> " <> show val <> ")"

instance eqParam :: Eq Param where
    eq (Param n1 v1) (Param n2 v2) = (n1 == n2) && (v1 == v2)

getOne :: (Array Param) -> String -> Maybe String
getOne params key = head $ getAll params key

getAll :: (Array Param) -> String -> (Array String)
getAll params key =
    mapMaybe (\(Param name val) -> if name == key then Just val else Nothing) params

parse :: String -> Either String (Array Param)
parse str = case runParser str queryString of
    Left err -> Left $ parseErrorMessage err
    Right result -> Right $ toUnfoldable result

queryString :: Parser String (List Param)
queryString = sepBy param (string "&")

param :: Parser String Param
param = do
    name <- liftM1 (decode <<< fromCharArray) $ some $ satisfy (\s -> s /= '=')
    _ <- string "="
    val  <- liftM1 (decode <<< fromCharArray) $ many $ satisfy (\s -> s /= '&')
    pure $ Param name val

foreign import decode :: String -> String


Reduce duplication

Reduce duplication

{-
Copyright 2016 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 SlamData.Workspace.Card.Open.Eval
  ( evalOpen
  ) where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Functor.Mu (Mu)
import Data.Json.Extended as EJ
import Data.Lens ((^?), (?~), (.~))
import Data.List as L
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Matryoshka as M
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port.VarMap as VM
import SqlSquared as Sql
import Utils.SqlSquared (all)

evalOpen
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ QuasarDSL m
  ⇒ Open.Model
  → Port.DataMap
  → m Port.Out
evalOpen model varMap = case model of
  Nothing → CE.throwOpenError CE.OpenNoResourceSelected
  Just (Open.Resource res) → do
    filePath ← maybe (CE.throwOpenError CE.OpenNoFileSelected) pure $ res ^? R._filePath
    checkPath filePath >>= case _ of
      Nothing → do
        CEM.addSource filePath
        pure (Port.resourceOut (Port.Path filePath))
      Just err → CE.throwOpenError err
  Just (Open.Variable (VM.Var var)) → do
    res ← CEM.temporaryOutputResource
    let
      sql =
        case SM.lookup var varMap of
          Just (Right v) → do
            -- If the var is an ident, use `SELECT * FROM :ident`
            -- If the var is an literal, use `SELECT :literal AS literal`
            -- If the var is any other expr, use it directly
            case unwrapParens (unwrap v) of
              Sql.Ident _ →
                Sql.buildSelect
                  $ all
                  ∘ (Sql._relations ?~ Sql.VariRelation { vari: var, alias: Nothing })
              Sql.Literal _ →
                selectVarAsVar var v
              Sql.SetLiteral _ →
                selectVarAsVar var v
              _ →
                unwrap v
          _ →
            -- This case should be impossible - if we selected a var in the
            -- card, the var should exist during eval
            Sql.set L.Nil
      varMap' =
        map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      backendPath =
        fromMaybe Path.rootDir $ Path.parentDir res
    CE.liftQ $ QQ.viewQuery res sql varMap'
    pure $ Port.resourceOut $ Port.View res (Sql.print sql) varMap

  where

  selectVarAsVar ∷ String → VM.VarMapValue → Sql.Sql
  selectVarAsVar var v =
    Sql.buildSelect
      $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)

  unwrapParens ∷ Sql.Sql → Sql.SqlF EJ.EJsonF (Mu (Sql.SqlF EJ.EJsonF))
  unwrapParens expr =
    case M.project expr of
      Sql.Parens expr' → unwrapParens expr'
      expr' → expr'

  checkPath filePath =
    CE.liftQ $ QFS.messageIfFileNotFound filePath $ CE.OpenFileNotFound (Path.printPath filePath)

{-
Copyright 2016 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 SlamData.Workspace.Card.Open.Eval
  ( evalOpen
  ) where

import SlamData.Prelude

import Control.Monad.Writer.Class (class MonadTell)
import Data.Functor.Mu (Mu)
import Data.Json.Extended as EJ
import Data.Lens ((^?), (?~), (.~))
import Data.List as L
import Data.Path.Pathy as Path
import Data.StrMap as SM
import Matryoshka as M
import SlamData.FileSystem.Resource as R
import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.FS as QFS
import SlamData.Quasar.Query as QQ
import SlamData.Workspace.Card.Error as CE
import SlamData.Workspace.Card.Eval.Monad as CEM
import SlamData.Workspace.Card.Open.Model as Open
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Port.VarMap as VM
import SqlSquared as Sql
import Utils.SqlSquared (all)

evalOpen
  ∷ ∀ m
  . MonadThrow CE.CardError m
  ⇒ MonadTell CEM.CardLog m
  ⇒ MonadAsk CEM.CardEnv m
  ⇒ QuasarDSL m
  ⇒ Open.Model
  → Port.DataMap
  → m Port.Out
evalOpen model varMap = case model of
  Nothing → CE.throwOpenError CE.OpenNoResourceSelected
  Just (Open.Resource res) → do
    filePath ← maybe (CE.throwOpenError CE.OpenNoFileSelected) pure $ res ^? R._filePath
    checkPath filePath >>= case _ of
      Nothing → do
        CEM.addSource filePath
        pure (Port.resourceOut (Port.Path filePath))
      Just err → CE.throwOpenError err
  Just (Open.Variable (VM.Var var)) → do
    res ← CEM.temporaryOutputResource
    let
      sql =
        case SM.lookup var varMap of
          Just (Right v) → do
            -- If the var is an ident, use `SELECT * FROM :ident`
            -- If the var is an literal, use `SELECT :literal AS varName`
            -- If the var is any other expr, use it directly
            case unwrapParens (unwrap v) of
              Sql.Ident _ →
                Sql.buildSelect
                  $ all
                  ∘ (Sql._relations ?~ Sql.VariRelation { vari: var, alias: Nothing })
              Sql.Literal _ →
                Sql.buildSelect
                  $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)
              Sql.SetLiteral _ →
                Sql.buildSelect
                  $ Sql._projections .~ pure (Sql.projection (unwrap v) # Sql.as var)
              _ →
                unwrap v
          _ →
            -- This case should be impossible - if we selected a var in the
            -- card, the var should exist during eval
            Sql.set L.Nil
      varMap' =
        map (Sql.print ∘ unwrap) $ Port.flattenResources varMap
      backendPath =
        fromMaybe Path.rootDir $ Path.parentDir res
    CE.liftQ $ QQ.viewQuery res sql varMap'
    pure $ Port.resourceOut $ Port.View res (Sql.print sql) varMap

  where
  unwrapParens ∷ Sql.Sql → Sql.SqlF EJ.EJsonF (Mu (Sql.SqlF EJ.EJsonF))
  unwrapParens expr =
    case M.project expr of
      Sql.Parens expr' → unwrapParens expr'
      expr' → expr'

  checkPath filePath =
    CE.liftQ $ QFS.messageIfFileNotFound filePath $ CE.OpenFileNotFound (Path.printPath filePath)