Updated Main module to make div element rotate

module Main where

import Prelude
import Application.State (rotate)
import Application.Types (ApplicationState(..))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, info)
import Control.Monad.Eff.Now (NOW, now)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Types (Window)
import DOM.HTML.Window (RequestAnimationFrameId, document, requestAnimationFrame)
import DOM.Node.Element (setAttribute)
import DOM.Node.NonElementParentNode (getElementById)
import DOM.Node.Types (Element, ElementId(ElementId), documentToNonElementParentNode)
import Data.DateTime.Instant (unInstant)
import Data.Maybe (Maybe(..))
import Data.Time.Duration (Milliseconds)
import Unsafe.Coerce (unsafeCoerce)

initialState :: ApplicationState
initialState = ApplicationState 0.0 88.0

rotateRecord :: ∀ eff.
  	ApplicationState ->
	Maybe Element ->
	Eff
		( dom :: DOM
        | eff
        )
        Unit
rotateRecord (ApplicationState rotation _) element = do
	case element of
		Just el ->
			setAttribute "style" ("width: 100px; height: 100px; background-color: black; transform-origin: 50% 50%; transform: rotate(" <> show rotation <> "deg);") el

		Nothing -> pure unit

keepLogging :: ∀ eff. ApplicationState -> Milliseconds -> Milliseconds -> Window -> Eff ( dom :: DOM, console :: CONSOLE, now :: NOW | eff) Unit
keepLogging appState previous current window =
	void $ requestAnimationFrame
		do
			-- Get the current timestamp in milliseconds
			current' <- unInstant <$> now
			-- Get the document type of the HTML document
			doc <- unsafeCoerce $ document window
			-- Retrieve the record element
			element <- getElementById (ElementId "record") $ documentToNonElementParentNode doc
			-- Declare the current parameter timestamp as the previous timestamp
			let previous' = current
			-- Update the application state by rotating the record element
			let appState' = rotate previous' current' appState

			rotateRecord appState' element
			keepLogging appState' previous current' window
	window

main :: ∀ eff. Eff
	(dom :: DOM
	, console :: CONSOLE
	, now :: NOW
	| eff
	) RequestAnimationFrameId
main = do
	window <- window
	current <- now
	requestAnimationFrame (keepLogging initialState (unInstant current) (unInstant current) window) window

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Window (RequestAnimationFrameId, requestAnimationFrame)

main :: forall e. Eff (dom :: DOM, console :: CONSOLE | e) RequestAnimationFrameId
main = do
	window <- window
	requestAnimationFrame (log "Hello world!") window


More polymorphic hoist functions

More polymorphic hoist functions

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, PG
, command
, execute
, hoist
, hoistWith
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (class MonadError, catchError, throwError)
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

type Database = String

-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with
-- | `ExceptT` to provide error handling.
-- |
-- | Errors originating from database queries or connection to the database are
-- | modeled with the `PGError` type. Use `runExceptT` from
-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either
-- | PGError a)`.
type PG a = ExceptT PGError Aff a

hoistWith :: forall e m. MonadAff m => MonadError e m => (PGError -> e) -> PG ~> ExceptT e m
hoistWith f m = do
  result <- liftAff $ runExceptT m
  case result of
    Right a -> pure a
    Left pgError -> throwError (f pgError)

hoist :: forall m. MonadAff m => MonadError PGError m => PG ~> ExceptT PGError m
hoist = hoistWith identity

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a
     . Pool
    -> (Connection -> PG a)
    -> PG a
withConnection p k = ExceptT $ P.withConnection p case _ of
  Right conn -> runExceptT $ k conn
  Left pgErr -> pure (Left pgErr)

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a
     . Connection
    -> PG a
    -> PG a
withTransaction conn action =
  ExceptT $ join <$> P.withTransaction conn (runExceptT action)

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> PG Unit
execute conn sql values = ExceptT $ P.execute conn sql values >>= case _ of
  Just pgErr -> pure (Left pgErr)
  Nothing -> pure (Right unit)

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o
     . ToSQLRow i
    => FromSQLRow o
    => Connection
    -> Query i o
    -> i
    -> PG (Array o)
query conn sql = ExceptT <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o
     . ToSQLRow i
    => FromSQLValue o
    => Connection
    -> Query i (Row1 o)
    -> i
    -> PG (Maybe o)
scalar conn sql = ExceptT <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i
     . ToSQLRow i
    => Connection
    -> Query i Int
    -> i
    -> PG Int
command conn sql = ExceptT <<< P.command conn sql

onIntegrityError :: forall a. PG a -> PG a -> PG a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e

module Database.PostgreSQL.PG
( module Row
, module Value
, module PostgreSQL
, PG
, command
, execute
, hoist
, hoistWith
, query
, onIntegrityError
, scalar
, withConnection
, withTransaction
) where

import Prelude

import Control.Monad.Error.Class (catchError, throwError)
import Control.Monad.Except (ExceptT(..))
import Control.Monad.Except.Trans (ExceptT, runExceptT)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Database.PostgreSQL (Connection, PGError(..), Pool, Query)
import Database.PostgreSQL (class FromSQLRow, class FromSQLValue, class ToSQLRow, class ToSQLValue, Connection, Database, PGError(..), PGErrorDetail, Pool, PoolConfiguration, Query(..), Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), defaultPoolConfiguration, fromSQLRow, fromSQLValue, instantFromString, instantToString, newPool, null, toSQLRow, toSQLValue, unsafeIsBuffer) as PostgreSQL
import Database.PostgreSQL (command, execute, query, scalar, withConnection, withTransaction) as P
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row0(..), Row1(..), Row10(..), Row11(..), Row12(..), Row13(..), Row14(..), Row15(..), Row16(..), Row17(..), Row18(..), Row19(..), Row2(..), Row3(..), Row4(..), Row5(..), Row6(..), Row7(..), Row8(..), Row9(..), fromSQLRow, toSQLRow) as Row
import Database.PostgreSQL.Row (class FromSQLRow, class ToSQLRow, Row1)
import Database.PostgreSQL.Value (class FromSQLValue)
import Database.PostgreSQL.Value (class FromSQLValue, class ToSQLValue, fromSQLValue, instantFromString, instantToString, null, toSQLValue, unsafeIsBuffer) as Value
import Effect.Aff (Aff)
import Effect.Aff.Class (class MonadAff, liftAff)

type Database = String

-- | PostgreSQL computations run in the `PG` monad. It's just `Aff` stacked with
-- | `ExceptT` to provide error handling.
-- |
-- | Errors originating from database queries or connection to the database are
-- | modeled with the `PGError` type. Use `runExceptT` from
-- | `Control.Monad.Except.Trans` to turn a `PG a` action into `Aff (Either
-- | PGError a)`.
type PG a = ExceptT PGError Aff a

hoistWith :: forall e m. MonadAff m => (PGError -> e) -> PG ~> ExceptT e m
hoistWith f m = ExceptT $ liftAff $
  runExceptT m >>= case _ of
    Right a -> pure (Right a)
    Left pgError -> pure (Left (f pgError))

hoist :: forall m. MonadAff m => PG ~> ExceptT PGError m
hoist = hoistWith identity

-- | Run an action with a connection. The connection is released to the pool
-- | when the action returns.
withConnection
    :: forall a
     . Pool
    -> (Connection -> PG a)
    -> PG a
withConnection p k = ExceptT $ P.withConnection p case _ of
  Right conn -> runExceptT $ k conn
  Left pgErr -> pure (Left pgErr)

-- | Run an action within a transaction. The transaction is committed if the
-- | action returns cleanly, and rolled back if the action throws (either a
-- | `PGError` or a JavaScript exception in PG context). If you want to
-- | change the transaction mode, issue a separate `SET TRANSACTION` statement
-- | within the transaction.
withTransaction
    :: forall a
     . Connection
    -> PG a
    -> PG a
withTransaction conn action =
  ExceptT $ join <$> P.withTransaction conn (runExceptT action)

-- | Execute a PostgreSQL query and discard its results.
execute
    :: forall i o
     . (ToSQLRow i)
    => Connection
    -> Query i o
    -> i
    -> PG Unit
execute conn sql values = ExceptT $ P.execute conn sql values >>= case _ of
  Just pgErr -> pure (Left pgErr)
  Nothing -> pure (Right unit)

-- | Execute a PostgreSQL query and return its results.
query
    :: forall i o
     . ToSQLRow i
    => FromSQLRow o
    => Connection
    -> Query i o
    -> i
    -> PG (Array o)
query conn sql = ExceptT <<< P.query conn sql

-- | Execute a PostgreSQL query and return the first field of the first row in
-- | the result.
scalar
    :: forall i o
     . ToSQLRow i
    => FromSQLValue o
    => Connection
    -> Query i (Row1 o)
    -> i
    -> PG (Maybe o)
scalar conn sql = ExceptT <<< P.scalar conn sql

-- | Execute a PostgreSQL query and return its command tag value
-- | (how many rows were affected by the query). This may be useful
-- | for example with `DELETE` or `UPDATE` queries.
command
    :: forall i
     . ToSQLRow i
    => Connection
    -> Query i Int
    -> i
    -> PG Int
command conn sql = ExceptT <<< P.command conn sql

onIntegrityError :: forall a. PG a -> PG a -> PG a
onIntegrityError errorResult db =
    catchError db handleError
    where
    handleError e =
        case e of
            IntegrityError _ -> errorResult
            _ -> throwError e


Fix InMemory put and delete bug

Fix InMemory put and delete bug

module Hyper.Node.Session.InMemory where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, readVar, takeVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (CONSOLE, log)
import Data.Map (Map)
import Data.Map as Map
import Data.Newtype (unwrap)
import Hyper.Session (class SessionStore, SessionID(..))

data InMemorySessionStore session = InMemorySessionStore (AVar (Map SessionID session))

instance sessionStoreInMemorySessionStore :: ( Monad m
                                             , MonadAff (avar :: AVAR, console :: CONSOLE | e) m
                                             )
                                          => SessionStore
                                            (InMemorySessionStore session)
                                            m
                                            session where
  newSessionID _ =
    pure (SessionID "new-id")

  get (InMemorySessionStore var) id =
    liftAff do
      log ("Looking up session: " <> show (unwrap id))
      Map.lookup id <$> readVar var

  put (InMemorySessionStore var) id session = do
    liftAff do
      log ("Saving session: " <> unwrap id)
      Map.insert id session <$> takeVar var >>= flip putVar var

  delete (InMemorySessionStore var) id = do
    liftAff do
      log ("Deleting session: " <> unwrap id)
      Map.delete id <$> takeVar var >>= flip putVar var

newInMemorySessionStore
  :: forall e session
   . Aff ( avar ∷ AVAR | e ) (InMemorySessionStore session)
newInMemorySessionStore = InMemorySessionStore <$> makeVar Map.empty

module Hyper.Node.Session.InMemory where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.Aff.AVar (AVAR, AVar, makeVar, putVar, readVar)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (CONSOLE, log)
import Data.Map (Map)
import Data.Map as Map
import Data.Newtype (unwrap)
import Hyper.Session (class SessionStore, SessionID(..))

data InMemorySessionStore session = InMemorySessionStore (AVar (Map SessionID session))

instance sessionStoreInMemorySessionStore :: ( Monad m
                                             , MonadAff (avar :: AVAR, console :: CONSOLE | e) m
                                             )
                                          => SessionStore
                                            (InMemorySessionStore session)
                                            m
                                            session where
  newSessionID _ =
    pure (SessionID "new-id")

  get (InMemorySessionStore var) id =
    liftAff do
      log ("Looking up session: " <> show (unwrap id))
      Map.lookup id <$> readVar var

  put (InMemorySessionStore var) id session = do
    liftAff do
      log ("Saving session: " <> unwrap id)
      Map.insert id session <$> readVar var >>= flip putVar var

  delete (InMemorySessionStore var) id = do
    liftAff do
      log ("Deleting session: " <> unwrap id)
      Map.delete id <$> readVar var >>= flip putVar var

newInMemorySessionStore
  :: forall e session
   . Aff ( avar ∷ AVAR | e ) (InMemorySessionStore session)
newInMemorySessionStore = InMemorySessionStore <$> makeVar Map.empty


Better split checking

Better split checking

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Model
  ( Model
  , eqModel
  , genModel
  , emptyModel
  , encode
  , decode
  ) where

import SlamData.Prelude
import Data.Argonaut as J
import Data.Argonaut ((~>), (:=), (.?))
import Data.Function (on)
import Data.Int (toNumber, floor)
import Data.List(List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe as Maybe
import Data.Ratio as Ratio
import Data.Rational (Rational(..), (%))
import Data.Rational as Rational
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Deck.DeckId (DeckId)
import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen
import Math as Math

type Model =
  { layout ∷ Pane.Pane (Maybe DeckId)
  }

eqModel
  ∷ Model
  → Model
  → Boolean
eqModel m1 m2 =
  m1.layout ≡ m2.layout

genModel ∷ Gen.Gen Model
genModel =
  { layout: _ } <$> genPane

emptyModel ∷ Model
emptyModel = { layout: Pane.Cell Nothing }

encode
  ∷ Model
  → J.Json
encode m =
  "layout" := encodePane m.layout
    ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj → decodeLayout obj <|> decodeDecks obj

  where
  decodeLayout obj = do
    layout ← decodePane =<< obj .? "layout"
    pure { layout }

  decodeDecks obj = do
    decks ∷ Map.Map DeckId DeckPosition ←
      traverse decodeDeckPosition =<< obj .? "decks"
    let
      layout = migrateLayout decks
    pure { layout }

encodePane
  ∷ ∀ a
  . J.EncodeJson a
  ⇒ Pane.Pane a
  → J.Json
encodePane = case _ of
  Pane.Cell a →
    "type" := "cell"
    ~> "value" := J.encodeJson a
    ~> J.jsonEmptyObject
  Pane.Split orn ps →
    "type" := "split"
      ~> "orientation" := encodeOrientation orn
      ~> "panes" := map encodeSplit ps
      ~> J.jsonEmptyObject
  where
  encodeSplit (Rational r × p) =
    "ratio" := J.encodeJson (Ratio.numerator r × Ratio.denominator r)
      ~> "pane" :=  encodePane p
      ~> J.jsonEmptyObject

decodePane
  ∷ ∀ a
  . J.DecodeJson a
  ⇒ J.Json
  → Either String (Pane.Pane a)
decodePane =
  J.decodeJson >=> \obj → do
    ty ← obj .? "type"
    case ty of
      "cell" → do
        value ← obj .? "value"
        pure (Pane.Cell value)
      "split" → do
        orn ← decodeOrientation =<< obj .? "orientation"
        ps ← traverse decodeSplits =<< obj .? "panes"
        pure (Pane.Split orn ps)
      _ → do
        Left ("Not a valid Pane tag: " <> ty)
  where
  decodeSplits obj = do
    n × d ← obj .? "ratio"
    pane ← decodePane =<< obj .? "pane"
    pure (n%d × pane)

genPane
  ∷ ∀ a
  . SC.Arbitrary a
  ⇒ Gen.Gen (Pane.Pane a)
genPane = genOrientation >>= goGen
  where
  goGen orn =
    SC.arbitrary >>=
    if _
      then Pane.Cell <$> SC.arbitrary
      else Pane.Split orn <$> genSplit orn 16 List.Nil

  genSplit orn range ps = do
    num ← Gen.chooseInt 1.0 (toNumber range)
    pane ← goGen (Orn.reverse orn)
    let
      ps' = List.Cons ((num%16) × pane) ps
      range' = range - num
    if range' ≡ 0
      then pure ps'
      else genSplit orn range' ps'

encodeOrientation ∷ Orn.Orientation → J.Json
encodeOrientation = J.encodeJson ∘ Orn.toString

decodeOrientation ∷ J.Json → Either String Orn.Orientation
decodeOrientation = J.decodeJson >=> case _ of
  "vertical" → pure Orn.Vertical
  "horizontal" → pure Orn.Horizontal
  s → Left ("Invalid orientation: " <> s)

genOrientation ∷ Gen.Gen Orn.Orientation
genOrientation = SC.arbitrary <#> if _ then Orn.Vertical else Orn.Horizontal

type DeckPosition =
  { x ∷ Number
  , y ∷ Number
  , width ∷ Number
  , height ∷ Number
  }

decodeDeckPosition
  ∷ J.Json
  → Either String DeckPosition
decodeDeckPosition =
  J.decodeJson >=> \obj → do
    x ← obj .? "x"
    y ← obj .? "y"
    width ← obj .? "width"
    height ← obj .? "height"
    pure { x, y, width, height }

migrateLayout
  ∷ Map.Map DeckId DeckPosition
  → Pane.Pane (Maybe DeckId)
migrateLayout decks =
  splitTop total Nil deckList

  where
  deckList =
    List.sortBy (compare `on` (snd ⋙ \r → Math.sqrt ((r.x * r.x) + (r.y * r.y))))
      $ Map.toList decks

  total =
    let
      size =
        foldl
          (\acc r →
            { width: if r.x + r.width > acc.width then r.x + r.width else acc.width
            , height: if r.y + r.height > acc.height then r.y + r.height else acc.height
            })
          { width: 0.0, height: 0.0 }
          decks
    in case deckList of
      List.Cons (_ × rect) _ →
        { x: rect.x
        , y: rect.y
        , width: size.width - rect.x
        , height: size.height - rect.y
        }
      _ →
        { x: 0.0
        , y: 0.0
        , width: 0.0
        , height: 0.0
        }

  splitTop r1 Nil Nil =
    Pane.Cell Nothing
  splitTop r1 ps Nil =
    splitLeft r1 Nil ps
  splitTop r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitTop r1 ps ((deckId × r2) : ds) | r2.y - r1.y == 0.0 =
    splitTop r1 ((deckId × r2) : ps) ds
  splitTop r1 ps ((deckId × r2) : ds) =
    case trySplitV r2.y (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.y - r1.y) % floor r1.height
          r1'   = r1 { height = r2.y - r1.y }
        in case bs of
          Nil →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (Pane.wrap Orn.Horizontal (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (splitLeft r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitTop r1 ((deckId × r2) : ps) ds

  splitLeft r1 Nil Nil =
    Pane.Cell Nothing
  splitLeft r1 ps Nil =
    splitTop r1 Nil ps
  splitLeft r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitLeft r1 ps ((deckId × r2) : ds) | r2.x - r1.x == 0.0 =
    splitLeft r1 ((deckId × r2) : ps) ds
  splitLeft r1 ps ((deckId × r2) : ds) =
    case trySplitH r2.x (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.x - r1.x) % floor r1.width
          r1'   = r1 { width = r2.x - r1.x }
        in case bs of
          Nil →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (Pane.wrap Orn.Vertical (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (splitTop r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitLeft r1 ((deckId × r2) : ps) ds

  trySplitH = trySplit Orn.Horizontal Nil Nil
  trySplitV = trySplit Orn.Vertical Nil Nil

  trySplit orn a b z Nil = Just (a × b)
  trySplit orn a b z ((deckId × r) : ds) =
    case orn of
      Orn.Horizontal →
        if z > r.x && z < r.x + r.width then
          Nothing
        else if r.x < z then
          trySplit orn ((deckId × r) : a) b z ds
        else
          trySplit orn a ((deckId × r) : b) z ds
      Orn.Vertical →
        if z > r.y && z < r.y + r.height then
          Nothing
        else if r.y < z then
          trySplit orn ((deckId × r) : a) b z ds
        else
          trySplit orn a ((deckId × r) : b) z ds

  merge orn ratio a b =
    let
      ps = List.fromFoldable [ ratio × Pane.Cell Nothing, (one - ratio) × Pane.Cell Nothing ]
    in case (Layout.defaultMerge orn ps 0 a), (Layout.defaultMerge orn ps 1 b) of
      Pane.Split _ as, Pane.Split _ bs →
        let
          as' = unsafePartial (Maybe.fromJust (List.init as))
          bs' = unsafePartial (Maybe.fromJust (List.tail bs))
        in
          Pane.Split orn (bestFit zero Nil (as' <> bs'))
      _, _ →
        -- Should never happen
        Pane.Split orn ps

  bestFit off acc Nil = Nil
  bestFit off acc ((_ × p) : Nil) =
    List.reverse ((one - off × p) : acc)
  bestFit off acc ((ratio × p) : ps) =
    let
      ratio' = Layout.closestSnapRatio (Rational.toNumber ratio)
    in
      bestFit (off + ratio') ((ratio' × p) : acc) ps

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Model
  ( Model
  , eqModel
  , genModel
  , emptyModel
  , encode
  , decode
  ) where

import SlamData.Prelude
import Data.Argonaut as J
import Data.Argonaut ((~>), (:=), (.?))
import Data.Function (on)
import Data.Int (toNumber, floor)
import Data.List(List(..), (:))
import Data.List as List
import Data.Map as Map
import Data.Maybe as Maybe
import Data.Ratio as Ratio
import Data.Rational (Rational(..), (%))
import Data.Rational as Rational
import SlamData.Workspace.Card.Draftboard.Layout as Layout
import SlamData.Workspace.Card.Draftboard.Orientation as Orn
import SlamData.Workspace.Card.Draftboard.Pane as Pane
import SlamData.Workspace.Deck.DeckId (DeckId)
import Test.StrongCheck.Arbitrary as SC
import Test.StrongCheck.Gen as Gen
import Math as Math

type Model =
  { layout ∷ Pane.Pane (Maybe DeckId)
  }

eqModel
  ∷ Model
  → Model
  → Boolean
eqModel m1 m2 =
  m1.layout ≡ m2.layout

genModel ∷ Gen.Gen Model
genModel =
  { layout: _ } <$> genPane

emptyModel ∷ Model
emptyModel = { layout: Pane.Cell Nothing }

encode
  ∷ Model
  → J.Json
encode m =
  "layout" := encodePane m.layout
    ~> J.jsonEmptyObject

decode
  ∷ J.Json
  → Either String Model
decode =
  J.decodeJson >=> \obj → decodeLayout obj <|> decodeDecks obj

  where
  decodeLayout obj = do
    layout ← decodePane =<< obj .? "layout"
    pure { layout }

  decodeDecks obj = do
    decks ∷ Map.Map DeckId DeckPosition ←
      traverse decodeDeckPosition =<< obj .? "decks"
    let
      layout = migrateLayout decks
    pure { layout }

encodePane
  ∷ ∀ a
  . J.EncodeJson a
  ⇒ Pane.Pane a
  → J.Json
encodePane = case _ of
  Pane.Cell a →
    "type" := "cell"
    ~> "value" := J.encodeJson a
    ~> J.jsonEmptyObject
  Pane.Split orn ps →
    "type" := "split"
      ~> "orientation" := encodeOrientation orn
      ~> "panes" := map encodeSplit ps
      ~> J.jsonEmptyObject
  where
  encodeSplit (Rational r × p) =
    "ratio" := J.encodeJson (Ratio.numerator r × Ratio.denominator r)
      ~> "pane" :=  encodePane p
      ~> J.jsonEmptyObject

decodePane
  ∷ ∀ a
  . J.DecodeJson a
  ⇒ J.Json
  → Either String (Pane.Pane a)
decodePane =
  J.decodeJson >=> \obj → do
    ty ← obj .? "type"
    case ty of
      "cell" → do
        value ← obj .? "value"
        pure (Pane.Cell value)
      "split" → do
        orn ← decodeOrientation =<< obj .? "orientation"
        ps ← traverse decodeSplits =<< obj .? "panes"
        pure (Pane.Split orn ps)
      _ → do
        Left ("Not a valid Pane tag: " <> ty)
  where
  decodeSplits obj = do
    n × d ← obj .? "ratio"
    pane ← decodePane =<< obj .? "pane"
    pure (n%d × pane)

genPane
  ∷ ∀ a
  . SC.Arbitrary a
  ⇒ Gen.Gen (Pane.Pane a)
genPane = genOrientation >>= goGen
  where
  goGen orn =
    SC.arbitrary >>=
    if _
      then Pane.Cell <$> SC.arbitrary
      else Pane.Split orn <$> genSplit orn 16 List.Nil

  genSplit orn range ps = do
    num ← Gen.chooseInt 1.0 (toNumber range)
    pane ← goGen (Orn.reverse orn)
    let
      ps' = List.Cons ((num%16) × pane) ps
      range' = range - num
    if range' ≡ 0
      then pure ps'
      else genSplit orn range' ps'

encodeOrientation ∷ Orn.Orientation → J.Json
encodeOrientation = J.encodeJson ∘ Orn.toString

decodeOrientation ∷ J.Json → Either String Orn.Orientation
decodeOrientation = J.decodeJson >=> case _ of
  "vertical" → pure Orn.Vertical
  "horizontal" → pure Orn.Horizontal
  s → Left ("Invalid orientation: " <> s)

genOrientation ∷ Gen.Gen Orn.Orientation
genOrientation = SC.arbitrary <#> if _ then Orn.Vertical else Orn.Horizontal

type DeckPosition =
  { x ∷ Number
  , y ∷ Number
  , width ∷ Number
  , height ∷ Number
  }

decodeDeckPosition
  ∷ J.Json
  → Either String DeckPosition
decodeDeckPosition =
  J.decodeJson >=> \obj → do
    x ← obj .? "x"
    y ← obj .? "y"
    width ← obj .? "width"
    height ← obj .? "height"
    pure { x, y, width, height }

migrateLayout
  ∷ Map.Map DeckId DeckPosition
  → Pane.Pane (Maybe DeckId)
migrateLayout decks =
  splitTop total Nil deckList

  where
  deckList =
    List.sortBy (compare `on` (snd ⋙ \r → Math.sqrt ((r.x * r.x) + (r.y * r.y))))
      $ Map.toList decks

  total =
    let
      size =
        foldl
          (\acc r →
            { width: if r.x + r.width > acc.width then r.x + r.width else acc.width
            , height: if r.y + r.height > acc.height then r.y + r.height else acc.height
            })
          { width: 0.0, height: 0.0 }
          decks
    in case deckList of
      List.Cons (_ × rect) _ →
        { x: rect.x
        , y: rect.y
        , width: size.width - rect.x
        , height: size.height - rect.y
        }
      _ →
        { x: 0.0
        , y: 0.0
        , width: 0.0
        , height: 0.0
        }

  splitTop r1 Nil Nil =
    Pane.Cell Nothing
  splitTop r1 ps Nil =
    splitLeft r1 Nil ps
  splitTop r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitTop r1 ps ((deckId × r2) : ds) | r2.y - r1.y == 0.0 =
    splitTop r1 ((deckId × r2) : ps) ds
  splitTop r1 ps ((deckId × r2) : ds) =
    case trySplitV r1.x r2.y r1.width (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.y - r1.y) % floor r1.height
          r1'   = r1 { height = r2.y - r1.y }
        in case bs of
          Nil →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (Pane.wrap Orn.Horizontal (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Vertical ratio
              (splitLeft r1' Nil as)
              (splitLeft r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitTop r1 ((deckId × r2) : ps) ds

  splitLeft r1 Nil Nil =
    Pane.Cell Nothing
  splitLeft r1 ps Nil =
    splitTop r1 Nil ps
  splitLeft r1 Nil ((deckId × r2) : Nil) =
    Pane.Cell (Just deckId)
  splitLeft r1 ps ((deckId × r2) : ds) | r2.x - r1.x == 0.0 =
    splitLeft r1 ((deckId × r2) : ps) ds
  splitLeft r1 ps ((deckId × r2) : ds) =
    case trySplitH r2.x r1.y r1.height (ps <> ds) of
      Just (as × bs) →
        let
          ratio = floor (r2.x - r1.x) % floor r1.width
          r1'   = r1 { width = r2.x - r1.x }
        in case bs of
          Nil →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (Pane.wrap Orn.Vertical (Pane.Cell (Just deckId)))
          _ →
            merge Orn.Horizontal ratio
              (splitTop r1' Nil as)
              (splitTop r1' Nil ((deckId × r2) : bs))
      Nothing →
        splitLeft r1 ((deckId × r2) : ps) ds

  trySplitH = trySplit Orn.Horizontal Nil Nil
  trySplitV = trySplit Orn.Vertical Nil Nil

  trySplit orn a b x y z Nil = Just (a × b)
  trySplit orn a b x y z ((deckId × r) : ds) =
    case orn of
      Orn.Horizontal →
        if inside r x y || inside r x (y + z) then
          Nothing
        else if r.x < x then
          trySplit orn ((deckId × r) : a) b x y z ds
        else
          trySplit orn a ((deckId × r) : b) x y z ds
      Orn.Vertical →
        if inside r x y || inside r (x + z) y
          then Nothing
        else if r.y < y then
          trySplit orn ((deckId × r) : a) b x y z ds
        else
          trySplit orn a ((deckId × r) : b) x y z ds

  inside r x y =
    x > r.x && x < r.x + r.width &&
    y > r.y && y < r.y + r.height

  merge orn ratio a b =
    let
      ps = List.fromFoldable [ ratio × Pane.Cell Nothing, (one - ratio) × Pane.Cell Nothing ]
    in case (Layout.defaultMerge orn ps 0 a), (Layout.defaultMerge orn ps 1 b) of
      Pane.Split _ as, Pane.Split _ bs →
        let
          as' = unsafePartial (Maybe.fromJust (List.init as))
          bs' = unsafePartial (Maybe.fromJust (List.tail bs))
        in
          Pane.Split orn (bestFit zero Nil (as' <> bs'))
      _, _ →
        -- Should never happen
        Pane.Split orn ps

  bestFit off acc Nil = Nil
  bestFit off acc ((_ × p) : Nil) =
    List.reverse ((one - off × p) : acc)
  bestFit off acc ((ratio × p) : ps) =
    let
      ratio' = Layout.closestSnapRatio (Rational.toNumber ratio)
    in
      bestFit (off + ratio') ((ratio' × p) : acc) ps


Fix auto generated wrong module

Fix auto generated wrong module

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , _address
       , _coin
       , mkCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , _ctxIdValue
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..))
import Pos.Types.Coin (Coin (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Types.Coin as C
import Pos.Wallet.Web.Error as E

import Data.Either (either)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)

import Data.Types (mkTime)

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses

_hash :: CHash -> String
_hash (CHash h) = h

_address :: CAddress -> String
_address (CAddress a) = _hash a

mkCAddress :: String -> CAddress
mkCAddress = CAddress <<< CHash

_coin :: Coin -> Int
_coin (Coin c) = c.getCoin

mkCoin :: Int -> Coin
mkCoin amount = Coin { getCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWalletType :: String -> CT.CWalletType
mkCWalletType = either (const CT.CWTPersonal) id <<< decodeJson <<< fromString

mkCCurrency :: String -> CT.CCurrency
mkCCurrency = either (const CT.ADA) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> String -> Number -> CT.CTxMeta
mkCTxMeta currency title description date =
    CT.CTxMeta { ctmCurrency: mkCCurrency currency
               , ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }

module Daedalus.Types
       ( module CT
       , module T
       , module E
       , _address
       , _coin
       , mkCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , _ctxIdValue
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..))
import Pos.Types.Types (Coin (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Types.Types as T
import Pos.Wallet.Web.Error as E

import Data.Either (either)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)

import Data.Types (mkTime)

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses

_hash :: CHash -> String
_hash (CHash h) = h

_address :: CAddress -> String
_address (CAddress a) = _hash a

mkCAddress :: String -> CAddress
mkCAddress = CAddress <<< CHash

_coin :: Coin -> Int
_coin (Coin c) = c.getCoin

mkCoin :: Int -> Coin
mkCoin amount = Coin { getCoin: amount }

-- NOTE: use genericRead maybe https://github.com/paluh/purescript-generic-read-example
mkCWalletType :: String -> CT.CWalletType
mkCWalletType = either (const CT.CWTPersonal) id <<< decodeJson <<< fromString

mkCCurrency :: String -> CT.CCurrency
mkCCurrency = either (const CT.ADA) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   }

_ctxIdValue :: CT.CTxId -> String
_ctxIdValue (CT.CTxId tx) = _hash tx

mkCTxId :: String -> CT.CTxId
mkCTxId = CT.CTxId <<< CHash

mkCTxMeta :: String -> String -> String -> Number -> CT.CTxMeta
mkCTxMeta currency title description date =
    CT.CTxMeta { ctmCurrency: mkCCurrency currency
               , ctmTitle: title
               , ctmDescription: description
               , ctmDate: mkTime date
               }


[PR Feedback]: Don't test for a particular server error message

One wrinkle is that at the moment we want to wait for the warning box to
appear, the warning box actually is momentarily visible (displaying an
old validation error that will shortly disappear). So it is necessary to
wait for it to be invisible, and then wait for it to become visible
again.

module Test.Selenium.File where

import Prelude
import DOM (DOM())
import Control.Apply ((*>))
import Control.Bind ((>=>), (=<<))
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error)
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, filter, null)
import Selenium.Types
import Selenium.MouseButton
import Selenium.ActionSequence
import Selenium.Key

import Utils.Log
import Test.Config
import Driver.File.Routing (Routes(..), routing)
import Driver.File.Search (searchPath)
import Routing (matchHash)
import qualified Data.Array as Arr
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 :: !

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

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

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

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

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

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

mountDatabaseWithMountConfig :: MountConfigR -> Check Unit
mountDatabaseWithMountConfig mountConfig = do
  home
  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://" ++ mountConfig.host ++ ":" ++ show mountConfig.port ++ "/" ++ config.database.name
  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

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

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

  config <- getConfig
  waitCheck mountShown config.selenium.waitTime

  where
    mountShown :: Check Boolean
    mountShown = checker $ do
      config <- getConfig
      isJust <$> findItem config.mount.name

badMountDatabase :: Check Unit
badMountDatabase = do
  sectionMsg "BAD MOUNT TEST DATABASE"
  config <- getConfig

  badMountConfig
    >>= mountDatabaseWithMountConfig

  warningBox <- getElementByCss config.configureMount.warningBox "no warning box"

  -- wait for any old validation messages to disappear
  waitCheck (checker $ not <$> visible warningBox) config.selenium.waitTime
  -- wait for the server error to appear
  waitCheck (checker $ visible warningBox) 8000

  cancelButton <- getElementByCss config.configureMount.cancelButton "no cancel button"
  actions $ leftClick cancelButton
  waitCheck modalDismissed config.selenium.waitTime

  where
    badMountConfig :: Check MountConfigR
    badMountConfig = do
      mountConfig <- mountConfigFromConfig
      pure $ mountConfig { port = mountConfig.port - 1 }

unmountDatabase :: Check Unit
unmountDatabase = do
  sectionMsg "UNMOUNT TEST DATABASE"
  home
  config <- getConfig
  mountItem <-
    findItem config.mount.name
      >>= maybe (errorMsg "No mount item") pure

  actions $ leftClick mountItem
  itemGetDeleteIcon mountItem >>= itemClickToolbarIcon mountItem
  _ <- later 3000 $ pure unit
  findItem config.mount.name
    >>= maybe (pure unit) (const $ errorMsg "did not unmount")
  successMsg "successfully unmounted"

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
  -- W/o this it will show toolbar
  actions $ mouseToLocation {x: 0.0, y: 0.0}
  { 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
  fileComponentLoaded

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
    fileComponentLoaded
    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
  fileComponentLoaded
  checkURL
  successMsg "Ok, went home after click on root breadcrumb"

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

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

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

  anchors :: Check (List Element)
  anchors = do
    bs <- breadcrumbs
    config <- getConfig
    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
    fileComponentLoaded
    nTexts <- getItemTexts
    if reverse nTexts == texts
      then successMsg "OK, sort works"
      else errorMsg "Sorting doesn't work"
  checkHash _ _ = errorMsg "need additional redirects in sorting"

fileUpload :: Check Unit
fileUpload = do
  sectionMsg "FILE UPLOAD"
  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 awaitInNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  back
  fileComponentLoaded

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

shareFile :: Check Unit
shareFile = do
  sectionMsg "SHARE FILE"
  goDown
  config <- getConfig
  uploadedItem <- getUploadedItem
  itemGetShareIcon uploadedItem >>= itemClickToolbarIcon uploadedItem
  waitCheck modalShown config.selenium.waitTime
  successMsg "Share modal dialog appeared"
  urlField <- getElementByCss config.share.urlField "there is no url field"
  urlValue <- attribute urlField "value"
  successMsg $ "Share url: " <> urlValue
  goTo urlValue
  waitCheck awaitInNotebook config.selenium.waitTime
  successMsg "Ok, share link led to notebook"

  where
    itemGetShareIcon :: Element -> Check Element
    itemGetShareIcon item =
      checkLocator shareLoc
        >>= child item
        >>= maybe (errorMsg "no share icon") pure

    shareLoc :: Element -> Check Element
    shareLoc el = getConfig >>= \config -> buttonLoc config.share.markShare el

searchForUploadedFile :: Check Unit
searchForUploadedFile = do
  sectionMsg "SEARCH"
  home
  config <- getConfig
  searchInput <- getElementByCss config.search.searchInput "no search input field"
  url <- getURL
  let filename = fromMaybe config.upload.file $ Arr.last $ Str.split "/" config.upload.file
  actions $ do
    leftClick searchInput
    sendKeys filename
  searchButton <- getElementByCss config.search.searchButton "no search button"
  actions $ leftClick searchButton
  waitCheck (awaitUrlChanged url) config.selenium.waitTime
  waitCheck (awaitItemShown filename) 5000
  matchingItems <- filter (contains filename) <$> getItemTexts

  if null matchingItems
    then errorMsg "Failed searching for uploaded file"
    else successMsg "Searched for and found uploaded file"

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

    awaitItemShown :: String -> Check Boolean
    awaitItemShown name = checker $ not <<< null <<< filter (contains name) <$> getItemTexts

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

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

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

  getUploadedItem
    >>= checkMove
    >>= checkDelete

  where
  errUploaded = errorMsg "File has not been uploaded"

  -- | 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

    _ <- later 3000 $ pure unit
    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
    _ <- later 3000 $ pure unit
    findItem config.move.other
      >>= maybe (pure unit) (const $ errorMsg "not deleted")
    successMsg "successfully deleted"

  moveLoc :: Element -> Check Element
  moveLoc el = getConfig >>= \config -> buttonLoc config.move.markMove 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

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

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

-- | 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

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
  fileComponentLoaded
  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
  _ <- later 1000 $ pure unit

  folder <- getNewFolder
  actions $ doubleClick leftButton folder
  fileComponentLoaded

  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"

createNotebookAndThen :: Check Unit -> Check Unit
createNotebookAndThen andThen = do
  goDown
  config <- getConfig
  actions <<< leftClick =<< getNewNotebookButton
  attempt (waitCheck notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")
  andThen
  where
  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    toolbarButton config.toolbar.newNotebook
      >>= maybe (errorMsg "No create notebook button") pure

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

createNotebook :: Check Unit
createNotebook = do
  sectionMsg "NEW NOTEBOOK CHECK"
  createNotebookAndThen do
    back
    fileComponentLoaded
    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

checkTitle :: Check Unit
checkTitle = do
  driver <- getDriver
  config <- getConfig
  windowTitle <- title
  if Str.contains config.version windowTitle
    then successMsg "Title contains version"
    else errorMsg $ "Title (" ++ windowTitle ++ ") doesn't contain version"

test :: Check Unit
test = do
  home
  badMountDatabase
  goodMountDatabase
  unmountDatabase
  goodMountDatabase
  checkMountedDatabase
  checkConfigureMount
  checkItemToolbar
  checkURL
  goDown
  checkBreadcrumbs
  sorting
  fileUpload
  searchForUploadedFile
  shareFile
  moveDelete
  trashCheck
  checkTitle
  createFolder
  createNotebook

module Test.Selenium.File where

import Prelude
import DOM (DOM())
import Control.Apply ((*>))
import Control.Bind ((>=>), (=<<))
import Control.Monad.Error.Class (throwError)
import Control.Monad.Eff.Exception (error)
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, filter, null)
import Selenium.Types
import Selenium.MouseButton
import Selenium.ActionSequence
import Selenium.Key

import Utils.Log
import Test.Config
import Driver.File.Routing (Routes(..), routing)
import Driver.File.Search (searchPath)
import Routing (matchHash)
import qualified Data.Array as Arr
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 :: !

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

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

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

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

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

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

mountDatabaseWithMountConfig :: MountConfigR -> Check Unit
mountDatabaseWithMountConfig mountConfig = do
  home
  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://" ++ mountConfig.host ++ ":" ++ show mountConfig.port ++ "/" ++ config.database.name
  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

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

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

  config <- getConfig
  waitCheck mountShown config.selenium.waitTime

  where
    mountShown :: Check Boolean
    mountShown = checker $ do
      config <- getConfig
      isJust <$> findItem config.mount.name

badMountDatabase :: Check Unit
badMountDatabase = do
  sectionMsg "BAD MOUNT TEST DATABASE"
  config <- getConfig

  badMountConfig
    >>= mountDatabaseWithMountConfig

  waitCheck (checker expectWarningMessage) 8000

  cancelButton <- getElementByCss config.configureMount.cancelButton "no cancel button"
  actions $ leftClick cancelButton
  waitCheck modalDismissed config.selenium.waitTime

  where
    expectWarningMessage :: Check Boolean
    expectWarningMessage = do
      config <- getConfig
      getElementByCss config.configureMount.warningBox "no warning box"
        >>= innerHtml
        <#> R.test (R.regex "Invalid server and / or port specified" R.noFlags)

    badMountConfig :: Check MountConfigR
    badMountConfig = do
      mountConfig <- mountConfigFromConfig
      pure $ mountConfig { port = mountConfig.port - 1 }

unmountDatabase :: Check Unit
unmountDatabase = do
  sectionMsg "UNMOUNT TEST DATABASE"
  home
  config <- getConfig
  mountItem <-
    findItem config.mount.name
      >>= maybe (errorMsg "No mount item") pure

  actions $ leftClick mountItem
  itemGetDeleteIcon mountItem >>= itemClickToolbarIcon mountItem
  _ <- later 3000 $ pure unit
  findItem config.mount.name
    >>= maybe (pure unit) (const $ errorMsg "did not unmount")
  successMsg "successfully unmounted"

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
  -- W/o this it will show toolbar
  actions $ mouseToLocation {x: 0.0, y: 0.0}
  { 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
  fileComponentLoaded

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
    fileComponentLoaded
    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
  fileComponentLoaded
  checkURL
  successMsg "Ok, went home after click on root breadcrumb"

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

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

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

  anchors :: Check (List Element)
  anchors = do
    bs <- breadcrumbs
    config <- getConfig
    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
    fileComponentLoaded
    nTexts <- getItemTexts
    if reverse nTexts == texts
      then successMsg "OK, sort works"
      else errorMsg "Sorting doesn't work"
  checkHash _ _ = errorMsg "need additional redirects in sorting"

fileUpload :: Check Unit
fileUpload = do
  sectionMsg "FILE UPLOAD"
  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 awaitInNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  back
  fileComponentLoaded

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

shareFile :: Check Unit
shareFile = do
  sectionMsg "SHARE FILE"
  goDown
  config <- getConfig
  uploadedItem <- getUploadedItem
  itemGetShareIcon uploadedItem >>= itemClickToolbarIcon uploadedItem
  waitCheck modalShown config.selenium.waitTime
  successMsg "Share modal dialog appeared"
  urlField <- getElementByCss config.share.urlField "there is no url field"
  urlValue <- attribute urlField "value"
  successMsg $ "Share url: " <> urlValue
  goTo urlValue
  waitCheck awaitInNotebook config.selenium.waitTime
  successMsg "Ok, share link led to notebook"

  where
    itemGetShareIcon :: Element -> Check Element
    itemGetShareIcon item =
      checkLocator shareLoc
        >>= child item
        >>= maybe (errorMsg "no share icon") pure

    shareLoc :: Element -> Check Element
    shareLoc el = getConfig >>= \config -> buttonLoc config.share.markShare el

searchForUploadedFile :: Check Unit
searchForUploadedFile = do
  sectionMsg "SEARCH"
  home
  config <- getConfig
  searchInput <- getElementByCss config.search.searchInput "no search input field"
  url <- getURL
  let filename = fromMaybe config.upload.file $ Arr.last $ Str.split "/" config.upload.file
  actions $ do
    leftClick searchInput
    sendKeys filename
  searchButton <- getElementByCss config.search.searchButton "no search button"
  actions $ leftClick searchButton
  waitCheck (awaitUrlChanged url) config.selenium.waitTime
  waitCheck (awaitItemShown filename) 5000
  matchingItems <- filter (contains filename) <$> getItemTexts

  if null matchingItems
    then errorMsg "Failed searching for uploaded file"
    else successMsg "Searched for and found uploaded file"

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

    awaitItemShown :: String -> Check Boolean
    awaitItemShown name = checker $ not <<< null <<< filter (contains name) <$> getItemTexts

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

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

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

  getUploadedItem
    >>= checkMove
    >>= checkDelete

  where
  errUploaded = errorMsg "File has not been uploaded"

  -- | 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

    _ <- later 3000 $ pure unit
    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
    _ <- later 3000 $ pure unit
    findItem config.move.other
      >>= maybe (pure unit) (const $ errorMsg "not deleted")
    successMsg "successfully deleted"

  moveLoc :: Element -> Check Element
  moveLoc el = getConfig >>= \config -> buttonLoc config.move.markMove 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

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

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

-- | 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

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
  fileComponentLoaded
  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
  _ <- later 1000 $ pure unit

  folder <- getNewFolder
  actions $ doubleClick leftButton folder
  fileComponentLoaded

  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"

createNotebookAndThen :: Check Unit -> Check Unit
createNotebookAndThen andThen = do
  goDown
  config <- getConfig
  actions <<< leftClick =<< getNewNotebookButton
  attempt (waitCheck notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")
  andThen
  where
  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    toolbarButton config.toolbar.newNotebook
      >>= maybe (errorMsg "No create notebook button") pure

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

createNotebook :: Check Unit
createNotebook = do
  sectionMsg "NEW NOTEBOOK CHECK"
  createNotebookAndThen do
    back
    fileComponentLoaded
    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

checkTitle :: Check Unit
checkTitle = do
  driver <- getDriver
  config <- getConfig
  windowTitle <- title
  if Str.contains config.version windowTitle
    then successMsg "Title contains version"
    else errorMsg $ "Title (" ++ windowTitle ++ ") doesn't contain version"

test :: Check Unit
test = do
  home
  badMountDatabase
  goodMountDatabase
  unmountDatabase
  goodMountDatabase
  checkMountedDatabase
  checkConfigureMount
  checkItemToolbar
  checkURL
  goDown
  checkBreadcrumbs
  sorting
  fileUpload
  searchForUploadedFile
  shareFile
  moveDelete
  trashCheck
  checkTitle
  createFolder
  createNotebook


Replace function by if-then

Replace function by if-then

module Test.Spec.Runner (
  Process(..),
  run
  ) where

import Prelude

import Control.Monad.Aff         (runAff)
import Control.Monad.Eff         (Eff())
import Control.Monad.Eff.Console (CONSOLE(), print)
import Data.Foldable             (sequence_)

import Test.Spec          (Spec(), collect)
import Test.Spec.Console  (withAttrs)
import Test.Spec.Summary  (successful)
import Test.Spec.Reporter (Reporter())

foreign import data Process :: !

foreign import exit :: forall eff. Int -> Eff (process :: Process | eff) Unit

-- Runs the tests and invoke all reporters.
-- If run in a NodeJS environment any failed test will cause the
-- process to exit with a non-zero exit code. On success it will
-- exit with a zero exit code explicitly, so passing integration tests that still have
-- connections open can run in CI successfully.
run :: forall e.
    Array (Reporter (process :: Process, console :: CONSOLE | e))
    -> Spec (process :: Process, console :: CONSOLE | e) Unit
    -> Eff  (process :: Process, console :: CONSOLE | e) Unit
run rs spec = do
  runAff
    (\err -> do withAttrs [31] $ print err
                exit 1)
    (\results -> do sequence_ (map (\f -> f results) rs)
                    if (successful results)
                      then exit 0
                      else exit 1)
    (collect spec)

module Test.Spec.Runner (
  Process(..),
  run
  ) where

import Prelude

import Control.Monad.Aff         (runAff)
import Control.Monad.Eff         (Eff())
import Control.Monad.Eff.Console (CONSOLE(), print)
import Data.Foldable             (sequence_)

import Test.Spec          (Spec(), collect)
import Test.Spec.Console  (withAttrs)
import Test.Spec.Summary  (successful)
import Test.Spec.Reporter (Reporter())

foreign import data Process :: !

foreign import exit :: forall eff. Int -> Eff (process :: Process | eff) Unit

-- Runs the tests and invoke all reporters.
-- If run in a NodeJS environment any failed test will cause the
-- process to exit with a non-zero exit code. On success it will
-- exit with a zero exit code explicitly, so passing integration tests that still have
-- connections open can run in CI successfully.
run :: forall e.
    Array (Reporter (process :: Process, console :: CONSOLE | e))
    -> Spec (process :: Process, console :: CONSOLE | e) Unit
    -> Eff  (process :: Process, console :: CONSOLE | e) Unit
run rs spec = do
  runAff
    (\err -> do withAttrs [31] $ print err
                exit 1)
    (\results -> do sequence_ (map (\f -> f results) rs)
                    exitWithCode (successful results))
    (collect spec)

exitWithCode :: forall t5.
  Boolean
  -> Eff ( process :: Process | t5) Unit
exitWithCode success = exit (code success)
  where code true  = 0
	code false = 1