[CSE-92] Refactor loading management

[CSE-92] Refactor loading management

- to get `totalBlocks` before `latestBlocks`
- to subscribe `SubBlock` after `totalBlocks` has been loaded

module Explorer.Update where

import Prelude
import Control.Comonad (extract)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (nowDateTime, NOW)
import Control.SocketIO.Client (SocketIO, emit, emit')
import DOM (DOM)
import DOM.HTML.HTMLElement (blur)
import DOM.HTML.HTMLInputElement (select)
import Data.Array (difference, length, unionBy, (:))
import Data.Either (Either(..))
import Data.Foldable (traverse_)
import Data.Int (fromString)
import Data.Lens ((^.), over, set)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)
import Explorer.Api.Http (fetchAddressSummary, fetchBlockSummary, fetchBlockTxs, fetchLatestBlocks, fetchLatestTxs, fetchTotalBlocks, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
import Explorer.I18n.Lang (translate)
import Explorer.I18n.Lenses (common, cAddress, cBlock, cCalculator, cEpoch, cSlot, cTitle, cTransaction, notfound, nfTitle) as I18nL
import Explorer.Lenses.State (addressDetail, addressTxPagination, addressTxPaginationEditable, blockDetail, blockTxPagination, blockTxPaginationEditable, blocksViewState, blsViewPagination, blsViewPaginationEditable, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlockPaginationEditable, dbViewBlocksExpanded, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, globalViewState, handleLatestBlocksSocketResult, handleLatestTxsSocketResult, initialBlocksRequested, initialTxsRequested, lang, latestBlocks, latestTransactions, loading, route, socket, subscriptions, totalBlocks, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), SocketSubscription(..), State)
import Explorer.Util.DOM (targetToHTMLElement, targetToHTMLInputElement)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(..), _Success, isNotAsked, isSuccess)
import Pos.Explorer.Socket.Methods (ClientEvent(..), Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CAddressSummary, _CBlockEntry, _CHash, _CTxEntry, _CTxId, caAddress, cbeBlkHash, cteId)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.Router (navigateTo) as P

update :: forall eff. Action -> State ->
    EffModel State Action
    (dom :: DOM
    , ajax :: AJAX
    , socket :: SocketIO
    , now :: NOW
    -- , console :: CONSOLE
    | eff
    )

-- Language

update (SetLanguage lang) state = noEffects $ state { lang = lang }

-- Socket

update (SocketConnected connected') state =
    { state: set (socket <<< connected) connected' state
    , effects:
          [ if connected'
            then pure SocketReconnectSubscriptions
            else pure NoOp
          ]
    }

update (SocketBlocksUpdated (Right blocks)) state = noEffects $
    if state ^. handleLatestBlocksSocketResult
    -- add incoming blocks ahead of previous blocks
    then  over (latestBlocks <<< _Success) (\b -> blocks <> b) $
          -- update total number of blocks
          if isSuccess $ state ^. totalBlocks
          then over (totalBlocks <<< _Success) ((+) $ length blocks) state
          else state
    else state

update (SocketBlocksUpdated (Left error)) state = noEffects $
    set latestBlocks (Failure error) $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state
update (SocketTxsUpdated (Right transactions)) state = noEffects $
    -- add incoming transactions ahead of previous transactions
    over latestTransactions (\t -> transactions <> t) state
update (SocketTxsUpdated (Left error)) state = noEffects $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state
update SocketCallMe state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff <<< emit' socket' $ toEvent CallMe
              Nothing -> pure unit
          pure NoOp
    ]}
update (SocketCallMeString str) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emit socket' (toEvent CallMeString) str
              Nothing -> pure unit
          pure NoOp
    ]}
update (SocketCallMeCTxId id) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emit socket' (toEvent CallMeTxId) id
              Nothing -> pure unit
          pure NoOp
    ]}

update (SocketUpdateSubscriptions nextSubs) state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state: set (socket <<< subscriptions) nextSubs state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                -- 1. unsubscribe all not used events
                let diffNextFromCurrentSubs = difference currentSubs nextSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Unsubscribe <<< unwrap) diffNextFromCurrentSubs
                -- 2. subscribe all new subscriptions
                let diffCurrentFromNextSubs = difference nextSubs currentSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) diffCurrentFromNextSubs
              Nothing -> pure unit
          pure NoOp
    ]}

update SocketReconnectSubscriptions state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) currentSubs
              Nothing -> pure unit
          pure NoOp
    ]}

-- Dashboard

update (DashboardExpandBlocks expanded) state = noEffects $
    set (dashboardViewState <<< dbViewBlocksExpanded) expanded state

update (DashboardExpandTransactions expanded) state = noEffects $
    set (dashboardViewState <<< dbViewTxsExpanded) expanded state

update (DashboardPaginateBlocks value) state = noEffects $
    set (dashboardViewState <<< dbViewBlockPagination) value state

update (DashboardEditBlocksPageNumber target editable) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (DashboardInvalidBlocksPageNumber target) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) false state
    , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

update (DashboardShowAPICode code) state = noEffects $
    set (dashboardViewState <<< dbViewSelectedApiCode) code state

-- Address

update (AddressPaginateTxs value) state = noEffects $
    set (viewStates <<< addressDetail <<< addressTxPagination) value state

update (AddressEditTxsPageNumber target editable) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (AddressInvalidTxsPageNumber target) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) false state
      , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

-- Block

update (BlockPaginateTxs value) state = noEffects $
    set (viewStates <<< blockDetail <<< blockTxPagination) value state

update (BlockEditTxsPageNumber target editable) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (BlockInvalidTxsPageNumber target) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) false state
      , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

-- Blocks

update (BlocksPaginateBlocks value) state = noEffects $
    set (viewStates <<< blocksViewState <<< blsViewPagination) value state

update (BlocksEditBlocksPageNumber target editable) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (BlocksInvalidBlocksPageNumber target) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) false state
      , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

-- DOM side effects

update ScrollTop state =
    { state
    , effects:
        -- FIXME: scrollTop disabled as a workaround for socketio
        [ -- liftEff scrollTop >>= \_ -> pure NoOp
        ]
    }
update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> pure NoOp
        ]
    }
update (BlurElement elem) state =
    { state
    , effects:
        [ liftEff $ blur elem >>= \_ -> pure NoOp
        ]
    }
update (GenerateQrCode address) state =
    { state
    , effects:
        [ liftEff $ generateQrCode (address ^. _CAddress) addressQRImageId *> pure NoOp
        ]
    }

-- global state
update (GlobalToggleMobileMenu toggled) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) toggled state

update (GlobalFocusSearchInput value) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewSearchInputFocused) value state

update GlobalSearch state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchQuery) in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchQuery) emptySearchQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure $ GlobalFocusSearchInput false
      , case state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch) of
          SearchAddress ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Address $ mkCAddress query) *> pure NoOp
          SearchTx ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Tx $ mkCTxId query) *> pure NoOp
          _ -> pure NoOp  -- TODO (ks) maybe put up a message?
      ]
    }
update GlobalSearchTime state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) emptySearchTimeQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure $ GlobalFocusSearchInput false
      , case query of
            Tuple (Just epoch) (Just slot) ->
                let epochIndex = mkEpochIndex epoch
                    slotIndex  = mkLocalSlotIndex slot
                    epochSlotUrl = EpochSlot epochIndex slotIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochSlotUrl) *> pure NoOp
            Tuple (Just epoch) Nothing ->
                let epochIndex = mkEpochIndex epoch
                    epochUrl   = Epoch $ epochIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochUrl) *> pure NoOp

            _ -> pure NoOp -- TODO (ks) maybe put up a message?
      ]
    }

update (GlobalUpdateSelectedSearch search) state =
    noEffects $ set (viewStates <<< globalViewState <<< gViewSelectedSearch) search state

update (GlobalUpdateSearchValue search) state =
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchQuery) search state

update (GlobalUpdateSearchEpochValue value) state =
    let slot = snd $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
        epoch = fromString value
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

update (GlobalUpdateSearchSlotValue value) state =
    let slot = fromString value
        epoch = fst $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

-- NoOp

update NoOp state = noEffects state

-- http endpoints

update RequestTotalBlocks state =
    { state:
          set totalBlocks Loading $ state
    , effects:
          [ attempt fetchTotalBlocks >>= pure <<< ReceiveTotalBlocks
          ]
    }

update (ReceiveTotalBlocks (Right total)) state =
    { state:
          set totalBlocks (Success total) $ state
    , effects:
        -- request `latestBlocks` if needed
        if isNotAsked $ state ^. latestBlocks
        then [ pure RequestInitialBlocks ]
        else []
    }

update (ReceiveTotalBlocks (Left error)) state =
    noEffects $
    set totalBlocks (Failure error)
    $ over errors (\errors' -> (show error) : errors') state

update RequestInitialBlocks state =
    { state: set loading true $ state
    , effects: [ attempt fetchLatestBlocks >>= pure <<< ReceiveInitialBlocks ]
    }

update (ReceiveInitialBlocks (Right blocks)) state =
    { state:
          set loading false <<<
          set initialBlocksRequested true <<<
          set handleLatestBlocksSocketResult true $
          -- add blocks
          over latestBlocks (\lBlocks -> if isSuccess lBlocks
                                            -- union blocks together
                                            then Success $ unionBlocks blocks (lBlocks ^. _Success)
                                            else Success blocks
                            )
          -- update total number of blocks
          $ if isSuccess $ state ^. totalBlocks
                then over (totalBlocks <<< _Success)
                          ((+) $ length $ unionBlocks blocks (state ^. (latestBlocks <<< _Success)))
                          state
                else state
    , effects:
        -- add subscription of `SubBlock` if we are on `Dashboard` only
        if (state ^. route) == Dashboard
        then [ pure $ SocketUpdateSubscriptions [ SocketSubscription SubBlock ] ]
        else []
    }
    where
        getHash block = block ^. (_CBlockEntry <<< cbeBlkHash <<< _CHash)
        -- Note:  To "union" current with new blocks we have to compare CBlockEntry
        --        Because we don't have an Eq instance of generated CBlockEntry's
        --        As a workaround we do have to compare CBlockEntry by its hash
        unionBlocks = unionBy (\b1 b2 -> getHash b1 == getHash b2)

update (ReceiveInitialBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set initialBlocksRequested true <<<
    set handleLatestBlocksSocketResult true $
    set latestBlocks (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockSummary hash) state =
    { state: set loading true $ state
    , effects: [ attempt (fetchBlockSummary hash) >>= pure <<< ReceiveBlockSummary ]
    }
update (ReceiveBlockSummary (Right blockSummary)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Just blockSummary) state
update (ReceiveBlockSummary (Left error)) state =
    noEffects $
    set loading false $
    over errors (\errors' -> (show error) : errors') state

-- Epoch, slot

update (RequestSearchBlocks epoch slot) state =
    { state:
          set loading true $
          set currentBlocksResult Loading $
          state
    , effects: [ attempt (searchEpoch epoch slot) >>= pure <<< ReceiveSearchBlocks ]
    }
update (ReceiveSearchBlocks (Right blocks)) state =
    noEffects $
    set loading false <<<
    set currentBlocksResult (Success blocks) $
    state

update (ReceiveSearchBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set currentBlocksResult (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockTxs hash) state =
    { state: set loading true $ state
    , effects: [ attempt (fetchBlockTxs hash) >>= pure <<< ReceiveBlockTxs ]
    }
update (ReceiveBlockTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set currentBlockTxs (Just txs) $
    state
update (ReceiveBlockTxs (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockTxs Nothing $
    over errors (\errors' -> (show error) : errors') state
update RequestInitialTxs state =
    { state: set loading true state
    , effects: [ attempt fetchLatestTxs >>= pure <<< ReceiveInitialTxs ]
    }
update (ReceiveInitialTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over latestTransactions (\t -> unionTxs txs t)
    state
    where
      getId tx = tx ^. (_CTxEntry <<< cteId <<< _CTxId <<< _CHash)
      -- Note: Because we don't have an Eq instance of generated CTxEntry
      unionTxs = unionBy (\tx1 tx2 -> getId tx1 == getId tx2)

update (ReceiveInitialTxs (Left error)) state = noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over errors (\errors' -> (show error) : errors') state

update (RequestTxSummary id) state =
    { state: set loading true state
    , effects: [ attempt (fetchTxSummary id) >>= pure <<< ReceiveTxSummary ]
    }
update (ReceiveTxSummary (Right tx)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Success tx) state
update (ReceiveTxSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestAddressSummary address) state =
    { state: set loading true state
    , effects: [ attempt (fetchAddressSummary address) >>= pure <<< ReceiveAddressSummary ]
    }
update (ReceiveAddressSummary (Right address)) state =
    { state:
        set loading false $
        set currentAddressSummary (Success address) state
    , effects:
        [ pure $ GenerateQrCode $ address ^. (_CAddressSummary <<< caAddress) ]
    }
update (ReceiveAddressSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentAddressSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

-- clock
update UpdateClock state = onlyEffects state $
    [ do
         SetClock <<< extract <$> liftEff nowDateTime
    ]
update (SetClock date) state = noEffects $ state { now = date }

-- socket-io workaround
update Reload state = update (UpdateView state.route) state

-- routing

update (UpdateView route) state = routeEffects route (state { route = route })

routeEffects :: forall eff. Route -> State -> EffModel State Action (dom :: DOM
    , ajax :: AJAX | eff)
routeEffects Dashboard state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions
                    [ SocketSubscription SubTx
                    ]
        , pure RequestInitialTxs
        ]
        -- get `totalBlocks` only once
        <>  if isNotAsked $ state ^. totalBlocks
            then [ pure RequestTotalBlocks ]
            else []
        -- request `latestBlocks` only if `totalBlocks` has been loaded before
        <>  if (isSuccess $ state ^. totalBlocks) && (isNotAsked $ state ^. latestBlocks)
            then [ pure RequestInitialBlocks ]
            else []
        -- subscribe to `SubBlock` if `latestBlocks` has been loaded before
        <>  if isSuccess $ state ^. latestBlocks
            then [ pure $ SocketUpdateSubscriptions [ SocketSubscription SubBlock ] ]
            else []
    }

routeEffects (Tx tx) state =
    { state:
        set currentTxSummary Loading $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTransaction) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        , pure $ RequestTxSummary tx
        ]
    }

routeEffects (Address cAddress) state =
    { state:
        set currentAddressSummary Loading $
        set currentCAddress cAddress $
        set (viewStates <<< addressDetail <<< addressTxPagination) minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cAddress) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        , pure $ RequestAddressSummary cAddress
        ]
    }

routeEffects (Epoch epochIndex) state =
    { state:
        set (viewStates <<< blocksViewState <<< blsViewPagination)
            minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cEpoch) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex Nothing
        ]
    }

routeEffects (EpochSlot epochIndex slotIndex) state =
    let lang' = state ^. lang
        epochTitle = translate (I18nL.common <<< I18nL.cEpoch) lang'
        slotTitle = translate (I18nL.common <<< I18nL.cSlot) lang'
    in
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (epochTitle <> " / " <> slotTitle)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex (Just slotIndex)
        ]
    }

routeEffects Calculator state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cCalculator) $ state ^. lang)
            state
    , effects: [ pure ScrollTop ]
    }

routeEffects (Block hash) state =
    { state:
        set currentBlockSummary Nothing $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cBlock) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        , pure $ RequestBlockSummary hash
        , pure $ RequestBlockTxs hash
        ]
    }

routeEffects Playground state =
    { state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        ]
    }

routeEffects NotFound state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.notfound <<< I18nL.nfTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        ]
    }

module Explorer.Update where

import Prelude
import Control.Comonad (extract)
import Control.Monad.Aff (attempt)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Now (nowDateTime, NOW)
import Control.SocketIO.Client (SocketIO, emit, emit')
import DOM (DOM)
import DOM.HTML.HTMLElement (blur)
import DOM.HTML.HTMLInputElement (select)
import Data.Array (difference, unionBy, (:))
import Data.Either (Either(..))
import Data.Foldable (traverse_)
import Data.Int (fromString)
import Data.Lens ((^.), over, set)
import Data.Maybe (Maybe(..))
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..), fst, snd)
import Explorer.Api.Http (fetchAddressSummary, fetchBlockSummary, fetchBlockTxs, fetchLatestBlocks, fetchLatestTxs, fetchTotalBlocks, fetchTxSummary, searchEpoch)
import Explorer.Api.Socket (toEvent)
import Explorer.I18n.Lang (translate)
import Explorer.I18n.Lenses (common, cAddress, cBlock, cCalculator, cEpoch, cSlot, cTitle, cTransaction, notfound, nfTitle) as I18nL
import Explorer.Lenses.State (addressDetail, addressTxPagination, addressTxPaginationEditable, blockDetail, blockTxPagination, blockTxPaginationEditable, blocksViewState, blsViewPagination, blsViewPaginationEditable, connected, connection, currentAddressSummary, currentBlockSummary, currentBlockTxs, currentBlocksResult, currentCAddress, currentTxSummary, dbViewBlockPagination, dbViewBlockPaginationEditable, dbViewBlocksExpanded, dbViewSelectedApiCode, dbViewTxsExpanded, errors, gViewMobileMenuOpenend, gViewSearchInputFocused, gViewSearchQuery, gViewSearchTimeQuery, gViewSelectedSearch, gViewTitle, globalViewState, handleLatestBlocksSocketResult, handleLatestTxsSocketResult, initialBlocksRequested, initialTxsRequested, lang, latestBlocks, latestTransactions, loading, socket, subscriptions, totalBlocks, viewStates)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (addressQRImageId, emptySearchQuery, emptySearchTimeQuery, minPagination)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (Search(..), SocketSubscription(..), State)
import Explorer.Util.DOM (targetToHTMLElement, targetToHTMLInputElement)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkEpochIndex, mkLocalSlotIndex)
import Explorer.Util.QrCode (generateQrCode)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.HTTP.Affjax (AJAX)
import Network.RemoteData (RemoteData(..), _Success)
import Pos.Explorer.Socket.Methods (ClientEvent(..), Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddress, _CAddressSummary, _CBlockEntry, _CHash, _CTxEntry, _CTxId, caAddress, cbeBlkHash, cteId)
import Pux (EffModel, noEffects, onlyEffects)
import Pux.Router (navigateTo) as P

update :: forall eff. Action -> State ->
    EffModel State Action
    (dom :: DOM
    , ajax :: AJAX
    , socket :: SocketIO
    , now :: NOW
    -- , console :: CONSOLE
    | eff
    )

-- Language

update (SetLanguage lang) state = noEffects $ state { lang = lang }

-- Socket

update (SocketConnected connected') state =
    { state: set (socket <<< connected) connected' state
    , effects:
          [ if connected'
            then pure SocketReconnectSubscriptions
            else pure NoOp
          ]
    }
update (SocketBlocksUpdated (Right blocks)) state = noEffects $
    if state ^. handleLatestBlocksSocketResult
    -- add incoming blocks ahead of previous blocks
    then over (latestBlocks <<< _Success) (\b -> blocks <> b) state
    else state
update (SocketBlocksUpdated (Left error)) state = noEffects $
    set latestBlocks (Failure error) $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state
update (SocketTxsUpdated (Right transactions)) state = noEffects $
    -- add incoming transactions ahead of previous transactions
    over latestTransactions (\t -> transactions <> t) state
update (SocketTxsUpdated (Left error)) state = noEffects $
    -- add incoming errors ahead of previous errors
    over errors (\errors' -> (show error) : errors') state
update SocketCallMe state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff <<< emit' socket' $ toEvent CallMe
              Nothing -> pure unit
          pure NoOp
    ]}
update (SocketCallMeString str) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emit socket' (toEvent CallMeString) str
              Nothing -> pure unit
          pure NoOp
    ]}
update (SocketCallMeCTxId id) state =
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> liftEff $ emit socket' (toEvent CallMeTxId) id
              Nothing -> pure unit
          pure NoOp
    ]}

update (SocketUpdateSubscriptions nextSubs) state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state: set (socket <<< subscriptions) nextSubs state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                -- 1. unsubscribe all not used events
                let diffNextFromCurrentSubs = difference currentSubs nextSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Unsubscribe <<< unwrap) diffNextFromCurrentSubs
                -- 2. subscribe all new subscriptions
                let diffCurrentFromNextSubs = difference nextSubs currentSubs
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) diffCurrentFromNextSubs
              Nothing -> pure unit
          pure NoOp
    ]}

update SocketReconnectSubscriptions state =
    let currentSubs = state ^. socket <<< subscriptions in
    { state
    , effects : [ do
          _ <- case state ^. (socket <<< connection) of
              Just socket' -> do
                traverse_ (liftEff <<< emit' socket' <<< toEvent <<< Subscribe <<< unwrap) currentSubs
              Nothing -> pure unit
          pure NoOp
    ]}

-- Dashboard

update (DashboardExpandBlocks expanded) state = noEffects $
    set (dashboardViewState <<< dbViewBlocksExpanded) expanded state

update (DashboardExpandTransactions expanded) state = noEffects $
    set (dashboardViewState <<< dbViewTxsExpanded) expanded state

update (DashboardPaginateBlocks value) state = noEffects $
    set (dashboardViewState <<< dbViewBlockPagination) value state

update (DashboardEditBlocksPageNumber target editable) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (DashboardInvalidBlocksPageNumber target) state =
    { state:
          set (dashboardViewState <<< dbViewBlockPaginationEditable) false state
    , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

update (DashboardShowAPICode code) state = noEffects $
    set (dashboardViewState <<< dbViewSelectedApiCode) code state

-- Address

update (AddressPaginateTxs value) state = noEffects $
    set (viewStates <<< addressDetail <<< addressTxPagination) value state

update (AddressEditTxsPageNumber target editable) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (AddressInvalidTxsPageNumber target) state =
    { state:
          set (viewStates <<< addressDetail <<< addressTxPaginationEditable) false state
      , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

-- Block

update (BlockPaginateTxs value) state = noEffects $
    set (viewStates <<< blockDetail <<< blockTxPagination) value state

update (BlockEditTxsPageNumber target editable) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (BlockInvalidTxsPageNumber target) state =
    { state:
          set (viewStates <<< blockDetail <<< blockTxPaginationEditable) false state
      , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

-- Blocks

update (BlocksPaginateBlocks value) state = noEffects $
    set (viewStates <<< blocksViewState <<< blsViewPagination) value state

update (BlocksEditBlocksPageNumber target editable) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) editable state
    , effects:
          [ if editable
            then pure $ SelectInputText $ targetToHTMLInputElement target
            else pure NoOp
          ]
    }

update (BlocksInvalidBlocksPageNumber target) state =
    { state:
          set (viewStates <<< blocksViewState <<< blsViewPaginationEditable) false state
      , effects:
          [ pure $ BlurElement $ targetToHTMLElement target
          ]
    }

-- DOM side effects

update ScrollTop state =
    { state
    , effects:
        -- FIXME: scrollTop disabled as a workaround for socketio
        [ -- liftEff scrollTop >>= \_ -> pure NoOp
        ]
    }
update (SelectInputText input) state =
    { state
    , effects:
        [ liftEff $ select input >>= \_ -> pure NoOp
        ]
    }
update (BlurElement elem) state =
    { state
    , effects:
        [ liftEff $ blur elem >>= \_ -> pure NoOp
        ]
    }
update (GenerateQrCode address) state =
    { state
    , effects:
        [ liftEff $ generateQrCode (address ^. _CAddress) addressQRImageId *> pure NoOp
        ]
    }

-- global state
update (GlobalToggleMobileMenu toggled) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) toggled state

update (GlobalFocusSearchInput value) state = noEffects $
    set (viewStates <<< globalViewState <<< gViewSearchInputFocused) value state

update GlobalSearch state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchQuery) in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchQuery) emptySearchQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure $ GlobalFocusSearchInput false
      , case state ^. (viewStates <<< globalViewState <<< gViewSelectedSearch) of
          SearchAddress ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Address $ mkCAddress query) *> pure NoOp
          SearchTx ->
              (liftEff <<< P.navigateTo <<< toUrl <<< Tx $ mkCTxId query) *> pure NoOp
          _ -> pure NoOp  -- TODO (ks) maybe put up a message?
      ]
    }
update GlobalSearchTime state =
    let query = state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    { state:
          set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) emptySearchTimeQuery $
          set (viewStates <<< globalViewState <<< gViewMobileMenuOpenend) false $
          state
    , effects: [
      -- set state of focus explicitly
      pure $ GlobalFocusSearchInput false
      , case query of
            Tuple (Just epoch) (Just slot) ->
                let epochIndex = mkEpochIndex epoch
                    slotIndex  = mkLocalSlotIndex slot
                    epochSlotUrl = EpochSlot epochIndex slotIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochSlotUrl) *> pure NoOp
            Tuple (Just epoch) Nothing ->
                let epochIndex = mkEpochIndex epoch
                    epochUrl   = Epoch $ epochIndex
                in
                (liftEff <<< P.navigateTo <<< toUrl $ epochUrl) *> pure NoOp

            _ -> pure NoOp -- TODO (ks) maybe put up a message?
      ]
    }

update (GlobalUpdateSelectedSearch search) state =
    noEffects $ set (viewStates <<< globalViewState <<< gViewSelectedSearch) search state

update (GlobalUpdateSearchValue search) state =
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchQuery) search state

update (GlobalUpdateSearchEpochValue value) state =
    let slot = snd $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
        epoch = fromString value
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

update (GlobalUpdateSearchSlotValue value) state =
    let slot = fromString value
        epoch = fst $ state ^. (viewStates <<< globalViewState <<< gViewSearchTimeQuery)
    in
    noEffects $ set (viewStates <<< globalViewState <<< gViewSearchTimeQuery) (Tuple epoch slot) state

-- NoOp

update NoOp state = noEffects state

-- http endpoints

update RequestTotalBlocks state =
    { state:
          set totalBlocks Loading $ state
    , effects:
          [ attempt fetchTotalBlocks >>= pure <<< ReceiveTotalBlocks
          ]
    }

update (ReceiveTotalBlocks (Right total)) state =
    noEffects $
    set totalBlocks (Success total) $ state

update (ReceiveTotalBlocks (Left error)) state =
    noEffects $
    set totalBlocks (Failure error)
    $ over errors (\errors' -> (show error) : errors') state

update RequestInitialBlocks state =
    { state: set loading true $ state
    , effects: [ attempt fetchLatestBlocks >>= pure <<< ReceiveInitialBlocks ]
    }

update (ReceiveInitialBlocks (Right blocks)) state =
    noEffects $
    set loading false <<<
    set initialBlocksRequested true <<<
    set handleLatestBlocksSocketResult true $
    over latestBlocks (\b -> case b of
                                  (Success b') -> Success $ unionBlocks blocks b'
                                  _ -> Success blocks
                      )
    state
    where
      getHash block = block ^. (_CBlockEntry <<< cbeBlkHash <<< _CHash)
      -- Note: Because we don't have an Eq instance of generated CBlockEntry
      unionBlocks = unionBy (\b1 b2 -> getHash b1 == getHash b2)

update (ReceiveInitialBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set initialBlocksRequested true <<<
    set handleLatestBlocksSocketResult true $
    set latestBlocks (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockSummary hash) state =
    { state: set loading true $ state
    , effects: [ attempt (fetchBlockSummary hash) >>= pure <<< ReceiveBlockSummary ]
    }
update (ReceiveBlockSummary (Right blockSummary)) state =
    noEffects $
    set loading false $
    set currentBlockSummary (Just blockSummary) state
update (ReceiveBlockSummary (Left error)) state =
    noEffects $
    set loading false $
    over errors (\errors' -> (show error) : errors') state

-- Epoch, slot

update (RequestSearchBlocks epoch slot) state =
    { state:
          set loading true $
          set currentBlocksResult Loading $
          state
    , effects: [ attempt (searchEpoch epoch slot) >>= pure <<< ReceiveSearchBlocks ]
    }
update (ReceiveSearchBlocks (Right blocks)) state =
    noEffects $
    set loading false <<<
    set currentBlocksResult (Success blocks) $
    state

update (ReceiveSearchBlocks (Left error)) state =
    noEffects $
    set loading false <<<
    set currentBlocksResult (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestBlockTxs hash) state =
    { state: set loading true $ state
    , effects: [ attempt (fetchBlockTxs hash) >>= pure <<< ReceiveBlockTxs ]
    }
update (ReceiveBlockTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set currentBlockTxs (Just txs) $
    state
update (ReceiveBlockTxs (Left error)) state =
    noEffects $
    set loading false $
    set currentBlockTxs Nothing $
    over errors (\errors' -> (show error) : errors') state
update RequestInitialTxs state =
    { state: set loading true state
    , effects: [ attempt fetchLatestTxs >>= pure <<< ReceiveInitialTxs ]
    }
update (ReceiveInitialTxs (Right txs)) state =
    noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over latestTransactions (\t -> unionTxs txs t)
    state
    where
      getId tx = tx ^. (_CTxEntry <<< cteId <<< _CTxId <<< _CHash)
      -- Note: Because we don't have an Eq instance of generated CTxEntry
      unionTxs = unionBy (\tx1 tx2 -> getId tx1 == getId tx2)

update (ReceiveInitialTxs (Left error)) state = noEffects $
    set loading false <<<
    set initialTxsRequested true <<<
    set handleLatestTxsSocketResult true $
    over errors (\errors' -> (show error) : errors') state

update (RequestTxSummary id) state =
    { state: set loading true state
    , effects: [ attempt (fetchTxSummary id) >>= pure <<< ReceiveTxSummary ]
    }
update (ReceiveTxSummary (Right tx)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Success tx) state
update (ReceiveTxSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentTxSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

update (RequestAddressSummary address) state =
    { state: set loading true state
    , effects: [ attempt (fetchAddressSummary address) >>= pure <<< ReceiveAddressSummary ]
    }
update (ReceiveAddressSummary (Right address)) state =
    { state:
        set loading false $
        set currentAddressSummary (Success address) state
    , effects:
        [ pure $ GenerateQrCode $ address ^. (_CAddressSummary <<< caAddress) ]
    }
update (ReceiveAddressSummary (Left error)) state =
    noEffects $
    set loading false $
    set currentAddressSummary (Failure error) $
    over errors (\errors' -> (show error) : errors') state

-- clock
update UpdateClock state = onlyEffects state $
    [ do
         SetClock <<< extract <$> liftEff nowDateTime
    ]
update (SetClock date) state = noEffects $ state { now = date }

-- socket-io workaround
update Reload state = update (UpdateView state.route) state

-- routing

update (UpdateView route) state = routeEffects route (state { route = route })

routeEffects :: forall eff. Route -> State -> EffModel State Action (dom :: DOM
    , ajax :: AJAX | eff)
routeEffects Dashboard state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions [ SocketSubscription SubBlock, SocketSubscription SubTx ]
        , pure RequestInitialBlocks
        , pure RequestInitialTxs
        , case state ^. totalBlocks of
              NotAsked -> pure RequestTotalBlocks
              _ -> pure NoOp
        ]
    }

routeEffects (Tx tx) state =
    { state:
        set currentTxSummary Loading $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cTransaction) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        , pure $ RequestTxSummary tx
        ]
    }

routeEffects (Address cAddress) state =
    { state:
        set currentAddressSummary Loading $
        set currentCAddress cAddress $
        set (viewStates <<< addressDetail <<< addressTxPagination) minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cAddress) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        , pure $ RequestAddressSummary cAddress
        ]
    }

routeEffects (Epoch epochIndex) state =
    { state:
        set (viewStates <<< blocksViewState <<< blsViewPagination)
            minPagination $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cEpoch) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex Nothing
        ]
    }

routeEffects (EpochSlot epochIndex slotIndex) state =
    let lang' = state ^. lang
        epochTitle = translate (I18nL.common <<< I18nL.cEpoch) lang'
        slotTitle = translate (I18nL.common <<< I18nL.cSlot) lang'
    in
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (epochTitle <> " / " <> slotTitle)
            state
    , effects:
        [ pure ScrollTop
        , pure $ RequestSearchBlocks epochIndex (Just slotIndex)
        ]
    }

routeEffects Calculator state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cCalculator) $ state ^. lang)
            state
    , effects: [ pure ScrollTop ]
    }

routeEffects (Block hash) state =
    { state:
        set currentBlockSummary Nothing $
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.common <<< I18nL.cBlock) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        , pure $ RequestBlockSummary hash
        , pure $ RequestBlockTxs hash
        ]
    }

routeEffects Playground state =
    { state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        ]
    }

routeEffects NotFound state =
    { state:
        set (viewStates <<< globalViewState <<< gViewTitle)
            (translate (I18nL.notfound <<< I18nL.nfTitle) $ state ^. lang)
            state
    , effects:
        [ pure ScrollTop
        , pure $ SocketUpdateSubscriptions []
        ]
    }


[CSM-257] Fix error message

[CSM-257] Fix error message

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , mkCProfile
       , _ctxIdValue
       , showCCurrency
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have at least " <> show len <> " words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

showCCurrency :: CT.CCurrency -> String
showCCurrency = dropModuleName <<< gShow
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split dot

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = _address r.cwaWSAddress <> "@" <> toString r.cwaIndex

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

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

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCoin: amount }

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

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

mkCWAssurance :: String -> CT.CWalletAssurance
mkCWAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> String -> Int -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName wAssurance wUnit =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   , cwAssurance: mkCWAssurance wAssurance
                   , cwUnit: wUnit
                   }

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> String -> String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wType wCurrency wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wType wCurrency wName "CWANormal" 0 -- FIXME: don't use string!
                   }

mkCWalletSetInit :: String -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta: CWalletSetMeta {cwsName: wSetName }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

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

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

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

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale

module Daedalus.Types
       ( module CT
       , module C
       , module E
       , module BP
       , module DT
       , _address
       , _ccoin
       , _passPhrase
       , mkCCoin
       , mkCAddress
       , mkCWalletMeta
       , mkCWalletInit
       , mkCTxMeta
       , mkCTxId
       , mkCCurrency
       , mkCProfile
       , _ctxIdValue
       , showCCurrency
       , mkBackupPhrase
       , mkCWalletRedeem
       , mkCPaperVendWalletRedeem
       , mkCInitialized
       , mkCPassPhrase
       , emptyCPassPhrase
       , getProfileLocale
       , walletAddressToUrl
       , mkCWalletSetInit
       ) where

import Prelude

import Pos.Wallet.Web.ClientTypes (CAddress (..), CHash (..), CPassPhrase (..), CCoin (..), WS (..), CWalletAddress (..), CWalletSetMeta (..))

import Pos.Wallet.Web.ClientTypes as CT
import Pos.Core.Types as C
import Pos.Wallet.Web.Error as E
import Pos.Util.BackupPhrase (BackupPhrase (..))
import Pos.Util.BackupPhrase as BP

import Control.Monad.Eff.Exception (error, Error)
import Data.Either (either, Either (..))
import Data.Maybe (Maybe (..))
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Argonaut.Core (fromString)
import Data.Generic (gShow)
import Data.Array.Partial (last)
import Data.Array (length, filter)
import Partial.Unsafe (unsafePartial)
import Data.String (split, null, trim, joinWith, Pattern (..))

import Daedalus.Crypto (isValidMnemonic, blake2b, bytesToB16)
import Data.Types (mkTime)
import Data.Types as DT
import Data.Int53 (fromInt, toString)

space :: Pattern
space = Pattern " "

dot :: Pattern
dot = Pattern "."

backupMnemonicLen :: Int
backupMnemonicLen = 12

paperVendMnemonicLen :: Int
paperVendMnemonicLen = 9

mkBackupPhrase :: Int -> String -> Either Error BackupPhrase
mkBackupPhrase len mnemonic = mkBackupPhraseIgnoreChecksum len mnemonic >>= const do
    if not $ isValidMnemonic mnemonicCleaned
        then Left $ error "Invalid mnemonic: checksum missmatch"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    mnemonicCleaned = cleanMnemonic mnemonic

cleanMnemonic :: String -> String
cleanMnemonic = joinWith " " <<< filter (not <<< null) <<< split space <<< trim

mkBackupPhraseIgnoreChecksum :: Int -> String -> Either Error BackupPhrase
mkBackupPhraseIgnoreChecksum len mnemonic =
    if not $ hasExactlyNwords len mnemonicCleaned
        then Left $ error "Invalid mnemonic: mnemonic should have at least 12 words"
        else Right $ BackupPhrase { bpToList: split space mnemonicCleaned }
  where
    hasExactlyNwords len' = (==) len' <<< length <<< split space
    mnemonicCleaned = cleanMnemonic mnemonic

showCCurrency :: CT.CCurrency -> String
showCCurrency = dropModuleName <<< gShow
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split dot

-- TODO: it would be useful to extend purescript-bridge
-- and generate lenses
walletAddressToUrl :: CWalletAddress -> String
walletAddressToUrl (CWalletAddress r) = _address r.cwaWSAddress <> "@" <> toString r.cwaIndex

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

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

_passPhrase :: CPassPhrase -> String
_passPhrase (CPassPhrase p) = p

emptyCPassPhrase :: CPassPhrase
emptyCPassPhrase = CPassPhrase ""

mkCPassPhrase :: String -> Maybe CPassPhrase
mkCPassPhrase "" = Nothing
mkCPassPhrase pass = Just <<< CPassPhrase <<< bytesToB16 $ blake2b pass

mkCAddress :: forall a. String -> CAddress a
mkCAddress = CAddress <<< CHash

_ccoin :: CCoin -> String
_ccoin (CCoin c) = c.getCoin

mkCCoin :: String -> CCoin
mkCCoin amount = CCoin { getCoin: amount }

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

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

mkCWAssurance :: String -> CT.CWalletAssurance
mkCWAssurance = either (const CT.CWANormal) id <<< decodeJson <<< fromString

mkCWalletMeta :: String -> String -> String -> String -> Int -> CT.CWalletMeta
mkCWalletMeta wType wCurrency wName wAssurance wUnit =
    CT.CWalletMeta { cwType: mkCWalletType wType
                   , cwCurrency: mkCCurrency wCurrency
                   , cwName: wName
                   , cwAssurance: mkCWAssurance wAssurance
                   , cwUnit: wUnit
                   }

mkCInitialized :: Int -> Int -> CT.CInitialized
mkCInitialized total preInit =
    CT.CInitialized { cTotalTime: fromInt total
                    , cPreInit: fromInt preInit
                    }

mkCWalletInit :: String -> String -> String -> CAddress WS -> CT.CWalletInit
mkCWalletInit wType wCurrency wName wSetId =
    CT.CWalletInit { cwInitWSetId: wSetId
                   , cwInitMeta: mkCWalletMeta wType wCurrency wName "CWANormal" 0 -- FIXME: don't use string!
                   }

mkCWalletSetInit :: String -> String -> Either Error CT.CWalletSetInit
mkCWalletSetInit wSetName mnemonic = do
    bp <- mkBackupPhrase backupMnemonicLen mnemonic
    pure $ CT.CWalletSetInit { cwsInitMeta: CWalletSetMeta {cwsName: wSetName }
                             , cwsBackupPhrase: bp
                             }

mkCWalletRedeem :: String -> CWalletAddress -> CT.CWalletRedeem
mkCWalletRedeem seed wAddress = do
    CT.CWalletRedeem { crWalletId: wAddress
                     , crSeed: seed
                     }

mkCPaperVendWalletRedeem :: String -> String -> CWalletAddress -> Either Error CT.CPaperVendWalletRedeem
mkCPaperVendWalletRedeem seed mnemonic wAddress = do
    bp <- mkBackupPhrase paperVendMnemonicLen mnemonic
    pure $ CT.CPaperVendWalletRedeem { pvWalletId: wAddress
                                     , pvBackupPhrase: bp
                                     , pvSeed: seed
                                     }

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

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

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

mkCProfile :: String -> CT.CProfile
mkCProfile locale =
    CT.CProfile { cpLocale: locale
                }

getProfileLocale :: CT.CProfile -> String
getProfileLocale (CT.CProfile r) = r.cpLocale


Focus when creating new decks (#863)

Focus when creating new decks (#863)

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Component
  ( draftboardComponent
  , module SlamData.Workspace.Card.Draftboard.Component.Query
  , module SlamData.Workspace.Card.Draftboard.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)

import Data.Array as Array
import Data.Function (on)
import Data.Lens ((.~), (?~))
import Data.List as List
import Data.Map as Map
import CSS as CSS

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils.Drag as Drag
import Halogen.Component.Utils (raise')
import Halogen.CustomEvents (mouseEventToPageEvent)
import Halogen.HTML.CSS.Indexed as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Math (round, floor)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph, unsafeUpdateCachedDraftboard)
import SlamData.Workspace.Card.Draftboard.Component.CSS as CCSS
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..), QueryP, QueryC)
import SlamData.Workspace.Card.Draftboard.Component.State (State, DeckPosition, initialState, encode, decode, _moving, _inserting, _grouping, modelFromState)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Deck.Common (wrappedDeck, defaultPosition, DeckOptions)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString, freshDeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Wiring (putDeck)

import Utils.CSS (zIndex)
import Utils.DOM (elementEq, scrollTop, scrollLeft, getOffsetClientRect)

type DraftboardDSL = H.ParentDSL State DNS.State QueryC DNQ.QueryP Slam DeckId

type DraftboardHTML = H.ParentHTML DNS.State QueryC DNQ.QueryP Slam DeckId

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

render ∷ CardOptions → State → DraftboardHTML
render opts state =
  HH.div_
    [ HH.div [ HP.class_ CCSS.insetShadow ] []
    , HH.div
        [ HP.class_ CCSS.grid
        , HC.style bgSize
        , HP.ref (right ∘ H.action ∘ SetElement)
        , HE.onClick \e → pure $
            guard (AT.isEditable opts.deck.accessType && not state.inserting) $>
            right (H.action $ AddDeck e)
        ]
        $ map renderDeck (foldl Array.snoc [] $ Map.toList state.decks)
    ]

  where
  renderDeck (deckId × rect) =
    HH.div
      [ HP.key $ deckIdToString deckId
      , HP.classes $
          case state.grouping of
            Just deckId' | deckId == deckId' → [ HH.className "grouping" ]
            _ → []
      , HC.style $
          case state.moving of
            Just (deckId' × rect') | deckId == deckId' → zIndex 2 *> cssPos rect'
            _ → cssPos rect
      ]
      [ HH.slot deckId $ mkDeckComponent deckId ]

  mkDeckComponent id _ =
    { component: opts.deckComponent (opaqueState $ DCS.initialDeck opts.deck.path id)
    , initialState: DNS.initialState
    }

  cssPos rect = do
    CSS.position CSS.absolute
    CSS.top $ CSS.px $ gridToPx rect.y
    CSS.left $ CSS.px $ gridToPx rect.x
    CSS.width $ CSS.px $ gridToPx rect.width
    CSS.height $ CSS.px $ gridToPx rect.height

  bgSize = do
    let size = foldr maxSize { width: 0.0, height: 0.0 } state.decks
        size' = maybe size (flip maxSize size ∘ snd) state.moving
    CSS.width $ CSS.px $ gridToPx $ size'.width + 1.0
    CSS.height $ CSS.px $ gridToPx $ size'.height + 1.0

evalCard ∷ Natural CC.CardEvalQuery DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify _ { decks = model.decks }
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Natural Query DraftboardDSL
evalBoard opts = case _ of
  Grabbing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        st ← H.get
        for_ (Map.lookup deckId (st.decks)) \rect →
        for_ st.canvas \el → do
          coords ← pageToGrid d el
          let
            cursorRect =
              { x: coords.x
              , y: coords.y
              , width: 1.0
              , height: 1.0
              }
            newRect = clampDeck rect
              { x = rect.x + (pxToGrid d.offsetX)
              , y = rect.y + (pxToGrid d.offsetY)
              }
            grouping =
              case overlapping cursorRect (Map.toList st.decks) of
                List.Cons (deckId' × _) _ | deckId ≠ deckId' → Just deckId'
                _ → Nothing
          H.modify
            $ (_moving ?~ Tuple deckId newRect)
            ∘ (_grouping .~ grouping)
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Resizing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
          let
            newRect = clampDeck rect
              { width = rect.width + (pxToGrid d.offsetX)
              , height = rect.height + (pxToGrid d.offsetY)
              }
          H.modify $ _moving ?~ Tuple deckId newRect
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  SetElement el next → do
    H.modify _ { canvas = el }
    pure next
  AddDeck e next → do
    let e' = mouseEventToPageEvent e
    H.gets _.canvas >>= traverse_ \el → do
      same ← H.fromEff (elementEq el e'.target)
      when same do
        coords ← pageToGrid { x: e'.pageX, y: e'.pageY } el
        addDeck opts DM.emptyDeck
          { x: floor $ coords.x + 1.0
          , y: floor $ coords.y
          }
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId
      $ H.action
      $ DCQ.Load opts.deck.path deckId (DL.succ opts.deck.level)
    pure next
  -- TODO: hopefully we can get rid of this later, as it's relatively expensive
  -- and will run quite frequently, as it's used to enable the `Unwrap` action.
  -- If we can add a real mechanism for handling card-specific actions on the
  -- deck backside we should be able to do something much more sensible, only
  -- building the decks' value here when we actually trigger an unwrap. -gb
  GetDecks k → do
    decks ← H.gets _.decks
    decks' ← runMaybeT $ for (Map.toList decks) \(deckId × position) -> do
      model ← MaybeT $ queryDeck deckId $ H.request DCQ.GetModel
      pure (deckId × (position × model))
    pure $ k $ maybe Map.empty Map.fromList decks'

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck = case _ of
    DCQ.GrabDeck ev _ → startDragging deckId ev Grabbing
    DCQ.ResizeDeck ev _ → startDragging deckId ev Resizing
    DCQ.DoAction DCQ.DeleteDeck _ → do
      deleteDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Wrap _ → do
      wrapDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction (DCQ.Unwrap decks) _ → do
      unwrapDeck opts deckId decks
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Mirror _ → do
      mirrorDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ → pure unit

  startDragging deckId ev tag =
    H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
      H.modify $ _moving ?~ Tuple deckId rect
      void
        $ Drag.subscribe' ev
        $ right ∘ H.action ∘ tag deckId

pageToGrid
  ∷ ∀ r
  . { x ∷ Number, y ∷ Number | r }
  → HTMLElement
  → DraftboardDSL { x ∷ Number, y ∷ Number }
pageToGrid e el = do
  rect ← H.fromEff $ getOffsetClientRect el
  scroll ←
    { top: _, left: _ }
    <$> H.fromEff (scrollTop el)
    <*> H.fromEff (scrollLeft el)
  pure
    { x: pxToGrid $ e.x - rect.left + scroll.left
    , y: pxToGrid $ e.y - rect.top + scroll.top
    }

pxToGrid ∷ Number → Number
pxToGrid = (_ / Config.gridPx)

gridToPx ∷ Number → Number
gridToPx = (_ * Config.gridPx)

stopDragging ∷ CardOptions → DraftboardDSL Unit
stopDragging opts = do
  st ← H.get
  for_ st.moving \(deckId × rect) → do
    let rect' = roundDeck rect
        decks = List.filter ((deckId /= _) ∘ fst) $ Map.toList st.decks
    case st.grouping of
      Just deckId' →
        groupDecks opts deckId deckId'
      Nothing →
        when (List.null $ overlapping rect' decks) do
          H.modify \s → s { decks = Map.insert deckId rect' s.decks }
  H.modify _
    { moving = Nothing
    , grouping = Nothing
    }

maxSize
  ∷ DeckPosition
  → { width ∷ Number, height ∷ Number }
  → { width ∷ Number, height ∷ Number }
maxSize deck size =
  { width: if x > size.width then x else size.width
  , height: if y > size.height then y else size.height
  }
  where
  x = deck.x + deck.width
  y = deck.y + deck.height

clampDeck ∷ DeckPosition → DeckPosition
clampDeck rect =
  { x: if rect.x < 0.0 then 0.0 else rect.x
  , y: if rect.y < 0.0 then 0.0 else rect.y
  , width: if rect.width < 10.0 then 10.0 else rect.width
  , height: if rect.height < 10.0 then 10.0 else rect.height
  }

roundDeck ∷ DeckPosition → DeckPosition
roundDeck rect =
  { x: round rect.x
  , y: round rect.y
  , width: round rect.width
  , height: round rect.height
  }

overlapping
  ∷ DeckPosition
  → List.List (DeckId × DeckPosition)
  → List.List (DeckId × DeckPosition)
overlapping a = List.filter go
  where
  go (_ × b) =
    not $ a.x + a.width <= b.x
       || b.x + b.width <= a.x
       || a.y + a.height <= b.y
       || b.y + b.height <= a.y

accomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → { x ∷ Number, y ∷ Number }
  → DeckPosition
  → Maybe DeckPosition
accomodateDeck bs = go List.Nil
  where
  go hist c a =
    case overlapping a bs of
      List.Nil →
        Just a
      bs' | not $ List.null $ List.intersectBy (eq `on` fst) hist bs' →
        Nothing
      List.Cons b _ →
        let a' = clampDeck $ reposition c a (snd b)
            c' = { x: a'.x + (floor (a'.width / 2.0)), y: a'.y }
        in  go (List.Cons b hist) c' a'

  reposition c a b
    | c.x >= b.x && c.x < b.x + b.width = a { y = b.y - a.height }
    | c.x >= b.x + b.width = a { x = b.x + b.width }
    | c.y < b.x = a { x = b.x - a.width }
    | otherwise = a

reallyAccomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → DeckPosition
  → DeckPosition
reallyAccomodateDeck decks deckPos =
  let deckPos' = deckPos { y = deckPos.y + deckPos.height }
      coords = { x: floor (deckPos'.x + deckPos'.x / 2.0), y: deckPos'.y }
  in
      case accomodateDeck decks coords deckPos of
        Nothing → reallyAccomodateDeck decks deckPos'
        Just a → a

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets (Map.keys ∘ _.decks) >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

addDeck ∷ CardOptions → DM.Deck → { x ∷ Number, y ∷ Number } → DraftboardDSL Unit
addDeck opts deck coords = do
  decks ← Map.toList <$> H.gets _.decks
  let
    deckPos = clampDeck $ defaultPosition
      { x = coords.x - 10.0
      , y = coords.y
      }
  for_ (accomodateDeck decks coords deckPos) $
    addDeckAt opts deck

addDeckAt ∷ CardOptions → DM.Deck → DeckPosition → DraftboardDSL Unit
addDeckAt { deck: opts, deckId: parentId, cardId } deck deckPos = do
  let deck' = deck { parent = Just (parentId × cardId) }
  H.modify $ _inserting .~ true
  deckId ← H.fromEff freshDeckId
  putDeck opts.path deckId deck' opts.wiring.decks >>= case _ of
    Left err → do
      H.modify $ _inserting .~ false
      -- TODO: do something to notify the user saving failed
      pure unit
    Right _ → void do
      H.modify \s → s
        { decks = Map.insert deckId deckPos s.decks
        , inserting = false
        }
      loadAndFocus opts deckId

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← deleteGraph deck.path deckId
  case res of
    Left err →
      -- TODO: do something to notify the user deleting failed
      pure unit
    Right _ →
      H.modify \s → s { decks = Map.delete deckId s.decks }

wrapDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
wrapDeck { cardId, deckId: parentId, deck } oldId = do
  H.gets (Map.lookup oldId ∘ _.decks) >>= traverse_ \deckPos → do
    let
      deckPos' = deckPos { x = 1.0, y = 1.0 }
      newDeck = (wrappedDeck deckPos' oldId) { parent = Just (parentId × cardId) }
    newId ← H.fromEff freshDeckId
    putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right _ → void do
        traverse_ (queryDeck oldId ∘ H.action)
          [ DCQ.SetParent (newId × CID.CardId 0)
          , DCQ.Save Nothing
          ]
        H.modify \s → s
          { decks
              = Map.insert newId deckPos
              $ Map.delete oldId
              $ s.decks
          }
        loadAndFocus deck newId

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Map.Map DeckId (DeckPosition × DM.Deck)
  → DraftboardDSL Unit
unwrapDeck { deckId, cardId, deck: opts } oldId decks = void $ runMaybeT do
  -- sort the decks here so they are ordered by position, this ensures that if
  -- decks need to be accomodated when broken out, the decks in the top left
  -- corner will maintain their position and the others will be accomodated.
  let deckList = List.sortBy (compare `on` toCoords) $ Map.toList decks
  let coord = deckId × cardId
  let level' = DL.succ opts.level
  offset ← MaybeT $ H.gets (Map.lookup oldId ∘ _.decks)
  lift do
    H.modify \s →
      s { decks = foldl (reinsert offset) (Map.delete oldId s.decks) deckList }
    for_ deckList \(deckId × (_ × deck)) → do
      let deck' = deck { parent = Just coord }
      putDeck opts.path deckId deck' opts.wiring.decks
      queryDeck deckId
        $ H.action
        $ DCQ.Load opts.path deckId level'
  where
  reinsert offset acc (deckId × (pos × deck)) =
    Map.insert deckId (updatePos (Map.toList acc) offset pos) acc
  updatePos currentDecks offset pos =
    reallyAccomodateDeck currentDecks $
      pos
        { x = pos.x + offset.x + 1.0
        , y = pos.y + offset.y + 1.0
        }
  toCoords (_ × (pos × _)) = Tuple pos.x pos.y

mirrorDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
mirrorDeck opts oldId = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        let
          newDeck =
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        newId ← H.fromEff freshDeckId
        putDeck opts.deck.path newId newDeck opts.deck.wiring.decks >>= case _ of
          Left _ →
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → do
            let modelCards'' = modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    for_ (Map.lookup oldId st.decks) \deckPos →
      addDeckAt opts deck $
        reallyAccomodateDeck (Map.toList st.decks) deckPos

groupDecks ∷ CardOptions → DeckId → DeckId → DraftboardDSL Unit
groupDecks { cardId, deckId, deck } deckFrom deckTo = do
  st ← H.get
  for_ (Map.lookup deckFrom st.decks) \rectFrom →
  for_ (Map.lookup deckTo st.decks) \rectTo →
    queryDeck deckTo (H.request DCQ.GetModelCards) >>= case _ of
      Just [ deckId' × { cardId, model: Card.Draftboard { decks } } ] → void do
        let
          rectFrom' =
            reallyAccomodateDeck (Map.toList decks) $
              rectFrom { x = 1.0, y = 1.0 }
          decks' = Map.insert deckFrom rectFrom' decks
          card = { cardId, model: Card.Draftboard { decks: decks' } }
        unsafeUpdateCachedDraftboard deck.wiring deckId' card
        H.modify \s → s { decks = Map.delete deckFrom s.decks }
        queryDeck deckTo
          $ H.action
          $ DCQ.SetModelCards [ deckId' × card ]

      _ → do
        let
          rectTo' = rectTo { x = 1.0, y = 1.0 }
          rectFrom' = rectFrom { x = 1.0, y = rectTo.height + 2.0 }
          newDeck = DM.emptyDeck
            { parent = Just (deckId × cardId)
            , cards = pure
              { cardId: CID.CardId 0
              , model: Card.Draftboard
                { decks: Map.fromFoldable
                  [ deckTo × rectTo'
                  , deckFrom × rectFrom'
                  ]
                }
              }
            }
        newId ← H.fromEff freshDeckId
        putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
          Left err → do
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → void do
            H.modify \s → s
              { decks
                  = Map.insert newId rectTo
                  $ Map.delete deckFrom
                  $ Map.delete deckTo
                  $ s.decks
              }
            loadAndFocus deck newId

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck deckId = H.query deckId ∘ right

loadAndFocus ∷ DeckOptions → DeckId → DraftboardDSL Unit
loadAndFocus opts deckId =
  traverse_ (queryDeck deckId ∘ H.action)
    [ DCQ.Load opts.path deckId (DL.succ opts.level)
    , DCQ.Focus
    ]

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Draftboard.Component
  ( draftboardComponent
  , module SlamData.Workspace.Card.Draftboard.Component.Query
  , module SlamData.Workspace.Card.Draftboard.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Maybe.Trans (MaybeT(..), runMaybeT)

import Data.Array as Array
import Data.Function (on)
import Data.Lens ((.~), (?~))
import Data.List as List
import Data.Map as Map
import CSS as CSS

import DOM.HTML.Types (HTMLElement)

import Halogen as H
import Halogen.Component.Opaque.Unsafe (opaqueState)
import Halogen.Component.Utils.Drag as Drag
import Halogen.Component.Utils (raise')
import Halogen.CustomEvents (mouseEventToPageEvent)
import Halogen.HTML.CSS.Indexed as HC
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP

import Math (round, floor)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.CardType as CT
import SlamData.Workspace.Card.Common (CardOptions)
import SlamData.Workspace.Card.Component as CC
import SlamData.Workspace.Card.Draftboard.Common (deleteGraph, unsafeUpdateCachedDraftboard)
import SlamData.Workspace.Card.Draftboard.Component.CSS as CCSS
import SlamData.Workspace.Card.Draftboard.Component.Query (Query(..), QueryP, QueryC)
import SlamData.Workspace.Card.Draftboard.Component.State (State, DeckPosition, initialState, encode, decode, _moving, _inserting, _grouping, modelFromState)
import SlamData.Workspace.Card.Model as Card
import SlamData.Workspace.Deck.Common (wrappedDeck, defaultPosition)
import SlamData.Workspace.Deck.Component.Nested.Query as DNQ
import SlamData.Workspace.Deck.Component.Nested.State as DNS
import SlamData.Workspace.Deck.Component.Query as DCQ
import SlamData.Workspace.Deck.Component.State as DCS
import SlamData.Workspace.Deck.DeckId (DeckId, deckIdToString, freshDeckId)
import SlamData.Workspace.Deck.DeckLevel as DL
import SlamData.Workspace.Deck.Model as DM
import SlamData.Workspace.Wiring (putDeck)

import Utils.CSS (zIndex)
import Utils.DOM (elementEq, scrollTop, scrollLeft, getOffsetClientRect)

type DraftboardDSL = H.ParentDSL State DNS.State QueryC DNQ.QueryP Slam DeckId

type DraftboardHTML = H.ParentHTML DNS.State QueryC DNQ.QueryP Slam DeckId

draftboardComponent ∷ CardOptions → CC.CardComponent
draftboardComponent opts = CC.makeCardComponent
  { cardType: CT.Draftboard
  , component: H.parentComponent
      { render: render opts
      , eval: coproduct evalCard (evalBoard opts)
      , peek: Just (peek opts)
      }
  , initialState: H.parentState initialState
  , _State: CC._DraftboardState
  , _Query: CC.makeQueryPrism' CC._DraftboardQuery
  }

render ∷ CardOptions → State → DraftboardHTML
render opts state =
  HH.div_
    [ HH.div [ HP.class_ CCSS.insetShadow ] []
    , HH.div
        [ HP.class_ CCSS.grid
        , HC.style bgSize
        , HP.ref (right ∘ H.action ∘ SetElement)
        , HE.onClick \e → pure $
            guard (AT.isEditable opts.deck.accessType && not state.inserting) $>
            right (H.action $ AddDeck e)
        ]
        $ map renderDeck (foldl Array.snoc [] $ Map.toList state.decks)
    ]

  where
  renderDeck (deckId × rect) =
    HH.div
      [ HP.key $ deckIdToString deckId
      , HP.classes $
          case state.grouping of
            Just deckId' | deckId == deckId' → [ HH.className "grouping" ]
            _ → []
      , HC.style $
          case state.moving of
            Just (deckId' × rect') | deckId == deckId' → zIndex 2 *> cssPos rect'
            _ → cssPos rect
      ]
      [ HH.slot deckId $ mkDeckComponent deckId ]

  mkDeckComponent id _ =
    { component: opts.deckComponent (opaqueState $ DCS.initialDeck opts.deck.path id)
    , initialState: DNS.initialState
    }

  cssPos rect = do
    CSS.position CSS.absolute
    CSS.top $ CSS.px $ gridToPx rect.y
    CSS.left $ CSS.px $ gridToPx rect.x
    CSS.width $ CSS.px $ gridToPx rect.width
    CSS.height $ CSS.px $ gridToPx rect.height

  bgSize = do
    let size = foldr maxSize { width: 0.0, height: 0.0 } state.decks
        size' = maybe size (flip maxSize size ∘ snd) state.moving
    CSS.width $ CSS.px $ gridToPx $ size'.width + 1.0
    CSS.height $ CSS.px $ gridToPx $ size'.height + 1.0

evalCard ∷ Natural CC.CardEvalQuery DraftboardDSL
evalCard = case _ of
  CC.EvalCard _ _ next →
    pure next
  CC.SetDimensions _ next →
    pure next
  CC.Save k →
    map (k ∘ Card.Draftboard ∘ modelFromState) H.get
  CC.Load card next → do
    case card of
      Card.Draftboard model → do
        H.modify _ { decks = model.decks }
        loadDecks
      _ → pure unit
    pure next
  CC.ModelUpdated _ next →
    pure next
  CC.ZoomIn next →
    pure next

evalBoard ∷ CardOptions → Natural Query DraftboardDSL
evalBoard opts = case _ of
  Grabbing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        st ← H.get
        for_ (Map.lookup deckId (st.decks)) \rect →
        for_ st.canvas \el → do
          coords ← pageToGrid d el
          let
            cursorRect =
              { x: coords.x
              , y: coords.y
              , width: 1.0
              , height: 1.0
              }
            newRect = clampDeck rect
              { x = rect.x + (pxToGrid d.offsetX)
              , y = rect.y + (pxToGrid d.offsetY)
              }
            grouping =
              case overlapping cursorRect (Map.toList st.decks) of
                List.Cons (deckId' × _) _ | deckId ≠ deckId' → Just deckId'
                _ → Nothing
          H.modify
            $ (_moving ?~ Tuple deckId newRect)
            ∘ (_grouping .~ grouping)
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  Resizing deckId ev next → do
    case ev of
      Drag.Move _ d → do
        H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
          let
            newRect = clampDeck rect
              { width = rect.width + (pxToGrid d.offsetX)
              , height = rect.height + (pxToGrid d.offsetY)
              }
          H.modify $ _moving ?~ Tuple deckId newRect
      Drag.Done _ → do
        stopDragging opts
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  SetElement el next → do
    H.modify _ { canvas = el }
    pure next
  AddDeck e next → do
    let e' = mouseEventToPageEvent e
    H.gets _.canvas >>= traverse_ \el → do
      same ← H.fromEff (elementEq el e'.target)
      when same do
        coords ← pageToGrid { x: e'.pageX, y: e'.pageY } el
        addDeck opts DM.emptyDeck
          { x: floor $ coords.x + 1.0
          , y: floor $ coords.y
          }
        CC.raiseUpdatedP' CC.EvalModelUpdate
    pure next
  LoadDeck deckId next → do
    queryDeck deckId
      $ H.action
      $ DCQ.Load opts.deck.path deckId (DL.succ opts.deck.level)
    pure next
  -- TODO: hopefully we can get rid of this later, as it's relatively expensive
  -- and will run quite frequently, as it's used to enable the `Unwrap` action.
  -- If we can add a real mechanism for handling card-specific actions on the
  -- deck backside we should be able to do something much more sensible, only
  -- building the decks' value here when we actually trigger an unwrap. -gb
  GetDecks k → do
    decks ← H.gets _.decks
    decks' ← runMaybeT $ for (Map.toList decks) \(deckId × position) -> do
      model ← MaybeT $ queryDeck deckId $ H.request DCQ.GetModel
      pure (deckId × (position × model))
    pure $ k $ maybe Map.empty Map.fromList decks'

peek ∷ ∀ a. CardOptions → H.ChildF DeckId DNQ.QueryP a → DraftboardDSL Unit
peek opts (H.ChildF deckId q) = coproduct (const (pure unit)) peekDeck q
  where
  peekDeck ∷ DCQ.Query a → DraftboardDSL Unit
  peekDeck = case _ of
    DCQ.GrabDeck ev _ → startDragging deckId ev Grabbing
    DCQ.ResizeDeck ev _ → startDragging deckId ev Resizing
    DCQ.DoAction DCQ.DeleteDeck _ → do
      deleteDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Wrap _ → do
      wrapDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction (DCQ.Unwrap decks) _ → do
      unwrapDeck opts deckId decks
      CC.raiseUpdatedP' CC.EvalModelUpdate
    DCQ.DoAction DCQ.Mirror _ → do
      mirrorDeck opts deckId
      CC.raiseUpdatedP' CC.EvalModelUpdate
    _ → pure unit

  startDragging deckId ev tag =
    H.gets (Map.lookup deckId ∘ _.decks) >>= traverse_ \rect → do
      H.modify $ _moving ?~ Tuple deckId rect
      void
        $ Drag.subscribe' ev
        $ right ∘ H.action ∘ tag deckId

pageToGrid
  ∷ ∀ r
  . { x ∷ Number, y ∷ Number | r }
  → HTMLElement
  → DraftboardDSL { x ∷ Number, y ∷ Number }
pageToGrid e el = do
  rect ← H.fromEff $ getOffsetClientRect el
  scroll ←
    { top: _, left: _ }
    <$> H.fromEff (scrollTop el)
    <*> H.fromEff (scrollLeft el)
  pure
    { x: pxToGrid $ e.x - rect.left + scroll.left
    , y: pxToGrid $ e.y - rect.top + scroll.top
    }

pxToGrid ∷ Number → Number
pxToGrid = (_ / Config.gridPx)

gridToPx ∷ Number → Number
gridToPx = (_ * Config.gridPx)

stopDragging ∷ CardOptions → DraftboardDSL Unit
stopDragging opts = do
  st ← H.get
  for_ st.moving \(deckId × rect) → do
    let rect' = roundDeck rect
        decks = List.filter ((deckId /= _) ∘ fst) $ Map.toList st.decks
    case st.grouping of
      Just deckId' →
        groupDecks opts deckId deckId'
      Nothing →
        when (List.null $ overlapping rect' decks) do
          H.modify \s → s { decks = Map.insert deckId rect' s.decks }
  H.modify _
    { moving = Nothing
    , grouping = Nothing
    }

maxSize
  ∷ DeckPosition
  → { width ∷ Number, height ∷ Number }
  → { width ∷ Number, height ∷ Number }
maxSize deck size =
  { width: if x > size.width then x else size.width
  , height: if y > size.height then y else size.height
  }
  where
  x = deck.x + deck.width
  y = deck.y + deck.height

clampDeck ∷ DeckPosition → DeckPosition
clampDeck rect =
  { x: if rect.x < 0.0 then 0.0 else rect.x
  , y: if rect.y < 0.0 then 0.0 else rect.y
  , width: if rect.width < 10.0 then 10.0 else rect.width
  , height: if rect.height < 10.0 then 10.0 else rect.height
  }

roundDeck ∷ DeckPosition → DeckPosition
roundDeck rect =
  { x: round rect.x
  , y: round rect.y
  , width: round rect.width
  , height: round rect.height
  }

overlapping
  ∷ DeckPosition
  → List.List (DeckId × DeckPosition)
  → List.List (DeckId × DeckPosition)
overlapping a = List.filter go
  where
  go (_ × b) =
    not $ a.x + a.width <= b.x
       || b.x + b.width <= a.x
       || a.y + a.height <= b.y
       || b.y + b.height <= a.y

accomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → { x ∷ Number, y ∷ Number }
  → DeckPosition
  → Maybe DeckPosition
accomodateDeck bs = go List.Nil
  where
  go hist c a =
    case overlapping a bs of
      List.Nil →
        Just a
      bs' | not $ List.null $ List.intersectBy (eq `on` fst) hist bs' →
        Nothing
      List.Cons b _ →
        let a' = clampDeck $ reposition c a (snd b)
            c' = { x: a'.x + (floor (a'.width / 2.0)), y: a'.y }
        in  go (List.Cons b hist) c' a'

  reposition c a b
    | c.x >= b.x && c.x < b.x + b.width = a { y = b.y - a.height }
    | c.x >= b.x + b.width = a { x = b.x + b.width }
    | c.y < b.x = a { x = b.x - a.width }
    | otherwise = a

reallyAccomodateDeck
  ∷ List.List (DeckId × DeckPosition)
  → DeckPosition
  → DeckPosition
reallyAccomodateDeck decks deckPos =
  let deckPos' = deckPos { y = deckPos.y + deckPos.height }
      coords = { x: floor (deckPos'.x + deckPos'.x / 2.0), y: deckPos'.y }
  in
      case accomodateDeck decks coords deckPos of
        Nothing → reallyAccomodateDeck decks deckPos'
        Just a → a

loadDecks ∷ DraftboardDSL Unit
loadDecks =
  H.gets (Map.keys ∘ _.decks) >>=
    traverse_ (raise' ∘ right ∘ H.action ∘ LoadDeck)

addDeck ∷ CardOptions → DM.Deck → { x ∷ Number, y ∷ Number } → DraftboardDSL Unit
addDeck opts deck coords = do
  decks ← Map.toList <$> H.gets _.decks
  let
    deckPos = clampDeck $ defaultPosition
      { x = coords.x - 10.0
      , y = coords.y
      }
  for_ (accomodateDeck decks coords deckPos) $
    addDeckAt opts deck

addDeckAt ∷ CardOptions → DM.Deck → DeckPosition → DraftboardDSL Unit
addDeckAt { deck: opts, deckId: parentId, cardId } deck deckPos = do
  let deck' = deck { parent = Just (parentId × cardId) }
  H.modify $ _inserting .~ true
  deckId ← H.fromEff freshDeckId
  putDeck opts.path deckId deck' opts.wiring.decks >>= case _ of
    Left err → do
      H.modify $ _inserting .~ false
      -- TODO: do something to notify the user saving failed
      pure unit
    Right _ → void do
      H.modify \s → s
        { decks = Map.insert deckId deckPos s.decks
        , inserting = false
        }
      queryDeck deckId
        $ H.action
        $ DCQ.Load opts.path deckId (DL.succ opts.level)

deleteDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
deleteDeck { deck } deckId = do
  res ← deleteGraph deck.path deckId
  case res of
    Left err →
      -- TODO: do something to notify the user deleting failed
      pure unit
    Right _ →
      H.modify \s → s { decks = Map.delete deckId s.decks }

wrapDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
wrapDeck { cardId, deckId: parentId, deck } oldId = do
  H.gets (Map.lookup oldId ∘ _.decks) >>= traverse_ \deckPos → do
    let
      deckPos' = deckPos { x = 1.0, y = 1.0 }
      newDeck = (wrappedDeck deckPos' oldId) { parent = Just (parentId × cardId) }
    newId ← H.fromEff freshDeckId
    putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
      Left err → do
        -- TODO: do something to notify the user saving failed
        pure unit
      Right _ → void do
        traverse_ (queryDeck oldId ∘ H.action)
          [ DCQ.SetParent (newId × CID.CardId 0)
          , DCQ.Save Nothing
          ]
        H.modify \s → s
          { decks
              = Map.insert newId deckPos
              $ Map.delete oldId
              $ s.decks
          }
        queryDeck newId
          $ H.action
          $ DCQ.Load deck.path newId (DL.succ deck.level)

unwrapDeck
  ∷ CardOptions
  → DeckId
  → Map.Map DeckId (DeckPosition × DM.Deck)
  → DraftboardDSL Unit
unwrapDeck { deckId, cardId, deck: opts } oldId decks = void $ runMaybeT do
  -- sort the decks here so they are ordered by position, this ensures that if
  -- decks need to be accomodated when broken out, the decks in the top left
  -- corner will maintain their position and the others will be accomodated.
  let deckList = List.sortBy (compare `on` toCoords) $ Map.toList decks
  let coord = deckId × cardId
  let level' = DL.succ opts.level
  offset ← MaybeT $ H.gets (Map.lookup oldId ∘ _.decks)
  lift do
    H.modify \s →
      s { decks = foldl (reinsert offset) (Map.delete oldId s.decks) deckList }
    for_ deckList \(deckId × (_ × deck)) → do
      let deck' = deck { parent = Just coord }
      putDeck opts.path deckId deck' opts.wiring.decks
      queryDeck deckId
        $ H.action
        $ DCQ.Load opts.path deckId level'
  where
  reinsert offset acc (deckId × (pos × deck)) =
    Map.insert deckId (updatePos (Map.toList acc) offset pos) acc
  updatePos currentDecks offset pos =
    reallyAccomodateDeck currentDecks $
      pos
        { x = pos.x + offset.x + 1.0
        , y = pos.y + offset.y + 1.0
        }
  toCoords (_ × (pos × _)) = Tuple pos.x pos.y

mirrorDeck ∷ CardOptions → DeckId → DraftboardDSL Unit
mirrorDeck opts oldId = do
  queryDeck oldId (H.request DCQ.GetModelCards) >>= traverse_ \modelCards → do
    let modelCards' = Array.span (not ∘ eq oldId ∘ fst) modelCards
    if Array.null modelCards'.rest
      then insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'.init }
      else do
        let
          newDeck =
            { parent: Nothing
            , mirror: map _.cardId <$> modelCards'.init
            , cards: snd <$> modelCards'.rest
            , name: ""
            }
        newId ← H.fromEff freshDeckId
        putDeck opts.deck.path newId newDeck opts.deck.wiring.decks >>= case _ of
          Left _ →
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → do
            let modelCards'' = modelCards'.init <> map (lmap (const newId)) modelCards'.rest
            queryDeck oldId $ H.action $ DCQ.SetModelCards modelCards''
            insertNewDeck DM.emptyDeck { mirror = DCS.coordModelToCoord <$> modelCards'' }
  where
  insertNewDeck deck = do
    st ← H.get
    for_ (Map.lookup oldId st.decks) \deckPos →
      addDeckAt opts deck $
        reallyAccomodateDeck (Map.toList st.decks) deckPos

groupDecks ∷ CardOptions → DeckId → DeckId → DraftboardDSL Unit
groupDecks { cardId, deckId, deck } deckFrom deckTo = do
  st ← H.get
  for_ (Map.lookup deckFrom st.decks) \rectFrom →
  for_ (Map.lookup deckTo st.decks) \rectTo →
    queryDeck deckTo (H.request DCQ.GetModelCards) >>= case _ of
      Just [ deckId' × { cardId, model: Card.Draftboard { decks } } ] → void do
        let
          rectFrom' =
            reallyAccomodateDeck (Map.toList decks) $
              rectFrom { x = 1.0, y = 1.0 }
          decks' = Map.insert deckFrom rectFrom' decks
          card = { cardId, model: Card.Draftboard { decks: decks' } }
        unsafeUpdateCachedDraftboard deck.wiring deckId' card
        H.modify \s → s { decks = Map.delete deckFrom s.decks }
        queryDeck deckTo
          $ H.action
          $ DCQ.SetModelCards [ deckId' × card ]

      _ → do
        let
          rectTo' = rectTo { x = 1.0, y = 1.0 }
          rectFrom' = rectFrom { x = 1.0, y = rectTo.height + 2.0 }
          newDeck = DM.emptyDeck
            { parent = Just (deckId × cardId)
            , cards = pure
              { cardId: CID.CardId 0
              , model: Card.Draftboard
                { decks: Map.fromFoldable
                  [ deckTo × rectTo'
                  , deckFrom × rectFrom'
                  ]
                }
              }
            }
        newId ← H.fromEff freshDeckId
        putDeck deck.path newId newDeck deck.wiring.decks >>= case _ of
          Left err → do
            -- TODO: do something to notify the user saving failed
            pure unit
          Right _ → void do
            H.modify \s → s
              { decks
                  = Map.insert newId rectTo
                  $ Map.delete deckFrom
                  $ Map.delete deckTo
                  $ s.decks
              }
            queryDeck newId
              $ H.action
              $ DCQ.Load deck.path newId (DL.succ deck.level)

queryDeck ∷ ∀ a. DeckId → DCQ.Query a → DraftboardDSL (Maybe a)
queryDeck deckId = H.query deckId ∘ right