[tests] Fix checkMountedDatabase

[tests] Fix checkMountedDatabase

thanks for catching this @garyb!

module Test.Selenium where

import Prelude
import DOM (DOM())
import Control.Apply ((*>))
import Control.Bind ((>=>), (=<<))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader.Trans
import Control.Monad.Reader.Class
import Control.Monad.Trans
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.Maybe.Unsafe (fromJust)
import Data.Either (Either(..), either, isLeft)
import Data.Foldable (foldl, elem, find)
import Data.Traversable (traverse)
import Data.List (List(), reverse)
import Text.Chalk
import Selenium
import Selenium.Types
import Selenium.MouseButton
import Selenium.ActionSequence
import Selenium.Key
import Selenium.Browser
import Selenium.Builder
import Utils.Log
import Test.Config
import qualified Control.Monad.Aff as A
import qualified Control.Monad.Aff.Console as AC
import Driver.File.Routing (Routes(..), routing)
import Driver.File.Search (searchPath)
import Routing (matchHash)
import qualified Data.String.Regex as R
import qualified Data.String as Str
import qualified Data.Char as Ch
import qualified Data.StrMap as SM
import qualified Data.Set as S
import qualified Config as SDCfg
import Test.Selenium.Common
import Test.Selenium.Monad
import Test.Selenium.Log

foreign import data MODULE :: !

foreign import makePublic :: forall a eff. String -> a -> Eff (module :: MODULE | eff) Unit

main = do
  makePublic "test" test

home :: Check Unit
home = do
  getConfig >>= goTo <<< _.slamdataUrl
  loaded

findItem :: String -> Check (Maybe Element)
findItem name = do
  config <- getConfig
  els <- css config.item.main >>= elements
  tpls <- traverse traverseFn els
  pure $ foldl foldFn Nothing tpls
  where
  traverseFn el = do
    eHtml <- attempt $ innerHtml el
    pure $ Tuple el $ case eHtml of
      Left _ -> ""
      Right html -> html
  foldFn (Just el) _ = Just el
  foldFn Nothing (Tuple el html) =
    if R.test (R.regex name R.noFlags) html
    then Just el
    else Nothing

toolbarButton :: String -> Check (Maybe Element)
toolbarButton key = do
  config <- getConfig
  toolbar <- getElementByCss config.toolbar.main "no toolbar"
  checkLocator (locator key) >>= child toolbar

  where
  locator :: String -> Element -> Check Element
  locator key el = do
    config <- getConfig
    css config.toolbar.button >>=
      children el >>=
      traverse traverseFn >>=
      foldl foldFn Nothing >>>
      maybe (throwError $ error "there is no button") pure
  traverseFn btn = do
    ch <- css key >>= child btn
    pure $ Tuple btn (isJust ch)
  foldFn :: Maybe Element -> Tuple Element Boolean -> Maybe Element
  foldFn Nothing (Tuple btn true) = Just btn
  foldFn a _ = a

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

getTestDb :: Check Element
getTestDb = findTestDb >>= maybe (errorMsg "There is no test database") pure

findUploaded :: Check (Maybe Element)
findUploaded = do
  config <- getConfig
  findItem config.move.name

mountDatabase :: Check Unit
mountDatabase = do
  sectionMsg "MOUNT TEST DATABASE"
  home
  mountButton <- getMountDatabaseButton
  actions $ leftClick mountButton
  config <- getConfig
  waitCheck modalShown config.selenium.waitTime
  uriField <- getElementByCss config.configureMount.uriField "no connection uri field"
  nameField <- getElementByCss config.configureMount.nameField "no mount name field"
  saveButton <- getElementByCss config.configureMount.saveButton "no save button"

  let connectionUri = "mongodb://" ++ config.mongodb.host ++ ":" ++ show config.mongodb.port ++ "/"
  actions $ do
    -- a strange hack follows to get the uri onto the clipboard, since the uri
    -- field cannot be edited except by pasting.
    leftClick nameField
    sendKeys connectionUri
    sendSelectAll
    sendCopy
    sendSelectAll
    sendKeys config.mount.name

    leftClick uriField
    sendPaste
    leftClick saveButton

  waitCheck mountShown config.selenium.waitTime

  where
  getMountDatabaseButton :: Check Element
  getMountDatabaseButton = do
    config <- getConfig
    toolbarButton config.toolbar.mountDatabase
      >>= maybe (errorMsg "No mount database button") pure

  mountShown :: Check Boolean
  mountShown = do
    config <- getConfig
    item <- findItem config.mount.name
    case item of
       Just _ -> pure true
       Nothing -> later 1000 mountShown

checkMountedDatabase :: Check Unit
checkMountedDatabase = do
  sectionMsg "CHECK TEST DATABASE IS MOUNTED"
  enterMount
  _ <- getTestDb
  successMsg "test database found"

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

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

  config <- getConfig
  waitCheck modalShown config.selenium.waitTime
  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"
  actions do
    leftClick usernameField
    sendSelectAll
    sendKeys "hello"
    sendUndo

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

  where
  getConfigureMountButton :: Check Element
  getConfigureMountButton = do
    config <- getConfig
    toolbarButton config.toolbar.configureMount
      >>= maybe (errorMsg "No configure mount button") pure

getItemToolbar :: Check { listGroupItem :: Element, itemToolbar :: Element}
getItemToolbar = do
  config <- getConfig
  listGroupItem <- getElementByCss config.item.main "there is no list-group-item"
  css config.item.toolbar
    >>= child 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
  { listGroupItem : groupItem, itemToolbar : toolbar } <- getItemToolbar
  apathize do
    assertBoolean "toolbar should not be displayed" <<< not =<< visible toolbar
    successMsg "toolbar is hidden"
    actions $ hover groupItem
    assertBoolean "hovered toolbar should be visible" =<< visible toolbar
    successMsg "hovered toolbar is visible"
  apathize do
    style <- getCss groupItem "background-color"
    actions $ leftClick groupItem
    newStyle <- getCss 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
  getURL >>= 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 <- getURL
  config <- getConfig
  mountItem <- findItem config.mount.name >>= maybe (errorMsg "No mount item") pure
  actions $ doubleClick leftButton mountItem
  waitCheck (awaitUrlChanged url *> pure true) config.selenium.waitTime
  loaded

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

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

  where

  checkOldHash url el old@(Salted oldSort oldSearch oldSalt) = do
    actions $ doubleClick leftButton el
    config <- getConfig
    waitCheck (awaitUrlChanged url *> pure true) config.selenium.waitTime
    loaded
    getURL >>= 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
  actions $ leftClick homeBreadcrumb
  loaded
  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
    css config.breadcrumbs.text
      >>= children bs

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

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

getItemTexts :: Check (List String)
getItemTexts = do
    config <- getConfig
    els <- css config.sort.main >>= elements
    (extractText <$>) <$> traverse innerHtml els
  where
  extractText =
    R.replace (R.regex "<i.+>.*</i>" R.noFlags) ""

sorting :: Check Unit
sorting = do
  sectionMsg "SORTING CHECK"
  goDown
  texts <- getItemTexts
  getURL >>= 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"
    actions $ click leftButton sortButton
    loaded
    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"
  goDown
  config <- getConfig

  successMsg "went down"
  uploadInput <- getElementByCss config.upload.input "There is no upload input"
  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 = "";
    }
  }
  """

  keys config.upload.filePath uploadInput
  waitCheck inNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  back
  loaded

  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"

  where
  inNotebook = do
    url <- getURL
    rgx <- nbRegex
    successMsg $ "URL: " ++ url
    if R.test rgx url
      then pure true
      else later 1000 inNotebook

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

moveDelete :: Check Unit
moveDelete = do
  sectionMsg "MOVE DELETE"
  goDown

  getUploadedItem
    >>= checkMove
    >>= checkDelete

  where
  errUploaded = errorMsg "File has not been uploaded"

  getUploadedItem :: Check Element
  getUploadedItem =
    findUploaded
      >>= maybe (errorMsg "File has not been uploade") pure

  -- | Move an item, and return the new/moved item
  checkMove :: Element -> Check Element
  checkMove item = do
    config <- getConfig
    itemGetMoveIcon item >>= itemClickToolbarIcon item
    waitCheck modalShown config.selenium.waitTime

    getElementByCss config.move.nameField "no rename field"
      >>= editNameField

    getElementByCss config.move.submit "no submit button"
      >>= actions <<< leftClick

    waitCheck (later 3000 $ pure false) 5000
    renamedItem <- findItem config.move.other >>= maybe (errorMsg "not renamed") pure
    successMsg "successfully renamed"
    pure renamedItem

    where
      -- | Type a new name into the "name" field
      editNameField :: Element -> Check Unit
      editNameField nameField = do
        config <- getConfig
        actions do
          leftClick nameField
          sendSelectAll
          sendKeys $ Str.fromChar $ Ch.fromCharCode 57367
          sendKeys config.move.other

      -- | Get an item's "move/rename" icon
      itemGetMoveIcon :: Element -> Check Element
      itemGetMoveIcon item =
        checkLocator moveLoc
          >>= child item
          >>= maybe (errorMsg "no move/rename icon") pure

  checkDelete :: Element -> Check Unit
  checkDelete item = do
    config <- getConfig
    itemGetDeleteIcon item >>= itemClickToolbarIcon item
    waitCheck (later 3000 $ pure false) 5000
    findItem config.move.other
      >>= maybe (pure unit) (const $ errorMsg "not deleted")
    successMsg "successfully deleted"

    where
      itemGetDeleteIcon :: Element -> Check Element
      itemGetDeleteIcon item =
        checkLocator deleteLoc
          >>= child item
          >>= maybe (errorMsg "no delete icon") pure

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

  moveLoc :: Element -> Check Element
  moveLoc el = getConfig >>= \config -> buttonLoc config.move.markMove el

  deleteLoc :: Element -> Check Element
  deleteLoc el = getConfig >>= \config -> buttonLoc config.move.markDelete el

  buttonLoc :: String -> Element -> Check Element
  buttonLoc ty el = do
    config <- getConfig
    tpls <- css config.move.button >>= children el >>=
      traverse (\el -> Tuple el <$> (css ty >>= child el))
    maybe (throwError $ error $ "no such button " <> ty)
      pure $ foldl foldFn Nothing tpls
    where
    foldFn (Just el) _ = Just el
    foldFn Nothing (Tuple el Nothing) = Nothing
    foldFn Nothing (Tuple el (Just _)) = Just el

trashCheck :: Check Unit
trashCheck = do
  sectionMsg "TRASH CHECK"
  goDown
  assertBoolean "Trash must not be shown" <<< not =<< isTrashVisible
  successMsg "Trash is hidden"

  showHideButton <- getShowHideButton
  actions $ leftClick showHideButton
  waitCheck (later 1000 $ pure true) 2000
  assertBoolean "Trash should be shown" =<< isTrashVisible

  trashItem <- fromJust <$> findItem trashKey
  actions $ doubleClick leftButton trashItem
  loaded
  deletedItem <- findDeletedItem
  successMsg "Deleted item found"

  where
  isTrashVisible :: Check Boolean
  isTrashVisible =
    findItem trashKey
      >>= maybe (pure false) visible

  trashKey :: String
  trashKey = R.replace (R.regex "\\." R.noFlags{global=true}) "\\." SDCfg.trashFolder

  getShowHideButton :: Check Element
  getShowHideButton = do
    config <- getConfig
    toolbarButton config.toolbar.showHide
      >>= maybe (errorMsg "No show/hide button") pure

  findDeletedItem :: Check Element
  findDeletedItem = do
    config <- getConfig
    findItem config.move.other
      >>= maybe (errorMsg "Can't find deleted item") pure

createFolder :: Check Unit
createFolder = do
  sectionMsg "NEW FOLDER CHECK"
  goDown
  config <- getConfig

  newFolderButton <- getNewFolderButton
  actions $ leftClick newFolderButton
  waitCheck (later 1000 $ pure true) config.selenium.waitTime

  folder <- getNewFolder
  actions $ doubleClick leftButton folder
  loaded

  getURL >>= getHashFromURL >>= checkHash

  where

  getNewFolderButton :: Check Element
  getNewFolderButton = do
    config <- getConfig
    toolbarButton config.toolbar.newFolder
      >>= maybe (errorMsg "No create folder button") pure

  getNewFolder :: Check Element
  getNewFolder =
    findItem SDCfg.newFolderName
      >>= maybe (errorMsg "new folder has not been created") pure

  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 errorMsg $
        "hash incorrect in created folder; expected '"
         <> expectedPath
         <> "', but got '"
         <> show actualPath
         <> "'."
  checkHash _ = errorMsg "incorrect hash"

createNotebook :: Check Unit
createNotebook = do
  sectionMsg "NEW NOTEBOOK CHECK"
  goDown
  config <- getConfig
  actions <<< leftClick =<< getNewNotebookButton
  attempt (waitCheck notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")

  back
  loaded
  newNotebook <- getNewNotebook
  successMsg "OK, new notebook found in parent directory"

  where
  getNewNotebook :: Check Element
  getNewNotebook =
    findItem SDCfg.newNotebookName
      >>= maybe (errorMsg "No notebook in parent directory") pure

  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    toolbarButton config.toolbar.newNotebook
      >>= maybe (errorMsg "No create notebook button") pure

  notebookCheck :: Check Boolean
  notebookCheck = do
    url <- getURL
    if R.test (R.regex "notebook.html" R.noFlags) url
      then pure true
      else later 1000 notebookCheck

-- TODO: Test the version in the nav bar
title :: Check Unit
title = do
  driver <- getDriver
  config <- getConfig
  windowTitle <- lift $ getTitle driver
  if Str.contains config.version windowTitle
    then successMsg "Title contains version"
    else errorMsg $ "Title (" ++ windowTitle ++ ") doesn't contain version"

test :: Config -> A.Aff _ Unit
test config =
  maybe error go $ str2browser config.selenium.browser
  where
  error = void $ AC.log $ red "Incorrect browser"
  go br = do
    AC.log $ yellow $ config.selenium.browser <> " setted as browser for tests\n\n"
    driver <- build $ browser br
    res <- A.attempt $ flip runReaderT {config: config, driver: driver} do
      home
      mountDatabase
      checkMountedDatabase
      checkConfigureMount
      checkItemToolbar
      checkURL
      goDown
      checkBreadcrumbs
      sorting
      fileUpload
      moveDelete
      trashCheck
      title
      createFolder
      createNotebook
    case res of
      Left e -> do
        quit driver
        throwError e
      Right _ ->
        quit driver

module Test.Selenium where

import Prelude
import DOM (DOM())
import Control.Apply ((*>))
import Control.Bind ((>=>), (=<<))
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (log, CONSOLE())
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Control.Monad.Reader.Trans
import Control.Monad.Reader.Class
import Control.Monad.Trans
import Data.Tuple (Tuple(..))
import Data.Maybe (Maybe(..), maybe, fromMaybe, isJust)
import Data.Maybe.Unsafe (fromJust)
import Data.Either (Either(..), either, isLeft)
import Data.Foldable (foldl, elem, find)
import Data.Traversable (traverse)
import Data.List (List(), reverse)
import Text.Chalk
import Selenium
import Selenium.Types
import Selenium.MouseButton
import Selenium.ActionSequence
import Selenium.Key
import Selenium.Browser
import Selenium.Builder
import Utils.Log
import Test.Config
import qualified Control.Monad.Aff as A
import qualified Control.Monad.Aff.Console as AC
import Driver.File.Routing (Routes(..), routing)
import Driver.File.Search (searchPath)
import Routing (matchHash)
import qualified Data.String.Regex as R
import qualified Data.String as Str
import qualified Data.Char as Ch
import qualified Data.StrMap as SM
import qualified Data.Set as S
import qualified Config as SDCfg
import Test.Selenium.Common
import Test.Selenium.Monad
import Test.Selenium.Log

foreign import data MODULE :: !

foreign import makePublic :: forall a eff. String -> a -> Eff (module :: MODULE | eff) Unit

main = do
  makePublic "test" test

home :: Check Unit
home = do
  getConfig >>= goTo <<< _.slamdataUrl
  loaded

findItem :: String -> Check (Maybe Element)
findItem name = do
  config <- getConfig
  els <- css config.item.main >>= elements
  tpls <- traverse traverseFn els
  pure $ foldl foldFn Nothing tpls
  where
  traverseFn el = do
    eHtml <- attempt $ innerHtml el
    pure $ Tuple el $ case eHtml of
      Left _ -> ""
      Right html -> html
  foldFn (Just el) _ = Just el
  foldFn Nothing (Tuple el html) =
    if R.test (R.regex name R.noFlags) html
    then Just el
    else Nothing

toolbarButton :: String -> Check (Maybe Element)
toolbarButton key = do
  config <- getConfig
  toolbar <- getElementByCss config.toolbar.main "no toolbar"
  checkLocator (locator key) >>= child toolbar

  where
  locator :: String -> Element -> Check Element
  locator key el = do
    config <- getConfig
    css config.toolbar.button >>=
      children el >>=
      traverse traverseFn >>=
      foldl foldFn Nothing >>>
      maybe (throwError $ error "there is no button") pure
  traverseFn btn = do
    ch <- css key >>= child btn
    pure $ Tuple btn (isJust ch)
  foldFn :: Maybe Element -> Tuple Element Boolean -> Maybe Element
  foldFn Nothing (Tuple btn true) = Just btn
  foldFn a _ = a

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

getTestDb :: Check Element
getTestDb = findTestDb >>= maybe (errorMsg "There is no test database") pure

findUploaded :: Check (Maybe Element)
findUploaded = do
  config <- getConfig
  findItem config.move.name

mountDatabase :: Check Unit
mountDatabase = do
  sectionMsg "MOUNT TEST DATABASE"
  home
  mountButton <- getMountDatabaseButton
  actions $ leftClick mountButton
  config <- getConfig
  waitCheck modalShown config.selenium.waitTime
  uriField <- getElementByCss config.configureMount.uriField "no connection uri field"
  nameField <- getElementByCss config.configureMount.nameField "no mount name field"
  saveButton <- getElementByCss config.configureMount.saveButton "no save button"

  let connectionUri = "mongodb://" ++ config.mongodb.host ++ ":" ++ show config.mongodb.port ++ "/"
  actions $ do
    -- a strange hack follows to get the uri onto the clipboard, since the uri
    -- field cannot be edited except by pasting.
    leftClick nameField
    sendKeys connectionUri
    sendSelectAll
    sendCopy
    sendSelectAll
    sendKeys config.mount.name

    leftClick uriField
    sendPaste
    leftClick saveButton

  waitCheck mountShown config.selenium.waitTime

  where
  getMountDatabaseButton :: Check Element
  getMountDatabaseButton = do
    config <- getConfig
    toolbarButton config.toolbar.mountDatabase
      >>= maybe (errorMsg "No mount database button") pure

  mountShown :: Check Boolean
  mountShown = do
    config <- getConfig
    item <- findItem config.mount.name
    case item of
       Just _ -> pure true
       Nothing -> later 1000 mountShown

checkMountedDatabase :: Check Unit
checkMountedDatabase = do
  sectionMsg "CHECK TEST DATABASE IS MOUNTED"
  home
  -- _ <- getTestDb
  successMsg "test database found"

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

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

  config <- getConfig
  waitCheck modalShown config.selenium.waitTime
  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"
  actions do
    leftClick usernameField
    sendSelectAll
    sendKeys "hello"
    sendUndo

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

  where
  getConfigureMountButton :: Check Element
  getConfigureMountButton = do
    config <- getConfig
    toolbarButton config.toolbar.configureMount
      >>= maybe (errorMsg "No configure mount button") pure

getItemToolbar :: Check { listGroupItem :: Element, itemToolbar :: Element}
getItemToolbar = do
  config <- getConfig
  listGroupItem <- getElementByCss config.item.main "there is no list-group-item"
  css config.item.toolbar
    >>= child 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
  { listGroupItem : groupItem, itemToolbar : toolbar } <- getItemToolbar
  apathize do
    assertBoolean "toolbar should not be displayed" <<< not =<< visible toolbar
    successMsg "toolbar is hidden"
    actions $ hover groupItem
    assertBoolean "hovered toolbar should be visible" =<< visible toolbar
    successMsg "hovered toolbar is visible"
  apathize do
    style <- getCss groupItem "background-color"
    actions $ leftClick groupItem
    newStyle <- getCss 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
  getURL >>= 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 <- getURL
  config <- getConfig
  mountItem <- findItem config.mount.name >>= maybe (errorMsg "No mount item") pure
  actions $ doubleClick leftButton mountItem
  waitCheck (awaitUrlChanged url *> pure true) config.selenium.waitTime
  loaded

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

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

  where

  checkOldHash url el old@(Salted oldSort oldSearch oldSalt) = do
    actions $ doubleClick leftButton el
    config <- getConfig
    waitCheck (awaitUrlChanged url *> pure true) config.selenium.waitTime
    loaded
    getURL >>= 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
  actions $ leftClick homeBreadcrumb
  loaded
  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
    css config.breadcrumbs.text
      >>= children bs

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

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

getItemTexts :: Check (List String)
getItemTexts = do
    config <- getConfig
    els <- css config.sort.main >>= elements
    (extractText <$>) <$> traverse innerHtml els
  where
  extractText =
    R.replace (R.regex "<i.+>.*</i>" R.noFlags) ""

sorting :: Check Unit
sorting = do
  sectionMsg "SORTING CHECK"
  goDown
  texts <- getItemTexts
  getURL >>= 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"
    actions $ click leftButton sortButton
    loaded
    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"
  goDown
  config <- getConfig

  successMsg "went down"
  uploadInput <- getElementByCss config.upload.input "There is no upload input"
  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 = "";
    }
  }
  """

  keys config.upload.filePath uploadInput
  waitCheck inNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  back
  loaded

  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"

  where
  inNotebook = do
    url <- getURL
    rgx <- nbRegex
    successMsg $ "URL: " ++ url
    if R.test rgx url
      then pure true
      else later 1000 inNotebook

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

moveDelete :: Check Unit
moveDelete = do
  sectionMsg "MOVE DELETE"
  goDown

  getUploadedItem
    >>= checkMove
    >>= checkDelete

  where
  errUploaded = errorMsg "File has not been uploaded"

  getUploadedItem :: Check Element
  getUploadedItem =
    findUploaded
      >>= maybe (errorMsg "File has not been uploade") pure

  -- | Move an item, and return the new/moved item
  checkMove :: Element -> Check Element
  checkMove item = do
    config <- getConfig
    itemGetMoveIcon item >>= itemClickToolbarIcon item
    waitCheck modalShown config.selenium.waitTime

    getElementByCss config.move.nameField "no rename field"
      >>= editNameField

    getElementByCss config.move.submit "no submit button"
      >>= actions <<< leftClick

    waitCheck (later 3000 $ pure false) 5000
    renamedItem <- findItem config.move.other >>= maybe (errorMsg "not renamed") pure
    successMsg "successfully renamed"
    pure renamedItem

    where
      -- | Type a new name into the "name" field
      editNameField :: Element -> Check Unit
      editNameField nameField = do
        config <- getConfig
        actions do
          leftClick nameField
          sendSelectAll
          sendKeys $ Str.fromChar $ Ch.fromCharCode 57367
          sendKeys config.move.other

      -- | Get an item's "move/rename" icon
      itemGetMoveIcon :: Element -> Check Element
      itemGetMoveIcon item =
        checkLocator moveLoc
          >>= child item
          >>= maybe (errorMsg "no move/rename icon") pure

  checkDelete :: Element -> Check Unit
  checkDelete item = do
    config <- getConfig
    itemGetDeleteIcon item >>= itemClickToolbarIcon item
    waitCheck (later 3000 $ pure false) 5000
    findItem config.move.other
      >>= maybe (pure unit) (const $ errorMsg "not deleted")
    successMsg "successfully deleted"

    where
      itemGetDeleteIcon :: Element -> Check Element
      itemGetDeleteIcon item =
        checkLocator deleteLoc
          >>= child item
          >>= maybe (errorMsg "no delete icon") pure

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

  moveLoc :: Element -> Check Element
  moveLoc el = getConfig >>= \config -> buttonLoc config.move.markMove el

  deleteLoc :: Element -> Check Element
  deleteLoc el = getConfig >>= \config -> buttonLoc config.move.markDelete el

  buttonLoc :: String -> Element -> Check Element
  buttonLoc ty el = do
    config <- getConfig
    tpls <- css config.move.button >>= children el >>=
      traverse (\el -> Tuple el <$> (css ty >>= child el))
    maybe (throwError $ error $ "no such button " <> ty)
      pure $ foldl foldFn Nothing tpls
    where
    foldFn (Just el) _ = Just el
    foldFn Nothing (Tuple el Nothing) = Nothing
    foldFn Nothing (Tuple el (Just _)) = Just el

trashCheck :: Check Unit
trashCheck = do
  sectionMsg "TRASH CHECK"
  goDown
  assertBoolean "Trash must not be shown" <<< not =<< isTrashVisible
  successMsg "Trash is hidden"

  showHideButton <- getShowHideButton
  actions $ leftClick showHideButton
  waitCheck (later 1000 $ pure true) 2000
  assertBoolean "Trash should be shown" =<< isTrashVisible

  trashItem <- fromJust <$> findItem trashKey
  actions $ doubleClick leftButton trashItem
  loaded
  deletedItem <- findDeletedItem
  successMsg "Deleted item found"

  where
  isTrashVisible :: Check Boolean
  isTrashVisible =
    findItem trashKey
      >>= maybe (pure false) visible

  trashKey :: String
  trashKey = R.replace (R.regex "\\." R.noFlags{global=true}) "\\." SDCfg.trashFolder

  getShowHideButton :: Check Element
  getShowHideButton = do
    config <- getConfig
    toolbarButton config.toolbar.showHide
      >>= maybe (errorMsg "No show/hide button") pure

  findDeletedItem :: Check Element
  findDeletedItem = do
    config <- getConfig
    findItem config.move.other
      >>= maybe (errorMsg "Can't find deleted item") pure

createFolder :: Check Unit
createFolder = do
  sectionMsg "NEW FOLDER CHECK"
  goDown
  config <- getConfig

  newFolderButton <- getNewFolderButton
  actions $ leftClick newFolderButton
  waitCheck (later 1000 $ pure true) config.selenium.waitTime

  folder <- getNewFolder
  actions $ doubleClick leftButton folder
  loaded

  getURL >>= getHashFromURL >>= checkHash

  where

  getNewFolderButton :: Check Element
  getNewFolderButton = do
    config <- getConfig
    toolbarButton config.toolbar.newFolder
      >>= maybe (errorMsg "No create folder button") pure

  getNewFolder :: Check Element
  getNewFolder =
    findItem SDCfg.newFolderName
      >>= maybe (errorMsg "new folder has not been created") pure

  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 errorMsg $
        "hash incorrect in created folder; expected '"
         <> expectedPath
         <> "', but got '"
         <> show actualPath
         <> "'."
  checkHash _ = errorMsg "incorrect hash"

createNotebook :: Check Unit
createNotebook = do
  sectionMsg "NEW NOTEBOOK CHECK"
  goDown
  config <- getConfig
  actions <<< leftClick =<< getNewNotebookButton
  attempt (waitCheck notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")

  back
  loaded
  newNotebook <- getNewNotebook
  successMsg "OK, new notebook found in parent directory"

  where
  getNewNotebook :: Check Element
  getNewNotebook =
    findItem SDCfg.newNotebookName
      >>= maybe (errorMsg "No notebook in parent directory") pure

  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    toolbarButton config.toolbar.newNotebook
      >>= maybe (errorMsg "No create notebook button") pure

  notebookCheck :: Check Boolean
  notebookCheck = do
    url <- getURL
    if R.test (R.regex "notebook.html" R.noFlags) url
      then pure true
      else later 1000 notebookCheck

-- TODO: Test the version in the nav bar
title :: Check Unit
title = do
  driver <- getDriver
  config <- getConfig
  windowTitle <- lift $ getTitle driver
  if Str.contains config.version windowTitle
    then successMsg "Title contains version"
    else errorMsg $ "Title (" ++ windowTitle ++ ") doesn't contain version"

test :: Config -> A.Aff _ Unit
test config =
  maybe error go $ str2browser config.selenium.browser
  where
  error = void $ AC.log $ red "Incorrect browser"
  go br = do
    AC.log $ yellow $ config.selenium.browser <> " setted as browser for tests\n\n"
    driver <- build $ browser br
    res <- A.attempt $ flip runReaderT {config: config, driver: driver} do
      home
      mountDatabase
      checkMountedDatabase
      checkConfigureMount
      checkItemToolbar
      checkURL
      goDown
      checkBreadcrumbs
      sorting
      fileUpload
      moveDelete
      trashCheck
      title
      createFolder
      createNotebook
    case res of
      Left e -> do
        quit driver
        throwError e
      Right _ ->
        quit driver


[SD-1552] AuthRedirect: make 'prompt' and 'authuser' optional

{-
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.AuthRedirect.RedirectHashPayload
  ( RedirectHashPayload
  , uriHashParser
  , parseUriHash
  ) where

import SlamData.Prelude

import Data.List as L
import Data.String as S
import Data.StrMap as SM

import Text.Parsing.StringParser as P
import Text.Parsing.StringParser.Combinators as PC
import Text.Parsing.StringParser.String as PS

import OIDCCryptUtils.Types as OIDC

type RedirectHashPayload =
  { idToken :: OIDC.IdToken
  , authUser :: Maybe String
  , state :: OIDC.BoundStateJWS
  , prompt :: Maybe String
  }

parameterParser :: P.Parser (Tuple String String)
parameterParser = do
  key <- PC.many (PS.noneOf ['=']) <#> L.fromList >>> S.fromCharArray
  PS.char '='
  val <- PC.many (PS.noneOf ['&']) <#> L.fromList >>> S.fromCharArray
  pure $ Tuple key val

parametersParser :: P.Parser (SM.StrMap String)
parametersParser =
  PC.sepBy parameterParser (PS.char '&')
    <#> SM.fromFoldable

-- | Parse the payload from the URI hash. Example:
-- |
-- |     #id_token=foo&authuser=0&hd=slamdata.com&state=bar&prompt=consent
-- |
uriHashParser :: P.Parser RedirectHashPayload
uriHashParser = do
  PS.char '#'
  params <- parametersParser
  let
    authUser = SM.lookup "authuser" params
    prompt = SM.lookup "prompt" params

  let lookup key = SM.lookup key params # maybe (P.fail $ "missing " <> key) pure
  idToken <- lookup "id_token" <#> OIDC.IdToken
  state <- lookup "state" <#> OIDC.BoundStateJWS

  pure
    { idToken
    , authUser
    , state
    , prompt
    }

parseUriHash
  :: String
  -> Either P.ParseError RedirectHashPayload
parseUriHash =
  P.runParser uriHashParser

{-
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.AuthRedirect.RedirectHashPayload
  ( RedirectHashPayload
  , uriHashParser
  , parseUriHash
  ) where

import SlamData.Prelude

import Data.List as L
import Data.String as S
import Data.StrMap as SM

import Text.Parsing.StringParser as P
import Text.Parsing.StringParser.Combinators as PC
import Text.Parsing.StringParser.String as PS

import OIDCCryptUtils.Types as OIDC

type RedirectHashPayload =
  { idToken :: OIDC.IdToken
  , authUser :: String
  , state :: OIDC.BoundStateJWS
  , prompt :: String
  }

parameterParser :: P.Parser (Tuple String String)
parameterParser = do
  key <- PC.many (PS.noneOf ['=']) <#> L.fromList >>> S.fromCharArray
  PS.char '='
  val <- PC.many (PS.noneOf ['&']) <#> L.fromList >>> S.fromCharArray
  pure $ Tuple key val

parametersParser :: P.Parser (SM.StrMap String)
parametersParser =
  PC.sepBy parameterParser (PS.char '&')
    <#> SM.fromFoldable

-- | Parse the payload from the URI hash. Example:
-- |
-- |     #id_token=foo&authuser=0&hd=slamdata.com&state=bar&prompt=consent
-- |
uriHashParser :: P.Parser RedirectHashPayload
uriHashParser = do
  PS.char '#'
  params <- parametersParser

  let lookup key = SM.lookup key params # maybe (P.fail $ "missing " <> key) pure
  idToken <- lookup "id_token" <#> OIDC.IdToken
  authUser <- lookup "authuser"
  state <- lookup "state" <#> OIDC.BoundStateJWS
  prompt <- lookup "prompt"

  pure
    { idToken
    , authUser
    , state
    , prompt
    }

parseUriHash
  :: String
  -> Either P.ParseError RedirectHashPayload
parseUriHash =
  P.runParser uriHashParser


Refactor queryNodes function

Refactor queryNodes function

module Main where

import Control.Applicative (pure)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.Classy.Node (fromNode)
import DOM.Classy.Element (fromElement, toElement)
import DOM.Event.Event (target)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (keyup)
import DOM.HTML.HTMLTextAreaElement (value)
import DOM.HTML.Types ( HTMLTextAreaElement
                      , HTMLUListElement
                      , htmlDocumentToParentNode
                      )
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (querySelector, QuerySelector(QuerySelector))
import DOM.Node.Types (elementToEventTarget, ParentNode)
import Data.Maybe (Maybe(..), maybe)
import Prelude (Unit, bind, show, (<<<), (>>=), ($), (<$>), (<*>))
import Util.Parse (parse)
import Data.Argonaut (encodeJson)

data Nodes = Nodes HTMLTextAreaElement HTMLUListElement

f :: String -> forall eff. Eff (console :: CONSOLE | eff) Unit
f s = log j where
  j = (show <<< encodeJson <<< parse) s

onTextChange :: forall eff. HTMLUListElement
                         -> Event
                         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
onTextChange ul e = maybe
  (log "No textarea node found")
  (\textarea -> value (textarea :: HTMLTextAreaElement) >>= f)
  ((fromNode <<< target) e)

queryNodes :: forall eff. ParentNode -> Eff (dom :: DOM | eff) (Maybe Nodes)
queryNodes docNode = do

  mUlElement       <- querySelector (QuerySelector "#out") docNode
  mTextareaElement <- querySelector (QuerySelector "#in")  docNode

  let mUl       = mUlElement       >>= fromElement
      mTextarea = mTextareaElement >>= fromElement

  pure $ Nodes <$> mTextarea <*> mUl

main :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
main = do
  doc <- window >>= document
  let docNode = htmlDocumentToParentNode doc

  nodes <- queryNodes docNode

  case nodes of

    Nothing        -> log "Could not access elements"
    Just (Nodes textarea ul) -> do

      let listener    = eventListener (onTextChange ul)
          eventTarget = elementToEventTarget (toElement textarea)
      addEventListener keyup listener true eventTarget

--------------------------------------------------------------------------------

module Main where

import Control.Applicative (pure)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.Classy.Node (fromNode)
import DOM.Classy.Element (fromElement, toElement)
import DOM.Event.Event (target)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.Event.Types (Event)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (keyup)
import DOM.HTML.HTMLTextAreaElement (value)
import DOM.HTML.Types ( HTMLTextAreaElement
                      , HTMLUListElement
                      , htmlDocumentToParentNode
                      )
import DOM.HTML.Window (document)
import DOM.Node.ParentNode (querySelector, QuerySelector(QuerySelector))
import DOM.Node.Types (elementToEventTarget, ParentNode)
import Data.Maybe (Maybe(..), maybe)
import Prelude (Unit, bind, show, (<<<), (>>=), ($))
import Util.Parse (parse)
import Data.Argonaut (encodeJson)

data Nodes = Nodes HTMLTextAreaElement HTMLUListElement

f :: String -> forall eff. Eff (console :: CONSOLE | eff) Unit
f s = log j where
  j = (show <<< encodeJson <<< parse) s

onTextChange :: forall eff. HTMLUListElement
                         -> Event
                         -> Eff (dom :: DOM, console :: CONSOLE | eff) Unit
onTextChange ul e = maybe
  (log "No textarea node found")
  (\textarea -> value (textarea :: HTMLTextAreaElement) >>= f)
  ((fromNode <<< target) e)

{-
DOM.Classy.Element.fromElement ∷ ∀ e. IsElement e ⇒ Element → Maybe e

DOM.Node.ParentNode.querySelector ∷ ∀ eff. QuerySelector
→ ParentNode
→ Eff ( dom ∷ DOM | eff ) (Maybe Element)

m a -> (a -> m b) -> m b

m e

E (m e)
DOM.Classy.Element.fromElement ∷ ∀ e. IsElement e ⇒ Element → Maybe e
-}

n :: forall eff. ParentNode -> Eff (dom :: DOM | eff) (Maybe Nodes)
n docNode = do

  mUlElement       <- querySelector (QuerySelector "#out") docNode
  mTextareaElement <- querySelector (QuerySelector "#in")  docNode

  case mUlElement of
    Nothing -> pure Nothing
    Just ulElement -> do

      case mTextareaElement of
        Nothing -> pure Nothing
        Just textareaElement -> do

          let mUl = fromElement ulElement

          case mUl of
            Nothing -> pure Nothing
            Just ul -> do

              let mTextarea = fromElement textareaElement

              case mTextarea of
                Nothing -> pure Nothing
                Just textarea -> do
                  pure $ pure (Nodes textarea ul)

main :: forall eff. Eff (dom :: DOM, console :: CONSOLE | eff) Unit
main = do
  doc <- window >>= document
  let docNode = htmlDocumentToParentNode doc

  nodes <- n docNode

  case nodes of

    Nothing        -> log "Could not access elements"
    Just (Nodes textarea ul) -> do

      let listener    = eventListener (onTextChange ul)
          eventLarget = elementToEventTarget (toElement textarea)
      addEventListener keyup listener true eventLarget

--------------------------------------------------------------------------------


Update

Update

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Maybe (Maybe(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

data Point3D = Point3D
	{	x :: Number
	,	y :: Number
	,	z :: Number
	}

vertices :: Array Point3D
vertices =
	[ Point3D {x:(-100.0), y:100.0, z:(-100.0)}
	,Point3D {x:100.0, y:100.0, z:(-100.0)}
	,Point3D {x:100.0, y:(-100.0), z:(-100.0)}
	,Point3D {x:(-100.0), y:(-100.0), z:(-100.0)}
	,Point3D {x:(-100.0), y:100.0, z:100.0}
	,Point3D {x:100.0, y:100.0, z:100.0}
	,Point3D {x:100.0, y:(-100.0), z:100.0}
	,Point3D {x:(-100.0), y:(-100.0), z:100.0}
	]

data Angle3D = Angle3D
	{	qx :: Number
	,	qy :: Number
	,	qz :: Number
	}

angle :: Angle3D
angle = Angle3D
	{	qx: Math.pi/4.0
	,	qy: Math.pi/3.0
	,	qz: Math.pi/4.0
	}

faces :: Array (Array Int)
faces = [
	[0,1,2,3],
	[1,5,6,2],
	[5,4,7,6],
	[4,0,3,7],
	[0,4,5,1],
	[3,2,6,7]
]

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D p) (Angle3D ang) =
	let	xRotQz = p.x * Math.cos ang.qz + p.y * Math.sin ang.qz
		yRotQz = p.y * Math.cos ang.qz + p.x * Math.sin ang.qz
		zRotQz = p.z
		xRotQzQx = xRotQz
		yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
		zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
		xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
		yRotQzQxQy = yRotQzQx
	in
		Point3D {x:xRotQzQxQy, y:yRotQzQxQy, z:p.z}

drawCube :: forall e. Context2D -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx = do
	ctx <- setFillStyle "#000000" ctx
	fillPath ctx do
		ctx <- moveTo ctx 100.0 100.0
		ctx <- lineTo ctx 200.0 200.0
		ctx <- lineTo ctx 150.0 150.0
		void $ closePath ctx

transform :: Point3D -> Point3D
transform (Point3D p) =
	let	nx = p.x + 200.0
		ny = p.x + 200.0
	in
		Point3D {x:nx, y:ny, z:p.z}

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
	Just canvas <- getCanvasElementById "thecanvas"
	ctx <- getContext2D canvas
	animFrame <- animationFrame
	ctx <- setFillStyle "#0000FF" ctx
	--ctx <- fillRect{x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
	drawCube ctx
	log("working")

module Main where

import Prelude
import Math as Math
import Data.Array
import Data.Maybe (Maybe(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (logShow, log)
import DOM
import Graphics.Canvas
import Signal
import Signal.DOM
import Partial.Unsafe (unsafePartial)

oRate :: Number
oRate = 0.999

fric :: Number
fric = 0.0

data Point3D = Point3D
	{	x :: Number
	,	y :: Number
	,	z :: Number
	}

vertices :: Array Point3D
vertices =
	[ Point3D {x:(-100.0), y:100.0, z:(-100.0)}
	,Point3D {x:100.0, y:100.0, z:(-100.0)}
	,Point3D {x:100.0, y:(-100.0), z:(-100.0)}
	,Point3D {x:(-100.0), y:(-100.0), z:(-100.0)}
	,Point3D {x:(-100.0), y:100.0, z:100.0}
	,Point3D {x:100.0, y:100.0, z:100.0}
	,Point3D {x:100.0, y:(-100.0), z:100.0}
	,Point3D {x:(-100.0), y:(-100.0), z:100.0}
	]

data Angle3D = Angle3D
	{	qx :: Number
	,	qy :: Number
	,	qz :: Number
	}

angle :: Angle3D
angle = Angle3D
	{	qx: Math.pi/4.0
	,	qy: Math.pi/3.0
	,	qz: Math.pi/4.0
	}

faces :: Array (Array Int)
faces = [
	[0,1,2,3],
	[1,5,6,2],
	[5,4,7,6],
	[4,0,3,7],
	[0,4,5,1],
	[3,2,6,7]
]

project3Dto2D :: Point3D -> Angle3D -> Point3D
project3Dto2D (Point3D p) (Angle3D ang) =
	let	xRotQz = p.x * Math.cos ang.qz + p.y * Math.sin ang.qz
		yRotQz = p.y * Math.cos ang.qz + p.x * Math.sin ang.qz
		zRotQz = p.z
		xRotQzQx = xRotQz
		yRotQzQx = yRotQz * Math.cos ang.qx + zRotQz * Math.sin ang.qx
		zRotQzQx = zRotQz * Math.cos ang.qx - yRotQz * Math.sin ang.qx
		xRotQzQxQy = xRotQzQx * Math.cos ang.qy + zRotQzQx * Math.sin ang.qy
		yRotQzQxQy = yRotQzQx
	in
		Point3D {x:xRotQzQxQy, y:yRotQzQxQy, z:p.z}

drawCube :: forall e. Context2D -> Eff (canvas :: CANVAS | e) Unit
drawCube ctx = do
	ctx <- setFillStyle "#000000" ctx
	fillPath ctx do
		ctx <- moveTo ctx 100.0 100.0
		ctx <- lineTo ctx 200.0 200.0
		ctx <- lineTo ctx 150.0 150.0
		void $ closePath ctx

transform :: Point3D -> Point3D
transform (Point3D p) =
	let	nx = p.x + 200.0
		ny = p.x + 200.0
	in
		Point3D {x:nx, y:ny, z:p.z}

--main :: forall eff. Eff(canvas :: CANVAS, dom :: DOM, timer :: TIMER | eff) Unit
main = void $ unsafePartial do
	Just canvas <- getCanvasElementById "thecanvas"
	ctx <- getContext2D canvas
	animFrame <- animationFrame
	ctx <- setFillStyle "#0000FF" ctx
	--ctx <- fillRect {x: 0.0, y: 0.0, w: 500.0, h: 500.0} ctx
	drawCube ctx
	log("working")


Fix #9, multiline strings

Fix #9, multiline strings

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | Integer Number
  | Float Number
  | Hex Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (Integer n)           = "Integer (" ++ show n ++ ")"
  show (Float n)             = "Float (" ++ show n ++ ")"
  show (Hex n)               = "Hex (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (Integer n1)        (Integer n2)        = n1 == n2
  (==) (Float n1)          (Float n2)          = n1 == n2
  (==) (Hex n1)            (Hex n2)            = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    let ns = eatWhile i isNumeric
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (Natural (buildNat ns.str 0 0)) : ts)
    where
    buildNat :: String -> Number -> Number -> Number
    buildNat s i acc | i >= length s = acc
    buildNat s i acc = buildNat s (i + 1) (acc * 10 + toDigit (charAt i s))

    toDigit :: String -> Number
    toDigit "0" = 0
    toDigit "1" = 1
    toDigit "2" = 2
    toDigit "3" = 3
    toDigit "4" = 4
    toDigit "5" = 5
    toDigit "6" = 6
    toDigit "7" = 7
    toDigit "8" = 8
    toDigit "9" = 9

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case {} of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | indexOf' "\"\"\"" i input == i =
    case readStringLiteral (i + 3) "\"\"\"" replaceNewLines of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)
    where
    replaceNewLines :: String -> String
    replaceNewLines = joinWith "\\n" <<< split "\n"
  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral (i + 1) "\"" id of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Position -> String -> (String -> String) -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral start term replace = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal"
    eat false count i | indexOf' term i input == i =
      let escaped = replace (take count (drop start input))
      -- TODO: include position info here
      in unEscape escaped (\s -> Right { next: i + length term, str: s, count: count }) (Left $ "Invalid string literal: " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false

module Language.PureScript.Parser.Lexer where

import Data.Array ()
import Data.Either
import Data.String

import Language.PureScript.Keywords (opCharsString)

data Token
  = LParen
  | RParen
  | LBrace
  | RBrace
  | LAngle
  | RAngle
  | LSquare
  | RSquare

  | Newline Indentation
  | ShouldIndent Indentation

  | LArrow
  | RArrow
  | LFatArrow
  | RFatArrow

  | Colon
  | DoubleColon
  | Equals
  | Pipe
  | Tick
  | Dot
  | Comma
  | Semi
  | At

  | LName String
  | UName String
  | Symbol String

  | StringLiteral String

  | Natural Number
  | Integer Number
  | Float Number
  | Hex Number

instance showToken :: Show Token where
  show LParen                = "LParen"
  show RParen                = "RParen"
  show LBrace                = "LBrace"
  show RBrace                = "RBrace"
  show LAngle                = "LAngle"
  show RAngle                = "RAngle"
  show LSquare               = "LSquare"
  show RSquare               = "RSquare"
  show LArrow                = "LArrow"
  show RArrow                = "RArrow"
  show LFatArrow             = "LFatArrow"
  show RFatArrow             = "RFatArrow"
  show Colon                 = "Colon"
  show DoubleColon           = "DoubleColon"
  show Equals                = "Equals"
  show Pipe                  = "Pipe"
  show Tick                  = "Tick"
  show Dot                   = "Dot"
  show Comma                 = "Comma"
  show Semi                  = "Semi"
  show At                    = "At"
  show (Newline n)           = "Newline (" ++ show n ++ ")"
  show (ShouldIndent n)      = "ShouldIndent (" ++ show n ++ ")"
  show (LName s)             = "LName (" ++ show s ++ ")"
  show (UName s)             = "UName (" ++ show s ++ ")"
  show (Symbol s)            = "Symbol (" ++ show s ++ ")"
  show (StringLiteral s)     = "StringLiteral (" ++ show s ++ ")"
  show (Natural n)           = "Natural (" ++ show n ++ ")"
  show (Integer n)           = "Integer (" ++ show n ++ ")"
  show (Float n)             = "Float (" ++ show n ++ ")"
  show (Hex n)               = "Hex (" ++ show n ++ ")"

instance eqToken :: Eq Token where
  (==) LParen              LParen              = true
  (==) RParen              RParen              = true
  (==) LBrace              LBrace              = true
  (==) RBrace              RBrace              = true
  (==) LAngle              LAngle              = true
  (==) RAngle              RAngle              = true
  (==) LSquare             LSquare             = true
  (==) RSquare             RSquare             = true
  (==) LArrow              LArrow              = true
  (==) RArrow              RArrow              = true
  (==) LFatArrow           LFatArrow           = true
  (==) RFatArrow           RFatArrow           = true
  (==) Colon               Colon               = true
  (==) DoubleColon         DoubleColon         = true
  (==) Equals              Equals              = true
  (==) Pipe                Pipe                = true
  (==) Tick                Tick                = true
  (==) Dot                 Dot                 = true
  (==) Comma               Comma               = true
  (==) Semi                Semi                = true
  (==) At                  At                  = true
  (==) (Newline n1)        (Newline n2)        = n1 == n2
  (==) (ShouldIndent n1)   (ShouldIndent n2)   = n1 == n2
  (==) (LName s1)          (LName s2)          = s1 == s2
  (==) (UName s1)          (UName s2)          = s1 == s2
  (==) (Symbol s1)         (Symbol s2)         = s1 == s2
  (==) (StringLiteral s1)  (StringLiteral s2)  = s1 == s2
  (==) (Natural n1)        (Natural n2)        = n1 == n2
  (==) (Integer n1)        (Integer n2)        = n1 == n2
  (==) (Float n1)          (Float n2)          = n1 == n2
  (==) (Hex n1)            (Hex n2)            = n1 == n2
  (==) _                   _                   = false
  (/=) tok1                tok2                = not (tok1 == tok2)

type Indentation = Number

type Line = Number
type Column = Number

type Position = Number

type Comments = [String]

type PositionedToken =
  { line :: Line
  , column :: Column
  , token :: Token
  , comments :: Comments
  }

mkPositionedToken :: Line -> Column -> [String] -> Token -> PositionedToken
mkPositionedToken line column comments token = { line: line, column: column, token: token, comments: comments }

foreign import unEscape
  "function unEscape(s) {\
  \  return function (sc) {\
  \    return function (fc) {\
  \      try {\
  \        return sc(JSON.parse('\"' + s + '\"'));\
  \      } catch (ex) {\
  \        return fc;\
  \      }\
  \    };\
  \  };\
  \}" :: forall r. String -> (String -> r) -> r -> r

lex :: String -> Either String [PositionedToken]
lex input = do
  let wh = eatWhitespace 0 []
  ts <- go 1 (wh.next + 1) wh.next [] []
  removeWhitespace [] ts []
  where
  go :: Line -> Column -> Position -> Comments -> [PositionedToken] -> Either String [PositionedToken]
  go _    _   i _  ts | i >= length input = Right (Data.Array.reverse ts)
  go line col i cs ts | charAt i input == " " = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\r" = go line (col + 1) (i + 1) cs ts
  go line col i cs ts | charAt i input == "\n" =
    let wh = eatWhitespace (i + 1) ts
    in go (line + 1) (wh.len + 1) wh.next cs wh.toks

  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) =
    let tok = eatWhile (i + 2) (\s -> s /= "\n")
    in go line (col + length tok.str) tok.next (cs ++ [tok.str]) ts
  go line col i cs ts | charAt i input == "{" && charAt (i + 1) input == "-" =
    let tok = eatWhile' (i + 2) (\j -> j < length input && ((charAt j input /= "-") || (charAt (j + 1) input /= "}")))
    in go line (col + length tok.str + 2) (tok.next + 2) (cs ++ [tok.str]) ts

  go line col i cs ts | charAt i input == "(" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LParen : ts)
  go line col i cs ts | charAt i input == ")" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RParen : ts)
  go line col i cs ts | charAt i input == "{" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LBrace : ts)
  go line col i cs ts | charAt i input == "}" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RBrace : ts)
  go line col i cs ts | charAt i input == "[" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LSquare : ts)
  go line col i cs ts | charAt i input == "]" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RSquare : ts)
  go line col i cs ts | charAt i input == "." && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Dot : ts)
  go line col i cs ts | charAt i input == "<" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs LAngle : ts)
  go line col i cs ts | charAt i input == ">" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs RAngle : ts)
  go line col i cs ts | charAt i input == ":" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Colon : ts)
  go line col i cs ts | charAt i input == "=" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Equals : ts)
  go line col i cs ts | charAt i input == "|" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Pipe : ts)
  go line col i cs ts | charAt i input == "@" && lookaheadChar (i + 1) (not <<< isSymbolChar) = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs At : ts)
  go line col i cs ts | charAt i input == "`" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Tick : ts)
  go line col i cs ts | charAt i input == "," = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Comma : ts)
  go line col i cs ts | charAt i input == ";" = go line (col + 1) (i + 1) [] (mkPositionedToken line col cs Semi : ts)

  go line col i cs ts | charAt i input == ":" && charAt (i + 1) input == ":" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs DoubleColon : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "-" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LArrow : ts)
  go line col i cs ts | charAt i input == "-" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RArrow : ts)
  go line col i cs ts | charAt i input == "<" && charAt (i + 1) input == "=" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs LFatArrow : ts)
  go line col i cs ts | charAt i input == "=" && charAt (i + 1) input == ">" && lookaheadChar (i + 2) (not <<< isSymbolChar) = go line (col + 2) (i + 2) [] (mkPositionedToken line col cs RFatArrow : ts)

  go line col i cs ts | isNumeric (charAt i input) =
    let ns = eatWhile i isNumeric
    in go line (col + length ns.str) ns.next [] (mkPositionedToken line col cs (Natural (buildNat ns.str 0 0)) : ts)
    where
    buildNat :: String -> Number -> Number -> Number
    buildNat s i acc | i >= length s = acc
    buildNat s i acc = buildNat s (i + 1) (acc * 10 + toDigit (charAt i s))

    toDigit :: String -> Number
    toDigit "0" = 0
    toDigit "1" = 1
    toDigit "2" = 2
    toDigit "3" = 3
    toDigit "4" = 4
    toDigit "5" = 5
    toDigit "6" = 6
    toDigit "7" = 7
    toDigit "8" = 8
    toDigit "9" = 9

  go line col i cs ts | isIdentStart (charAt i input) =
    let tok = eatWhile i isIdentChar
        col' = col + length tok.str
    in case tok.str of
      s | shouldIndent tok.str ->
        let lme = nextLexeme line col' tok.next
        in case {} of
          _ | charAt lme.next input == "{" -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)
          _ -> go lme.line lme.col lme.next [] (mkPositionedToken line col cs (ShouldIndent lme.col) : mkPositionedToken line col [] (LName tok.str) : ts)
      s -> go line col' tok.next [] (mkPositionedToken line col cs (LName tok.str) : ts)

  go line col i cs ts | isUpper (charAt i input) =
    let tok = eatWhile i isIdentChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (UName tok.str) : ts)
  go line col i cs ts | isSymbolChar (charAt i input) =
    let tok = eatWhile i isSymbolChar
    in go line (col + length tok.str) tok.next [] (mkPositionedToken line col cs (Symbol tok.str) : ts)

  go line col i cs ts | charAt i input == "\"" =
    case readStringLiteral (i + 1) of
      Left err -> Left err
      Right tok -> go line (col + tok.count) tok.next [] (mkPositionedToken line col cs (StringLiteral tok.str) : ts)

  go line col _ _ _ = Left $ "Lexer error at line " ++ show line ++ ", column " ++ show col

  removeWhitespace :: [Indentation] -> [PositionedToken] -> [PositionedToken] -> Either String [PositionedToken]
  removeWhitespace ms       ({ token = Newline _ } : (t@{ token = Newline _ }) : ts) acc = removeWhitespace ms (t : ts) acc
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | m == n = removeWhitespace (m : ms) ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace []       ((t@{ token = Newline 1 })      : ts) acc = removeWhitespace [] ts (mkPositionedToken t.line t.column t.comments Semi : acc)
  removeWhitespace (m : ms) ((t@{ token = Newline n })      : ts) acc | n < m = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace ms       ((t@{ token = Newline n })      : ts) acc = removeWhitespace ms ts acc
  removeWhitespace (m : ms) ((t@{ token = ShouldIndent n }) : ts) acc | n > m = removeWhitespace (n : m : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace []       ((t@{ token = ShouldIndent n }) : ts) acc | n > 1 = removeWhitespace [n] ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       ((t@{ token = ShouldIndent n }) : ts) acc = removeWhitespace ms (mkPositionedToken t.line t.column t.comments (Newline n) : ts) (mkPositionedToken t.line t.column [] RBrace : mkPositionedToken t.line t.column [] LBrace : acc)
  removeWhitespace (1 : ms) ((t@{ token = RBrace })         : ts) acc = removeWhitespace ms ts (mkPositionedToken t.line t.column t.comments RBrace : acc)
  removeWhitespace _        ((t@{ token = RBrace })         : ts) acc = Left "Unexpected }"
  removeWhitespace ms       ((t@{ token = LBrace })         : ts) acc = removeWhitespace (1 : ms) ts (mkPositionedToken t.line t.column t.comments LBrace : acc)
  removeWhitespace ms       (t : ts)                              acc = removeWhitespace ms ts (t : acc)
  removeWhitespace []       []                                    acc = return (Data.Array.reverse acc)
  removeWhitespace (m : ms) []                                    acc | m > 1 = removeWhitespace ms [] (mkPositionedToken 0 0 [] RBrace : acc)

  nextLexeme :: Line -> Column -> Position -> { line :: Line, col :: Column, next :: Position }
  nextLexeme = eat
    where
    eat line col i | charAt i input == " "  = eat line (col + 1) (i + 1)
    eat line col i | charAt i input == "\r" = eat line col (i + 1)
    eat line col i | charAt i input == "\n" = eat (line + 1) 1 (i + 1)
    eat line col i = { line: line, col: col, next: i }

  eatWhitespace :: Position -> [PositionedToken] -> { len :: Number, count :: Number, next :: Position, toks :: [PositionedToken] }
  eatWhitespace = eat 0 0
    where
    eat len count i ts | charAt i input == " " = eat (len + 1) (count + 1) (i + 1) ts
    eat len count i ts | charAt i input == "\r" = eat len (count + 1) (i + 1) ts
    -- TODO: include position info here
    eat len count i ts = { len: len, count: count, next: i, toks: mkPositionedToken 0 0 [] (Newline (len + 1)) : ts }

  eatWhile :: Position -> (String -> Boolean) -> { next :: Position, str :: String }
  eatWhile start p = eatWhile' start (\i -> p (charAt i input))

  eatWhile' :: Position -> (Number -> Boolean) -> { next :: Position, str :: String }
  eatWhile' start p = eat start 0
    where
    eat i _   | i >= length input = { next: i, str: drop start input }
    eat i len | p i = eat (i + 1) (len + 1)
    eat i len = { next: i, str: take len (drop start input) }

  readStringLiteral :: Position -> Either String { next :: Position, str :: String, count :: Number }
  readStringLiteral start = eat false 0 start
    where
    eat :: Boolean -> Number -> Position -> Either String { next :: Position, str :: String, count :: Number }
    eat _     _     i | i >= length input = Left $ "Unterminated string literal"
    eat false count i | charAt i input == "\"" =
      let escaped = take count (drop start input)
      in unEscape escaped (\s -> Right { next: i + 1, str: s, count: count }) (Left $ "Invalid string literal: " ++ show escaped)
    eat _     count i | charAt i input == "\\" = eat true (count + 1) (i + 1)
    eat _     count i = eat false (count + 1) (i + 1)

  lookaheadChar :: Position -> (String -> Boolean) -> Boolean
  lookaheadChar i pred = pred (charAt i input)

  isSymbolChar :: String -> Boolean
  isSymbolChar c = indexOf c opCharsString >= 0

  isLower :: String -> Boolean
  isLower c = c >= "a" && c <= "z"

  isUpper :: String -> Boolean
  isUpper c = c >= "A" && c <= "Z"

  isAlpha :: String -> Boolean
  isAlpha c = isLower c || isUpper c

  isNumeric :: String -> Boolean
  isNumeric c = c >= "0" && c <= "9"

  isAlphaNum :: String -> Boolean
  isAlphaNum c = isAlpha c || isNumeric c

  isIdentStart :: String -> Boolean
  isIdentStart c = isLower c || (c == "_")

  isIdentChar :: String -> Boolean
  isIdentChar c = isAlphaNum c || (c == "_")

  isNumericLiteralChar :: String -> Boolean
  isNumericLiteralChar c = isNumeric c || (c == ".") || (c == "b") || (c == "x") || (c == "-")

  shouldIndent :: String -> Boolean
  shouldIndent "of" = true
  shouldIndent "do" = true
  shouldIndent "where" = true
  shouldIndent "let" = true
  shouldIndent _ = false


WIP fix stalling reauthetication init

WIP fix stalling reauthetication init

{-
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.Quasar.Auth.Reauthentication (reauthentication, EIdToken) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Rec.Class (forever)
import Control.UI.Browser as Browser
import SlamData.Prelude
import DOM (DOM)
import OIDC.Aff as OIDCAff
import OIDCCryptUtils (RSASIGNTIME)
import OIDCCryptUtils.Types (IdToken(..))
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import Text.Parsing.StringParser (ParseError(..))
import Utils (passover)
import Utils.DOM as DOMUtils
import Utils.LocalStorage as LocalStorage

-- TODO: Replace popup with iframe
-- TODO: Replace localstorage events and retrieval with iframe events and location
-- TODO: Update to Purescript 0.9.x

type EIdToken = Either String IdToken
type ReauthEffects eff =
  ( rsaSignTime :: RSASIGNTIME
  , avar :: AVAR
  , dom :: DOM
  , random :: RANDOM
  | eff)

race ∷ ∀ eff a. AffAVar eff a → AffAVar eff a → AffAVar eff a
race a1 a2 = do
  va <- AVar.makeVar -- the `a` value
  ve <- AVar.makeVar -- the error count (starts at 0)
  AVar.putVar ve 0
  c1 <- Aff.forkAff $ either (maybeKill va ve) (AVar.putVar va) =<< Aff.attempt a1
  c2 <- Aff.forkAff $ either (maybeKill va ve) (AVar.putVar va) =<< Aff.attempt a2
  AVar.takeVar va `Aff.cancelWith` (c1 <> c2)
  where
  maybeKill va ve err = do
    e <- AVar.takeVar ve
    if e == 1 then AVar.killVar va err else pure unit
    AVar.putVar ve (e + 1)

fromStallingProducer :: forall o eff. StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit → AffAVar eff o
fromStallingProducer producer = do
  var ← AVar.makeVar
  StallingCoroutine.runStallingProcess
    (producer $$? (Coroutine.consumer \e → liftAff (AVar.putVar var e) $> Just unit))
  AVar.takeVar var

-- | Write an AVar to the returned bus to get a new OIDC id token from the given provider
reauthentication ∷ ∀ eff. Aff (ReauthEffects eff) (BusRW (AVar EIdToken))
reauthentication =
  (\state → passover (forever ∘ reauthenticate state <=< Bus.read) =<< Bus.make)
    =<< AVar.makeVar' (Nothing ∷ Maybe (Promise EIdToken))

reauthenticate ∷ ∀ eff. AVar (Maybe (Promise EIdToken)) → AVar EIdToken → Aff (ReauthEffects eff) Unit
reauthenticate stateAvar replyAvar =
  maybe
    (const (putState Nothing) =<< reply =<< passover (putState ∘ Just) =<< requestNewIdToken)
    reply
    =<< AVar.takeVar stateAvar
  where
  putState ∷ Maybe (Promise EIdToken) → Aff (ReauthEffects eff) Unit
  putState = AVar.putVar stateAvar

  reply ∷ Promise EIdToken → Aff (ReauthEffects eff) Unit
  reply = void ∘ Aff.forkAff ∘ AVar.putVar replyAvar <=< Promise.wait

  openReauthenticationPopup ∷ Aff (ReauthEffects eff) Unit
  openReauthenticationPopup =
    either
      (const $ pure unit)
      (liftEff ∘ DOMUtils.openPopup)
      =<< requestReauthenticationURI

  requestNewIdToken ∷ Aff (ReauthEffects eff) (Promise EIdToken)
  requestNewIdToken =
    openReauthenticationPopup *> Promise.defer retrieveIdTokenFromLSOnChange

  retrieveIdTokenFromLSOnChange ∷ Aff (ReauthEffects eff) EIdToken
  retrieveIdTokenFromLSOnChange =
    race
      (const retrieveIdTokenFromLS =<< fromStallingProducer =<< liftEff getIdTokenStorageEvents)
      (Aff.later' Config.reauthenticationTimeout $ pure $ Left "No token recieved before timeout.")

  retrieveIdTokenFromLS ∷ Aff (ReauthEffects eff) (Either String IdToken)
  retrieveIdTokenFromLS =
    map IdToken <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

  retrieveProviderRFromLS ∷ Eff (ReauthEffects eff) (Either String QAT.ProviderR)
  retrieveProviderRFromLS =
    map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

  appendAuthPath ∷ String → String
  appendAuthPath s = (s ++ _) Config.redirectURIString

  runParseError ∷ ParseError → String
  runParseError (ParseError s) = s

  requestReauthenticationURI ∷ Aff (ReauthEffects eff) (Either String String)
  requestReauthenticationURI =
    liftEff do
      redirectUri <- appendAuthPath <$> Browser.locationString
      runExceptT $ (ExceptT ∘ map (bimap runParseError id) ∘ flip (OIDCAff.requestAuthenticationURI OIDCAff.None) redirectUri) =<< ExceptT retrieveProviderRFromLS

{-
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.Quasar.Auth.Reauthentication (reauthentication, EIdToken) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.Monad.Rec.Class (forever)
import Control.UI.Browser as Browser
import SlamData.Prelude
import DOM (DOM)
import OIDC.Aff as OIDCAff
import OIDCCryptUtils (RSASIGNTIME)
import OIDCCryptUtils.Types (IdToken(..))
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import Text.Parsing.StringParser (ParseError(..))
import Utils (passover)
import Utils.DOM as DOMUtils
import Utils.LocalStorage as LocalStorage

-- TODO: Replace popup with iframe
-- TODO: Replace localstorage events and retrieval with iframe events and location
-- TODO: Update to Purescript 0.9.x

type EIdToken = Either String IdToken
type ReauthEffects eff =
  ( rsaSignTime :: RSASIGNTIME
  , avar :: AVAR
  , dom :: DOM
  , random :: RANDOM
  | eff)

race ∷ ∀ eff a. AffAVar eff a → AffAVar eff a → AffAVar eff a
race a1 a2 = do
  va <- AVar.makeVar -- the `a` value
  ve <- AVar.makeVar -- the error count (starts at 0)
  AVar.putVar ve 0
  c1 <- Aff.forkAff $ either (maybeKill va ve) (AVar.putVar va) =<< Aff.attempt a1
  c2 <- Aff.forkAff $ either (maybeKill va ve) (AVar.putVar va) =<< Aff.attempt a2
  AVar.takeVar va `Aff.cancelWith` (c1 <> c2)
  where
  maybeKill va ve err = do
    e <- AVar.takeVar ve
    if e == 1 then AVar.killVar va err else pure unit
    AVar.putVar ve (e + 1)

fromStallingProducer :: forall o eff. StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit → AffAVar eff o
fromStallingProducer producer = do
  var ← AVar.makeVar
  StallingCoroutine.runStallingProcess
    (producer $$? (Coroutine.consumer \e → liftAff (AVar.putVar var e) $> Just unit))
  AVar.takeVar var

-- | Write an AVar to the returned bus to get a new OIDC id token from the given provider
reauthentication ∷ ∀ eff. Aff (ReauthEffects eff) (BusRW (AVar EIdToken))
reauthentication =
  (\state → passover (forever ∘ reauthenticate state <=< Bus.read) =<< Bus.make)
    =<< AVar.makeVar' (Nothing ∷ Maybe (Promise EIdToken))

reauthenticate ∷ ∀ eff. AVar (Maybe (Promise EIdToken)) → AVar EIdToken → Aff (ReauthEffects eff) Unit
reauthenticate stateAvar replyAvar =
  maybe
    (const (putState Nothing) =<< reply =<< passover (putState ∘ Just) =<< requestNewIdToken)
    reply
    =<< AVar.takeVar stateAvar
  where
  putState ∷ Maybe (Promise EIdToken) → Aff (ReauthEffects eff) Unit
  putState = AVar.putVar stateAvar

  reply ∷ Promise EIdToken → Aff (ReauthEffects eff) Unit
  reply = AVar.putVar replyAvar <=< Promise.wait

  openReauthenticationPopup ∷ Aff (ReauthEffects eff) Unit
  openReauthenticationPopup =
    either
      (const $ pure unit)
      (liftEff ∘ DOMUtils.openPopup)
      =<< requestReauthenticationURI

  requestNewIdToken ∷ Aff (ReauthEffects eff) (Promise EIdToken)
  requestNewIdToken =
    openReauthenticationPopup *> Promise.defer retrieveIdTokenFromLSOnChange

  retrieveIdTokenFromLSOnChange ∷ Aff (ReauthEffects eff) EIdToken
  retrieveIdTokenFromLSOnChange =
    race
      (const retrieveIdTokenFromLS =<< fromStallingProducer =<< liftEff getIdTokenStorageEvents)
      (Aff.later' Config.reauthenticationTimeout $ pure $ Left "No token recieved before timeout.")

  retrieveIdTokenFromLS ∷ Aff (ReauthEffects eff) (Either String IdToken)
  retrieveIdTokenFromLS =
    map IdToken <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

  retrieveProviderRFromLS ∷ Eff (ReauthEffects eff) (Either String QAT.ProviderR)
  retrieveProviderRFromLS =
    map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

  appendAuthPath ∷ String → String
  appendAuthPath s = (s ++ _) Config.redirectURIString

  runParseError ∷ ParseError → String
  runParseError (ParseError s) = s

  requestReauthenticationURI ∷ Aff (ReauthEffects eff) (Either String String)
  requestReauthenticationURI =
    liftEff do
      redirectUri <- appendAuthPath <$> Browser.locationString
      runExceptT $ (ExceptT ∘ map (bimap runParseError id) ∘ flip (OIDCAff.requestAuthenticationURI OIDCAff.None) redirectUri) =<< ExceptT retrieveProviderRFromLS