Fix one-card component init with `key` & structure fix

{-
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.Notebook.Deck.Component
  ( comp
  , initialState
  , module SlamData.Notebook.Deck.Component.Query
  , module DCS
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Console (log)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.UI.Browser (newTab, locationObject)
import Control.Monad.Aff.Free (fromEff)

import CSS.Geometry (width)
import CSS.Size (pct, Size(..), Rel, nil)
import CSS.String (fromString)
import CSS.Transform (transform, translate)

import Data.Argonaut (Json)
import Data.Array (catMaybes, nub)
import Data.BrowserFeatures (BrowserFeatures)
import Data.Int (toNumber)
import Data.Lens as Lens
import Data.Lens (LensP(), view, (.~), (%~), (?~), (^?))
import Data.Lens.Prism.Coproduct (_Right)
import Data.List as List
import Data.Map as Map
import Data.Ord (max)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as S
import Data.String as Str
import Data.Time (Milliseconds(..))

import Ace.Halogen.Component as Ace

import DOM.HTML.Location as Location

import Halogen as H
import Halogen.Component.ChildPath (ChildPath, injSlot, injState)
import Halogen.Component.Utils (forceRerender')
import Halogen.Component.Utils.Debounced (fireDebouncedQuery')
import Halogen.HTML.CSS.Indexed (style)
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Indexed as HH
import Halogen.Component.ChildPath (injSlot, injState)
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Quasar.Aff as Quasar
import Quasar.Auth as Auth

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.FileSystem.Resource as R
import SlamData.Notebook.AccessType (AccessType(..), isEditable)
import SlamData.Notebook.Action as NA
import SlamData.Notebook.Card.CardId (CardId(), runCardId, cardIdToString)
import SlamData.Notebook.Card.CardType
  (CardType(..), AceMode(..), cardName, cardGlyph, autorun, nextCardTypes)
import SlamData.Notebook.Card.Common.EvalQuery (CardEvalQuery(..))
import SlamData.Notebook.Card.Component (CardQueryP, CardQuery(..), InnerCardQuery, AnyCardQuery(..), _NextQuery, initialCardState)
import SlamData.Notebook.Card.Next.Component as Next
import SlamData.Notebook.Card.OpenResource.Component as Open
import SlamData.Notebook.Card.Port (Port(..))
import SlamData.Notebook.Deck.BackSide.Component as Back
import SlamData.Notebook.Deck.Component.ChildSlot (cpBackSide, cpCard, ChildQuery, ChildState, ChildSlot, CardSlot(..))
import SlamData.Notebook.Deck.Component.Query (QueryP, Query(..))

import SlamData.Notebook.Deck.Component.State as DCS
import SlamData.Notebook.Deck.DeckId (DeckId(..), deckIdToString)
import SlamData.Notebook.Deck.Model as Model
import SlamData.Notebook.Model as NB
import SlamData.Notebook.Routing (mkNotebookHash, mkNotebookCardHash, mkNotebookURL)
import SlamData.Quasar.Data (save, load) as Quasar
import SlamData.Quasar.FS (move, getNewName) as Quasar
import SlamData.Render.CSS as CSS
import Utils.Debounced (debouncedEventSource)
import Utils.Path (DirPath, FilePath)
import Utils.DOM (getBoundingClientRect, offsetLeft)
import Utils.CSS (transition)

type NotebookHTML = H.ParentHTML ChildState Query ChildQuery Slam ChildSlot
type NotebookDSL = H.ParentDSL DCS.State ChildState Query ChildQuery Slam ChildSlot

initialState ∷ BrowserFeatures → DCS.StateP
initialState fs = H.parentState $ DCS.initialDeck fs

comp ∷ H.Component DCS.StateP QueryP Slam
comp =
  H.parentComponent
    { render: render ∘ DCS.virtualState
    , eval
    , peek: Just peek
    }

render ∷ DCS.State → NotebookHTML
render state =
  case state.stateMode of
    DCS.Loading →
      HH.div
        [ HP.classes [ B.alert, B.alertInfo ] ]
        [ HH.h1
          [ HP.class_ B.textCenter ]
          [ HH.text "Loading..." ]
          -- We need to render the cards but have them invisible during loading
          -- otherwise the various nested components won't initialise correctly.
          -- This div is required, along with the key, so that structurally it
          -- is in the same place in both `Loading` and `Ready` states.
        , HH.div
            [ HP.key "deck-container" ]
            [ renderCards false ]
        ]
    DCS.Ready →
      -- WARNING: Very strange things happen when this is not in a div; see SD-1326.
      HH.div
        ([ HP.class_ CSS.board ]
           ⊕ (guard (isJust state.initialSliderX)
                $> (HE.onMouseUp \e -> HEH.preventDefault $> H.action (StopSlidingAndSnap e)))
           ⊕ (guard (isJust state.initialSliderX)
                $> (HE.onMouseLeave \e -> HEH.stopPropagation $> HEH.preventDefault $> H.action (StopSlidingAndSnap e)))
           ⊕ (guard (isJust state.initialSliderX)
                $> (HE.onMouseMove $ HE.input UpdateSliderPosition)))
        [ HH.div
            [ HP.class_ CSS.deck
            , HP.key "deck-container"
            ]
            [ renderCards $ not state.backsided
            , renderBackside state.backsided
              -- Commented until one card representation
--            , HH.button [ HP.classes [ B.btn, B.btnPrimary ]
--                        , HE.onClick (HE.input_ FlipDeck)
--                        , ARIA.label "Flip deck"
--                        ]
--              [ HH.text "Flip" ]
            ]
        ]

    DCS.Error err →
      HH.div
        [ HP.classes [ B.alert, B.alertDanger ] ]
        [ HH.h1
            [ HP.class_ B.textCenter ]
            [ HH.text err ]
        ]

  where
  renderBackside visible =
    HH.div
      ( [ ARIA.hidden $ show $ not visible ]
        ⊕ ((guard $ not visible) $> (HP.class_ CSS.invisible)))

      [ HH.slot' cpBackSide unit \_ →
         { component: Back.comp
         , initialState: Back.initialState
         }
      ]

  renderCards visible =
    -- The key here helps out virtual-dom: the entire subtree will be moved
    -- when the loading message disappears, rather than being reconstructed in
    -- the parent element
    HH.div
      ([ HP.key "notebook-cards"
       , HP.classes [ CSS.cardSlider ]
       , HE.onTransitionEnd $ HE.input_ StopSliderTransition
       , style
           $ (cardSliderWidth $ List.length state.cards + 1)
           *> (cardSliderTransform (List.length state.cards + 1) (activeCardIndex state) state.sliderTranslateX)
           *> (cardSliderTransition state.sliderTransition)
       ]
       ⊕ (guard (not visible) $> (HP.class_ CSS.invisible)))
      ( List.fromList (map (renderCard $ List.length state.cards + 1) state.cards)
        ⊕ (pure $ newCardMenu (List.length state.cards + 1) state))

  renderCard cardsCount cardDef =
    HH.div
    ([ HP.key ("card" ⊕ cardIdToString cardDef.id)
     , HP.classes [ CSS.card ]
     , style $ cardWidth cardsCount
    ]
     ⊕ foldMap (viewingStyle cardDef) state.viewingCard)
    [ cardGripper
    , HH.Slot $ transformCardConstructor cardDef.ctor
    ]

  cardGripper =
    HH.div
      [ HP.classes [ CSS.cardGripper ]
      , HE.onMouseDown \e -> HEH.preventDefault $> H.action (StartSliding e)
      ]
      []

  transformCardConstructor (H.SlotConstructor p l) =
    H.SlotConstructor
      (injSlot cpCard p)
      (l <#> \def →
        { component: H.transformChild cpCard def.component
        , initialState: injState cpCard def.initialState
        }
      )

  viewingStyle cardDef cid =
    guard (not (cardDef.id ≡ cid))
    $> (HP.class_ CSS.invisible)

  shouldHideNextAction =
    isJust state.viewingCard ∨ state.accessType ≡ ReadOnly

  newCardMenu cardsCount state =
    HH.div
      ([ HP.key ("next-action-card")
       , HP.classes [ CSS.card ]
       , HP.ref (H.action <<< SetNextActionCardElement)
       , style $ cardWidth cardsCount
       ]
       ⊕ (guard shouldHideNextAction $> (HP.class_ CSS.invisible)))

    [ cardGripper
    , HH.slot' cpCard (CardSlot top) \_ →
       { component: Next.nextCardComponent
       , initialState: H.parentState initialCardState
       }
    ]

  cardWidthPct cardsCount =
    100.0 / toNumber cardsCount

  cardWidth cardsCount =
    width $ calc $ (show $ cardWidthPct cardsCount) ++ "% - 1.5rem"

  cardSliderWidth cardsCount =
    width $ pct $ 100.0 * toNumber cardsCount

  cardSliderTransform cardCount activeCardIndex translateX =
    transform $ translate (cardSliderTranslateX cardCount activeCardIndex translateX) nil

  cardSliderTransition false = transition "0"
  cardSliderTransition true = transition "all 0.33s"

  cardSliderTranslateX cardCount activeCardIndex translateX =
    calc
      $ "(((-100% / " ++ show cardCount ++ ") + 1.5rem)"
      ++ " * " ++ show activeCardIndex ++ ")"
      ++ " + (" ++ show translateX ++ "px)"

  calc s = Size $ fromString $ "calc(" ++ s ++ ")"

eval ∷ Natural Query NotebookDSL
eval (AddCard cardType next) = createCard cardType $> next
eval (RunActiveCard next) = do
  (maybe (pure unit) runCard =<< H.gets (_.activeCardId)) $> next
eval (LoadNotebook fs dir deckId next) = do
  state ← H.get
  H.modify (DCS._stateMode .~ DCS.Loading)
  json ← Quasar.load $ deckIndex dir deckId
  case Model.decode =<< json of
    Left err → do
      H.fromAff $ log err
      H.modify $ DCS._stateMode .~ DCS.Error "There was a problem decoding the saved notebook"
    Right model →
      case DCS.fromModel fs (Just dir) (Just deckId) model of
        Tuple cards st → do
          H.set st
          forceRerender'
          ranCards ← catMaybes <$> for cards \card → do
            H.query' cpCard  (CardSlot card.cardId)
              $ left
              $ H.action
              $ LoadCard card
            pure if card.hasRun then Just card.cardId else Nothing
          -- We only need to run the root node in each subgraph, as doing so
          -- will result in all child nodes being run also as the outputs
          -- propagate down each subgraph.
          traverse_ runCard $ nub $ flip DCS.findRoot st <$> ranCards
          H.modify $ DCS._stateMode .~ DCS.Ready
  updateNextActionCard
  forceRerender'
  pure next

eval (ExploreFile fs res next) = do
  H.set $ DCS.initialDeck fs
  H.modify
    $ (DCS._path .~ Pathy.parentDir res)
    ∘ (DCS.addCard OpenResource Nothing)
  forceRerender'
  H.query' cpCard (CardSlot zero)
    $ right
    $ H.ChildF unit
    $ right
    $ OpenResourceQuery
    $ right
    $ H.action
    $ Open.ResourceSelected
    $ R.File res
  forceRerender'
  runCard zero
  -- Flush the eval queue
  saveNotebook
  updateNextActionCard
  pure next
eval (Publish next) = do
  H.gets DCS.deckPath >>= \mpath →
    for_ mpath $ H.fromEff ∘ newTab ∘ flip mkNotebookURL (NA.Load ReadOnly)
  pure next
eval (Reset fs dir deckId next) = do
  let nb = DCS.initialDeck fs
  H.set $ nb { id = deckId, path = Just dir }
  pure next
eval (SetName name next) =
  H.modify (DCS._name .~ Just name) $> next
eval (SetAccessType aType next) = do
  cids ← map Map.keys $ H.gets _.cardTypes
  for_ cids \cardId →
    void
      $ H.query' cpCard (CardSlot cardId)
      $ left
      $ H.action
      $ SetCardAccessType aType
  H.modify $ DCS._accessType .~ aType
  unless (isEditable aType)
    $ H.modify (DCS._backsided .~ false)
  pure next
eval (GetNotebookPath k) = k <$> H.gets DCS.deckPath
eval (SetViewingCard mbcid next) = H.modify (DCS._viewingCard .~ mbcid) $> next
eval (SaveNotebook next) = saveNotebook $> next
eval (RunPendingCards next) = do
  -- Only run pending cards if we have a deckPath. Some cards run with the
  -- assumption that the deck is saved to disk.
  H.gets DCS.deckPath >>= traverse_ \_ → runPendingCards
  pure next
eval (GetGlobalVarMap k) = k <$> H.gets _.globalVarMap
eval (SetGlobalVarMap m next) = do
  st ← H.get
  when (m ≠ st.globalVarMap) do
    H.modify $ DCS._globalVarMap .~ m
    traverse_ runCard $ DCS.cardsOfType API st
  pure next
eval (FindCardParent cid k) = k <$> H.gets (DCS.findParent cid)
eval (GetCardType cid k) = k <$> H.gets (DCS.getCardType cid)
eval (FlipDeck next) = H.modify (DCS._backsided %~ not) $> next
eval (GetActiveCardId k) = map k $ H.gets DCS.findLast
eval (StartSliding mouseEvent next) =
  setInitialSliderX (Just mouseEvent.screenX) $> next
  where
  setInitialSliderX =
    H.modify <<< (DCS._initialSliderX .~)
eval (StopSlidingAndSnap mouseEvent next) =
  snap *> stopSliding *> startTransition $> next
  where
  stopSliding =
    setInitialX Nothing *> setTranslateX 0.0
  setInitialX =
    H.modify <<< (DCS._initialSliderX .~)
  getBoundingClientWidth =
    fromEff <<< map _.width <<< getBoundingClientRect
  getNextActionCardElement =
    H.gets _.nextActionCardElement
  getCardWidth =
    traverse getBoundingClientWidth =<< getNextActionCardElement
  setActiveCardId =
    H.modify <<< (DCS._activeCardId .~)
  setTranslateX =
    H.modify <<< (DCS._sliderTranslateX .~)
  snapActiveCardIndex translateX (Just cardWidth) | translateX < (-(cardWidth / 2.0)) =
    add 1
  snapActiveCardIndex translateX (Just cardWidth) | translateX > (cardWidth / 2.0) =
    max 0 <<< flip sub 1
  snapActiveCardIndex translateX _ =
    id
  getCardIdByIndex cards =
    map _.id <<< List.index cards
  snapActiveCardId st cardWidth =
    getCardIdByIndex st.cards
      $ snapActiveCardIndex st.sliderTranslateX cardWidth
      $ activeCardIndex st
  snap =
    setActiveCardId =<< (snapActiveCardId <$> H.get <*> getCardWidth)
  setSliderTransition =
    H.modify <<< (DCS._sliderTransition .~)
  startTransition =
    setSliderTransition true
eval (UpdateSliderPosition mouseEvent next) =
  (maybe (pure unit) (setTranslateX <<< translateXCalc) =<< getInitialX) $> next
  where
  getInitialX =
    H.gets _.initialSliderX
  translateXCalc initialX =
    mouseEvent.screenX - initialX
  setTranslateX =
    H.modify <<< (DCS._sliderTranslateX .~)
eval (SetNextActionCardElement element next) =
  setNextActionCardElement element $> next
  where
  setNextActionCardElement =
    H.modify <<< (DCS._nextActionCardElement .~)
eval (StopSliderTransition next) =
  setSliderTransition false $> next
  where
  setSliderTransition =
    H.modify <<< (DCS._sliderTransition .~)

peek ∷ ∀ a. H.ChildF ChildSlot ChildQuery a → NotebookDSL Unit
peek (H.ChildF s q) =
  coproduct
    (either peekCards (\_ _ → pure unit) s)
    peekBackSide
    q

peekBackSide ∷ ∀ a. Back.Query a → NotebookDSL Unit
peekBackSide (Back.UpdateFilter _ _) = pure unit
peekBackSide (Back.DoAction action _) = case action of
  Back.Trash → do
    activeId ← H.gets _.activeCardId
    lastId ← H.gets DCS.findLast
    for_ (activeId <|> lastId) \trashId → do
      descendants ← H.gets $ DCS.findDescendants trashId
      H.modify ∘ DCS.removeCards $ S.insert trashId descendants
      triggerSave
      updateNextActionCard
      H.modify $ DCS._backsided .~ false
  Back.Share → pure unit
  Back.Embed → pure unit
  Back.Publish →
    H.gets DCS.deckPath >>= \mpath →
      for_ mpath $ H.fromEff ∘ newTab ∘ flip mkNotebookURL (NA.Load ReadOnly)
  Back.Mirror → pure unit
  Back.Wrap → pure unit

peekCards ∷ ∀ a. CardSlot → CardQueryP a → NotebookDSL Unit
peekCards (CardSlot cardId) q =
  coproduct (peekCard cardId) (peekCardInner cardId) q

-- | Peek on the card component to observe actions from the card control
-- | buttons.
peekCard ∷ ∀ a. CardId → CardQuery a → NotebookDSL Unit
peekCard cardId q = case q of
  RunCard _ → runCard cardId
  RefreshCard _ → runCard ∘ DCS.findRoot cardId =<< H.get
  TrashCard _ → do
    descendants ← H.gets $ DCS.findDescendants cardId
    H.modify ∘ DCS.removeCards $ S.insert cardId descendants
    triggerSave
    updateNextActionCard
  ToggleCaching _ →
    triggerSave
  ShareCard _ → pure unit
  StopCard _ → do
    H.modify $ DCS._runTrigger .~ Nothing
    H.modify $ DCS._pendingCards %~ S.delete cardId
    runPendingCards
  _ → pure unit

updateNextActionCard ∷ NotebookDSL Unit
updateNextActionCard = do
  cid ← H.gets DCS.findLast
  mbMessage ← case cid of
    Just cardId → do
      out ←
        map join
          $ H.query' cpCard (CardSlot cardId)
          $ left (H.request GetOutput)
      pure $ case out of
        Nothing →
          Just "Next actions will be made available once the last card has been run"
        Just Blocked →
          Just "There are no available next actions"
        Just (CardError _) →
          Just "There are no available next actions (parent cards have errors)"
        _ → Nothing
    Nothing → pure Nothing
  queryNextActionCard
    $ H.action
    $ Next.SetMessage mbMessage

  lastCardType ← H.gets DCS.findLastCardType
  queryNextActionCard
    $ H.action
    $ Next.SetAvailableTypes
    $ nextCardTypes lastCardType
  pure unit
  where
  queryNextActionCard q =
    H.query' cpCard (CardSlot top)
      $ right
      $ H.ChildF unit
      $ right
      $ NextQuery
      $ right q

createCard ∷ CardType → NotebookDSL Unit
createCard cardType = do
  cid ← H.gets DCS.findLast
  s ← H.get
  case cid of
    Nothing →
      H.modify $ DCS.addCard cardType Nothing
    Just cardId → do
      Tuple st newCardId ← H.gets $ DCS.addCard' cardType (Just cardId)
      H.set st
      forceRerender'
      input ←
        map join $ H.query' cpCard (CardSlot cardId) $ left (H.request GetOutput)

      for_ input \input' → do
        path ← H.gets DCS.deckPath
        let setupInfo = { notebookPath: path, inputPort: input', cardId: newCardId }
        void
          $ H.query' cpCard  (CardSlot newCardId)
          $ right
          $ H.ChildF unit
          $ left
          $ H.action (SetupCard setupInfo)
      runCard newCardId
  updateNextActionCard
  triggerSave

-- | Peek on the inner card components to observe `NotifyRunCard`, which is
-- | raised by actions within a card that should cause the card to run.
peekCardInner
  ∷ ∀ a. CardId → H.ChildF Unit InnerCardQuery a → NotebookDSL Unit
peekCardInner cardId (H.ChildF _ q) =
  coproduct (peekEvalCard cardId) (peekAnyCard cardId) q

peekEvalCard ∷ ∀ a. CardId → CardEvalQuery a → NotebookDSL Unit
peekEvalCard cardId (NotifyRunCard _) = runCard cardId
peekEvalCard _ _ = pure unit

peekAnyCard ∷ ∀ a. CardId → AnyCardQuery a → NotebookDSL Unit
peekAnyCard cardId q = do
  for_ (q ^? _NextQuery ∘ _Right ∘ Next._AddCardType) createCard
  when (queryShouldRun q) $ runCard cardId
  when (queryShouldSave q) triggerSave
  pure unit

queryShouldRun ∷ ∀ a. AnyCardQuery a → Boolean
queryShouldRun (SaveQuery q) = false
queryShouldRun _ = true

queryShouldSave  ∷ ∀ a. AnyCardQuery a → Boolean
queryShouldSave (AceQuery q) =
  coproduct evalQueryShouldSave aceQueryShouldSave q
queryShouldSave _ = true

evalQueryShouldSave ∷ ∀ a. CardEvalQuery a → Boolean
evalQueryShouldSave _ = true

aceQueryShouldSave
  ∷ ∀ p a. H.ChildF p Ace.AceQuery a → Boolean
aceQueryShouldSave (H.ChildF _ q) =
  case q of
    Ace.TextChanged _ → true
    _ → false

-- | Runs all card that are present in the set of pending cards.
runPendingCards ∷ NotebookDSL Unit
runPendingCards = do
  cards ← H.gets _.pendingCards
  traverse_ runCard' cards
  updateNextActionCard
  where
  runCard' ∷ CardId → NotebookDSL Unit
  runCard' cardId = do
    mbParentId ← H.gets $ DCS.findParent cardId
    case mbParentId of
      -- if there's no parent there's no input port value to pass through
      Nothing → updateCard Nothing cardId
      Just parentId → do
        value ←
          map join $ H.query' cpCard (CardSlot parentId) $ left (H.request GetOutput)
        case value of
          -- if there's a parent but no output the parent card hasn't been evaluated
          -- yet, so we can't run this card either
          Nothing → pure unit
          -- if there's a parent and an output, pass it on as this card's input
          Just p → updateCard (Just p) cardId
    H.modify $ DCS._pendingCards %~ S.delete cardId
    triggerSave

-- | Enqueues the card with the specified ID in the set of cards that are
-- | pending to run and enqueues a debounced H.query to trigger the cards to
-- | actually run.
runCard ∷ CardId → NotebookDSL Unit
runCard cardId = do
  H.modify (DCS.addPendingCard cardId)
  fireDebouncedQuery' (Milliseconds 500.0) DCS._runTrigger RunPendingCards

-- | Updates the evaluated value for a card by running it with the specified
-- | input and then runs any cards that depend on the card's output with the
-- | new result.
updateCard ∷ Maybe Port → CardId → NotebookDSL Unit
updateCard inputPort cardId = do
  path ← H.gets DCS.deckPath
  globalVarMap ← H.gets _.globalVarMap
  let input = { notebookPath: path, inputPort, cardId, globalVarMap }
  result ←
    map join
      $ H.query' cpCard (CardSlot cardId)
      $ left
      $ H.request (UpdateCard input)

  H.modify ∘ Lens.over DCS._failingCards $
    case result of
      Just (CardError msg) → S.insert cardId
      _ → S.delete cardId
  forceRerender'

  runCardDescendants cardId (fromMaybe Blocked result)
  where
  runCardDescendants ∷ CardId → Port → NotebookDSL Unit
  runCardDescendants parentId value = do
    -- Crucially, we run the card descendents according to the virtual graph;
    -- this enables the correct behavior of virtual cards, including the Error Card.
    children ← H.gets $ DCS.findChildren parentId ∘ DCS.virtualState
    traverse_ (updateCard (Just value)) children

-- | Triggers the H.query for autosave. This does not immediate perform the save
-- | H.action, but instead enqueues a debounced H.query to trigger the actual save.
triggerSave ∷ NotebookDSL Unit
triggerSave =
  fireDebouncedQuery' (Milliseconds 500.0) DCS._saveTrigger SaveNotebook

-- | Saves the notebook as JSON, using the current values present in the state.
saveNotebook ∷ NotebookDSL Unit
saveNotebook = H.get >>= \st → do
  if isUnsaved st ∧ isNewExploreNotebook st
    -- If its an unsaved Explore notebook, it is safe to go ahead and run it.
    then runPendingCards
    else do
      cards ← catMaybes <$> for (List.fromList st.cards) \card →
        H.query' cpCard (CardSlot card.id)
          $ left
          $ H.request (SaveCard card.id card.ty)

      let json = Model.encode { name: st.name, cards, dependencies: st.dependencies }

      for_ st.path \path → do
        deckId ← runExceptT do
          i ← ExceptT $ genId path st.id
          ExceptT $ save path i json
          pure i

        case deckId of
          Left err → do
            -- TODO: do something to notify the user saving failed
            pure unit
          Right deckId' → do
            H.modify $ DCS._id .~ Just deckId'

            -- runPendingCards would be deffered if there had previously been
            -- no `deckPath`. We need to flush the queue.
            when (isNothing $ DCS.deckPath st) runPendingCards

            -- We need to get the modified version of the notebook state.
            H.gets DCS.deckPath >>= traverse_ \path' →
              let notebookHash =
                    case st.viewingCard of
                      Nothing →
                        mkNotebookHash path' (NA.Load st.accessType) st.globalVarMap
                      Just cid →
                        mkNotebookCardHash path' cid st.accessType st.globalVarMap
              in H.fromEff $ locationObject >>= Location.setHash notebookHash

  where

  isUnsaved ∷ DCS.State → Boolean
  isUnsaved = isNothing ∘ DCS.deckPath

  isNewExploreNotebook ∷ DCS.State → Boolean
  isNewExploreNotebook { cards } =
    let
      cardArrays = List.toUnfoldable (map _.ty cards)
    in
      cardArrays ≡ [ OpenResource ] ∨ cardArrays ≡ [ OpenResource, JTable ]

  -- Finds a new name for a notebook in the specified parent directory, using
  -- a name value as a basis to start with.
  getNewName' ∷ DirPath → String → NotebookDSL (Either Exn.Error Pathy.DirName)
  getNewName' dir name =
    let baseName = name ⊕ "." ⊕ Config.notebookExtension
    in map Pathy.DirName <$> Quasar.getNewName dir baseName

  genId ∷ DirPath → Maybe DeckId → NotebookDSL (Either Exn.Error DeckId)
  genId path deckId = case deckId of
    Just id' → pure $ Right id'
    Nothing → map DeckId <$> NB.fresh (path </> Pathy.file "index")

  -- Saves a notebook and returns the name it was saved as.
  save ∷ DirPath → DeckId → Json → NotebookDSL (Either Exn.Error Unit)
  save dir deckId json = Quasar.save (deckIndex dir deckId) json

  -- Renames a notebook and returns the new name it was changed to.
  rename
    ∷ DirPath
    → Pathy.DirName
    → String
    → NotebookDSL (Either Exn.Error Pathy.DirName)
  rename dir oldName newName = runExceptT do
    newName' ← ExceptT $ getNewName' dir newName
    let oldPath = dir </> Pathy.dir' oldName
        newPath = dir </> Pathy.dir' newName'
    ExceptT $ Quasar.move (R.Directory oldPath) (Left newPath)
    pure newName'

-- | Takes a `DirName` for a saved notebook and returns the name part without
-- | the `.slam` extension.
nameFromDirName ∷ Pathy.DirName → String
nameFromDirName dirName =
  let name = Pathy.runDirName dirName
  in Str.take (Str.length name - Str.length Config.notebookExtension - 1) name

deckIndex ∷ DirPath → DeckId → FilePath
deckIndex path deckId = path </> Pathy.dir (deckIdToString deckId) </> Pathy.file "index"

{-
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.Notebook.Deck.Component
  ( comp
  , initialState
  , module SlamData.Notebook.Deck.Component.Query
  , module DCS
  ) where

import SlamData.Prelude

import Control.Monad.Aff.Console (log)
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Except.Trans (ExceptT(..), runExceptT)
import Control.UI.Browser (newTab, locationObject)
import Control.Monad.Aff.Free (fromEff)

import CSS.Geometry (width)
import CSS.Size (pct, Size(..), Rel, nil)
import CSS.String (fromString)
import CSS.Transform (transform, translate)

import Data.Argonaut (Json)
import Data.Array (catMaybes, nub)
import Data.BrowserFeatures (BrowserFeatures)
import Data.Int (toNumber)
import Data.Lens as Lens
import Data.Lens (LensP(), view, (.~), (%~), (?~), (^?))
import Data.Lens.Prism.Coproduct (_Right)
import Data.List as List
import Data.Map as Map
import Data.Ord (max)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as Pathy
import Data.Set as S
import Data.String as Str
import Data.Time (Milliseconds(..))

import Ace.Halogen.Component as Ace

import DOM.HTML.Location as Location

import Halogen as H
import Halogen.Component.ChildPath (ChildPath, injSlot, injState)
import Halogen.Component.Utils (forceRerender')
import Halogen.Component.Utils.Debounced (fireDebouncedQuery')
import Halogen.HTML.CSS.Indexed (style)
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Indexed as HH
import Halogen.Component.ChildPath (injSlot, injState)
import Halogen.HTML.Properties.Indexed as HP
import Halogen.Themes.Bootstrap3 as B
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Quasar.Aff as Quasar
import Quasar.Auth as Auth

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.FileSystem.Resource as R
import SlamData.Notebook.AccessType (AccessType(..), isEditable)
import SlamData.Notebook.Action as NA
import SlamData.Notebook.Card.CardId (CardId(), runCardId, cardIdToString)
import SlamData.Notebook.Card.CardType
  (CardType(..), AceMode(..), cardName, cardGlyph, autorun, nextCardTypes)
import SlamData.Notebook.Card.Common.EvalQuery (CardEvalQuery(..))
import SlamData.Notebook.Card.Component (CardQueryP, CardQuery(..), InnerCardQuery, AnyCardQuery(..), _NextQuery, initialCardState)
import SlamData.Notebook.Card.Next.Component as Next
import SlamData.Notebook.Card.OpenResource.Component as Open
import SlamData.Notebook.Card.Port (Port(..))
import SlamData.Notebook.Deck.BackSide.Component as Back
import SlamData.Notebook.Deck.Component.ChildSlot (cpBackSide, cpCard, ChildQuery, ChildState, ChildSlot, CardSlot(..))
import SlamData.Notebook.Deck.Component.Query (QueryP, Query(..))

import SlamData.Notebook.Deck.Component.State as DCS
import SlamData.Notebook.Deck.DeckId (DeckId(..), deckIdToString)
import SlamData.Notebook.Deck.Model as Model
import SlamData.Notebook.Model as NB
import SlamData.Notebook.Routing (mkNotebookHash, mkNotebookCardHash, mkNotebookURL)
import SlamData.Quasar.Data (save, load) as Quasar
import SlamData.Quasar.FS (move, getNewName) as Quasar
import SlamData.Render.CSS as CSS
import Utils.Debounced (debouncedEventSource)
import Utils.Path (DirPath, FilePath)
import Utils.DOM (getBoundingClientRect, offsetLeft)
import Utils.CSS (transition)

type NotebookHTML = H.ParentHTML ChildState Query ChildQuery Slam ChildSlot
type NotebookDSL = H.ParentDSL DCS.State ChildState Query ChildQuery Slam ChildSlot

initialState ∷ BrowserFeatures → DCS.StateP
initialState fs = H.parentState $ DCS.initialDeck fs

comp ∷ H.Component DCS.StateP QueryP Slam
comp =
  H.parentComponent
    { render: render ∘ DCS.virtualState
    , eval
    , peek: Just peek
    }

render ∷ DCS.State → NotebookHTML
render state =
  case state.stateMode of
    DCS.Loading →
      HH.div
        [ HP.classes [ B.alert, B.alertInfo ] ]
        [ HH.h1
          [ HP.class_ B.textCenter ]
          [ HH.text "Loading..." ]
          -- We need to render the cards but have them invisible during loading
          -- otherwise the various nested components won't initialise correctly
        , renderCards false
        ]
    DCS.Ready →
      -- WARNING: Very strange things happen when this is not in a div; see SD-1326.
      HH.div
        ([ HP.class_ CSS.board ]
           ⊕ (guard (isJust state.initialSliderX)
                $> (HE.onMouseUp \e -> HEH.preventDefault $> H.action (StopSlidingAndSnap e)))
           ⊕ (guard (isJust state.initialSliderX)
                $> (HE.onMouseLeave \e -> HEH.stopPropagation $> HEH.preventDefault $> H.action (StopSlidingAndSnap e)))
           ⊕ (guard (isJust state.initialSliderX)
                $> (HE.onMouseMove $ HE.input UpdateSliderPosition)))
        [ HH.div
            [ HP.class_ CSS.deck ]
            [ renderCards $ not state.backsided
            , renderBackside state.backsided
              -- Commented until one card representation
--            , HH.button [ HP.classes [ B.btn, B.btnPrimary ]
--                        , HE.onClick (HE.input_ FlipDeck)
--                        , ARIA.label "Flip deck"
--                        ]
--              [ HH.text "Flip" ]
            ]
        ]

    DCS.Error err →
      HH.div
        [ HP.classes [ B.alert, B.alertDanger ] ]
        [ HH.h1
            [ HP.class_ B.textCenter ]
            [ HH.text err ]
        ]

  where
  renderBackside visible =
    HH.div
      ( [ ARIA.hidden $ show $ not visible ]
        ⊕ ((guard $ not visible) $> (HP.class_ CSS.invisible)))

      [ HH.slot' cpBackSide unit \_ →
         { component: Back.comp
         , initialState: Back.initialState
         }
      ]

  renderCards visible =
    -- The key here helps out virtual-dom: the entire subtree will be moved
    -- when the loading message disappears, rather than being reconstructed in
    -- the parent element
    HH.div
      ([ HP.key "notebook-cards"
       , HP.classes [ CSS.cardSlider ]
       , HE.onTransitionEnd $ HE.input_ StopSliderTransition
       , style
           $ (cardSliderWidth $ List.length state.cards + 1)
           *> (cardSliderTransform (List.length state.cards + 1) (activeCardIndex state) state.sliderTranslateX)
           *> (cardSliderTransition state.sliderTransition)
       ]
       ⊕ (guard (not visible) $> (HP.class_ CSS.invisible)))
      ( List.fromList (map (renderCard $ List.length state.cards + 1) state.cards)
        ⊕ (pure $ newCardMenu (List.length state.cards + 1) state))

  renderCard cardsCount cardDef =
    HH.div
    ([ HP.key ("card" ⊕ cardIdToString cardDef.id)
     , HP.classes [ CSS.card ]
     , style $ cardWidth cardsCount
    ]
     ⊕ foldMap (viewingStyle cardDef) state.viewingCard)
    [ cardGripper
    , HH.Slot $ transformCardConstructor cardDef.ctor
    ]

  cardGripper =
    HH.div
      [ HP.classes [ CSS.cardGripper ]
      , HE.onMouseDown \e -> HEH.preventDefault $> H.action (StartSliding e)
      ]
      []

  transformCardConstructor (H.SlotConstructor p l) =
    H.SlotConstructor
      (injSlot cpCard p)
      (l <#> \def →
        { component: H.transformChild cpCard def.component
        , initialState: injState cpCard def.initialState
        }
      )

  viewingStyle cardDef cid =
    guard (not (cardDef.id ≡ cid))
    $> (HP.class_ CSS.invisible)

  shouldHideNextAction =
    isJust state.viewingCard ∨ state.accessType ≡ ReadOnly

  newCardMenu cardsCount state =
    HH.div
      ([ HP.key ("next-action-card")
       , HP.classes [ CSS.card ]
       , HP.ref (H.action <<< SetNextActionCardElement)
       , style $ cardWidth cardsCount
       ]
       ⊕ (guard shouldHideNextAction $> (HP.class_ CSS.invisible)))

    [ cardGripper
    , HH.slot' cpCard (CardSlot top) \_ →
       { component: Next.nextCardComponent
       , initialState: H.parentState initialCardState
       }
    ]

  cardWidthPct cardsCount =
    100.0 / toNumber cardsCount

  cardWidth cardsCount =
    width $ calc $ (show $ cardWidthPct cardsCount) ++ "% - 1.5rem"

  cardSliderWidth cardsCount =
    width $ pct $ 100.0 * toNumber cardsCount

  cardSliderTransform cardCount activeCardIndex translateX =
    transform $ translate (cardSliderTranslateX cardCount activeCardIndex translateX) nil

  cardSliderTransition false = transition "0"
  cardSliderTransition true = transition "all 0.33s"

  cardSliderTranslateX cardCount activeCardIndex translateX =
    calc
      $ "(((-100% / " ++ show cardCount ++ ") + 1.5rem)"
      ++ " * " ++ show activeCardIndex ++ ")"
      ++ " + (" ++ show translateX ++ "px)"

  calc s = Size $ fromString $ "calc(" ++ s ++ ")"

eval ∷ Natural Query NotebookDSL
eval (AddCard cardType next) = createCard cardType $> next
eval (RunActiveCard next) = do
  (maybe (pure unit) runCard =<< H.gets (_.activeCardId)) $> next
eval (LoadNotebook fs dir deckId next) = do
  state ← H.get
  H.modify (DCS._stateMode .~ DCS.Loading)
  json ← Quasar.load $ deckIndex dir deckId
  case Model.decode =<< json of
    Left err → do
      H.fromAff $ log err
      H.modify $ DCS._stateMode .~ DCS.Error "There was a problem decoding the saved notebook"
    Right model →
      case DCS.fromModel fs (Just dir) (Just deckId) model of
        Tuple cards st → do
          H.set st
          forceRerender'
          ranCards ← catMaybes <$> for cards \card → do
            H.query' cpCard  (CardSlot card.cardId)
              $ left
              $ H.action
              $ LoadCard card
            pure if card.hasRun then Just card.cardId else Nothing
          -- We only need to run the root node in each subgraph, as doing so
          -- will result in all child nodes being run also as the outputs
          -- propagate down each subgraph.
          traverse_ runCard $ nub $ flip DCS.findRoot st <$> ranCards
          H.modify $ DCS._stateMode .~ DCS.Ready
  updateNextActionCard
  forceRerender'
  pure next

eval (ExploreFile fs res next) = do
  H.set $ DCS.initialDeck fs
  H.modify
    $ (DCS._path .~ Pathy.parentDir res)
    ∘ (DCS.addCard OpenResource Nothing)
  forceRerender'
  H.query' cpCard (CardSlot zero)
    $ right
    $ H.ChildF unit
    $ right
    $ OpenResourceQuery
    $ right
    $ H.action
    $ Open.ResourceSelected
    $ R.File res
  forceRerender'
  runCard zero
  -- Flush the eval queue
  saveNotebook
  updateNextActionCard
  pure next
eval (Publish next) = do
  H.gets DCS.deckPath >>= \mpath →
    for_ mpath $ H.fromEff ∘ newTab ∘ flip mkNotebookURL (NA.Load ReadOnly)
  pure next
eval (Reset fs dir deckId next) = do
  let nb = DCS.initialDeck fs
  H.set $ nb { id = deckId, path = Just dir }
  pure next
eval (SetName name next) =
  H.modify (DCS._name .~ Just name) $> next
eval (SetAccessType aType next) = do
  cids ← map Map.keys $ H.gets _.cardTypes
  for_ cids \cardId →
    void
      $ H.query' cpCard (CardSlot cardId)
      $ left
      $ H.action
      $ SetCardAccessType aType
  H.modify $ DCS._accessType .~ aType
  unless (isEditable aType)
    $ H.modify (DCS._backsided .~ false)
  pure next
eval (GetNotebookPath k) = k <$> H.gets DCS.deckPath
eval (SetViewingCard mbcid next) = H.modify (DCS._viewingCard .~ mbcid) $> next
eval (SaveNotebook next) = saveNotebook $> next
eval (RunPendingCards next) = do
  -- Only run pending cards if we have a deckPath. Some cards run with the
  -- assumption that the deck is saved to disk.
  H.gets DCS.deckPath >>= traverse_ \_ → runPendingCards
  pure next
eval (GetGlobalVarMap k) = k <$> H.gets _.globalVarMap
eval (SetGlobalVarMap m next) = do
  st ← H.get
  when (m ≠ st.globalVarMap) do
    H.modify $ DCS._globalVarMap .~ m
    traverse_ runCard $ DCS.cardsOfType API st
  pure next
eval (FindCardParent cid k) = k <$> H.gets (DCS.findParent cid)
eval (GetCardType cid k) = k <$> H.gets (DCS.getCardType cid)
eval (FlipDeck next) = H.modify (DCS._backsided %~ not) $> next
eval (GetActiveCardId k) = map k $ H.gets DCS.findLast
eval (StartSliding mouseEvent next) =
  setInitialSliderX (Just mouseEvent.screenX) $> next
  where
  setInitialSliderX =
    H.modify <<< (DCS._initialSliderX .~)
eval (StopSlidingAndSnap mouseEvent next) =
  snap *> stopSliding *> startTransition $> next
  where
  stopSliding =
    setInitialX Nothing *> setTranslateX 0.0
  setInitialX =
    H.modify <<< (DCS._initialSliderX .~)
  getBoundingClientWidth =
    fromEff <<< map _.width <<< getBoundingClientRect
  getNextActionCardElement =
    H.gets _.nextActionCardElement
  getCardWidth =
    traverse getBoundingClientWidth =<< getNextActionCardElement
  setActiveCardId =
    H.modify <<< (DCS._activeCardId .~)
  setTranslateX =
    H.modify <<< (DCS._sliderTranslateX .~)
  snapActiveCardIndex translateX (Just cardWidth) | translateX < (-(cardWidth / 2.0)) =
    add 1
  snapActiveCardIndex translateX (Just cardWidth) | translateX > (cardWidth / 2.0) =
    max 0 <<< flip sub 1
  snapActiveCardIndex translateX _ =
    id
  getCardIdByIndex cards =
    map _.id <<< List.index cards
  snapActiveCardId st cardWidth =
    getCardIdByIndex st.cards
      $ snapActiveCardIndex st.sliderTranslateX cardWidth
      $ activeCardIndex st
  snap =
    setActiveCardId =<< (snapActiveCardId <$> H.get <*> getCardWidth)
  setSliderTransition =
    H.modify <<< (DCS._sliderTransition .~)
  startTransition =
    setSliderTransition true
eval (UpdateSliderPosition mouseEvent next) =
  (maybe (pure unit) (setTranslateX <<< translateXCalc) =<< getInitialX) $> next
  where
  getInitialX =
    H.gets _.initialSliderX
  translateXCalc initialX =
    mouseEvent.screenX - initialX
  setTranslateX =
    H.modify <<< (DCS._sliderTranslateX .~)
eval (SetNextActionCardElement element next) =
  setNextActionCardElement element $> next
  where
  setNextActionCardElement =
    H.modify <<< (DCS._nextActionCardElement .~)
eval (StopSliderTransition next) =
  setSliderTransition false $> next
  where
  setSliderTransition =
    H.modify <<< (DCS._sliderTransition .~)

peek ∷ ∀ a. H.ChildF ChildSlot ChildQuery a → NotebookDSL Unit
peek (H.ChildF s q) =
  coproduct
    (either peekCards (\_ _ → pure unit) s)
    peekBackSide
    q

peekBackSide ∷ ∀ a. Back.Query a → NotebookDSL Unit
peekBackSide (Back.UpdateFilter _ _) = pure unit
peekBackSide (Back.DoAction action _) = case action of
  Back.Trash → do
    activeId ← H.gets _.activeCardId
    lastId ← H.gets DCS.findLast
    for_ (activeId <|> lastId) \trashId → do
      descendants ← H.gets $ DCS.findDescendants trashId
      H.modify ∘ DCS.removeCards $ S.insert trashId descendants
      triggerSave
      updateNextActionCard
      H.modify $ DCS._backsided .~ false
  Back.Share → pure unit
  Back.Embed → pure unit
  Back.Publish →
    H.gets DCS.deckPath >>= \mpath →
      for_ mpath $ H.fromEff ∘ newTab ∘ flip mkNotebookURL (NA.Load ReadOnly)
  Back.Mirror → pure unit
  Back.Wrap → pure unit

peekCards ∷ ∀ a. CardSlot → CardQueryP a → NotebookDSL Unit
peekCards (CardSlot cardId) q =
  coproduct (peekCard cardId) (peekCardInner cardId) q

-- | Peek on the card component to observe actions from the card control
-- | buttons.
peekCard ∷ ∀ a. CardId → CardQuery a → NotebookDSL Unit
peekCard cardId q = case q of
  RunCard _ → runCard cardId
  RefreshCard _ → runCard ∘ DCS.findRoot cardId =<< H.get
  TrashCard _ → do
    descendants ← H.gets $ DCS.findDescendants cardId
    H.modify ∘ DCS.removeCards $ S.insert cardId descendants
    triggerSave
    updateNextActionCard
  ToggleCaching _ →
    triggerSave
  ShareCard _ → pure unit
  StopCard _ → do
    H.modify $ DCS._runTrigger .~ Nothing
    H.modify $ DCS._pendingCards %~ S.delete cardId
    runPendingCards
  _ → pure unit

updateNextActionCard ∷ NotebookDSL Unit
updateNextActionCard = do
  cid ← H.gets DCS.findLast
  mbMessage ← case cid of
    Just cardId → do
      out ←
        map join
          $ H.query' cpCard (CardSlot cardId)
          $ left (H.request GetOutput)
      pure $ case out of
        Nothing →
          Just "Next actions will be made available once the last card has been run"
        Just Blocked →
          Just "There are no available next actions"
        Just (CardError _) →
          Just "There are no available next actions (parent cards have errors)"
        _ → Nothing
    Nothing → pure Nothing
  queryNextActionCard
    $ H.action
    $ Next.SetMessage mbMessage

  lastCardType ← H.gets DCS.findLastCardType
  queryNextActionCard
    $ H.action
    $ Next.SetAvailableTypes
    $ nextCardTypes lastCardType
  pure unit
  where
  queryNextActionCard q =
    H.query' cpCard (CardSlot top)
      $ right
      $ H.ChildF unit
      $ right
      $ NextQuery
      $ right q

createCard ∷ CardType → NotebookDSL Unit
createCard cardType = do
  cid ← H.gets DCS.findLast
  s ← H.get
  case cid of
    Nothing →
      H.modify $ DCS.addCard cardType Nothing
    Just cardId → do
      Tuple st newCardId ← H.gets $ DCS.addCard' cardType (Just cardId)
      H.set st
      forceRerender'
      input ←
        map join $ H.query' cpCard (CardSlot cardId) $ left (H.request GetOutput)

      for_ input \input' → do
        path ← H.gets DCS.deckPath
        let setupInfo = { notebookPath: path, inputPort: input', cardId: newCardId }
        void
          $ H.query' cpCard  (CardSlot newCardId)
          $ right
          $ H.ChildF unit
          $ left
          $ H.action (SetupCard setupInfo)
      runCard newCardId
  updateNextActionCard
  triggerSave

-- | Peek on the inner card components to observe `NotifyRunCard`, which is
-- | raised by actions within a card that should cause the card to run.
peekCardInner
  ∷ ∀ a. CardId → H.ChildF Unit InnerCardQuery a → NotebookDSL Unit
peekCardInner cardId (H.ChildF _ q) =
  coproduct (peekEvalCard cardId) (peekAnyCard cardId) q

peekEvalCard ∷ ∀ a. CardId → CardEvalQuery a → NotebookDSL Unit
peekEvalCard cardId (NotifyRunCard _) = runCard cardId
peekEvalCard _ _ = pure unit

peekAnyCard ∷ ∀ a. CardId → AnyCardQuery a → NotebookDSL Unit
peekAnyCard cardId q = do
  for_ (q ^? _NextQuery ∘ _Right ∘ Next._AddCardType) createCard
  when (queryShouldRun q) $ runCard cardId
  when (queryShouldSave q) triggerSave
  pure unit

queryShouldRun ∷ ∀ a. AnyCardQuery a → Boolean
queryShouldRun (SaveQuery q) = false
queryShouldRun _ = true

queryShouldSave  ∷ ∀ a. AnyCardQuery a → Boolean
queryShouldSave (AceQuery q) =
  coproduct evalQueryShouldSave aceQueryShouldSave q
queryShouldSave _ = true

evalQueryShouldSave ∷ ∀ a. CardEvalQuery a → Boolean
evalQueryShouldSave _ = true

aceQueryShouldSave
  ∷ ∀ p a. H.ChildF p Ace.AceQuery a → Boolean
aceQueryShouldSave (H.ChildF _ q) =
  case q of
    Ace.TextChanged _ → true
    _ → false

-- | Runs all card that are present in the set of pending cards.
runPendingCards ∷ NotebookDSL Unit
runPendingCards = do
  cards ← H.gets _.pendingCards
  traverse_ runCard' cards
  updateNextActionCard
  where
  runCard' ∷ CardId → NotebookDSL Unit
  runCard' cardId = do
    mbParentId ← H.gets $ DCS.findParent cardId
    case mbParentId of
      -- if there's no parent there's no input port value to pass through
      Nothing → updateCard Nothing cardId
      Just parentId → do
        value ←
          map join $ H.query' cpCard (CardSlot parentId) $ left (H.request GetOutput)
        case value of
          -- if there's a parent but no output the parent card hasn't been evaluated
          -- yet, so we can't run this card either
          Nothing → pure unit
          -- if there's a parent and an output, pass it on as this card's input
          Just p → updateCard (Just p) cardId
    H.modify $ DCS._pendingCards %~ S.delete cardId
    triggerSave

-- | Enqueues the card with the specified ID in the set of cards that are
-- | pending to run and enqueues a debounced H.query to trigger the cards to
-- | actually run.
runCard ∷ CardId → NotebookDSL Unit
runCard cardId = do
  H.modify (DCS.addPendingCard cardId)
  fireDebouncedQuery' (Milliseconds 500.0) DCS._runTrigger RunPendingCards

-- | Updates the evaluated value for a card by running it with the specified
-- | input and then runs any cards that depend on the card's output with the
-- | new result.
updateCard ∷ Maybe Port → CardId → NotebookDSL Unit
updateCard inputPort cardId = do
  path ← H.gets DCS.deckPath
  globalVarMap ← H.gets _.globalVarMap
  let input = { notebookPath: path, inputPort, cardId, globalVarMap }
  result ←
    map join
      $ H.query' cpCard (CardSlot cardId)
      $ left
      $ H.request (UpdateCard input)

  H.modify ∘ Lens.over DCS._failingCards $
    case result of
      Just (CardError msg) → S.insert cardId
      _ → S.delete cardId
  forceRerender'

  runCardDescendants cardId (fromMaybe Blocked result)
  where
  runCardDescendants ∷ CardId → Port → NotebookDSL Unit
  runCardDescendants parentId value = do
    -- Crucially, we run the card descendents according to the virtual graph;
    -- this enables the correct behavior of virtual cards, including the Error Card.
    children ← H.gets $ DCS.findChildren parentId ∘ DCS.virtualState
    traverse_ (updateCard (Just value)) children

-- | Triggers the H.query for autosave. This does not immediate perform the save
-- | H.action, but instead enqueues a debounced H.query to trigger the actual save.
triggerSave ∷ NotebookDSL Unit
triggerSave =
  fireDebouncedQuery' (Milliseconds 500.0) DCS._saveTrigger SaveNotebook

-- | Saves the notebook as JSON, using the current values present in the state.
saveNotebook ∷ NotebookDSL Unit
saveNotebook = H.get >>= \st → do
  if isUnsaved st ∧ isNewExploreNotebook st
    -- If its an unsaved Explore notebook, it is safe to go ahead and run it.
    then runPendingCards
    else do
      cards ← catMaybes <$> for (List.fromList st.cards) \card →
        H.query' cpCard (CardSlot card.id)
          $ left
          $ H.request (SaveCard card.id card.ty)

      let json = Model.encode { name: st.name, cards, dependencies: st.dependencies }

      for_ st.path \path → do
        deckId ← runExceptT do
          i ← ExceptT $ genId path st.id
          ExceptT $ save path i json
          pure i

        case deckId of
          Left err → do
            -- TODO: do something to notify the user saving failed
            pure unit
          Right deckId' → do
            H.modify $ DCS._id .~ Just deckId'

            -- runPendingCards would be deffered if there had previously been
            -- no `deckPath`. We need to flush the queue.
            when (isNothing $ DCS.deckPath st) runPendingCards

            -- We need to get the modified version of the notebook state.
            H.gets DCS.deckPath >>= traverse_ \path' →
              let notebookHash =
                    case st.viewingCard of
                      Nothing →
                        mkNotebookHash path' (NA.Load st.accessType) st.globalVarMap
                      Just cid →
                        mkNotebookCardHash path' cid st.accessType st.globalVarMap
              in H.fromEff $ locationObject >>= Location.setHash notebookHash

  where

  isUnsaved ∷ DCS.State → Boolean
  isUnsaved = isNothing ∘ DCS.deckPath

  isNewExploreNotebook ∷ DCS.State → Boolean
  isNewExploreNotebook { cards } =
    let
      cardArrays = List.toUnfoldable (map _.ty cards)
    in
      cardArrays ≡ [ OpenResource ] ∨ cardArrays ≡ [ OpenResource, JTable ]

  -- Finds a new name for a notebook in the specified parent directory, using
  -- a name value as a basis to start with.
  getNewName' ∷ DirPath → String → NotebookDSL (Either Exn.Error Pathy.DirName)
  getNewName' dir name =
    let baseName = name ⊕ "." ⊕ Config.notebookExtension
    in map Pathy.DirName <$> Quasar.getNewName dir baseName

  genId ∷ DirPath → Maybe DeckId → NotebookDSL (Either Exn.Error DeckId)
  genId path deckId = case deckId of
    Just id' → pure $ Right id'
    Nothing → map DeckId <$> NB.fresh (path </> Pathy.file "index")

  -- Saves a notebook and returns the name it was saved as.
  save ∷ DirPath → DeckId → Json → NotebookDSL (Either Exn.Error Unit)
  save dir deckId json = Quasar.save (deckIndex dir deckId) json

  -- Renames a notebook and returns the new name it was changed to.
  rename
    ∷ DirPath
    → Pathy.DirName
    → String
    → NotebookDSL (Either Exn.Error Pathy.DirName)
  rename dir oldName newName = runExceptT do
    newName' ← ExceptT $ getNewName' dir newName
    let oldPath = dir </> Pathy.dir' oldName
        newPath = dir </> Pathy.dir' newName'
    ExceptT $ Quasar.move (R.Directory oldPath) (Left newPath)
    pure newName'

-- | Takes a `DirName` for a saved notebook and returns the name part without
-- | the `.slam` extension.
nameFromDirName ∷ Pathy.DirName → String
nameFromDirName dirName =
  let name = Pathy.runDirName dirName
  in Str.take (Str.length name - Str.length Config.notebookExtension - 1) name

deckIndex ∷ DirPath → DeckId → FilePath
deckIndex path deckId = path </> Pathy.dir (deckIdToString deckId) </> Pathy.file "index"


[CSM-219] Fix changeWalletSetPass client endpoint

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, mkCPassPhrase, mkCWalletSetInit)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn5, mkEffFn5, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------

-- | Resets wallet database (metadata) and wallets/keys
-- This should be used only in testing
-- Arguments:
-- Returns:
-- Example in nodejs:
testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

--------------------------------------------------------------------------------
-- Wallet Sets ---------------------------------------------------------------------

-- | Gets specified wallet set
-- Arguments: wallet set id/hash
-- Returns json representation of requested wallet set
-- Example in nodejs:
--
getWalletSet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWalletSet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWalletSet <<< mkCAddress

-- | Gets all wallet sets
-- Arguments:
-- Returns json representation of all wallet sets
-- Example in nodejs:
--
getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWalletSets

-- | Creates a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password)
-- Returns json representation of created wallet set
-- Example in nodejs:
--
newWalletSet :: forall eff . EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String
  (Promise Json)
newWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
    either throwError (B.newWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- TODO: note that restoreWalletSet and newWalletSet are the same. They will be unified in future

-- | Restores a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password
-- Returns json representation of restored wallet set
-- Example in nodejs:
--
restoreWalletSet :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
restoreWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, name
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
renameWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
renameWalletSet = mkEffFn2 \wSetId name -> fromAff <<< map encodeJson $ B.renameWalletSet (mkCAddress wSetId) name

-- | Import a wallet set.
-- Arguments: file path to the wallet set on a filesystem, spending password (set to empty string if you don't want to set password)
-- Returns json representation of imported wallet set
-- Example in nodejs:
--
importWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
importWalletSet = mkEffFn2 \filePath spendingPassword -> fromAff <<< map encodeJson $ B.importWalletSet (mkCPassPhrase spendingPassword) filePath

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, old spending password (set to empty string if there is no password), new spending password (set to empty string if you want to remove password)
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
changeWalletSetPass :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
changeWalletSetPass = mkEffFn3 \wSetId oldPass newPass -> fromAff <<< map encodeJson $ B.changeWalletSetPass (mkCAddress wSetId) (mkCPassPhrase oldPass) (mkCPassPhrase newPass)

--------------------------------------------------------------------------------
-- Wallets ---------------------------------------------------------------------
--
--
-- getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)
--
-- updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale
--
-- getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getWallets = fromAff $ map encodeJson B.getWallets
--
-- getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress
--
-- getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
-- getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
--     B.getHistory
--         (mkCAddress addr)
--         skip
--         limit
--
-- searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
-- searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
--     B.searchHistory
--         (mkCAddress addr)
--         search
--         skip
--         limit
--
-- send :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
-- send = mkEffFn4 \addrFrom addrTo amount spendingPassword -> fromAff <<< map encodeJson $
--     B.send
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--
-- sendExtended :: forall eff. EffFn7 (ajax :: AJAX | eff) String String String String String String String (Promise Json)
-- sendExtended = mkEffFn7 \addrFrom addrTo amount curr title desc spendingPassword -> fromAff <<< map encodeJson $
--     B.sendExtended
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--         (mkCCurrency curr)
--         title
--         desc
--
-- generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
-- generateMnemonic = Crypto.generateMnemonic
--
-- -- | bip39.validateMnemonic and has at least len words
-- isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
-- isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len
--
-- newWallet :: forall eff . EffFn5 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String String
--   (Promise Json)
-- newWallet = mkEffFn5 \wType wCurrency wName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
--     either throwError (B.newWallet $ mkCPassPhrase spendingPassword) $ mkCWalletInit wType wCurrency wName mnemonic
--
-- -- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- -- Daedalus.ClientApi.newWallet(
-- --     'CWTPersonal'
-- --   , 'ADA'
-- --   , 'wallet name'
-- --   , function(mnemonics) {
-- --     // if this function finishes we will send request for wallet
-- --     // creation to the backend. That means user validated and
-- --     // stored mnemonics.
-- --     // if an exception is thrown new wallet request will be aborted
-- --     // and promise should return thrown error
-- --     if(userSavedMnemonics) {
-- --       // do nothing
-- --     } else {
-- --       throw new Error("Wallet canceled")
-- --     }
-- --   }
-- --   )()
-- --   .then(function(value) {
-- --     console.log('SUCCESS', value);
-- --   }, function(reason) {
-- --     console.log('ERROR', reason);
-- --   })
-- -- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
-- --   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- -- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
-- --
-- --     mnemonic <- liftEff Crypto.generateMnemonic
-- --     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
-- --     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
-- --     either throwError B.newWallet $ do
-- --         isConfirmed
-- --         mkCWalletInit wType wCurrency wName mnemonic
--
-- updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
-- updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
--     B.updateWallet
--         (mkCAddress addr)
--         $ mkCWalletMeta wType wCurrency wName wAssurance wUnit
--
-- updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
-- updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
--     B.updateTransaction
--         (mkCAddress addr)
--         (mkCTxId ctxId)
--         $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate
--
-- deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
-- deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress
--
-- isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
-- isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)
--
-- notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
-- notify = mkEffFn2 \messageCb errorCb -> do
--     -- TODO (akegalj) grab global (mutable) state of  here
--     -- instead of creating newRef
--     conn <- newRef WSNotConnected
--     openConn $ mkWSState conn messageCb errorCb
--
-- blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
-- blockchainSlotDuration = fromAff B.blockchainSlotDuration
--
-- restoreWallet :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
-- restoreWallet = mkEffFn5 \wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase spendingPassword) <<< mkCWalletInit wType wCurrency wName
--
--
-- nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- nextUpdate = fromAff $ map encodeJson B.nextUpdate
--
-- applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
-- applyUpdate = fromAff B.applyUpdate
--
-- systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- systemVersion = fromAff $ map encodeJson B.systemVersion
--
-- redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
-- redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed
--
-- redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
-- redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic
--
-- reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
-- reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total
--
-- importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey
--
-- syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- syncProgress = fromAff $ map encodeJson B.syncProgress
--
-- -- Valid redeem code is base64 encoded 32byte data
-- -- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
-- isValidRedemptionKey :: String -> Boolean
-- isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
--   where
--     -- Because it is 32byte base64 encoded
--     endsWithEqual = isJust $ stripSuffix (Pattern "=") code
--
-- -- Valid paper vend key is base58 encoded 32byte data
-- isValidPaperVendRedemptionKey :: String -> Boolean
-- isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, mkCPassPhrase, mkCWalletSetInit)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn5, mkEffFn5, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------

-- | Resets wallet database (metadata) and wallets/keys
-- This should be used only in testing
-- Arguments:
-- Returns:
-- Example in nodejs:
testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

--------------------------------------------------------------------------------
-- Wallet Sets ---------------------------------------------------------------------

-- | Gets specified wallet set
-- Arguments: wallet set id/hash
-- Returns json representation of requested wallet set
-- Example in nodejs:
--
getWalletSet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWalletSet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWalletSet <<< mkCAddress

-- | Gets all wallet sets
-- Arguments:
-- Returns json representation of all wallet sets
-- Example in nodejs:
--
getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWalletSets

-- | Creates a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password)
-- Returns json representation of created wallet set
-- Example in nodejs:
--
newWalletSet :: forall eff . EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String
  (Promise Json)
newWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
    either throwError (B.newWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- TODO: note that restoreWalletSet and newWalletSet are the same. They will be unified in future

-- | Restores a new wallet set.
-- Arguments: wallet set name, mnemonics, spending password (set to empty string if you don't want to set password
-- Returns json representation of restored wallet set
-- Example in nodejs:
--
restoreWalletSet :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
restoreWalletSet = mkEffFn3 \wSetName mnemonic spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWalletSet $ mkCPassPhrase spendingPassword) $ mkCWalletSetInit wSetName mnemonic

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, name
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
renameWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
renameWalletSet = mkEffFn2 \wSetId name -> fromAff <<< map encodeJson $ B.renameWalletSet (mkCAddress wSetId) name

-- | Import a wallet set.
-- Arguments: file path to the wallet set on a filesystem, spending password (set to empty string if you don't want to set password)
-- Returns json representation of imported wallet set
-- Example in nodejs:
--
importWalletSet :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Json)
importWalletSet = mkEffFn2 \filePath spendingPassword -> fromAff <<< map encodeJson $ B.importWalletSet (mkCPassPhrase spendingPassword) filePath

-- | Rename a wallet set.
-- Arguments: wallet set id/hash, old spending password (set to empty string if there is no password), new spending password (set to empty string if you want to remove password)
-- Returns json representation of renamed wallet set
-- Example in nodejs:
--
changeWalletSetPass :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
importWalletSetPass = mkEffFn3 \wSetId oldPass newPass -> fromAff <<< map encodeJson $ B.changeWalletSetPass (mkCPassPhrase oldPass) (mkCPassPhrase newPass)

--
--
-- getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)
--
-- updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale
--
-- getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- getWallets = fromAff $ map encodeJson B.getWallets
--
-- getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress
--
-- getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
-- getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
--     B.getHistory
--         (mkCAddress addr)
--         skip
--         limit
--
-- searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
-- searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
--     B.searchHistory
--         (mkCAddress addr)
--         search
--         skip
--         limit
--
-- send :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
-- send = mkEffFn4 \addrFrom addrTo amount spendingPassword -> fromAff <<< map encodeJson $
--     B.send
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--
-- sendExtended :: forall eff. EffFn7 (ajax :: AJAX | eff) String String String String String String String (Promise Json)
-- sendExtended = mkEffFn7 \addrFrom addrTo amount curr title desc spendingPassword -> fromAff <<< map encodeJson $
--     B.sendExtended
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--         (mkCCurrency curr)
--         title
--         desc
--
-- generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
-- generateMnemonic = Crypto.generateMnemonic
--
-- -- | bip39.validateMnemonic and has at least len words
-- isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
-- isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len
--
-- newWallet :: forall eff . EffFn5 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String String
--   (Promise Json)
-- newWallet = mkEffFn5 \wType wCurrency wName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
--     either throwError (B.newWallet $ mkCPassPhrase spendingPassword) $ mkCWalletInit wType wCurrency wName mnemonic
--
-- -- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- -- Daedalus.ClientApi.newWallet(
-- --     'CWTPersonal'
-- --   , 'ADA'
-- --   , 'wallet name'
-- --   , function(mnemonics) {
-- --     // if this function finishes we will send request for wallet
-- --     // creation to the backend. That means user validated and
-- --     // stored mnemonics.
-- --     // if an exception is thrown new wallet request will be aborted
-- --     // and promise should return thrown error
-- --     if(userSavedMnemonics) {
-- --       // do nothing
-- --     } else {
-- --       throw new Error("Wallet canceled")
-- --     }
-- --   }
-- --   )()
-- --   .then(function(value) {
-- --     console.log('SUCCESS', value);
-- --   }, function(reason) {
-- --     console.log('ERROR', reason);
-- --   })
-- -- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
-- --   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- -- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
-- --
-- --     mnemonic <- liftEff Crypto.generateMnemonic
-- --     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
-- --     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
-- --     either throwError B.newWallet $ do
-- --         isConfirmed
-- --         mkCWalletInit wType wCurrency wName mnemonic
--
-- updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
-- updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
--     B.updateWallet
--         (mkCAddress addr)
--         $ mkCWalletMeta wType wCurrency wName wAssurance wUnit
--
-- updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
-- updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
--     B.updateTransaction
--         (mkCAddress addr)
--         (mkCTxId ctxId)
--         $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate
--
-- deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
-- deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress
--
-- isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
-- isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)
--
-- notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
-- notify = mkEffFn2 \messageCb errorCb -> do
--     -- TODO (akegalj) grab global (mutable) state of  here
--     -- instead of creating newRef
--     conn <- newRef WSNotConnected
--     openConn $ mkWSState conn messageCb errorCb
--
-- blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
-- blockchainSlotDuration = fromAff B.blockchainSlotDuration
--
-- restoreWallet :: forall eff. EffFn5 (ajax :: AJAX | eff) String String String String String (Promise Json)
-- restoreWallet = mkEffFn5 \wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase spendingPassword) <<< mkCWalletInit wType wCurrency wName
--
--
-- nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- nextUpdate = fromAff $ map encodeJson B.nextUpdate
--
-- applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
-- applyUpdate = fromAff B.applyUpdate
--
-- systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- systemVersion = fromAff $ map encodeJson B.systemVersion
--
-- redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
-- redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed
--
-- redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
-- redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic
--
-- reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
-- reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total
--
-- importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
-- importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey
--
-- syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
-- syncProgress = fromAff $ map encodeJson B.syncProgress
--
-- -- Valid redeem code is base64 encoded 32byte data
-- -- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
-- isValidRedemptionKey :: String -> Boolean
-- isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
--   where
--     -- Because it is 32byte base64 encoded
--     endsWithEqual = isJust $ stripSuffix (Pattern "=") code
--
-- -- Valid paper vend key is base58 encoded 32byte data
-- isValidPaperVendRedemptionKey :: String -> Boolean
-- isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code


Use HSL color

Use HSL color

module App.BoardView where

import App.FixedMatrix72 as FM
import App.Board (Pit, PitRef, Player, Board)
import App.FixedMatrix72 (Row(B, A))
import Prelude (bind, const, show, ($), (<>))
import Pux.CSS (Color, backgroundColor, em, hsl, lighten, padding, rotateHue, style)
import Pux.Html (Html, div, hr, span, text)
import Pux.Html.Events (onClick)

class BoardView a where
  getBoard :: a -> Board
  isPlaying :: a -> Player -> Boolean
  pitState :: a -> PitRef -> PitState

data PitState = Normal | Lifted | Captured | Sowed

pitStateColor :: PitState -> Color
pitStateColor = go
  where go Normal = hsl 200.0 1.0 0.3
        go Captured = rotateHue 300.0 $ go Lifted
        go Lifted = rotateHue 200.0 $ go Normal
        go Sowed = lighten 0.3 $ go Normal

view :: forall action state. BoardView state
     => (PitRef -> action) -> state -> Html action
view f state =
  div []
  [ viewStore state A
  , hr [] [] -- XXX: remove this ugly display hack
  , div [] $ viewRow A
  , hr [] [] -- XXX: remove this ugly display hack
  , div [] $ viewRow B
  , hr [] [] -- XXX: remove this ugly display hack
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = FM.mapRowWithIndex player viewCell' board.cells
      where viewCell' ref = viewCell state (f ref) ref

viewStore :: forall a state. BoardView state
          => state -> Row -> Html a
viewStore state player =
  div [css] [text $ "Player " <> show player]
    where css = style $ do
            backgroundColor color
            apply4 padding (em 0.5)
          color = if isPlaying state player
                  then pitStateColor Sowed
                  else pitStateColor Normal

viewCell :: forall a state. BoardView state
          => state -> a -> PitRef -> Pit -> Html a
viewCell state action ref count =
  span [css, event] [body]
  where
    body = text $ show count
    event = onClick $ const action
    css = style $ do
      backgroundColor color
      apply4 padding (em 0.9)
      where
        color = pitStateColor $ pitState state ref

apply4 :: forall a b. (a -> a -> a -> a -> b) -> a -> b
apply4 f a = f a a a a

module App.BoardView where

import App.FixedMatrix72 as FM
import App.Board (Pit, PitRef, Player, Board)
import App.FixedMatrix72 (Row(B, A))
import Prelude (bind, const, show, ($), (<<<), (<>))
import Pux.CSS (Color, backgroundColor, boxSizing, borderBox, display, em, inline, padding, rgb, style)
import Pux.Html (Html, div, hr, text, (#), (!))
import Pux.Html.Events (onClick)

class BoardView a where
  getBoard :: a -> Board
  isPlaying :: a -> Player -> Boolean
  pitState :: a -> PitRef -> PitState

data PitState = Normal | Lifted | Captured | Sowed

pitStateColor :: PitState -> Color
pitStateColor Normal = rgb 100 200 100
pitStateColor Captured = rgb 300 0 0
pitStateColor Lifted = rgb 200 200 300
pitStateColor Sowed = rgb 100 300 300

view :: forall action state. BoardView state
     => (PitRef -> action) -> state -> Html action
view f state =
  div []
  [ viewStore state A
  , hr [] [] -- XXX: remove this ugly display hack
  , div [] $ viewRow A
  , hr [] [] -- XXX: remove this ugly display hack
  , div [] $ viewRow B
  , hr [] [] -- XXX: remove this ugly display hack
  , viewStore state B
  ]
  where
    board = getBoard state
    viewRow player = FM.mapRowWithIndex player viewCell' board.cells
      where viewCell' ref = viewCell state (f ref) ref

viewStore :: forall a state. BoardView state
          => state -> Row -> Html a
viewStore state player =
  div ! css # text $ "Player " <> show player
    where css = style $ do
                  backgroundColor color
          color = if isPlaying state player
                  then focusColor
                  else rgb 198 34 112

viewCell :: forall a state. BoardView state
          => state -> a -> PitRef -> Pit -> Html a
viewCell state action ref count =
  div ! css ! event # body
  where
    body = text $ show count
    event = onClick $ const action
    css = style $ do
      display inline
      backgroundColor $ pitColor state ref
      squarePadding (em 1.0)
      boxSizing borderBox
      where
        squarePadding sz = padding sz sz sz sz

pitColor :: forall state. BoardView state
         => state -> PitRef -> Color
pitColor state = pitStateColor <<< pitState state

focusColor :: Color
focusColor = rgb 100 200 100