Add dummy fetch function that returns features

module Genetics.Browser.UI.Container
       where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (JObject, _Number, _Object, _String)
import Data.Array (null, uncons)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Either.Nested (Either2)
import Data.Foldable (foldMap, sequence_)
import Data.Foreign (Foreign, renderForeignError)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap, wrap)
import Data.Options (Options, (:=))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse_)
import Data.Variant (Variant)
import Genetics.Browser.Biodalliance (RendererInfo, initBD, renderers, setLocation, sources)
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Biodalliance.Source (Source)
import Genetics.Browser.Biodalliance.Source as Source
import Genetics.Browser.Config (BrowserConfig(..), parseBrowserConfig)
import Genetics.Browser.Config.Track (validateConfigs)
import Genetics.Browser.Cytoscape (ParsedEvent(..))
import Genetics.Browser.Cytoscape as Cytoscape
import Genetics.Browser.Cytoscape.Collection (filter, isEdge, targetNodes)
import Genetics.Browser.Cytoscape.Types (CY, Cytoscape, Element, elementJObject)
import Genetics.Browser.Events (Location, Range)
import Genetics.Browser.Events.TrackSink (TrackSink, appendTrackSink, emptyTrackSink, forkTrackSink)
import Genetics.Browser.Events.TrackSource (TrackSource, appendTrackSource, applyTrackSource, emptyTrackSource)
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Genetics.Browser.Units (Bp(Bp), Chr(..), _Bp, _BpMBp, _Chr, _MBp, bp)
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)

type BDEventEff eff = (console :: CONSOLE, bd :: BD, avar :: AVAR | eff)
type CyEventEff eff = (console :: CONSOLE, cy :: CY, avar :: AVAR | eff)

type BDHandlerOutput eff = Biodalliance -> Eff (BDEventEff eff) Unit
type CyHandlerOutput eff = Cytoscape -> Eff (CyEventEff eff) Unit

locationInputBD :: TrackSink (location :: Location) _ (BDHandlerOutput _)
locationInputBD = appendTrackSink (SProxy :: SProxy "location") f emptyTrackSink
  where f loc bd = do
            log "bd got location"
            setLocation bd loc.chr (bp loc.pos - Bp 1000000.0) (bp loc.pos + Bp 1000000.0)

rangeInputBD :: TrackSink ( range :: Range, location :: Location ) _ (BDHandlerOutput _)
rangeInputBD = appendTrackSink (SProxy :: SProxy "range") f locationInputBD
  where f :: Range -> BDHandlerOutput _
        f ran bd = do
            log "bd got range"
            setLocation bd ran.chr ran.minPos ran.maxPos

rangeInputCy :: ∀ eff. TrackSink (range :: Range) _ (CyHandlerOutput _)
rangeInputCy = appendTrackSink (SProxy :: SProxy "range") f emptyTrackSink
  where f ran cy = do
            log "cy got range"
            log $ "chr: " <> show ran.chr
            let pred el = case parseLocationElementCy el of
                  Nothing -> false
                  Just loc -> loc.chr == ran.chr

            graphColl <- liftEff $ Cytoscape.graphGetCollection cy
            let edges = filter ((not $ wrap pred) && isEdge) graphColl

            _ <- liftEff $ Cytoscape.graphRemoveCollection $ targetNodes edges
            pure unit

rangeEventOutputBD :: TrackSource JObject (range :: Range)
rangeEventOutputBD = appendTrackSource (SProxy :: SProxy "range") f emptyTrackSource
  where f obj =  do
              chr <- obj ^? ix "chr" <<< _String <<< re _Chr
              minPos <- obj ^? ix "min" <<< _Number <<< re _Bp
              maxPos <- obj ^? ix "max" <<< _Number <<< re _Bp
              pure $ {chr, minPos, maxPos}

parseLocationElementCy :: Element -> Maybe Location
parseLocationElementCy el = do
    loc <- elementJObject el ^? ix "data" <<< _Object <<< ix "lrsLoc"
    chr <- loc ^? _Object <<< ix "chr" <<< _String <<< re _Chr
            -- ridiculous.
    pos <- loc ^? _Object <<< ix "pos" <<< _Number
                    <<< re _MBp <<< re _BpMBp
    pure $ { chr, pos }

locationEventOutputCy :: TrackSource ParsedEvent (location :: Location)
locationEventOutputCy = appendTrackSource (SProxy :: SProxy "location") f emptyTrackSource
  where f (ParsedEvent ev) = case ev.target of
            Left el -> parseLocationElementCy el
            Right _ -> Nothing

subscribeBDEvents :: ∀ r.
                     TrackSource JObject r
                  -> Biodalliance
                  -> BusRW (Variant r)
                  -> Eff _ Unit
subscribeBDEvents h bd bus =
  Biodalliance.addFeatureListener bd $ \obj -> do
    let evs = applyTrackSource h obj
    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

subscribeCyEvents :: ∀ r.
                     TrackSource ParsedEvent r
                  -> Cytoscape
                  -> BusRW (Variant r) -> Eff _ Unit
subscribeCyEvents h cy bus =
  Cytoscape.onClick cy $ \obj -> do
    let evs = applyTrackSource h obj
    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | PropagateMessage Message a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a

data Message
  = BDInstance Biodalliance
  | CyInstance Cytoscape
  -- | WithCy Cytoscape

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void
type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Message (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      ]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Nothing
  handleBDMessage (UIBD.SendBD bd) = Just $ H.action $ PropagateMessage (BDInstance bd)

  -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendCy cy) = Just $ H.action $ PropagateMessage (CyInstance cy)
  handleCyMessage (UICy.SendEvent) = Nothing

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message (Aff (Effects eff))
  eval = case _ of
    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next

    PropagateMessage msg next -> do
      case msg of
        BDInstance _ -> liftEff $ log "propagating BD"
        CyInstance _ -> liftEff $ log "propagating Cy"
      H.raise msg
      pure next

    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

createSource :: forall eff a. (Chr -> Bp -> Bp -> Aff eff a) -> Source a
createSource = Source.createSource

fetchHelloWorld :: ∀ a b c. a -> b -> c -> Aff _ String
fetchHelloWorld _ _ _ = pure "Hello world"

fetchFeature :: Chr -> Bp -> Bp -> Aff _ (Array
                                          { chr :: String
                                          , min :: Int
                                          , max :: Int
                                          })
fetchFeature chr pmin pmax =
  let f chr min max = { chr, min, max }
  in do
     liftEff $ log "Fetching a purescript feature!!"
     pure [ f "11" 10000000 11000000
          , f "11"  9000000 12000000
          , f "11"  9500000  9900000
          ]

foreign import setBDRef :: ∀ eff. Biodalliance -> Eff eff Unit

main :: Foreign -> Eff _ Unit
main fConfig = HA.runHalogenAff do
  case runExcept $ parseBrowserConfig fConfig of
    Left e -> liftEff $ do
      log "Invalid browser configuration:"
      sequence_ $ log <<< renderForeignError <$> e

    Right (BrowserConfig config) -> do
      let {bdTracks, cyGraphs} = validateConfigs config.tracks

          opts' = bdOpts <> sources := bdTracks.results

      liftEff $ log $ "BDTrack errors: " <> foldMap ((<>) ", ") bdTracks.errors
      liftEff $ log $ "CyGraph errors: " <> foldMap ((<>) ", ") cyGraphs.errors

      let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
          mkBd = initBD opts' config.wrapRenderer config.browser

      liftEff $ log "running main"
      HA.awaitLoad
      el <- HA.selectElement (wrap "#psgbHolder")

      case el of
        Nothing -> do
          liftEff $ log "no element for browser!"
        Just el' -> do

          io <- runUI component unit el'

          busFromBD <- Bus.make
          busFromCy <- Bus.make

          when (not null bdTracks.results) do
            io.subscribe $ CR.consumer $ case _ of
              BDInstance bd -> do
                liftEff $ log "attaching BD event handlers"
                _ <- forkTrackSink rangeInputBD bd busFromCy
                _ <- liftEff $ subscribeBDEvents rangeEventOutputBD bd busFromBD
                liftEff $ setBDRef bd
                pure Nothing
              _ -> pure $ Just unit
            liftEff $ log "creating BD"
            io.query $ H.action (CreateBD mkBd)
            liftEff $ log "created BD!"

          liftEff $ log $ "cytoscape enabled: " <> show (not null cyGraphs.results)
          case uncons cyGraphs.results of
            Nothing -> pure unit
            Just {head, tail} -> do
              io.subscribe $ CR.consumer $ case _ of
                CyInstance cy -> do
                  liftEff $ log "attaching Cy event handlers"
                  _ <- forkTrackSink rangeInputCy cy busFromBD
                  _ <- liftEff $ subscribeCyEvents locationEventOutputCy cy busFromCy
                  pure Nothing
                _ -> pure $ Just unit

              liftEff $ log "creating Cy.js"
              io.query $ H.action (CreateCy $ _.elementsUri <<< unwrap $ head)
              liftEff $ log "created cy!"

module Genetics.Browser.UI.Container
       where

import Prelude

import Control.Coroutine as CR
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVAR)
import Control.Monad.Aff.Bus (BusRW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Except (runExcept)
import DOM.HTML.Types (HTMLElement)
import Data.Argonaut (JObject, _Number, _Object, _String)
import Data.Array (null, uncons)
import Data.Const (Const)
import Data.Either (Either(..))
import Data.Either.Nested (Either2)
import Data.Foldable (foldMap, sequence_)
import Data.Foreign (Foreign, renderForeignError)
import Data.Functor.Coproduct.Nested (type (<\/>))
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap, wrap)
import Data.Options (Options, (:=))
import Data.Symbol (SProxy(..))
import Data.Traversable (traverse_)
import Data.Variant (Variant)
import Genetics.Browser.Biodalliance (RendererInfo, initBD, renderers, setLocation, sources)
import Genetics.Browser.Biodalliance as Biodalliance
import Genetics.Browser.Biodalliance.Source (ForeignSourceBase)
import Genetics.Browser.Biodalliance.Source as Source
import Genetics.Browser.Config (BrowserConfig(..), parseBrowserConfig)
import Genetics.Browser.Config.Track (validateConfigs)
import Genetics.Browser.Cytoscape (ParsedEvent(..))
import Genetics.Browser.Cytoscape as Cytoscape
import Genetics.Browser.Cytoscape.Collection (filter, isEdge, targetNodes)
import Genetics.Browser.Cytoscape.Types (CY, Cytoscape, Element, elementJObject)
import Genetics.Browser.Events (Location, Range)
import Genetics.Browser.Events.TrackSink (TrackSink, appendTrackSink, emptyTrackSink, forkTrackSink)
import Genetics.Browser.Events.TrackSource (TrackSource, appendTrackSource, applyTrackSource, emptyTrackSource)
import Genetics.Browser.Renderer.GWAS as GWAS
import Genetics.Browser.Renderer.Lineplot (LinePlotConfig)
import Genetics.Browser.Renderer.Lineplot as QTL
import Genetics.Browser.Types (BD, Biodalliance, Renderer)
import Genetics.Browser.UI.Biodalliance as UIBD
import Genetics.Browser.UI.Cytoscape as UICy
import Genetics.Browser.Units (Bp(Bp), Chr, _Bp, _BpMBp, _Chr, _MBp, bp)
import Halogen as H
import Halogen.Aff as HA
import Halogen.Component.ChildPath as CP
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.VDom.Driver (runUI)

type BDEventEff eff = (console :: CONSOLE, bd :: BD, avar :: AVAR | eff)
type CyEventEff eff = (console :: CONSOLE, cy :: CY, avar :: AVAR | eff)

type BDHandlerOutput eff = Biodalliance -> Eff (BDEventEff eff) Unit
type CyHandlerOutput eff = Cytoscape -> Eff (CyEventEff eff) Unit

locationInputBD :: TrackSink (location :: Location) _ (BDHandlerOutput _)
locationInputBD = appendTrackSink (SProxy :: SProxy "location") f emptyTrackSink
  where f loc bd = do
            log "bd got location"
            setLocation bd loc.chr (bp loc.pos - Bp 1000000.0) (bp loc.pos + Bp 1000000.0)

rangeInputBD :: TrackSink ( range :: Range, location :: Location ) _ (BDHandlerOutput _)
rangeInputBD = appendTrackSink (SProxy :: SProxy "range") f locationInputBD
  where f :: Range -> BDHandlerOutput _
        f ran bd = do
            log "bd got range"
            setLocation bd ran.chr ran.minPos ran.maxPos

rangeInputCy :: ∀ eff. TrackSink (range :: Range) _ (CyHandlerOutput _)
rangeInputCy = appendTrackSink (SProxy :: SProxy "range") f emptyTrackSink
  where f ran cy = do
            log "cy got range"
            log $ "chr: " <> show ran.chr
            let pred el = case parseLocationElementCy el of
                  Nothing -> false
                  Just loc -> loc.chr == ran.chr

            graphColl <- liftEff $ Cytoscape.graphGetCollection cy
            let edges = filter ((not $ wrap pred) && isEdge) graphColl

            _ <- liftEff $ Cytoscape.graphRemoveCollection $ targetNodes edges
            pure unit

rangeEventOutputBD :: TrackSource JObject (range :: Range)
rangeEventOutputBD = appendTrackSource (SProxy :: SProxy "range") f emptyTrackSource
  where f obj =  do
              chr <- obj ^? ix "chr" <<< _String <<< re _Chr
              minPos <- obj ^? ix "min" <<< _Number <<< re _Bp
              maxPos <- obj ^? ix "max" <<< _Number <<< re _Bp
              pure $ {chr, minPos, maxPos}

parseLocationElementCy :: Element -> Maybe Location
parseLocationElementCy el = do
    loc <- elementJObject el ^? ix "data" <<< _Object <<< ix "lrsLoc"
    chr <- loc ^? _Object <<< ix "chr" <<< _String <<< re _Chr
            -- ridiculous.
    pos <- loc ^? _Object <<< ix "pos" <<< _Number
                    <<< re _MBp <<< re _BpMBp
    pure $ { chr, pos }

locationEventOutputCy :: TrackSource ParsedEvent (location :: Location)
locationEventOutputCy = appendTrackSource (SProxy :: SProxy "location") f emptyTrackSource
  where f (ParsedEvent ev) = case ev.target of
            Left el -> parseLocationElementCy el
            Right _ -> Nothing

subscribeBDEvents :: ∀ r.
                     TrackSource JObject r
                  -> Biodalliance
                  -> BusRW (Variant r)
                  -> Eff _ Unit
subscribeBDEvents h bd bus =
  Biodalliance.addFeatureListener bd $ \obj -> do
    let evs = applyTrackSource h obj
    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

subscribeCyEvents :: ∀ r.
                     TrackSource ParsedEvent r
                  -> Cytoscape
                  -> BusRW (Variant r) -> Eff _ Unit
subscribeCyEvents h cy bus =
  Cytoscape.onClick cy $ \obj -> do
    let evs = applyTrackSource h obj
    traverse_ (\x -> Aff.launchAff $ Bus.write x bus) evs

qtlGlyphify :: LinePlotConfig -> Renderer
qtlGlyphify = QTL.render

gwasGlyphify :: Renderer
gwasGlyphify = GWAS.render

data Track = BDTrack | CyTrack

type State = Unit

data Query a
  = CreateBD (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance) a
  | PropagateMessage Message a
  | BDScroll Bp a
  | BDJump Chr Bp Bp a
  | CreateCy String a
  | ResetCy a

data Message
  = BDInstance Biodalliance
  | CyInstance Cytoscape
  -- | WithCy Cytoscape

type ChildSlot = Either2 UIBD.Slot UICy.Slot

type ChildQuery = UIBD.Query <\/> UICy.Query <\/> Const Void
type Effects eff = UIBD.Effects (UICy.Effects eff)

component :: ∀ eff. H.Component HH.HTML Query Unit Message (Aff (Effects eff))
component =
  H.parentComponent
    { initialState: const initialState
    , render
    , eval
    , receiver: const Nothing
    }
  where

  initialState :: State
  initialState = unit

  render :: State -> H.ParentHTML Query ChildQuery ChildSlot (Aff (Effects eff))
  render state =
    HH.div_
      [ HH.div_
        [ HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp (-1000000.0))))
          ]
          [ HH.text "Scroll left 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ (BDScroll (Bp 1000000.0)))
          ]
          [ HH.text "Scroll right 1MBp" ]
        , HH.button
          [  HE.onClick (HE.input_ ResetCy)
          ]
          [ HH.text "Reset cytoscape" ]
          -- these divs are used to control the sizes of the subcomponents without having to query the children
        , HH.div
            [] [HH.slot' CP.cp1 UIBD.Slot UIBD.component unit handleBDMessage]
        , HH.div
            [] [HH.slot' CP.cp2 UICy.Slot UICy.component unit handleCyMessage]
        ]
      ]

  handleBDMessage :: UIBD.Message -> Maybe (Query Unit)
  handleBDMessage UIBD.Initialized = Nothing
  handleBDMessage (UIBD.SendBD bd) = Just $ H.action $ PropagateMessage (BDInstance bd)

  -- TODO the event source track should be handled automatically somehow
  handleCyMessage :: UICy.Output -> Maybe (Query Unit)
  handleCyMessage (UICy.SendCy cy) = Just $ H.action $ PropagateMessage (CyInstance cy)
  handleCyMessage (UICy.SendEvent) = Nothing

  eval :: Query ~> H.ParentDSL State Query ChildQuery ChildSlot Message (Aff (Effects eff))
  eval = case _ of
    CreateBD bd next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Initialize bd)
      pure next

    PropagateMessage msg next -> do
      case msg of
        BDInstance _ -> liftEff $ log "propagating BD"
        CyInstance _ -> liftEff $ log "propagating Cy"
      H.raise msg
      pure next

    BDScroll dist next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Scroll dist)
      pure next
    BDJump chr xl xr next -> do
      _ <- H.query' CP.cp1 UIBD.Slot $ H.action (UIBD.Jump chr xl xr)
      pure next

    CreateCy div next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action (UICy.Initialize div)
      pure next
    ResetCy next -> do
      _ <- H.query' CP.cp2 UICy.Slot $ H.action UICy.Reset
      pure next

qtlRenderer :: RendererInfo
qtlRenderer = { name: "qtlRenderer"
              , renderer: qtlGlyphify { minScore: 4.0
                                      , maxScore: 6.0
                                      , color: "#ff0000"
                                      }
              , canvasHeight: 200.0
              }

gwasRenderer :: RendererInfo
gwasRenderer = { name: "gwasRenderer"
               , renderer: gwasGlyphify
               , canvasHeight: 300.0
               }

bdOpts :: Options Biodalliance
bdOpts = renderers := [ qtlRenderer, gwasRenderer ]

createSource = Source.createSource

fetchHelloWorld :: ∀ a b c. a -> b -> c -> Aff _ String
fetchHelloWorld _ _ _ = pure "Hello world"

foreign import setBDRef :: ∀ eff. Biodalliance -> Eff eff Unit
main :: Foreign -> Eff _ Unit
main fConfig = HA.runHalogenAff do
  case runExcept $ parseBrowserConfig fConfig of
    Left e -> liftEff $ do
      log "Invalid browser configuration:"
      sequence_ $ log <<< renderForeignError <$> e

    Right (BrowserConfig config) -> do
      let {bdTracks, cyGraphs} = validateConfigs config.tracks

          opts' = bdOpts <> sources := bdTracks.results

      liftEff $ log $ "BDTrack errors: " <> foldMap ((<>) ", ") bdTracks.errors
      liftEff $ log $ "CyGraph errors: " <> foldMap ((<>) ", ") cyGraphs.errors

      let mkBd :: (∀ eff. HTMLElement -> Eff (bd :: BD | eff) Biodalliance)
          mkBd = initBD opts' config.wrapRenderer config.browser

      liftEff $ log "running main"
      HA.awaitLoad
      el <- HA.selectElement (wrap "#psgbHolder")

      case el of
        Nothing -> do
          liftEff $ log "no element for browser!"
        Just el' -> do

          io <- runUI component unit el'

          busFromBD <- Bus.make
          busFromCy <- Bus.make

          when (not null bdTracks.results) do
            io.subscribe $ CR.consumer $ case _ of
              BDInstance bd -> do
                liftEff $ log "attaching BD event handlers"
                _ <- forkTrackSink rangeInputBD bd busFromCy
                _ <- liftEff $ subscribeBDEvents rangeEventOutputBD bd busFromBD
                liftEff $ setBDRef bd
                pure Nothing
              _ -> pure $ Just unit
            liftEff $ log "creating BD"
            io.query $ H.action (CreateBD mkBd)
            liftEff $ log "created BD!"

          liftEff $ log $ "cytoscape enabled: " <> show (not null cyGraphs.results)
          case uncons cyGraphs.results of
            Nothing -> pure unit
            Just {head, tail} -> do
              io.subscribe $ CR.consumer $ case _ of
                CyInstance cy -> do
                  liftEff $ log "attaching Cy event handlers"
                  _ <- forkTrackSink rangeInputCy cy busFromBD
                  _ <- liftEff $ subscribeCyEvents locationEventOutputCy cy busFromCy
                  pure Nothing
                _ -> pure $ Just unit

              liftEff $ log "creating Cy.js"
              io.query $ H.action (CreateCy $ _.elementsUri <<< unwrap $ head)
              liftEff $ log "created cy!"


dont do a url here

dont do a url here

module WebAPI.Settings where
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Generic (gShow)
import Servant.PureScript.Settings (SPSettings_(..))
import WebAPI (SPParams_(..))

settings :: SPSettings_ SPParams_
settings =  SPSettings_ {
                    encodeJson : encodeJson
                  , decodeJson : decodeJson
                  , toURLPiece : gShow
                  , params : SPParams_ {
                      baseURL : ""
                  }}

module WebAPI.Settings where
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Generic (gShow)
import Servant.PureScript.Settings (SPSettings_(..))
import WebAPI (SPParams_(..))

settings :: SPSettings_ SPParams_
settings =  SPSettings_ {
                    encodeJson : encodeJson
                  , decodeJson : decodeJson
                  , toURLPiece : gShow
                  , params : SPParams_ {
                      baseURL : "http://localhost:8080/"
                  }}


Added getUrl function to Connection interface

-- | Low level interface for communicating with Subscriber.
--
--   For a high-level declarative interface see "Servant.Subscriber".
module Servant.Subscriber.Connection (
    Config
  , module Exports
  , makeConnection
  , subscribe
  , subscribeAll
  , unsubscribe
  , unsubscribeAll
  , setPongRequest
  , setCloseRequest
  , close
  , getUrl
  ) where

import Control.Bind ((<=<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (modifyRef, readRef, writeRef, newRef)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.ST (ST)

import Data.List (List)
import Data.List as List
import Data.Maybe (isJust, Maybe(Nothing, Just), fromMaybe)

import Data.StrMap as StrMap
import Data.StrMap.ST (STStrMap)
import Data.StrMap.ST as SM
import Prelude
import Servant.Subscriber.Internal (Connection, SubscriberEff, Notification(..), realize, ToUserType) as Exports
import Servant.Subscriber.Internal (SubscriptionState(Ordered), getHttpReq, OrderKey, Order, mutate, Orders, makeOrderKey, Subscription, Notification, Connection, SubscriberEff)
import Servant.Subscriber.Request (HttpRequest, Request(Unsubscribe, Subscribe, SetPongRequest, SetCloseRequest))
import WebSocket (Code(Code))
import WebSocket as WS

type Config eff a = {
    url    :: String
  , callback ::  a -> SubscriberEff eff Unit
  , notify ::  Notification -> SubscriberEff eff Unit
  }

makeConnection :: forall eff a. Config eff a -> SubscriberEff eff (Connection eff a)
makeConnection c = do
      connRef <- newRef Nothing
      orders <-  Ref.newRef StrMap.empty
      pongRequest <- Ref.newRef Nothing
      closeRequest <- Ref.newRef Nothing
      pure $ {
          orders : orders
        , url : WS.URL c.url
        , callback :  c.callback
        , notify :  c.notify
        , connection : connRef
        , pongRequest : pongRequest
        , closeRequest : closeRequest
        }
-- | Which url is this subscriber connected to?
getUrl :: forall eff a. Connection eff a -> String
getUrl conn = case conn.url of
  WS.URL url' -> url'

-- | Drop all subscriptions and close connection.
close :: forall eff a. Connection eff a -> SubscriberEff eff Unit
close impl = do
      writeRef impl.orders StrMap.empty
      mConn <- readRef impl.connection
      case mConn of
        Nothing -> pure unit
        Just (WS.Connection conn) -> conn.close' (Code 1000) Nothing

-- | Add a single subscription to orders.
--
-- For actually sending requests to the server call `realize`.
subscribe :: forall eff a. Subscription a -> Connection eff a -> SubscriberEff eff Unit
subscribe sub impl = do
      modifyRef impl.orders
        $ StrMap.alter (Just <<< updateOrder sub) (makeOrderKey sub.req)

-- | Unsubscribe a given request.
--
-- For actually sending requests to the server call `realize`.
unsubscribe :: forall eff a. HttpRequest -> Connection eff a -> SubscriberEff eff Unit
unsubscribe req' impl = do
      mc <- readRef impl.connection
      case mc of
        Nothing -> modifyRef impl.orders $ StrMap.delete (makeOrderKey req')
        Just c -> do
          let key = makeOrderKey req'
          modifyRef impl.orders $ StrMap.update (Just <<< _ { req = Unsubscribe req', state = Ordered}) key

-- | Set a request which will be issued by the server on every websocket pong event.
--
--   Currently a pong request can not be unset, once set it is there for eternity
--   you can only change it to something else. This of course can be fixed when needed!
--
--   WARNING: Don't ever subscribe a request and also call setPongRequest on it, this might not work as expected.
--            (The Subscribed response is used in both cases, so one of the two requests might never get confirmed)
--            Also never call setPongRequest and setCloseRequest on the same request. This restriction is mostly
--            because of laziness and can of course also be fixed!.
--
--   WARNING (another one): You have to call realize after calling this function, otherwise nothing will happen!
setPongRequest :: forall eff a. HttpRequest -> Connection eff a -> SubscriberEff eff Unit
setPongRequest req' impl = do
      prevReq <- readRef impl.pongRequest
      modifyRef impl.orders $
         deletePrevious (makeOrderKey <$> prevReq)
         >>> StrMap.insert (makeOrderKey req') { req : SetPongRequest req'
                                               , parseResponses : List.Nil
                                               ,  state : Ordered
                                               }
      writeRef impl.pongRequest $ Just req'

-- | Set a request which will be issued by the server when the websocket connection closes for any reason.
--
--   Currently a close request can not be unset, once set it is there for eternity
--   you can only change it to something else. This of course can be fixed when needed!
--
--   WARNING: Don't ever subscribe a request and also call setCloseRequest on it, this might not work as expected.
--            (The `Subscribed` response is used in both cases, so one of the two requests might never get confirmed)
--            Also never call `setPongRequest` and `setCloseRequest` on the same request. This restriction is mostly
--            because of my laziness and can of course also be fixed!.
setCloseRequest :: forall eff a. HttpRequest -> Connection eff a -> SubscriberEff eff Unit
setCloseRequest req' impl = do
      prevReq <- readRef impl.closeRequest
      modifyRef impl.orders $
         deletePrevious (makeOrderKey <$> prevReq)
         >>> StrMap.insert (makeOrderKey req') { req : SetCloseRequest req'
                                               , parseResponses : List.Nil
                                               ,  state : Ordered
                                               }
      writeRef impl.closeRequest $ Just req'

-- | Add all given subscriptions to orders for being subscribed.
--
-- For actually sending requests to the server call `realize`.
subscribeAll :: forall eff a. List (Subscription a) -> Connection eff a -> SubscriberEff eff Unit
subscribeAll subsList impl = do
    modifyRef impl.orders $ insertSubscriptions subsList
  where
    insertSubscriptions :: List (Subscription a) -> Orders a -> Orders a
    insertSubscriptions subs = mutate (\ orders' -> List.foldM mutSubscribe orders' subs)

-- | Internal function used by subscribeAll for efficiently adding many subscriptions.
mutSubscribe :: forall a h. STStrMap h (Order a) -> Subscription a -> Eff (st :: ST h) (STStrMap h (Order a))
mutSubscribe orders sub = do
  old <- SM.peek orders $ makeOrderKey sub.req
  let new = updateOrder sub old
  SM.poke orders (makeOrderKey sub.req) new

-- | Unsubscribe all given requests.
--
-- For actually sending requests to the server call `realize`.
unsubscribeAll :: forall eff a. List HttpRequest -> Connection eff a -> SubscriberEff eff Unit
unsubscribeAll reqs impl = do
  let
    keys = map makeOrderKey reqs
  mc <- readRef impl.connection
  modifyRef impl.orders $ deleteSubscriptions (isJust mc) keys
  where
    deleteSubscriptions :: Boolean -> List OrderKey -> Orders a -> Orders a
    deleteSubscriptions isActive keys = mutate (\orders' -> List.foldM (mutUnsubscribe isActive) orders' keys)

-- | Internal function used by unsubscribeAll for efficiently removing many subscriptions.
mutUnsubscribe :: forall a h. Boolean -> STStrMap h (Order a) -> OrderKey -> Eff (st :: ST h) (STStrMap h (Order a))
mutUnsubscribe connActive orders key = if connActive
                                        then do
                                          mOrder' <- SM.peek orders key
                                          case mOrder' of
                                            Nothing -> pure orders
                                            Just order' -> SM.poke orders key $ order' {
                                                req = Unsubscribe $ getHttpReq order'.req
                                              , state = Ordered
                                              }
                                        else SM.delete orders key

updateOrder :: forall a. Subscription a -> Maybe (Order a) -> Order a
updateOrder sub orig = case orig of
    Nothing -> {
        state : Ordered
      , req : Subscribe sub.req
      , parseResponses : sub.parseResponses
      }
    Just o -> o { parseResponses = sub.parseResponses }

-- | Helper function for setPongRequest and setCloseRequest.
deletePrevious :: forall a. Maybe OrderKey -> Orders a -> Orders a
deletePrevious mKey = fromMaybe id (StrMap.delete <$> mKey)

-- | Low level interface for communicating with Subscriber.
--
--   For a high-level declarative interface see "Servant.Subscriber".
module Servant.Subscriber.Connection (
    Config
  , module Exports
  , makeConnection
  , subscribe
  , subscribeAll
  , unsubscribe
  , unsubscribeAll
  , setPongRequest
  , setCloseRequest
  , close
  ) where

import Control.Bind ((<=<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Ref (modifyRef, readRef, writeRef, newRef)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.ST (ST)

import Data.List (List)
import Data.List as List
import Data.Maybe (isJust, Maybe(Nothing, Just), fromMaybe)

import Data.StrMap as StrMap
import Data.StrMap.ST (STStrMap)
import Data.StrMap.ST as SM
import Prelude
import Servant.Subscriber.Internal (Connection, SubscriberEff, Notification(..), realize, ToUserType) as Exports
import Servant.Subscriber.Internal (SubscriptionState(Ordered), getHttpReq, OrderKey, Order, mutate, Orders, makeOrderKey, Subscription, Notification, Connection, SubscriberEff)
import Servant.Subscriber.Request (HttpRequest, Request(Unsubscribe, Subscribe, SetPongRequest, SetCloseRequest))
import WebSocket (Code(Code))
import WebSocket as WS

type Config eff a = {
    url    :: String
  , callback ::  a -> SubscriberEff eff Unit
  , notify ::  Notification -> SubscriberEff eff Unit
  }

makeConnection :: forall eff a. Config eff a -> SubscriberEff eff (Connection eff a)
makeConnection c = do
      connRef <- newRef Nothing
      orders <-  Ref.newRef StrMap.empty
      pongRequest <- Ref.newRef Nothing
      closeRequest <- Ref.newRef Nothing
      pure $ {
          orders : orders
        , url : WS.URL c.url
        , callback :  c.callback
        , notify :  c.notify
        , connection : connRef
        , pongRequest : pongRequest
        , closeRequest : closeRequest
        }

-- | Drop all subscriptions and close connection.
close :: forall eff a. Connection eff a -> SubscriberEff eff Unit
close impl = do
      writeRef impl.orders StrMap.empty
      mConn <- readRef impl.connection
      case mConn of
        Nothing -> pure unit
        Just (WS.Connection conn) -> conn.close' (Code 1000) Nothing

-- | Add a single subscription to orders.
--
-- For actually sending requests to the server call `realize`.
subscribe :: forall eff a. Subscription a -> Connection eff a -> SubscriberEff eff Unit
subscribe sub impl = do
      modifyRef impl.orders
        $ StrMap.alter (Just <<< updateOrder sub) (makeOrderKey sub.req)

-- | Unsubscribe a given request.
--
-- For actually sending requests to the server call `realize`.
unsubscribe :: forall eff a. HttpRequest -> Connection eff a -> SubscriberEff eff Unit
unsubscribe req' impl = do
      mc <- readRef impl.connection
      case mc of
        Nothing -> modifyRef impl.orders $ StrMap.delete (makeOrderKey req')
        Just c -> do
          let key = makeOrderKey req'
          modifyRef impl.orders $ StrMap.update (Just <<< _ { req = Unsubscribe req', state = Ordered}) key

-- | Set a request which will be issued by the server on every websocket pong event.
--
--   Currently a pong request can not be unset, once set it is there for eternity
--   you can only change it to something else. This of course can be fixed when needed!
--
--   WARNING: Don't ever subscribe a request and also call setPongRequest on it, this might not work as expected.
--            (The Subscribed response is used in both cases, so one of the two requests might never get confirmed)
--            Also never call setPongRequest and setCloseRequest on the same request. This restriction is mostly
--            because of laziness and can of course also be fixed!.
--
--   WARNING (another one): You have to call realize after calling this function, otherwise nothing will happen!
setPongRequest :: forall eff a. HttpRequest -> Connection eff a -> SubscriberEff eff Unit
setPongRequest req' impl = do
      prevReq <- readRef impl.pongRequest
      modifyRef impl.orders $
         deletePrevious (makeOrderKey <$> prevReq)
         >>> StrMap.insert (makeOrderKey req') { req : SetPongRequest req'
                                               , parseResponses : List.Nil
                                               ,  state : Ordered
                                               }
      writeRef impl.pongRequest $ Just req'

-- | Set a request which will be issued by the server when the websocket connection closes for any reason.
--
--   Currently a close request can not be unset, once set it is there for eternity
--   you can only change it to something else. This of course can be fixed when needed!
--
--   WARNING: Don't ever subscribe a request and also call setCloseRequest on it, this might not work as expected.
--            (The `Subscribed` response is used in both cases, so one of the two requests might never get confirmed)
--            Also never call `setPongRequest` and `setCloseRequest` on the same request. This restriction is mostly
--            because of my laziness and can of course also be fixed!.
setCloseRequest :: forall eff a. HttpRequest -> Connection eff a -> SubscriberEff eff Unit
setCloseRequest req' impl = do
      prevReq <- readRef impl.closeRequest
      modifyRef impl.orders $
         deletePrevious (makeOrderKey <$> prevReq)
         >>> StrMap.insert (makeOrderKey req') { req : SetCloseRequest req'
                                               , parseResponses : List.Nil
                                               ,  state : Ordered
                                               }
      writeRef impl.closeRequest $ Just req'

-- | Add all given subscriptions to orders for being subscribed.
--
-- For actually sending requests to the server call `realize`.
subscribeAll :: forall eff a. List (Subscription a) -> Connection eff a -> SubscriberEff eff Unit
subscribeAll subsList impl = do
    modifyRef impl.orders $ insertSubscriptions subsList
  where
    insertSubscriptions :: List (Subscription a) -> Orders a -> Orders a
    insertSubscriptions subs = mutate (\ orders' -> List.foldM mutSubscribe orders' subs)

-- | Internal function used by subscribeAll for efficiently adding many subscriptions.
mutSubscribe :: forall a h. STStrMap h (Order a) -> Subscription a -> Eff (st :: ST h) (STStrMap h (Order a))
mutSubscribe orders sub = do
  old <- SM.peek orders $ makeOrderKey sub.req
  let new = updateOrder sub old
  SM.poke orders (makeOrderKey sub.req) new

-- | Unsubscribe all given requests.
--
-- For actually sending requests to the server call `realize`.
unsubscribeAll :: forall eff a. List HttpRequest -> Connection eff a -> SubscriberEff eff Unit
unsubscribeAll reqs impl = do
  let
    keys = map makeOrderKey reqs
  mc <- readRef impl.connection
  modifyRef impl.orders $ deleteSubscriptions (isJust mc) keys
  where
    deleteSubscriptions :: Boolean -> List OrderKey -> Orders a -> Orders a
    deleteSubscriptions isActive keys = mutate (\orders' -> List.foldM (mutUnsubscribe isActive) orders' keys)

-- | Internal function used by unsubscribeAll for efficiently removing many subscriptions.
mutUnsubscribe :: forall a h. Boolean -> STStrMap h (Order a) -> OrderKey -> Eff (st :: ST h) (STStrMap h (Order a))
mutUnsubscribe connActive orders key = if connActive
                                        then do
                                          mOrder' <- SM.peek orders key
                                          case mOrder' of
                                            Nothing -> pure orders
                                            Just order' -> SM.poke orders key $ order' {
                                                req = Unsubscribe $ getHttpReq order'.req
                                              , state = Ordered
                                              }
                                        else SM.delete orders key

updateOrder :: forall a. Subscription a -> Maybe (Order a) -> Order a
updateOrder sub orig = case orig of
    Nothing -> {
        state : Ordered
      , req : Subscribe sub.req
      , parseResponses : sub.parseResponses
      }
    Just o -> o { parseResponses = sub.parseResponses }

-- | Helper function for setPongRequest and setCloseRequest.
deletePrevious :: forall a. Maybe OrderKey -> Orders a -> Orders a
deletePrevious mKey = fromMaybe id (StrMap.delete <$> mKey)


Fixed trial period warning not presenting issue (#1846)

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.ChildSlot
  , component
  ) where

import SlamData.Prelude

import CSS as CSS

import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Rec.Class (tailRecM, Step(Done, Loop))
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser as Browser
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import DOM.Event.Event as DEE

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array as Array
import Data.Coyoneda (liftCoyoneda)
import Data.Foldable as F
import Data.Lens ((.~), preview)
import Data.MediaType (MediaType(..))
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir, printPath)
import Data.String as S
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Core as HC
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES

import Quasar.Advanced.QuasarAF as QA
import Quasar.Data (QData(..))
import Quasar.Mount as QM

import SlamData.Common.Sort (notSort)
import SlamData.Config as Config
import SlamData.Dialog.Render as RenderDialog
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.CSS as FileSystemClassNames
import SlamData.FileSystem.Component.ChildSlot (ChildQuery, ChildSlot)
import SlamData.FileSystem.Component.ChildSlot as CS
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, initialState)
import SlamData.FileSystem.Component.State as State
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Component.Message as DialogMessage
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.Couchbase.Component.State as Couchbase
import SlamData.FileSystem.Dialog.Mount.MarkLogic.Component.State as MarkLogic
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Mount.SparkHDFS.Component.State as Spark
import SlamData.FileSystem.Dialog.Mount.SparkLocal.Component.State as SparkLocal
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Resource (Resource)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Component as GlobalMenu
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Monad (Slam)
import SlamData.Notification as Notification
import SlamData.Notification.Component as NC
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Auth (authHeaders) as API
import SlamData.Quasar.Class (liftQuasar)
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.Wiring as Wiring
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)

import Utils (finally)
import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type DSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ H.Component HH.HTML Query Unit Void Slam
component =
  H.lifecycleParentComponent
    { render
    , eval
    , receiver: const Nothing
    , initialState: const initialState
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ FileSystemClassNames.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    $ [ HH.slot' CS.cpHeader unit Header.component unit absurd
      , content
          [ HH.slot' CS.cpSearch unit Search.component unit $ HE.input HandleSearch
          , HH.div_
            [ Breadcrumbs.render { path, sort, salt }
            , toolbar state
            ]
          , row [ sorting state ]
          , HH.slot' CS.cpListing unit Listing.component unit $ HE.input HandleListing
          ]
      , HH.slot' CS.cpDialog unit Dialog.component unit $ HE.input HandleDialog
      , HH.slot' CS.cpNotify unit (NC.component $ NC.renderModeFromAccessType Editable) unit
          $ HE.input HandleNotifications
      ]
    ⊕ (guard state.presentIntroVideo $> renderIntroVideo)
    ⊕ (guard state.presentIntroVideo $> renderIntroVideoBackdrop)

renderIntroVideoBackdrop ∷ HTML
renderIntroVideoBackdrop =
  HH.div
    [ HP.class_ (HH.ClassName "deck-dialog-backdrop")
    , HE.onMouseDown $ HE.input_ DismissIntroVideo
    ]
    []

renderIntroVideo ∷ HTML
renderIntroVideo =
  HH.div
    [ HP.class_ $ HC.ClassName "deck-dialog" ]
    [ HH.div
        [ HCSS.style do
             CSS.paddingLeft CSS.nil
             CSS.paddingRight CSS.nil
        ]
        [ HH.h4
            [ HCSS.style do
                CSS.paddingLeft $ CSS.rem 1.0
                CSS.paddingRight $ CSS.rem 1.0
            ]
            [ HH.text "Welcome to SlamData!" ]
        , HH.video
            [ HP.autoplay true ]
            [ HH.source
                [ HP.type_ (MediaType "video/mp4")
                , HP.src "video/getting-started.mp4"
                ]
            ]
        , RenderDialog.modalFooter
            [ HH.button
                [ HP.type_ HP.ButtonButton
                , HE.onClick $ HE.input_ DismissIntroVideo
                , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
                , HCSS.style $ CSS.marginRight $ CSS.rem 1.0
                ]
                [ HH.text "Skip video" ]
            ]
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    w ← H.lift Wiring.expose
    whenM
      (not <$> dismissedIntroVideoBefore)
      (H.modify $ State._presentIntroVideo .~ true)
    H.subscribe $ busEventSource (flip HandleError ES.Listening) w.bus.globalError
    H.subscribe $ busEventSource (flip HandleSignInMessage ES.Listening) w.auth.signIn
    H.subscribe $ busEventSource (flip HandleLicenseProblem ES.Listening) w.bus.licenseProblems
    daysRemaining ← map _.daysRemaining <$> liftQuasar QA.licenseInfo
    case daysRemaining of
      Right i | i <= 30 && i > 0 → void $ H.liftAff do
        trigger ← AVar.makeVar
        Bus.write (daysRemainingNotification trigger i) w.bus.notify
        Aff.forkAff $ AVar.takeVar trigger *> (H.liftEff $ Browser.newTab "https://slamdata.com/contact-us/")
      _ →
        pure unit
    pure next
  Transition page next → do
    H.modify
      $ (State._isMount .~ page.isMount)
      ∘ (State._salt .~ page.salt)
      ∘ (State._sort .~ page.sort)
      ∘ (State._path .~ page.path)
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Reset
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValue $ fromMaybe "" page.query
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValid true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetPath page.path
    resort
    pure next

  PreventDefault e q → do
    H.liftEff $ DEE.preventDefault e
    eval q
  Resort next → do
    st ← H.get
    searchValue ← H.query' CS.cpSearch unit (H.request Search.GetValue)
    H.liftEff $ setLocation $ browseURL searchValue (notSort st.sort) st.salt st.path
    pure next
  SetPath path next → do
    H.modify $ State._path .~ path
    pure next
  SetSort sort next → do
    H.modify $ State._sort .~ sort
    resort
    pure next
  SetSalt salt next → do
    H.modify $ State._salt .~ salt
    pure next
  CheckIsMount path next → do
    checkIsMount path
    pure next
  CheckIsUnconfigured next → do
    checkIsUnconfigured
    pure next
  SetVersion version next → do
    H.modify $ State._version .~ Just version
    pure next

  ShowHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ true
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden false
    pure next
  HideHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ false
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden true
    pure next

  Configure next → do
    path ← H.gets _.path
    configure $ R.Database path
    pure next
  MakeMount next → do
    parent ← H.gets _.path
    showDialog $ Dialog.Mount $ Mount.New { parent }
    pure next
  MakeFolder next → do
    result ← runExceptT do
      path ← lift $ H.gets _.path
      dirName ← ExceptT $ API.getNewName path Config.newFolderName
      let
        dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
        cleanupItem = void $ H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Filter (_ ≠ dirItem)
      _ ← H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Add dirItem
      finally cleanupItem $ ExceptT $ API.save hiddenFile jsonEmptyObject
      pure dirRes
    case result of
      Left err → case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "You can only create files or folders in data sources."
            ⊕ "Please mount a data source, and then create your file or location inside the mounted data source."
        Right ge →
          GE.raiseGlobalError ge
      Right dirRes →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item dirRes
    pure next
  MakeWorkspace next → do
    state ← H.get
    isMounted >>= if _
       then
         createWorkspace state.path \mkUrl →
           H.liftEff $ setLocation $ mkUrl New
       else
         showDialog
           $ Dialog.Error
           $ "There was a problem creating the workspace: Path "
           ⊕ printPath state.path
           ⊕ " is not inside a mount."
    pure next
  UploadFile el next → do
    mbInput ← H.liftEff $ D.querySelector "input" el
    for_ mbInput \input →
      void $ H.liftEff $ Be.raiseEvent "click" input
    pure next
  FileListChanged el next → do
    fileArr ← map Cf.fileListToArray $ (H.liftAff $ Cf.files el)
    H.liftEff $ clearValue el
    -- TODO: notification? this shouldn't be a runtime exception anyway!
    -- let err ∷ Slam Unit
    --     err = throwError $ error "empty filelist"
    -- in H.liftAff err
    for_ (Array.head fileArr) uploadFileSelected
    pure next
  Download next → do
    path ← H.gets _.path
    download $ R.Directory path
    pure next

  DismissSignInSubmenu next → do
    dismissSignInSubmenu
    pure next
  DismissMountHint next → do
    dismissMountHint
    pure next
  DismissIntroVideo next → do
    dismissIntroVideo
    pure next

  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  HandleListing (Listing.ItemMessage m) next → do
    handleItemMessage m
    pure next
  HandleListing (Listing.Added items) next
    | Array.length items < 2 → do
        resort
        pure next
    | otherwise → do
        path ← H.gets _.path
        presentMountHint items path
        resort
        pure next
  HandleDialog DialogMessage.Dismiss next →
    pure next
  HandleDialog (DialogMessage.MountSave originalMount) next → do
    mbMbMount ←
      H.query' CS.cpDialog unit $ H.request Dialog.SaveMount
    for_ (join mbMbMount) \newPath → do
      hideDialog
      path ← H.gets _.path
      case originalMount of
        -- Refresh if mount is current directory
        -- path </> dir "" is equal to path
        Nothing | R.Database path ≡ newPath || (R.Database $ path </> dir "") ≡ newPath →
          H.liftEff Browser.reload
        -- Add new item to list
        Nothing →
          void $ H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item (R.Mount newPath)
        -- Rename current mount at path
        Just oldPath@(R.Database p) | path ≡ p && oldPath /= newPath → do
          handleItemMessage (Item.Open $ R.Mount newPath)
          void $ API.delete (R.Mount oldPath)
        -- Rename mount in listing
        Just oldPath | oldPath /= newPath → do
          _ ← H.query' CS.cpListing unit $ H.action $ Listing.Remove $ Item (R.Mount oldPath)
          _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item (R.Mount newPath)
          void $ API.delete (R.Mount oldPath)
        Just oldPath → do
          pure unit
    resort
    checkIsMount =<< H.gets _.path
    checkIsUnconfigured
    pure next
  HandleDialog DialogMessage.MountDelete next → do
    mount ← R.Mount ∘ R.Database <$> H.gets _.path
    remove mount
    H.liftEff Browser.reload
    pure next
  HandleNotifications NC.ExpandGlobalMenu next → do
    gripperState ← queryHeaderGripper $ H.request Gripper.GetState
    when (gripperState ≠ Just Gripper.Opened) do
      _ ← queryHeaderGripper $ H.action $ Gripper.StartDragging 0.0
      _ ← queryHeaderGripper $ H.action Gripper.StopDragging
      pure unit
    pure next
  HandleNotifications (NC.Fulfill trigger) next → do
    H.liftAff $ AVar.putVar trigger unit
    pure next
  HandleSearch m next → do
    salt ← H.liftEff newSalt
    st ← H.get
    value ← case m of
      Search.Cleared →
        pure Nothing
      Search.Submit → do
        H.query' CS.cpSearch unit $ H.request Search.GetValue
    H.liftEff $ setLocation $ browseURL value st.sort salt st.path
    pure next
  HandleLicenseProblem problem next → do
    _ ← H.query' CS.cpDialog unit $ H.action $ Dialog.Show $ Dialog.LicenseProblem problem
    pure next
  SetLoading bool next → do
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading bool
    pure next
  SetIsSearching bool next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsSearching bool
    pure next
  AddListings items next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Adds items
    pure next
  ShowError message next → do
    _ ← H.query' CS.cpDialog unit $ H.action $ Dialog.Show $ Dialog.Error message
    pure next
  HandleSignInMessage message next → do
    when (message ≡ GlobalMenu.SignInSuccess) (H.liftEff Browser.reload)
    pure next

handleItemMessage ∷ Item.Message → DSL Unit
handleItemMessage = case _ of
  Item.Selected →
    pure unit
  Item.Edit res → do
    loc ← H.liftEff locationString
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load Editable)
  Item.Open res → do
    { sort, salt, path } ← H.get
    loc ← H.liftEff locationString
    for_ (preview R._filePath res) \fp →
      createWorkspace path \mkUrl →
        H.liftEff $ setLocation $ mkUrl $ Exploring fp
    for_ (preview R._dirPath res) \dp →
      H.liftEff $ setLocation $ browseURL Nothing sort salt dp
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load ReadOnly)
  Item.Configure (R.Mount mount) → do
    configure mount
  Item.Configure _ →
    pure unit
  Item.Move res → do
    showDialog $ Dialog.Rename res
    flip getDirectories rootDir \x →
      void $ H.query' CS.cpDialog unit $ H.action $ Dialog.AddDirsToRename x
  Item.Remove res →
    remove res
  Item.Share res → do
    path ← H.gets _.path
    loc ← map (_ ⊕ "/") $ H.liftEff locationString
    for_ (preview R._filePath res) \fp → do
      createWorkspace path \mkUrl →
        showDialog $ Dialog.Share $ append loc $ mkUrl $ Exploring fp
    for_ (preview R._Workspace res) \wp → do
      showDialog (Dialog.Share $ append loc $ mkWorkspaceURL wp (Load ReadOnly))
  Item.Download res →
    download res

checkIsMount ∷ DirPath → DSL Unit
checkIsMount path = do
  isMount ← isRight <$> API.mountInfo (Left path)
  H.modify $ State._isMount .~ isMount

isMounted ∷ DSL Boolean
isMounted = do
  path ← H.gets _.path
  tailRecM go path
  where
  go ∷ DirPath → DSL (Step DirPath Boolean)
  go path = do
    isMount ← isRight <$> API.mountInfo (Left path)
    pure
      $ if isMount
          then Done true
          else maybe (Done false) Loop (parentDir path)

checkIsUnconfigured ∷ DSL Unit
checkIsUnconfigured = do
  isMount ← isRight <$> API.mountInfo (Left rootDir)
  isEmpty ← either (const false) Array.null <$> API.children rootDir
  H.modify $ State._isUnconfigured .~ (not isMount ∧ isEmpty)

remove ∷ Resource → DSL Unit
remove res = do
  -- Replace actual item with phantom
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ PhantomItem res
  -- Save order of items during deletion (or phantom will be on top of list)
  resort
  -- Try to delete
  mbTrashFolder ← H.lift $ API.delete res
  -- Remove phantom resource after we have response from server
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  case mbTrashFolder of
    Left err → do
      -- Error occured: put item back and show dialog
      void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)
      case GE.fromQError err of
        Left m →
          showDialog $ Dialog.Error m
        Right ge →
          GE.raiseGlobalError ge
    Right mbRes →
      -- Item has been deleted: probably add trash folder
      for_ mbRes \res' →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res')

  listing ← fromMaybe [] <$> (H.query' CS.cpListing unit $ H.request Listing.Get)
  path ← H.gets _.path
  presentMountHint listing path

  resort
  checkIsMount path
  checkIsUnconfigured

dismissMountHint ∷ DSL Unit
dismissMountHint = do
  LS.persist LSK.dismissedMountHintKey true
  H.modify $ State._presentMountHint .~ false

dismissIntroVideo ∷ DSL Unit
dismissIntroVideo = do
  LS.persist LSK.dismissedIntroVideoKey true
  H.modify $ State._presentIntroVideo .~ false

dismissedIntroVideoBefore ∷ DSL Boolean
dismissedIntroVideoBefore =
  either (const false) id <$> LS.retrieve LSK.dismissedIntroVideoKey

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.liftEff (Cf.name f)
      <#> RX.replace (unsafePartial fromRight $ RX.regex "/" RXF.global) ":"
      >>= API.getNewName path

  case name of
    Left err → handleError err
    Right name' → do
      reader ← H.liftEff Cf.newReaderEff
      content' ← H.liftAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = Array.last (S.split (S.Pattern ".") name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      _ ← H.query' CS.cpListing unit $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
      case f' of
        Left err → handleError err
        Right _ →
          void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)

  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in (startsWithEndsWith "[" "]" trimmed) || (startsWithEndsWith "{" "}" trimmed)

  startsWithEndsWith startsWith endsWith s =
    F.all isJust [S.stripPrefix (S.Pattern startsWith) s, S.stripSuffix (S.Pattern endsWith) s]

  handleError err =
    case GE.fromQError err of
      Left msg → showDialog $ Dialog.Error msg
      Right ge → GE.raiseGlobalError ge

presentMountHint ∷ ∀ a. Array a → DirPath → DSL Unit
presentMountHint xs path = do
  isSearching ←
    map (fromMaybe false) $ H.query' CS.cpSearch unit (H.request Search.IsSearching)
  isLoading ←
    map (fromMaybe true)  $ H.query' CS.cpSearch unit (H.request Search.IsLoading)

  H.modify
    ∘ (State._presentMountHint .~ _)
    ∘ ((Array.null xs ∧ path ≡ rootDir ∧ not (isSearching ∧ isLoading)) ∧ _)
    ∘ not
    ∘ either (const false) id
    =<< dismissedBefore
  where
  dismissedBefore ∷ DSL (Either String Boolean)
  dismissedBefore =
    LS.retrieve LSK.dismissedMountHintKey

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu =
  void $ queryGlobalMenu (H.action GlobalMenu.DismissSubmenu)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  H.query' CS.cpSearch unit (H.request Search.IsSearching)
    >>= traverse_ \isSearching →
      void $ H.query' CS.cpListing unit $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure m =
  API.mountInfo anyPath >>= case m, _ of
    R.View path, Left err → raiseError err
    R.Database path, Left err
      | path /= rootDir → raiseError err
      | otherwise →
          showDialog $ Dialog.Mount Mount.Root
    R.View path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: either parentDir parentDir anyPath
          , name: Just $ getNameStr anyPath
          , settings: fromConfig config
          }
    R.Database path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: if path ≡ rootDir then Nothing else either parentDir parentDir anyPath
          , name: if path ≡ rootDir then Nothing else Just $ getNameStr anyPath
          , settings: fromConfig config
          }
  where
    anyPath =
      R.mountPath m

    fromConfig = case _ of
      QM.ViewConfig config → Mount.SQL2 (SQL2.stateFromViewInfo config)
      QM.ModuleConfig config → Mount.SQL2 SQL2.initialState
      QM.MongoDBConfig config → Mount.MongoDB (MongoDB.fromConfig config)
      QM.CouchbaseConfig config → Mount.Couchbase (Couchbase.fromConfig config)
      QM.MarkLogicConfig config → Mount.MarkLogic (MarkLogic.fromConfig config)
      QM.SparkHDFSConfig config → Mount.SparkHDFS (Spark.fromConfig config)
      QM.SparkLocalConfig config → Mount.SparkLocal (SparkLocal.fromConfig config)

    raiseError err = case GE.fromQError err of
      Left msg →
        showDialog $ Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ msg
      Right ge →
        GE.raiseGlobalError ge

download ∷ R.Resource → DSL Unit
download res = do
  hs ← H.lift API.authHeaders
  showDialog $ Dialog.Download res hs
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = Array.filter pred items
          parents = Array.mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren $ R.isDirectory ∨ R.isDatabaseMount

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' CS.cpDialog unit ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog =
  void $ H.query' CS.cpDialog unit $ H.action Dialog.RaiseDismiss

queryHeaderGripper ∷ ∀ a. Gripper.Query a → DSL (Maybe a)
queryHeaderGripper =
   H.query' CS.cpHeader unit ∘ Header.QueryGripper ∘ liftCoyoneda

queryGlobalMenu ∷ ∀ a. GlobalMenu.Query a → DSL (Maybe a)
queryGlobalMenu =
   H.query' CS.cpHeader unit ∘ Header.QueryGlobalMenu ∘ liftCoyoneda

createWorkspace ∷ ∀ a. DirPath → ((Action → String) → DSL a) → DSL Unit
createWorkspace path action = do
  let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      case GE.fromQError err of
        Left msg →
          -- This error isn't strictly true as we're not actually creating the
          -- workspace here, but saying there was a problem "creating a name for the
          -- workspace" would be a little strange
          showDialog $ Dialog.Error
            $ "There was a problem creating the workspace: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right name' →
      void $ action (mkWorkspaceURL (path </> dir name'))

daysRemainingNotification ∷ AVar.AVar Unit → Int → Notification.NotificationOptions
daysRemainingNotification avar i =
  { notification: Notification.Info $ show i <> " Licensed days remaining."
  , detail: Nothing
  , actionOptions:
      Just $ Notification.ActionOptions
        { message: "Please get in touch renew your License."
        , actionMessage: "Contact SlamData"
        , action: Notification.Fulfill avar
        }
  , timeout: Nothing
  }

{-
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.FileSystem.Component
  ( module SlamData.FileSystem.Component.State
  , module SlamData.FileSystem.Component.Query
  , module SlamData.FileSystem.Component.ChildSlot
  , component
  ) where

import SlamData.Prelude

import CSS as CSS

import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Rec.Class (tailRecM, Step(Done, Loop))
import Control.UI.Browser (setLocation, locationString, clearValue)
import Control.UI.Browser as Browser
import Control.UI.Browser.Event as Be
import Control.UI.File as Cf

import DOM.Event.Event as DEE

import Data.Argonaut (jsonParser, jsonEmptyObject)
import Data.Array as Array
import Data.Coyoneda (liftCoyoneda)
import Data.Foldable as F
import Data.Lens ((.~), preview)
import Data.MediaType (MediaType(..))
import Data.MediaType.Common (textCSV, applicationJSON)
import Data.Path.Pathy (rootDir, (</>), dir, file, parentDir, printPath)
import Data.String as S
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.CSS as HCSS
import Halogen.HTML.Core as HC
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES

import Quasar.Advanced.QuasarAF as QA
import Quasar.Data (QData(..))
import Quasar.Mount as QM

import SlamData.Common.Sort (notSort)
import SlamData.Config as Config
import SlamData.Dialog.Render as RenderDialog
import SlamData.FileSystem.Breadcrumbs.Component as Breadcrumbs
import SlamData.FileSystem.Component.CSS as FileSystemClassNames
import SlamData.FileSystem.Component.ChildSlot (ChildQuery, ChildSlot)
import SlamData.FileSystem.Component.ChildSlot as CS
import SlamData.FileSystem.Component.Query (Query(..))
import SlamData.FileSystem.Component.Render (sorting, toolbar)
import SlamData.FileSystem.Component.State (State, initialState)
import SlamData.FileSystem.Component.State as State
import SlamData.FileSystem.Dialog.Component as Dialog
import SlamData.FileSystem.Dialog.Component.Message as DialogMessage
import SlamData.FileSystem.Dialog.Mount.Component as Mount
import SlamData.FileSystem.Dialog.Mount.Couchbase.Component.State as Couchbase
import SlamData.FileSystem.Dialog.Mount.MarkLogic.Component.State as MarkLogic
import SlamData.FileSystem.Dialog.Mount.MongoDB.Component.State as MongoDB
import SlamData.FileSystem.Dialog.Mount.SQL2.Component.State as SQL2
import SlamData.FileSystem.Dialog.Mount.SparkHDFS.Component.State as Spark
import SlamData.FileSystem.Dialog.Mount.SparkLocal.Component.State as SparkLocal
import SlamData.FileSystem.Listing.Component as Listing
import SlamData.FileSystem.Listing.Item (Item(..), itemResource, sortItem)
import SlamData.FileSystem.Listing.Item.Component as Item
import SlamData.FileSystem.Resource (Resource)
import SlamData.FileSystem.Resource as R
import SlamData.FileSystem.Routing (browseURL)
import SlamData.FileSystem.Routing.Salt (newSalt)
import SlamData.FileSystem.Search.Component as Search
import SlamData.GlobalError as GE
import SlamData.GlobalMenu.Component as GlobalMenu
import SlamData.Header.Component as Header
import SlamData.Header.Gripper.Component as Gripper
import SlamData.LocalStorage.Class as LS
import SlamData.LocalStorage.Keys as LSK
import SlamData.Monad (Slam)
import SlamData.Notification as Notification
import SlamData.Notification.Component as NC
import SlamData.Quasar (ldJSON) as API
import SlamData.Quasar.Auth (authHeaders) as API
import SlamData.Quasar.Class (liftQuasar)
import SlamData.Quasar.Data (makeFile, save) as API
import SlamData.Quasar.FS (children, delete, getNewName) as API
import SlamData.Quasar.Mount (mountInfo) as API
import SlamData.Render.Common (content, row)
import SlamData.Wiring as Wiring
import SlamData.Workspace.Action (Action(..), AccessType(..))
import SlamData.Workspace.Routing (mkWorkspaceURL)

import Utils (finally)
import Utils.DOM as D
import Utils.Path (DirPath, getNameStr)

type HTML = H.ParentHTML Query ChildQuery ChildSlot Slam
type DSL = H.ParentDSL State Query ChildQuery ChildSlot Void Slam

component ∷ H.Component HH.HTML Query Unit Void Slam
component =
  H.lifecycleParentComponent
    { render
    , eval
    , receiver: const Nothing
    , initialState: const initialState
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    }

render ∷ State → HTML
render state@{ version, sort, salt, path } =
  HH.div
    [ HP.classes [ FileSystemClassNames.filesystem ]
    , HE.onClick (HE.input_ DismissSignInSubmenu)
    ]
    $ [ HH.slot' CS.cpHeader unit Header.component unit absurd
      , content
          [ HH.slot' CS.cpSearch unit Search.component unit $ HE.input HandleSearch
          , HH.div_
            [ Breadcrumbs.render { path, sort, salt }
            , toolbar state
            ]
          , row [ sorting state ]
          , HH.slot' CS.cpListing unit Listing.component unit $ HE.input HandleListing
          ]
      , HH.slot' CS.cpDialog unit Dialog.component unit $ HE.input HandleDialog
      , HH.slot' CS.cpNotify unit (NC.component $ NC.renderModeFromAccessType Editable) unit
          $ HE.input HandleNotifications
      ]
    ⊕ (guard state.presentIntroVideo $> renderIntroVideo)
    ⊕ (guard state.presentIntroVideo $> renderIntroVideoBackdrop)

renderIntroVideoBackdrop ∷ HTML
renderIntroVideoBackdrop =
  HH.div
    [ HP.class_ (HH.ClassName "deck-dialog-backdrop")
    , HE.onMouseDown $ HE.input_ DismissIntroVideo
    ]
    []

renderIntroVideo ∷ HTML
renderIntroVideo =
  HH.div
    [ HP.class_ $ HC.ClassName "deck-dialog" ]
    [ HH.div
        [ HCSS.style do
             CSS.paddingLeft CSS.nil
             CSS.paddingRight CSS.nil
        ]
        [ HH.h4
            [ HCSS.style do
                CSS.paddingLeft $ CSS.rem 1.0
                CSS.paddingRight $ CSS.rem 1.0
            ]
            [ HH.text "Welcome to SlamData!" ]
        , HH.video
            [ HP.autoplay true ]
            [ HH.source
                [ HP.type_ (MediaType "video/mp4")
                , HP.src "video/getting-started.mp4"
                ]
            ]
        , RenderDialog.modalFooter
            [ HH.button
                [ HP.type_ HP.ButtonButton
                , HE.onClick $ HE.input_ DismissIntroVideo
                , HP.classes [ HH.ClassName "btn", HH.ClassName "btn-primary" ]
                , HCSS.style $ CSS.marginRight $ CSS.rem 1.0
                ]
                [ HH.text "Skip video" ]
            ]
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    w ← H.lift Wiring.expose
    whenM
      (not <$> dismissedIntroVideoBefore)
      (H.modify $ State._presentIntroVideo .~ true)
    H.subscribe $ busEventSource (flip HandleError ES.Listening) w.bus.globalError
    H.subscribe $ busEventSource (flip HandleSignInMessage ES.Listening) w.auth.signIn
    H.subscribe $ busEventSource (flip HandleLicenseProblem ES.Listening) w.bus.licenseProblems
    daysRemaining ← map _.daysRemaining <$> liftQuasar QA.licenseInfo
    case daysRemaining of
      Right i | i <= 30 && i < 0 → void $ H.liftAff do
        trigger ← AVar.makeVar
        Bus.write (daysRemainingNotification trigger i) w.bus.notify
        Aff.forkAff $ AVar.takeVar trigger *> (H.liftEff $ Browser.newTab "https://slamdata.com/contact-us/")
      _ →
        pure unit
    pure next
  Transition page next → do
    H.modify
      $ (State._isMount .~ page.isMount)
      ∘ (State._salt .~ page.salt)
      ∘ (State._sort .~ page.sort)
      ∘ (State._path .~ page.path)
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Reset
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValue $ fromMaybe "" page.query
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetValid true
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetPath page.path
    resort
    pure next

  PreventDefault e q → do
    H.liftEff $ DEE.preventDefault e
    eval q
  Resort next → do
    st ← H.get
    searchValue ← H.query' CS.cpSearch unit (H.request Search.GetValue)
    H.liftEff $ setLocation $ browseURL searchValue (notSort st.sort) st.salt st.path
    pure next
  SetPath path next → do
    H.modify $ State._path .~ path
    pure next
  SetSort sort next → do
    H.modify $ State._sort .~ sort
    resort
    pure next
  SetSalt salt next → do
    H.modify $ State._salt .~ salt
    pure next
  CheckIsMount path next → do
    checkIsMount path
    pure next
  CheckIsUnconfigured next → do
    checkIsUnconfigured
    pure next
  SetVersion version next → do
    H.modify $ State._version .~ Just version
    pure next

  ShowHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ true
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden false
    pure next
  HideHiddenFiles next → do
    H.modify $ State._showHiddenFiles .~ false
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsHidden true
    pure next

  Configure next → do
    path ← H.gets _.path
    configure $ R.Database path
    pure next
  MakeMount next → do
    parent ← H.gets _.path
    showDialog $ Dialog.Mount $ Mount.New { parent }
    pure next
  MakeFolder next → do
    result ← runExceptT do
      path ← lift $ H.gets _.path
      dirName ← ExceptT $ API.getNewName path Config.newFolderName
      let
        dirPath = path </> dir dirName
        dirRes = R.Directory dirPath
        dirItem = PhantomItem dirRes
        hiddenFile = dirPath </> file (Config.folderMark)
        cleanupItem = void $ H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Filter (_ ≠ dirItem)
      _ ← H.lift $ H.query' CS.cpListing unit $ H.action $ Listing.Add dirItem
      finally cleanupItem $ ExceptT $ API.save hiddenFile jsonEmptyObject
      pure dirRes
    case result of
      Left err → case GE.fromQError err of
        Left msg →
          showDialog $ Dialog.Error
            $ "You can only create files or folders in data sources."
            ⊕ "Please mount a data source, and then create your file or location inside the mounted data source."
        Right ge →
          GE.raiseGlobalError ge
      Right dirRes →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item dirRes
    pure next
  MakeWorkspace next → do
    state ← H.get
    isMounted >>= if _
       then
         createWorkspace state.path \mkUrl →
           H.liftEff $ setLocation $ mkUrl New
       else
         showDialog
           $ Dialog.Error
           $ "There was a problem creating the workspace: Path "
           ⊕ printPath state.path
           ⊕ " is not inside a mount."
    pure next
  UploadFile el next → do
    mbInput ← H.liftEff $ D.querySelector "input" el
    for_ mbInput \input →
      void $ H.liftEff $ Be.raiseEvent "click" input
    pure next
  FileListChanged el next → do
    fileArr ← map Cf.fileListToArray $ (H.liftAff $ Cf.files el)
    H.liftEff $ clearValue el
    -- TODO: notification? this shouldn't be a runtime exception anyway!
    -- let err ∷ Slam Unit
    --     err = throwError $ error "empty filelist"
    -- in H.liftAff err
    for_ (Array.head fileArr) uploadFileSelected
    pure next
  Download next → do
    path ← H.gets _.path
    download $ R.Directory path
    pure next

  DismissSignInSubmenu next → do
    dismissSignInSubmenu
    pure next
  DismissMountHint next → do
    dismissMountHint
    pure next
  DismissIntroVideo next → do
    dismissIntroVideo
    pure next

  HandleError ge next → do
    showDialog $ Dialog.Error $ GE.print ge
    pure next
  HandleListing (Listing.ItemMessage m) next → do
    handleItemMessage m
    pure next
  HandleListing (Listing.Added items) next
    | Array.length items < 2 → do
        resort
        pure next
    | otherwise → do
        path ← H.gets _.path
        presentMountHint items path
        resort
        pure next
  HandleDialog DialogMessage.Dismiss next →
    pure next
  HandleDialog (DialogMessage.MountSave originalMount) next → do
    mbMbMount ←
      H.query' CS.cpDialog unit $ H.request Dialog.SaveMount
    for_ (join mbMbMount) \newPath → do
      hideDialog
      path ← H.gets _.path
      case originalMount of
        -- Refresh if mount is current directory
        -- path </> dir "" is equal to path
        Nothing | R.Database path ≡ newPath || (R.Database $ path </> dir "") ≡ newPath →
          H.liftEff Browser.reload
        -- Add new item to list
        Nothing →
          void $ H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item (R.Mount newPath)
        -- Rename current mount at path
        Just oldPath@(R.Database p) | path ≡ p && oldPath /= newPath → do
          handleItemMessage (Item.Open $ R.Mount newPath)
          void $ API.delete (R.Mount oldPath)
        -- Rename mount in listing
        Just oldPath | oldPath /= newPath → do
          _ ← H.query' CS.cpListing unit $ H.action $ Listing.Remove $ Item (R.Mount oldPath)
          _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ Item (R.Mount newPath)
          void $ API.delete (R.Mount oldPath)
        Just oldPath → do
          pure unit
    resort
    checkIsMount =<< H.gets _.path
    checkIsUnconfigured
    pure next
  HandleDialog DialogMessage.MountDelete next → do
    mount ← R.Mount ∘ R.Database <$> H.gets _.path
    remove mount
    H.liftEff Browser.reload
    pure next
  HandleNotifications NC.ExpandGlobalMenu next → do
    gripperState ← queryHeaderGripper $ H.request Gripper.GetState
    when (gripperState ≠ Just Gripper.Opened) do
      _ ← queryHeaderGripper $ H.action $ Gripper.StartDragging 0.0
      _ ← queryHeaderGripper $ H.action Gripper.StopDragging
      pure unit
    pure next
  HandleNotifications (NC.Fulfill trigger) next → do
    H.liftAff $ AVar.putVar trigger unit
    pure next
  HandleSearch m next → do
    salt ← H.liftEff newSalt
    st ← H.get
    value ← case m of
      Search.Cleared →
        pure Nothing
      Search.Submit → do
        H.query' CS.cpSearch unit $ H.request Search.GetValue
    H.liftEff $ setLocation $ browseURL value st.sort salt st.path
    pure next
  HandleLicenseProblem problem next → do
    _ ← H.query' CS.cpDialog unit $ H.action $ Dialog.Show $ Dialog.LicenseProblem problem
    pure next
  SetLoading bool next → do
    _ ← H.query' CS.cpSearch unit $ H.action $ Search.SetLoading bool
    pure next
  SetIsSearching bool next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.SetIsSearching bool
    pure next
  AddListings items next → do
    _ ← H.query' CS.cpListing unit $ H.action $ Listing.Adds items
    pure next
  ShowError message next → do
    _ ← H.query' CS.cpDialog unit $ H.action $ Dialog.Show $ Dialog.Error message
    pure next
  HandleSignInMessage message next → do
    when (message ≡ GlobalMenu.SignInSuccess) (H.liftEff Browser.reload)
    pure next

handleItemMessage ∷ Item.Message → DSL Unit
handleItemMessage = case _ of
  Item.Selected →
    pure unit
  Item.Edit res → do
    loc ← H.liftEff locationString
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load Editable)
  Item.Open res → do
    { sort, salt, path } ← H.get
    loc ← H.liftEff locationString
    for_ (preview R._filePath res) \fp →
      createWorkspace path \mkUrl →
        H.liftEff $ setLocation $ mkUrl $ Exploring fp
    for_ (preview R._dirPath res) \dp →
      H.liftEff $ setLocation $ browseURL Nothing sort salt dp
    for_ (preview R._Workspace res) \wp →
      H.liftEff $ setLocation $ append (loc ⊕ "/") $ mkWorkspaceURL wp (Load ReadOnly)
  Item.Configure (R.Mount mount) → do
    configure mount
  Item.Configure _ →
    pure unit
  Item.Move res → do
    showDialog $ Dialog.Rename res
    flip getDirectories rootDir \x →
      void $ H.query' CS.cpDialog unit $ H.action $ Dialog.AddDirsToRename x
  Item.Remove res →
    remove res
  Item.Share res → do
    path ← H.gets _.path
    loc ← map (_ ⊕ "/") $ H.liftEff locationString
    for_ (preview R._filePath res) \fp → do
      createWorkspace path \mkUrl →
        showDialog $ Dialog.Share $ append loc $ mkUrl $ Exploring fp
    for_ (preview R._Workspace res) \wp → do
      showDialog (Dialog.Share $ append loc $ mkWorkspaceURL wp (Load ReadOnly))
  Item.Download res →
    download res

checkIsMount ∷ DirPath → DSL Unit
checkIsMount path = do
  isMount ← isRight <$> API.mountInfo (Left path)
  H.modify $ State._isMount .~ isMount

isMounted ∷ DSL Boolean
isMounted = do
  path ← H.gets _.path
  tailRecM go path
  where
  go ∷ DirPath → DSL (Step DirPath Boolean)
  go path = do
    isMount ← isRight <$> API.mountInfo (Left path)
    pure
      $ if isMount
          then Done true
          else maybe (Done false) Loop (parentDir path)

checkIsUnconfigured ∷ DSL Unit
checkIsUnconfigured = do
  isMount ← isRight <$> API.mountInfo (Left rootDir)
  isEmpty ← either (const false) Array.null <$> API.children rootDir
  H.modify $ State._isUnconfigured .~ (not isMount ∧ isEmpty)

remove ∷ Resource → DSL Unit
remove res = do
  -- Replace actual item with phantom
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Add $ PhantomItem res
  -- Save order of items during deletion (or phantom will be on top of list)
  resort
  -- Try to delete
  mbTrashFolder ← H.lift $ API.delete res
  -- Remove phantom resource after we have response from server
  _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter $ not ∘ eq res ∘ itemResource
  case mbTrashFolder of
    Left err → do
      -- Error occured: put item back and show dialog
      void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)
      case GE.fromQError err of
        Left m →
          showDialog $ Dialog.Error m
        Right ge →
          GE.raiseGlobalError ge
    Right mbRes →
      -- Item has been deleted: probably add trash folder
      for_ mbRes \res' →
        void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res')

  listing ← fromMaybe [] <$> (H.query' CS.cpListing unit $ H.request Listing.Get)
  path ← H.gets _.path
  presentMountHint listing path

  resort
  checkIsMount path
  checkIsUnconfigured

dismissMountHint ∷ DSL Unit
dismissMountHint = do
  LS.persist LSK.dismissedMountHintKey true
  H.modify $ State._presentMountHint .~ false

dismissIntroVideo ∷ DSL Unit
dismissIntroVideo = do
  LS.persist LSK.dismissedIntroVideoKey true
  H.modify $ State._presentIntroVideo .~ false

dismissedIntroVideoBefore ∷ DSL Boolean
dismissedIntroVideoBefore =
  either (const false) id <$> LS.retrieve LSK.dismissedIntroVideoKey

uploadFileSelected ∷ Cf.File → DSL Unit
uploadFileSelected f = do
  { path, sort, salt } ← H.get
  name ←
    H.liftEff (Cf.name f)
      <#> RX.replace (unsafePartial fromRight $ RX.regex "/" RXF.global) ":"
      >>= API.getNewName path

  case name of
    Left err → handleError err
    Right name' → do
      reader ← H.liftEff Cf.newReaderEff
      content' ← H.liftAff $ Cf.readAsBinaryString f reader

      let fileName = path </> file name'
          res = R.File fileName
          fileItem = PhantomItem res
          ext = Array.last (S.split (S.Pattern ".") name')
          mime = if ext ≡ Just "csv"
                 then textCSV
                 else if isApplicationJSON content'
                      then applicationJSON
                      else API.ldJSON
      _ ← H.query' CS.cpListing unit $ H.action (Listing.Add fileItem)
      f' ← API.makeFile fileName (CustomData mime content')
      _ ← H.query' CS.cpListing unit $ H.action $ Listing.Filter (not ∘ eq res ∘ itemResource)
      case f' of
        Left err → handleError err
        Right _ →
          void $ H.query' CS.cpListing unit $ H.action $ Listing.Add (Item res)

  where
  isApplicationJSON ∷ String → Boolean
  isApplicationJSON content'
    -- Parse if content is small enough
    | S.length content' < 1048576 = isRight $ jsonParser content'
    -- Or check if its first/last characters are [/]
    | otherwise =
        let trimmed = S.trim content'
        in (startsWithEndsWith "[" "]" trimmed) || (startsWithEndsWith "{" "}" trimmed)

  startsWithEndsWith startsWith endsWith s =
    F.all isJust [S.stripPrefix (S.Pattern startsWith) s, S.stripSuffix (S.Pattern endsWith) s]

  handleError err =
    case GE.fromQError err of
      Left msg → showDialog $ Dialog.Error msg
      Right ge → GE.raiseGlobalError ge

presentMountHint ∷ ∀ a. Array a → DirPath → DSL Unit
presentMountHint xs path = do
  isSearching ←
    map (fromMaybe false) $ H.query' CS.cpSearch unit (H.request Search.IsSearching)
  isLoading ←
    map (fromMaybe true)  $ H.query' CS.cpSearch unit (H.request Search.IsLoading)

  H.modify
    ∘ (State._presentMountHint .~ _)
    ∘ ((Array.null xs ∧ path ≡ rootDir ∧ not (isSearching ∧ isLoading)) ∧ _)
    ∘ not
    ∘ either (const false) id
    =<< dismissedBefore
  where
  dismissedBefore ∷ DSL (Either String Boolean)
  dismissedBefore =
    LS.retrieve LSK.dismissedMountHintKey

dismissSignInSubmenu ∷ DSL Unit
dismissSignInSubmenu =
  void $ queryGlobalMenu (H.action GlobalMenu.DismissSubmenu)

resort ∷ DSL Unit
resort = do
  sort ← H.gets _.sort
  H.query' CS.cpSearch unit (H.request Search.IsSearching)
    >>= traverse_ \isSearching →
      void $ H.query' CS.cpListing unit $ H.action $ Listing.SortBy (sortItem isSearching sort)

configure ∷ R.Mount → DSL Unit
configure m =
  API.mountInfo anyPath >>= case m, _ of
    R.View path, Left err → raiseError err
    R.Database path, Left err
      | path /= rootDir → raiseError err
      | otherwise →
          showDialog $ Dialog.Mount Mount.Root
    R.View path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: either parentDir parentDir anyPath
          , name: Just $ getNameStr anyPath
          , settings: fromConfig config
          }
    R.Database path, Right config →
      showDialog $ Dialog.Mount
        $ Mount.Edit
          { parent: if path ≡ rootDir then Nothing else either parentDir parentDir anyPath
          , name: if path ≡ rootDir then Nothing else Just $ getNameStr anyPath
          , settings: fromConfig config
          }
  where
    anyPath =
      R.mountPath m

    fromConfig = case _ of
      QM.ViewConfig config → Mount.SQL2 (SQL2.stateFromViewInfo config)
      QM.ModuleConfig config → Mount.SQL2 SQL2.initialState
      QM.MongoDBConfig config → Mount.MongoDB (MongoDB.fromConfig config)
      QM.CouchbaseConfig config → Mount.Couchbase (Couchbase.fromConfig config)
      QM.MarkLogicConfig config → Mount.MarkLogic (MarkLogic.fromConfig config)
      QM.SparkHDFSConfig config → Mount.SparkHDFS (Spark.fromConfig config)
      QM.SparkLocalConfig config → Mount.SparkLocal (SparkLocal.fromConfig config)

    raiseError err = case GE.fromQError err of
      Left msg →
        showDialog $ Dialog.Error
          $ "There was a problem reading the mount settings: "
          ⊕ msg
      Right ge →
        GE.raiseGlobalError ge

download ∷ R.Resource → DSL Unit
download res = do
  hs ← H.lift API.authHeaders
  showDialog $ Dialog.Download res hs
  pure unit

getChildren
  ∷ (R.Resource → Boolean)
  → (Array R.Resource → DSL Unit)
  → DirPath
  → DSL Unit
getChildren pred cont start = do
  ei ← API.children start
  case ei of
    Right items → do
      let items' = Array.filter pred items
          parents = Array.mapMaybe (either Just (const Nothing) ∘ R.getPath) items
      cont items'
      traverse_ (getChildren pred cont) parents
    _ → pure unit

getDirectories ∷ (Array R.Resource → DSL Unit) → DirPath → DSL Unit
getDirectories = getChildren $ R.isDirectory ∨ R.isDatabaseMount

showDialog ∷ Dialog.Dialog → DSL Unit
showDialog = void ∘ H.query' CS.cpDialog unit ∘ H.action ∘ Dialog.Show

hideDialog ∷ DSL Unit
hideDialog =
  void $ H.query' CS.cpDialog unit $ H.action Dialog.RaiseDismiss

queryHeaderGripper ∷ ∀ a. Gripper.Query a → DSL (Maybe a)
queryHeaderGripper =
   H.query' CS.cpHeader unit ∘ Header.QueryGripper ∘ liftCoyoneda

queryGlobalMenu ∷ ∀ a. GlobalMenu.Query a → DSL (Maybe a)
queryGlobalMenu =
   H.query' CS.cpHeader unit ∘ Header.QueryGlobalMenu ∘ liftCoyoneda

createWorkspace ∷ ∀ a. DirPath → ((Action → String) → DSL a) → DSL Unit
createWorkspace path action = do
  let newWorkspaceName = Config.newWorkspaceName ⊕ "." ⊕ Config.workspaceExtension
  name ← API.getNewName path newWorkspaceName
  case name of
    Left err →
      case GE.fromQError err of
        Left msg →
          -- This error isn't strictly true as we're not actually creating the
          -- workspace here, but saying there was a problem "creating a name for the
          -- workspace" would be a little strange
          showDialog $ Dialog.Error
            $ "There was a problem creating the workspace: " ⊕ msg
        Right ge →
          GE.raiseGlobalError ge
    Right name' →
      void $ action (mkWorkspaceURL (path </> dir name'))

daysRemainingNotification ∷ AVar.AVar Unit → Int → Notification.NotificationOptions
daysRemainingNotification avar i =
  { notification: Notification.Info $ show i <> " Licensed days remaining."
  , detail: Nothing
  , actionOptions:
      Just $ Notification.ActionOptions
        { message: "Please get in touch renew your License."
        , actionMessage: "Contact SlamData"
        , action: Notification.Fulfill avar
        }
  , timeout: Nothing
  }