browser rendering functions for BrowserContainer

module Genetics.Browser where

import Prelude

import Color (Color, black, white)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Reader (class MonadReader, ask)
import Data.Array ((..))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens ((^.))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap, wrap)
import Data.Number.Format as Num
import Data.Pair (Pair(..))
import Data.Record as Record
import Data.Record.Builder (build, insert)
import Data.Record.Unsafe as Record
import Data.Symbol (class IsSymbol, SProxy(SProxy), reflectSymbol)
import Data.Variant (Variant, case_, inj, onMatch)
import Genetics.Browser.Cached (Cached, cache)
import Genetics.Browser.Canvas (BrowserCanvas, BrowserContainer(..), Label, LayerRenderable, UISlot, UISlotGravity(UIBottom, UITop, UIRight, UILeft), _Dimensions, _Track)
import Genetics.Browser.Canvas (uiSlots) as Canvas
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, Normalized(Normalized), _Segments, aroundPair, pairSize, scaledSegments, viewScale)
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerMask(..), LayerType(..))
import Genetics.Browser.Types (Bp, ChrId, _exp)
import Graphics.Canvas (Dimensions) as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math (pow)
import Math as Math
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Feature a = { position  :: Pair Bp
                 , frameSize :: Bp
                 , feature   :: a }

featureNormX :: Feature _ -> Normalized Number
featureNormX { frameSize, position: (Pair l _) } = wrap $ unwrap (l / frameSize)

type NPoint = { x :: Normalized Number
              , y :: Normalized Number }

type DrawingR  = ( point :: Drawing
                 , range :: Number
                         -> { drawing :: Unit -> Drawing
                            , width :: Number } )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Pair (Normalized Number) )
type HPos = Variant HorPlaceR

type BatchRenderer a = { drawing :: Drawing
                       , place :: a -> Normalized Point }

type SingleRenderer a = { draw  :: a -> DrawingV
                        , horPlace :: a -> HPos
                        , verPlace :: a -> Normalized Number }

type OldRenderer a = Variant ( batch :: BatchRenderer a
                             , single :: SingleRenderer a )

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

type SingleGlyph = { drawing :: Unit -> Drawing, point :: Point, width :: Number }

sigLevelRuler :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> Canvas.Dimensions
              -> Drawing
sigLevelRuler {min, max, sig} color f = outlined outline rulerDrawing <> label
  where normY = (sig - min) / (max - min)
        thickness = 2.0
        outline = outlineColor color <> lineWidth thickness
        y = thickness + f.height - (normY * f.height)
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

        text  = "P = " <> (10.0 `pow` -sig) ^. _exp 1

        font' = font sansSerif 16 mempty
        label = Drawing.text font' (f.width+4.0) (y-6.0) (fillColor color) text

chrLabelTrack :: ∀ r.
                 { fontSize :: Int | r }
              -> CoordSys ChrId BigInt
              -> Map ChrId (Array NormalizedGlyph)
chrLabelTrack {fontSize} cs =
  let font' = font sansSerif fontSize mempty

      chrText :: ChrId -> Drawing
      chrText chr =
        Drawing.text font' zero zero (fillColor black) (unwrap chr)

      mkLabel :: ChrId -> NormalizedGlyph
      mkLabel chr = { drawing: inj (SProxy :: SProxy "point") $ chrText chr
                    , horPos:  inj (SProxy :: SProxy "point") $ Normalized (0.5)
                    , verPos: Normalized (0.03) }

  in mapWithIndex (\i _ -> [mkLabel i]) $ cs ^. _Segments

-- boxesTrack :: Number
--            -> CoordSys ChrId BigInt
--            -> Canvas.Dimensions
--            -> Pair BigInt -> CanvasReadyDrawing
-- boxesTrack h cs = unsafeCoerce unit
-- boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ cs ^. _BrowserIntervals
--   where glyph :: NormalizedGlyph
--         glyph = { drawing: inj _range draw
--                 , horPos:  inj _range $ Normalized <$> (Pair zero one)
--                 , verPos: aone }
--         draw = \w ->
--              let rect = rectangle 0.0 0.0 w h
--              in outlined (outlineColor black <> lineWidth 1.5) rect

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { color :: Color
              , hPad :: Number
              , numSteps :: Int
              | VScaleRow () }

defaultVScaleConfig :: Record (VScaleRow ())
                    -> VScale
defaultVScaleConfig =
  build (insert (SProxy :: SProxy "color")    black
     >>> insert (SProxy :: SProxy "hPad")     0.125
     >>> insert (SProxy :: SProxy "numSteps") 3)

-- type Config (n :: Symbol) a r = forall m. MonadReader ({ n :: a | r}) m

defaultVScaleConfig' :: forall m.
                        MonadReader (Record (VScaleRow ())) m
                     => m VScale
defaultVScaleConfig' = do
  a <- ask
  pure $ build (insert (SProxy :: SProxy "color")    black
     >>> insert (SProxy :: SProxy "hPad")     0.125
     >>> insert (SProxy :: SProxy "numSteps") 3) a

drawVScaleInSlot :: VScale
                 -> UISlot
                 -> Drawing
drawVScaleInSlot vscale {offset, size} =
  let
      -- TODO expose linewidth config
      -- TODO expose offsets in config
      hPad = size.width * vscale.hPad
      numSteps = vscale.numSteps

      x = 7.0 * hPad

      spokes = (_ / (Int.toNumber numSteps))
               <<< Int.toNumber <$> (0 .. numSteps)

      barOutline = outlineColor vscale.color <> lineWidth 2.0

      vBar = Drawing.path [{x, y: 0.0}, {x, y: size.height}]

      hBar w y = Drawing.path [{x:x-w, y}, {x, y}]
      bars = vBar
          <> foldMap (\i -> hBar 8.0 (i * size.height)) spokes

      unitLabel =
        Drawing.translate (size.width * 0.4 - hPad) (size.height * 0.72)
        $ Drawing.rotate (- Math.pi / 2.0)
        $ Drawing.text (font sansSerif 18 mempty)
            0.0 0.0 (fillColor black) "-log10 (P value)"

      label yN = Drawing.text
                    (font sansSerif 14 mempty)
                    (size.width * 0.6 - hPad)
                    (yN * size.height + 5.0)
                    (fillColor black)
                 $ Num.toStringWith (Num.fixed 0)
                 $ (\p -> min vscale.max p)
                 $ vscale.min + (1.0 - yN) * (vscale.max - vscale.min)

      labels = foldMap label spokes

  in outlined barOutline bars <> labels <> unitLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { entries :: Array LegendEntry }

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

type LegendConfig r =
  { entries :: Array LegendEntry
  , hPad :: Number, vPad :: Number
  , fontSize :: Int | r }

defaultLegendConfig :: Array LegendEntry -> LegendConfig ()
defaultLegendConfig entries =
  { entries
  , hPad: 0.2, vPad: 0.2
  , fontSize: 12 }

drawLegendInSlot :: ∀ r.
                    LegendConfig r
                 -> UISlot
                 -> Drawing
drawLegendInSlot c@{entries} {offset, size} =
  let
      hPad = size.width  * c.hPad
      vPad = size.height * c.vPad

      x = hPad

      font' = font sansSerif c.fontSize mempty

      drawEntry :: Number -> { text :: String, icon :: Drawing } -> Drawing
      drawEntry y {text, icon} =
        translate x y
          $ icon <> Drawing.text font' 12.0 0.0 (fillColor black) text

      d = (size.height - 2.0*vPad) / length entries
      ds = mapWithIndex (\i ic -> drawEntry (vPad*(Int.toNumber (i+1) )) ic) entries
  in fold ds

type Padding = { vertical :: Number
               , horizontal :: Number
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy (eq `on` _.text) $ Array.fromFoldable $ map f as

horPlaceOnSegment :: forall r.
                     Pair Number
                  -> { horPos :: Variant HorPlaceR | r }
                  -> Number
horPlaceOnSegment segmentPixels o =
    case_
  # onMatch { point: \(Normalized x) -> x * pairSize segmentPixels
            , range: \(Pair l r)     -> unwrap l * pairSize segmentPixels }
  $ o.horPos

finalizeNormDrawing :: forall r.
                       Pair Number
                    -> { drawing :: DrawingV | r }
                    -> { drawing :: Unit -> Drawing, width :: Number }
finalizeNormDrawing seg o =
    case_
  # onMatch { point: \x -> { drawing: \_ -> x, width: 1.0 }
            , range: (_ $ pairSize seg) }
  $ o.drawing

renderNormalized1 :: Number
                  -> Pair Number
                  -> NormalizedGlyph
                  -> SingleGlyph
renderNormalized1 height seg@(Pair l _) ng =
  let x = horPlaceOnSegment seg ng + l
      y = height * (one - unwrap ng.verPos)
      {drawing, width} = finalizeNormDrawing seg ng
  in { point: {x,y}, drawing, width }

rescaleNormSingleGlyphs :: Number
                        -> Pair Number
                        -> Array NormalizedGlyph
                        -> Array SingleGlyph
rescaleNormSingleGlyphs height seg =
  map (renderNormalized1 height seg)

withPixelSegments :: forall r m.
                     Monoid m
                  => CoordSys ChrId BigInt
                  -> { width :: Number | r }
                  -> Pair BigInt
                  -> (ChrId -> Pair Number -> m)
                  -> m
withPixelSegments cs cdim bView =
  let scale = viewScale cdim (wrap bView)
  in flip foldMapWithIndex (scaledSegments cs scale)

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

type DrawingN = { drawing :: Drawing, points :: Array Point }

type RenderedTrack a = { features :: Array a
                       , drawings :: Array DrawingN
                       , labels   :: Array Label
                       , overlaps :: Number -> Point -> Array a }

type Renderer a =
     Canvas.Dimensions
  -> Map ChrId (Array a)
  -> Map ChrId (Pair Number)
  -> RenderedTrack a

type Renderer' a = Map ChrId (Array a)
                -> Map ChrId (Pair Number)
                -> Canvas.Dimensions
                -> LayerRenderable

pixelSegments :: ∀ r.
                 { segmentPadding :: Number | r }
              -> CoordSys _ _
              -> BrowserCanvas
              -> CoordSysView
              -> Map _ _
pixelSegments conf cSys canvas csView =
  let trackDim = canvas ^. _Track <<< _Dimensions
      -- segmentPadding = 12.0 -- TODO this should be configurable
  in aroundPair (-conf.segmentPadding)
       <$> scaledSegments cSys (viewScale trackDim csView)

pixelSegments' :: ∀ r.
                 { segmentPadding :: Number | r }
              -> CoordSys _ _
              -> Canvas.Dimensions
              -> CoordSysView
              -> Map _ _
pixelSegments' conf cSys trackDim csView =
  aroundPair (-conf.segmentPadding)
       <$> scaledSegments cSys (viewScale trackDim csView)

renderTrack :: ∀ a b.
               _
            -> CoordSys ChrId _
            -> Renderer a
            -> Map ChrId (Array a)
            -> BrowserCanvas
            -> CoordSysView
            -> RenderedTrack a
renderTrack conf cSys renderer trackData canvas =
  let trackDim = canvas ^. _Track <<< _Dimensions
  in renderer trackDim trackData <<< pixelSegments conf cSys canvas

renderTrack' :: ∀ a.
               _
            -> CoordSys ChrId _
            -> Component (Renderer' a)
            -> Map ChrId (Array a)
            -> Canvas.Dimensions
            -> CoordSysView
            -> Layer (Canvas.Dimensions -> LayerRenderable)
renderTrack' conf cSys com trackData dim csview =
  let
      segs :: Map ChrId (Pair Number)
      segs = pixelSegments' conf cSys dim csview

  in case com of
        Full     r -> Layer Scrolling NoMask
                      $ Full     $ r trackData segs
        Padded p r -> Layer Scrolling NoMask
                      $ Padded p $ r trackData segs
        Outside rs -> Layer Scrolling NoMask
                      $ Outside { top:    rs.top    trackData segs
                                , right:  rs.right  trackData segs
                                , bottom: rs.bottom trackData segs
                                , left:   rs.left   trackData segs }

renderTrackLive :: forall r r' l m a b.
                   RowCons l a r r'
                => IsSymbol l
                => MonadReader {|r'} m
                => CoordSys ChrId _
                -> SProxy l
                -> (a -> Renderer b)
                -> a
                -> Map ChrId (Array b)
                -> Eff _ (Cached a
                             (BrowserCanvas
                             -> CoordSysView
                             -> RenderedTrack b))
renderTrackLive cSys _ renderer init trackData = do
  let f :: a -> BrowserCanvas -> CoordSysView -> RenderedTrack b
      f a bc v = let trackDim = bc ^. _Track <<< _Dimensions
                 in renderer a trackDim trackData
                    $ pixelSegments {segmentPadding: 12.0} cSys bc v
  cache f init

renderTrackLive' :: forall r0 r1 l m a b.
                    RowCons l a r0 r1
                 => RowLacks l r0
                 => IsSymbol l
                 => MonadReader { segmentPadding :: Number | r1 } m
                 => CoordSys ChrId _
                 -> SProxy l
                 -> (a -> Renderer b)
                 -> Map ChrId (Array b)
                 -> m (Eff _ (Cached a
                         (BrowserCanvas
                         -> CoordSysView
                         -> RenderedTrack b)))
renderTrackLive' cSys _ renderer trackData = do

  conf <- ask

  let f :: a -> BrowserCanvas -> CoordSysView -> RenderedTrack b
      f a bc v = let trackDim = bc ^. _Track <<< _Dimensions
                 in renderer a trackDim trackData
                    $ pixelSegments conf cSys bc v

      x :: a
      x = Record.unsafeGet (reflectSymbol (SProxy :: SProxy l)) conf

  pure $ cache f x

renderFixedUI :: forall a b.
                 (UISlot -> Drawing)
              -> UISlotGravity
              -> BrowserCanvas
              -> Drawing
renderFixedUI uiDrawing slotG canvas =
  let slots = Canvas.uiSlots canvas

      slot@{offset, size} = case slotG of
        UILeft   -> slots.left
        UIRight  -> slots.right
        UITop    -> slots.top
        UIBottom -> slots.bottom

      drawInSlot :: _
      drawInSlot d =
          (translate offset.x offset.y
           $ filled (fillColor white)
           $ rectangle zero zero size.width size.height)
        <> translate offset.x offset.y d
  in drawInSlot (uiDrawing slot)

renderRelativeUI :: CoordSys ChrId BigInt
                 -> Map ChrId (Array NormalizedGlyph)
                 -> BrowserCanvas
                 -> CoordSysView
                 -> Drawing
renderRelativeUI cSys uiGlyphs canvas =
  let
      trackDim = canvas ^. _Track <<< _Dimensions
      overlayDim = canvas ^. _Dimensions

      renderUIElement :: Map ChrId (Array NormalizedGlyph)
                      -> ChrId -> Pair Number -> Array SingleGlyph
      renderUIElement m k s
          = fold $ rescaleNormSingleGlyphs overlayDim.height s
                <$> (Map.lookup k m)

      drawTrackUI :: Pair BigInt -> (ChrId -> Pair Number -> (Array _)) -> Drawing
      drawTrackUI v = foldMap f <<< withPixelSegments cSys trackDim v
        where f {drawing, point} = Drawing.translate point.x point.y (drawing unit)

  in \v -> drawTrackUI (unwrap v) $ renderUIElement uiGlyphs

chrLabelsUI :: ∀ r.
               CoordSys ChrId BigInt
            -> { fontSize :: Int | r }
            -> BrowserCanvas
            -> CoordSysView
            -> Drawing
chrLabelsUI cSys c = renderRelativeUI cSys (chrLabelTrack c cSys)

type Peak x y r = { covers :: Pair x
                  , y :: y
                  , elements :: Array r }

module Genetics.Browser where

import Prelude

import Color (Color, black, white)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Reader (class MonadReader, ask)
import Data.Array ((..))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.Function (on)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens ((^.))
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap, wrap)
import Data.Number.Format as Num
import Data.Pair (Pair(..))
import Data.Record as Record
import Data.Record.Builder (build, insert)
import Data.Record.Unsafe as Record
import Data.Symbol (class IsSymbol, SProxy(SProxy), reflectSymbol)
import Data.Variant (Variant, case_, inj, onMatch)
import Genetics.Browser.Cached (Cached, cache)
import Genetics.Browser.Canvas (BrowserCanvas, Label, UISlot, UISlotGravity(UIBottom, UITop, UIRight, UILeft), _Dimensions, _Track)
import Genetics.Browser.Canvas (uiSlots) as Canvas
import Genetics.Browser.Coordinates (CoordSys, CoordSysView, Normalized(Normalized), _Segments, aroundPair, pairSize, scaledSegments, viewScale)
import Genetics.Browser.Types (Bp, ChrId, _exp)
import Graphics.Canvas (Dimensions) as Canvas
import Graphics.Drawing (Drawing, Point, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Math (pow)
import Math as Math
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

type Feature a = { position  :: Pair Bp
                 , frameSize :: Bp
                 , feature   :: a }

featureNormX :: Feature _ -> Normalized Number
featureNormX { frameSize, position: (Pair l _) } = wrap $ unwrap (l / frameSize)

type NPoint = { x :: Normalized Number
              , y :: Normalized Number }

type DrawingR  = ( point :: Drawing
                 , range :: Number
                         -> { drawing :: Unit -> Drawing
                            , width :: Number } )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Pair (Normalized Number) )
type HPos = Variant HorPlaceR

type BatchRenderer a = { drawing :: Drawing
                       , place :: a -> Normalized Point }

type SingleRenderer a = { draw  :: a -> DrawingV
                        , horPlace :: a -> HPos
                        , verPlace :: a -> Normalized Number }

type OldRenderer a = Variant ( batch :: BatchRenderer a
                             , single :: SingleRenderer a )

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

type SingleGlyph = { drawing :: Unit -> Drawing, point :: Point, width :: Number }

sigLevelRuler :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> Canvas.Dimensions
              -> Drawing
sigLevelRuler {min, max, sig} color f = outlined outline rulerDrawing <> label
  where normY = (sig - min) / (max - min)
        thickness = 2.0
        outline = outlineColor color <> lineWidth thickness
        y = thickness + f.height - (normY * f.height)
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

        text  = "P = " <> (10.0 `pow` -sig) ^. _exp 1

        font' = font sansSerif 16 mempty
        label = Drawing.text font' (f.width+4.0) (y-6.0) (fillColor color) text

chrLabelTrack :: ∀ r.
                 { fontSize :: Int | r }
              -> CoordSys ChrId BigInt
              -> Map ChrId (Array NormalizedGlyph)
chrLabelTrack {fontSize} cs =
  let font' = font sansSerif fontSize mempty

      chrText :: ChrId -> Drawing
      chrText chr =
        Drawing.text font' zero zero (fillColor black) (unwrap chr)

      mkLabel :: ChrId -> NormalizedGlyph
      mkLabel chr = { drawing: inj (SProxy :: SProxy "point") $ chrText chr
                    , horPos:  inj (SProxy :: SProxy "point") $ Normalized (0.5)
                    , verPos: Normalized (0.03) }

  in mapWithIndex (\i _ -> [mkLabel i]) $ cs ^. _Segments

-- boxesTrack :: Number
--            -> CoordSys ChrId BigInt
--            -> Canvas.Dimensions
--            -> Pair BigInt -> CanvasReadyDrawing
-- boxesTrack h cs = unsafeCoerce unit
-- boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ cs ^. _BrowserIntervals
--   where glyph :: NormalizedGlyph
--         glyph = { drawing: inj _range draw
--                 , horPos:  inj _range $ Normalized <$> (Pair zero one)
--                 , verPos: aone }
--         draw = \w ->
--              let rect = rectangle 0.0 0.0 w h
--              in outlined (outlineColor black <> lineWidth 1.5) rect

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { color :: Color
              , hPad :: Number
              , numSteps :: Int
              | VScaleRow () }

defaultVScaleConfig :: Record (VScaleRow ())
                    -> VScale
defaultVScaleConfig =
  build (insert (SProxy :: SProxy "color")    black
     >>> insert (SProxy :: SProxy "hPad")     0.125
     >>> insert (SProxy :: SProxy "numSteps") 3)

-- type Config (n :: Symbol) a r = forall m. MonadReader ({ n :: a | r}) m

defaultVScaleConfig' :: forall m.
                        MonadReader (Record (VScaleRow ())) m
                     => m VScale
defaultVScaleConfig' = do
  a <- ask
  pure $ build (insert (SProxy :: SProxy "color")    black
     >>> insert (SProxy :: SProxy "hPad")     0.125
     >>> insert (SProxy :: SProxy "numSteps") 3) a

drawVScaleInSlot :: VScale
                 -> UISlot
                 -> Drawing
drawVScaleInSlot vscale {offset, size} =
  let
      -- TODO expose linewidth config
      -- TODO expose offsets in config
      hPad = size.width * vscale.hPad
      numSteps = vscale.numSteps

      x = 7.0 * hPad

      spokes = (_ / (Int.toNumber numSteps))
               <<< Int.toNumber <$> (0 .. numSteps)

      barOutline = outlineColor vscale.color <> lineWidth 2.0

      vBar = Drawing.path [{x, y: 0.0}, {x, y: size.height}]

      hBar w y = Drawing.path [{x:x-w, y}, {x, y}]
      bars = vBar
          <> foldMap (\i -> hBar 8.0 (i * size.height)) spokes

      unitLabel =
        Drawing.translate (size.width * 0.4 - hPad) (size.height * 0.72)
        $ Drawing.rotate (- Math.pi / 2.0)
        $ Drawing.text (font sansSerif 18 mempty)
            0.0 0.0 (fillColor black) "-log10 (P value)"

      label yN = Drawing.text
                    (font sansSerif 14 mempty)
                    (size.width * 0.6 - hPad)
                    (yN * size.height + 5.0)
                    (fillColor black)
                 $ Num.toStringWith (Num.fixed 0)
                 $ (\p -> min vscale.max p)
                 $ vscale.min + (1.0 - yN) * (vscale.max - vscale.min)

      labels = foldMap label spokes

  in outlined barOutline bars <> labels <> unitLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { entries :: Array LegendEntry }

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

type LegendConfig r =
  { entries :: Array LegendEntry
  , hPad :: Number, vPad :: Number
  , fontSize :: Int | r }

defaultLegendConfig :: Array LegendEntry -> LegendConfig ()
defaultLegendConfig entries =
  { entries
  , hPad: 0.2, vPad: 0.2
  , fontSize: 12 }

drawLegendInSlot :: ∀ r.
                    LegendConfig r
                 -> UISlot
                 -> Drawing
drawLegendInSlot c@{entries} {offset, size} =
  let
      hPad = size.width  * c.hPad
      vPad = size.height * c.vPad

      x = hPad

      font' = font sansSerif c.fontSize mempty

      drawEntry :: Number -> { text :: String, icon :: Drawing } -> Drawing
      drawEntry y {text, icon} =
        translate x y
          $ icon <> Drawing.text font' 12.0 0.0 (fillColor black) text

      d = (size.height - 2.0*vPad) / length entries
      ds = mapWithIndex (\i ic -> drawEntry (vPad*(Int.toNumber (i+1) )) ic) entries
  in fold ds

type Padding = { vertical :: Number
               , horizontal :: Number
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy (eq `on` _.text) $ Array.fromFoldable $ map f as

horPlaceOnSegment :: forall r.
                     Pair Number
                  -> { horPos :: Variant HorPlaceR | r }
                  -> Number
horPlaceOnSegment segmentPixels o =
    case_
  # onMatch { point: \(Normalized x) -> x * pairSize segmentPixels
            , range: \(Pair l r)     -> unwrap l * pairSize segmentPixels }
  $ o.horPos

finalizeNormDrawing :: forall r.
                       Pair Number
                    -> { drawing :: DrawingV | r }
                    -> { drawing :: Unit -> Drawing, width :: Number }
finalizeNormDrawing seg o =
    case_
  # onMatch { point: \x -> { drawing: \_ -> x, width: 1.0 }
            , range: (_ $ pairSize seg) }
  $ o.drawing

renderNormalized1 :: Number
                  -> Pair Number
                  -> NormalizedGlyph
                  -> SingleGlyph
renderNormalized1 height seg@(Pair l _) ng =
  let x = horPlaceOnSegment seg ng + l
      y = height * (one - unwrap ng.verPos)
      {drawing, width} = finalizeNormDrawing seg ng
  in { point: {x,y}, drawing, width }

rescaleNormSingleGlyphs :: Number
                        -> Pair Number
                        -> Array NormalizedGlyph
                        -> Array SingleGlyph
rescaleNormSingleGlyphs height seg =
  map (renderNormalized1 height seg)

withPixelSegments :: forall r m.
                     Monoid m
                  => CoordSys ChrId BigInt
                  -> { width :: Number | r }
                  -> Pair BigInt
                  -> (ChrId -> Pair Number -> m)
                  -> m
withPixelSegments cs cdim bView =
  let scale = viewScale cdim (wrap bView)
  in flip foldMapWithIndex (scaledSegments cs scale)

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

type DrawingN = { drawing :: Drawing, points :: Array Point }

type RenderedTrack a = { features :: Array a
                       , drawings :: Array DrawingN
                       , labels   :: Array Label
                       , overlaps :: Number -> Point -> Array a }

type Renderer a =
     Canvas.Dimensions
  -> Map ChrId (Array a)
  -> Map ChrId (Pair Number)
  -> RenderedTrack a

pixelSegments :: ∀ r.
                 { segmentPadding :: Number | r }
              -> CoordSys _ _
              -> BrowserCanvas
              -> CoordSysView
              -> Map _ _
pixelSegments conf cSys canvas csView =
  let trackDim = canvas ^. _Track <<< _Dimensions
      -- segmentPadding = 12.0 -- TODO this should be configurable
  in aroundPair (-conf.segmentPadding)
       <$> scaledSegments cSys (viewScale trackDim csView)

renderTrack :: ∀ a b.
               _
            -> CoordSys ChrId _
            -> Renderer a
            -> Map ChrId (Array a)
            -> BrowserCanvas
            -> CoordSysView
            -> RenderedTrack a
renderTrack conf cSys renderer trackData canvas =
  let trackDim = canvas ^. _Track <<< _Dimensions
  in renderer trackDim trackData <<< pixelSegments conf cSys canvas

renderTrackLive :: forall r r' l m a b.
                   RowCons l a r r'
                => IsSymbol l
                => MonadReader {|r'} m
                => CoordSys ChrId _
                -> SProxy l
                -> (a -> Renderer b)
                -> a
                -> Map ChrId (Array b)
                -> Eff _ (Cached a
                             (BrowserCanvas
                             -> CoordSysView
                             -> RenderedTrack b))
renderTrackLive cSys _ renderer init trackData = do
  let f :: a -> BrowserCanvas -> CoordSysView -> RenderedTrack b
      f a bc v = let trackDim = bc ^. _Track <<< _Dimensions
                 in renderer a trackDim trackData
                    $ pixelSegments {segmentPadding: 12.0} cSys bc v
  cache f init

renderTrackLive' :: forall r0 r1 l m a b.
                    RowCons l a r0 r1
                 => RowLacks l r0
                 => IsSymbol l
                 => MonadReader { segmentPadding :: Number | r1 } m
                 => CoordSys ChrId _
                 -> SProxy l
                 -> (a -> Renderer b)
                 -> Map ChrId (Array b)
                 -> m (Eff _ (Cached a
                         (BrowserCanvas
                         -> CoordSysView
                         -> RenderedTrack b)))
renderTrackLive' cSys _ renderer trackData = do

  conf <- ask

  let f :: a -> BrowserCanvas -> CoordSysView -> RenderedTrack b
      f a bc v = let trackDim = bc ^. _Track <<< _Dimensions
                 in renderer a trackDim trackData
                    $ pixelSegments conf cSys bc v

      x :: a
      x = Record.unsafeGet (reflectSymbol (SProxy :: SProxy l)) conf

  pure $ cache f x

renderFixedUI :: forall a b.
                 (UISlot -> Drawing)
              -> UISlotGravity
              -> BrowserCanvas
              -> Drawing
renderFixedUI uiDrawing slotG canvas =
  let slots = Canvas.uiSlots canvas

      slot@{offset, size} = case slotG of
        UILeft   -> slots.left
        UIRight  -> slots.right
        UITop    -> slots.top
        UIBottom -> slots.bottom

      drawInSlot :: _
      drawInSlot d =
          (translate offset.x offset.y
           $ filled (fillColor white)
           $ rectangle zero zero size.width size.height)
        <> translate offset.x offset.y d
  in drawInSlot (uiDrawing slot)

renderRelativeUI :: CoordSys ChrId BigInt
                 -> Map ChrId (Array NormalizedGlyph)
                 -> BrowserCanvas
                 -> CoordSysView
                 -> Drawing
renderRelativeUI cSys uiGlyphs canvas =
  let
      trackDim = canvas ^. _Track <<< _Dimensions
      overlayDim = canvas ^. _Dimensions

      renderUIElement :: Map ChrId (Array NormalizedGlyph)
                      -> ChrId -> Pair Number -> Array SingleGlyph
      renderUIElement m k s
          = fold $ rescaleNormSingleGlyphs overlayDim.height s
                <$> (Map.lookup k m)

      drawTrackUI :: Pair BigInt -> (ChrId -> Pair Number -> (Array _)) -> Drawing
      drawTrackUI v = foldMap f <<< withPixelSegments cSys trackDim v
        where f {drawing, point} = Drawing.translate point.x point.y (drawing unit)

  in \v -> drawTrackUI (unwrap v) $ renderUIElement uiGlyphs

chrLabelsUI :: ∀ r.
               CoordSys ChrId BigInt
            -> { fontSize :: Int | r }
            -> BrowserCanvas
            -> CoordSysView
            -> Drawing
chrLabelsUI cSys c = renderRelativeUI cSys (chrLabelTrack c cSys)

type Peak x y r = { covers :: Pair x
                  , y :: y
                  , elements :: Array r }


[tests] Add two strategic wait-times [Please revert pending Quasar fix]

This is to work around SD-876; when taht ticket is resolved, this commit
should be reverted.

This should resolve SD-905.

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.Selenium.File where

import Prelude
import 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, isNothing)
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 hiding (sequence)
import Selenium.Key
import Selenium.Monad
import Selenium.Combinators (checker, awaitUrlChanged, waitUntilJust)

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 >>= get <<< _.slamdataUrl
  fileComponentLoaded

findItem :: String -> Check (Maybe Element)
findItem name = do
  config <- getConfig
  els <- byCss config.item.main >>= findElements
  tpls <- traverse traverseFn els
  pure $ foldl foldFn Nothing tpls
  where
  traverseFn el = do
    eHtml <- attempt $ getInnerHtml 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"
  locator (locatorFn key) >>= findChild toolbar

  where
  locatorFn :: String -> Element -> Check Element
  locatorFn key el = do
    config <- getConfig
    byCss config.toolbar.button >>=
      findChildren el >>=
      traverse traverseFn >>=
      foldl foldFn Nothing >>>
      maybe (throwError $ error "there is no button") pure
  traverseFn btn = do
    ch <- byCss key >>= findChild 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
  sequence $ leftClick mountButton
  config <- getConfig
  wait modalShown config.selenium.waitTime
  uriField <- getElementByCss config.configureMount.uriField "no connection uri field"
  nameField <- getElementByCss config.configureMount.nameField "no mount name field"
  pathField <- getElementByCss config.configureMount.pathField "no path field"
  saveButton <- getElementByCss config.configureMount.saveButton "no save button"

  let connectionUri = "mongodb://" ++ mountConfig.host ++ ":" ++ show mountConfig.port ++ "/" ++ config.database.name
  let platform = platformFromConfig config

  sequence $ 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 platform
    sendCopy platform
    sendSelectAll platform
    sendKeys config.mount.name

    leftClick uriField
    sendPaste platform

    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
  wait mountShown config.selenium.waitTime
  waitTime 1000

  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
  wait (checker $ not <$> isDisplayed warningBox) config.selenium.waitTime
  -- wait for the server error to appear
  wait (checker $ isDisplayed warningBox) 8000

  cancelButton <- getElementByCss config.configureMount.cancelButton "no cancel button"
  sequence $ leftClick cancelButton
  wait 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

  sequence $ leftClick mountItem
  itemGetDeleteIcon mountItem >>= itemClickToolbarIcon mountItem
  wait (checker $ isNothing <$> findItem config.mount.name) config.selenium.waitTime
  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"
  sequence $ leftClick button

  config <- getConfig
  wait 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"

  let platform = platformFromConfig config
  sequence do
    leftClick usernameField
    sendSelectAll platform
    sendKeys "hello"
    sendUndo platform

  getElementByCss config.configureMount.saveButton "no save button"
    >>= isEnabled
    >>= 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"
  byCss config.item.toolbar
    >>= findChild listGroupItem
    >>= maybe toolbarErrorMsg (\tb -> pure { listGroupItem : listGroupItem, itemToolbar : tb })
  where
    toolbarErrorMsg = errorMsg "there is no toolbar in list-group-item"

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

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

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

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

enterMount :: Check Unit
enterMount = do
  home
  url <- getCurrentUrl
  config <- getConfig
  mountItem <- findItem config.mount.name >>= maybe (errorMsg "No mount item") pure
  sequence $ doubleClick leftButton mountItem
  wait (awaitUrlChanged url) config.selenium.waitTime
  fileComponentLoaded

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

  enterMount
  url <- getCurrentUrl
  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
    sequence $ doubleClick leftButton el
    config <- getConfig
    wait (awaitUrlChanged url) config.selenium.waitTime
    fileComponentLoaded
    getCurrentUrl >>= getHashFromURL >>= checkHashes old
  checkOldHash _ _ _ = errorMsg "weird initial hash in goDown"

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

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

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

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

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

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

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

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

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

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

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

sorting :: Check Unit
sorting = do
  sectionMsg "SORTING CHECK"
  goDown
  texts <- getItemTexts
  getCurrentUrl >>= getHashFromURL >>= checkHash texts
  where
  checkHash :: List String -> Routes -> Check Unit
  checkHash texts (Salted sort search salt) = do
    config <- getConfig
    sortButton <- getElementByCss config.sort.button "there is no sort button"
    sequence $ 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 = "";
    }
  }
  """

  sendKeysEl config.upload.filePath uploadInput
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  navigateBack
  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
  wait modalShown config.selenium.waitTime
  successMsg "Share modal dialog appeared"
  urlField <- getElementByCss config.share.urlField "there is no url field"
  urlValue <- getAttribute urlField "value"
  successMsg $ "Share url: " <> urlValue
  get urlValue
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, share link led to notebook"

  where
    itemGetShareIcon :: Element -> Check Element
    itemGetShareIcon item =
      locator shareLoc
        >>= findChild 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 <- getCurrentUrl
  let filename = fromMaybe config.upload.file $ Arr.last $ Str.split "/" config.upload.file
  sequence $ do
    leftClick searchInput
    sendKeys filename
  searchButton <- getElementByCss config.search.searchButton "no search button"
  sequence $ leftClick searchButton
  wait (awaitUrlChanged url) config.selenium.waitTime
  wait (awaitItemWithPhrase filename) config.selenium.waitTime
  successMsg "Searched for and found item"

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

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

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

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

buttonLoc :: String -> Element -> Check Element
buttonLoc ty el = do
  config <- getConfig
  tpls <- byCss config.move.button >>= findChildren el >>=
    traverse (\el -> Tuple el <$> (byCss ty >>= findChild 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 =
  locator deleteLoc
    >>= findChild 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
  sequence $ leftClick item
  wait (checker $ isDisplayed icon) config.selenium.waitTime
  sequence $ 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
  sequence $ leftClick showHideButton

  config <- getConfig
  wait (checker isTrashVisible) config.selenium.waitTime

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

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

  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
  sequence $ leftClick newFolderButton
  folder <- waitUntilJust (findItem SDCfg.newFolderName) config.selenium.waitTime
  sequence $ doubleClick leftButton folder
  fileComponentLoaded

  getCurrentUrl >>= 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
  sequence <<< leftClick =<< getNewNotebookButton
  attempt (wait notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")
  andThen
  where
  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    toolbarButton config.toolbar.newNotebook
      >>= maybe (errorMsg "No create notebook button") pure

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

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

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

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

moveDelete :: String -> Check Unit -> String -> String -> Check Unit
moveDelete msg setUp src tgt = do
  sectionMsg $ "check move/delete " <> msg
  setUp
  config <- getConfig
  item <- findItem src
          >>= maybe (errorMsg $ "there is no source " <> msg) pure
  itemGetMoveIcon item >>= itemClickToolbarIcon item
  wait modalShown config.selenium.waitTime
  getElementByCss config.move.nameField "no rename field"
    >>= editNameField

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

  renamed <- waitUntilJust (findItem tgt) config.selenium.waitTime
  successMsg $ "ok, successfully renamed (" <> msg <> ")"

  itemGetDeleteIcon renamed >>= itemClickToolbarIcon renamed
  wait (checker $ isNothing <$> findItem tgt) config.selenium.waitTime
  successMsg $ "ok, successfully deleted (" <> msg <> ")"
  where
  itemGetMoveIcon :: Element -> Check Element
  itemGetMoveIcon item =
    locator moveLoc
      >>= findChild item
      >>= maybe (errorMsg "no move/rename icon") pure

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

  editNameField :: Element -> Check Unit
  editNameField nameField = do
    config <- getConfig
    let platform = platformFromConfig config
    sequence do
      leftClick nameField
      sendSelectAll platform
      sendDelete
      sendKeys tgt

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

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

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

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

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

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.Selenium.File where

import Prelude
import 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, isNothing)
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 hiding (sequence)
import Selenium.Key
import Selenium.Monad
import Selenium.Combinators (checker, awaitUrlChanged, waitUntilJust)

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 >>= get <<< _.slamdataUrl
  fileComponentLoaded

findItem :: String -> Check (Maybe Element)
findItem name = do
  config <- getConfig
  els <- byCss config.item.main >>= findElements
  tpls <- traverse traverseFn els
  pure $ foldl foldFn Nothing tpls
  where
  traverseFn el = do
    eHtml <- attempt $ getInnerHtml 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"
  locator (locatorFn key) >>= findChild toolbar

  where
  locatorFn :: String -> Element -> Check Element
  locatorFn key el = do
    config <- getConfig
    byCss config.toolbar.button >>=
      findChildren el >>=
      traverse traverseFn >>=
      foldl foldFn Nothing >>>
      maybe (throwError $ error "there is no button") pure
  traverseFn btn = do
    ch <- byCss key >>= findChild 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
  sequence $ leftClick mountButton
  config <- getConfig
  wait modalShown config.selenium.waitTime
  uriField <- getElementByCss config.configureMount.uriField "no connection uri field"
  nameField <- getElementByCss config.configureMount.nameField "no mount name field"
  pathField <- getElementByCss config.configureMount.pathField "no path field"
  saveButton <- getElementByCss config.configureMount.saveButton "no save button"

  let connectionUri = "mongodb://" ++ mountConfig.host ++ ":" ++ show mountConfig.port ++ "/" ++ config.database.name
  let platform = platformFromConfig config

  sequence $ 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 platform
    sendCopy platform
    sendSelectAll platform
    sendKeys config.mount.name

    leftClick uriField
    sendPaste platform

    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
  wait 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
  wait (checker $ not <$> isDisplayed warningBox) config.selenium.waitTime
  -- wait for the server error to appear
  wait (checker $ isDisplayed warningBox) 8000

  cancelButton <- getElementByCss config.configureMount.cancelButton "no cancel button"
  sequence $ leftClick cancelButton
  wait 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

  sequence $ leftClick mountItem
  itemGetDeleteIcon mountItem >>= itemClickToolbarIcon mountItem
  wait (checker $ isNothing <$> findItem config.mount.name) config.selenium.waitTime
  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"
  sequence $ leftClick button

  config <- getConfig
  wait 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"

  let platform = platformFromConfig config
  sequence do
    leftClick usernameField
    sendSelectAll platform
    sendKeys "hello"
    sendUndo platform

  getElementByCss config.configureMount.saveButton "no save button"
    >>= isEnabled
    >>= 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"
  byCss config.item.toolbar
    >>= findChild listGroupItem
    >>= maybe toolbarErrorMsg (\tb -> pure { listGroupItem : listGroupItem, itemToolbar : tb })
  where
    toolbarErrorMsg = errorMsg "there is no toolbar in list-group-item"

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

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

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

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

enterMount :: Check Unit
enterMount = do
  home
  url <- getCurrentUrl
  config <- getConfig
  mountItem <- findItem config.mount.name >>= maybe (errorMsg "No mount item") pure
  sequence $ doubleClick leftButton mountItem
  wait (awaitUrlChanged url) config.selenium.waitTime
  fileComponentLoaded

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

  enterMount
  url <- getCurrentUrl
  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
    sequence $ doubleClick leftButton el
    config <- getConfig
    wait (awaitUrlChanged url) config.selenium.waitTime
    fileComponentLoaded
    getCurrentUrl >>= getHashFromURL >>= checkHashes old
  checkOldHash _ _ _ = errorMsg "weird initial hash in goDown"

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

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

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

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

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

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

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

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

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

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

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

sorting :: Check Unit
sorting = do
  sectionMsg "SORTING CHECK"
  goDown
  texts <- getItemTexts
  getCurrentUrl >>= getHashFromURL >>= checkHash texts
  where
  checkHash :: List String -> Routes -> Check Unit
  checkHash texts (Salted sort search salt) = do
    config <- getConfig
    sortButton <- getElementByCss config.sort.button "there is no sort button"
    sequence $ 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 = "";
    }
  }
  """

  sendKeysEl config.upload.filePath uploadInput
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, explore notebook created"
  navigateBack
  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
  wait modalShown config.selenium.waitTime
  successMsg "Share modal dialog appeared"
  urlField <- getElementByCss config.share.urlField "there is no url field"
  urlValue <- getAttribute urlField "value"
  successMsg $ "Share url: " <> urlValue
  get urlValue
  wait awaitInNotebook config.selenium.waitTime
  successMsg "Ok, share link led to notebook"

  where
    itemGetShareIcon :: Element -> Check Element
    itemGetShareIcon item =
      locator shareLoc
        >>= findChild 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 <- getCurrentUrl
  let filename = fromMaybe config.upload.file $ Arr.last $ Str.split "/" config.upload.file
  sequence $ do
    leftClick searchInput
    sendKeys filename
  searchButton <- getElementByCss config.search.searchButton "no search button"
  sequence $ leftClick searchButton
  wait (awaitUrlChanged url) config.selenium.waitTime
  wait (awaitItemWithPhrase filename) config.selenium.waitTime
  successMsg "Searched for and found item"

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

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

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

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

buttonLoc :: String -> Element -> Check Element
buttonLoc ty el = do
  config <- getConfig
  tpls <- byCss config.move.button >>= findChildren el >>=
    traverse (\el -> Tuple el <$> (byCss ty >>= findChild 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 =
  locator deleteLoc
    >>= findChild 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
  sequence $ leftClick item
  wait (checker $ isDisplayed icon) config.selenium.waitTime
  sequence $ 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
  sequence $ leftClick showHideButton

  config <- getConfig
  wait (checker isTrashVisible) config.selenium.waitTime

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

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

  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
  sequence $ leftClick newFolderButton
  folder <- waitUntilJust (findItem SDCfg.newFolderName) config.selenium.waitTime
  sequence $ doubleClick leftButton folder
  fileComponentLoaded

  getCurrentUrl >>= 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
  sequence <<< leftClick =<< getNewNotebookButton
  attempt (wait notebookCheck config.selenium.waitTime)
    >>= either (\_ -> errorMsg "no redirect to notebook") (\_ -> successMsg "ok, notebook created")
  andThen
  where
  getNewNotebookButton :: Check Element
  getNewNotebookButton = do
    config <- getConfig
    toolbarButton config.toolbar.newNotebook
      >>= maybe (errorMsg "No create notebook button") pure

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

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

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

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

moveDelete :: String -> Check Unit -> String -> String -> Check Unit
moveDelete msg setUp src tgt = do
  sectionMsg $ "check move/delete " <> msg
  setUp
  config <- getConfig
  item <- findItem src
          >>= maybe (errorMsg $ "there is no source " <> msg) pure
  itemGetMoveIcon item >>= itemClickToolbarIcon item
  wait modalShown config.selenium.waitTime
  getElementByCss config.move.nameField "no rename field"
    >>= editNameField

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

  renamed <- waitUntilJust (findItem tgt) config.selenium.waitTime
  successMsg $ "ok, successfully renamed (" <> msg <> ")"

  itemGetDeleteIcon renamed >>= itemClickToolbarIcon renamed
  wait (checker $ isNothing <$> findItem tgt) config.selenium.waitTime
  successMsg $ "ok, successfully deleted (" <> msg <> ")"
  where
  itemGetMoveIcon :: Element -> Check Element
  itemGetMoveIcon item =
    locator moveLoc
      >>= findChild item
      >>= maybe (errorMsg "no move/rename icon") pure

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

  editNameField :: Element -> Check Unit
  editNameField nameField = do
    config <- getConfig
    let platform = platformFromConfig config
    sequence do
      leftClick nameField
      sendSelectAll platform
      sendDelete
      sendKeys tgt

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

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

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

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

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