[CSE-193] Add tests for handling page numbers

while switching filter of genesis addresses

module Explorer.Update.Test where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Array (index, length, (..), (:))
import Data.Either (Either(..))
import Data.Generic (gShow)
import Data.Identity (Identity)
import Data.Lens ((^.), set)
import Data.Maybe (fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.NominalDiffTime (mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Api.Types (SocketSubscription(..), SocketSubscriptionData(..))
import Explorer.I18n.Lang (Language(..))
import Explorer.Lenses.State (connected, currentAddressSummary, dbViewBlockPagination, dbViewLoadingBlockPagination, dbViewMaxBlockPagination, gblAddressInfosPagination, gblMaxAddressInfosPagination, genesisBlockViewState, lang, latestBlocks, latestTransactions, loading, socket, subscriptions, viewStates)
import Explorer.State (initialState, mkSocketSubscriptionItem)
import Explorer.Test.MockFactory (mkCBlockEntry, mkCTxBrief, mkEmptyCAddressSummary, mkEmptyCTxEntry, mkCTxBriefs, setEpochSlotOfBlock, setHashOfBlock, setIdOfTx, setTimeOfTx, setTxOfAddressSummary)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (PageNumber(..), PageSize(..))
import Explorer.Update (update)
import Explorer.Util.Factory (mkCHash, mkCTxId)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.RemoteData (RemoteData(..), _Success, isLoading, isNotAsked, withDefault)
import Pos.Explorer.Socket.Methods (Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, caTxList)
import Test.Spec (Group, describe, it)
import Test.Spec.Assertions (shouldEqual)

testUpdate :: forall r. StateT (Array (Group (Aff r Unit))) Identity Unit
testUpdate =
    describe "Explorer.Update" do

        describe "uses action SetLanguage" do
            it "to update language"
                let effModel =  update (SetLanguage German) initialState
                    state = _.state effModel
                    result = state ^. lang
                in result `shouldEqual` German

        describe "uses action SocketBlocksPageUpdated" do
            -- Mock blocks with epoch, slots and hashes
            let totalPages = 70
                blockA = setEpochSlotOfBlock 0 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 0 2 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 0 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 1 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
            it "to update latestBlocks (but not currentPage number) at the last (current) page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        , blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "to update latestBlocks and currentPage number to switch to the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success <<< PageNumber $ totalPages - 1)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "not to update latestBlocks and current page number since we are not at the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        ]
                    newBlocks =
                        [ blockB
                        , blockC
                        , blockD
                        ]
                    currentPage = totalPages - 2
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber currentPage) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blockResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blockResult) `shouldEqual` (gShow currentBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber currentPage)
            it "to count total pages"
                let blocks = [ blockC ]
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages blocks))) initialState
                    state = _.state effModel
                    result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "handles SocketAddressTxsUpdated action" do
            -- mock `currentAddressSummary` first
            let addrs = setTxOfAddressSummary (mkCTxBriefs (9..0)) mkEmptyCAddressSummary
                initialState' =
                    set currentAddressSummary (Success addrs) initialState
                latestTx = mkCTxBrief 19
                txs = latestTx : mkCTxBriefs (18..10)
                effModel = update (SocketAddressTxsUpdated (Right txs)) initialState'
                state = _.state effModel
                updatedAddrs = state ^. (currentAddressSummary <<< _Success <<< _CAddressSummary <<< caTxList)

            it "to add all new transactions" do
                length updatedAddrs `shouldEqual` 20
            it "to add latest transactions on top of txs list"
                let mAddr = index updatedAddrs 0 in
                fromMaybe "not-found" (gShow <$> mAddr) `shouldEqual` (gShow latestTx)

        describe "handles RequestPaginatedBlocks action" do
            let effModel = update DashboardRequestBlocksTotalPages initialState
                state = _.state effModel
            it "to set loading state of dbViewMaxBlockPaginations" do
                (isLoading $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination)) `shouldEqual` true

        describe "handles RequestPaginatedBlocks action" do
            let pageNumber = PageNumber 2
                effModel = update (RequestPaginatedBlocks pageNumber (PageSize 1)) initialState
                state = _.state effModel
            it "to set dbViewLoadingBlockPagination to true" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination)) `shouldEqual` true
            it "to not update state of latestBlocks" do
                (isNotAsked $ state ^. latestBlocks) `shouldEqual` true
            it "to update dbViewBlockPagination"
                let result = (state ^. (dashboardViewState <<< dbViewBlockPagination))
                in (gShow result) `shouldEqual` (gShow pageNumber)

        describe "handles DashboardReceiveBlocksTotalPages action" do
            let totalPages = 70
                effModel = update (DashboardReceiveBlocksTotalPages $ Right totalPages) initialState
                state = _.state effModel
            it "to update dbViewMaxBlockPagination to number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "uses action ReceivePaginatedBlocks" do
            -- Mock blocks with epoch, slots and hashes
            let blockA = setEpochSlotOfBlock 2 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 2 0 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 9 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 8 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
                blockE = setEpochSlotOfBlock 1 7 $ setHashOfBlock (mkCHash "E") mkCBlockEntry
                currentBlocks =
                    [ blockA
                    , blockB
                    , blockC
                    ]
                pageNumber = PageNumber 2
                -- set `latestBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) initialState
                paginatedBlocks =
                    [ blockC
                    , blockD
                    , blockE
                    ]
                totalPages = 10
                effModel = update (ReceivePaginatedBlocks (Right (Tuple totalPages paginatedBlocks))) initialState'
                state = _.state effModel
            it "to add blocks to latestBlocks"
                let result = withDefault [] $ state ^. latestBlocks
                in (gShow result) `shouldEqual` (gShow paginatedBlocks)
            it "to update number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages
            it "to set loading to false" do
                (state ^. loading) `shouldEqual` false
            it "to set dbViewLoadingBlockPagination to false" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination))
                    `shouldEqual` false

        describe "uses action SocketTxsUpdated" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                txD = setTimeOfTx (mkTime 2.1) $ setIdOfTx (mkCTxId "D") mkEmptyCTxEntry
                currentTxs =
                    [ txA
                    , txB
                    ]
                -- set `latestTransactions` to simulate that we have already txs before
                initialState' =
                    set latestTransactions (Success currentTxs) initialState
                newTxs =
                    [ txA
                    , txC
                    , txD
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState'
                state = _.state effModel
            it "to update latestTransactions w/o duplicates and sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txD
                        , txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "handles ReceiveLastTxs action" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                newTxs =
                    [ txA
                    , txC
                    , txB
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState
                state = _.state effModel
            it "to update latestTransactions sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "handles ReceiveGenesisAddressInfoTotalPages action" do
            it "to update gblMaxAddressInfosPagination w/ number of total pages"
                let totalPages = 5
                    effModel = update (ReceiveGenesisAddressInfoTotalPages $ Right totalPages) initialState
                    state = _.state effModel
                    result = unwrap <<< withDefault (PageNumber 0) $
                                state ^. (viewStates <<< genesisBlockViewState <<< gblMaxAddressInfosPagination)
                in result `shouldEqual` totalPages
            it "to leave gblMaxAddressInfosPagination untouched"
                let totalPages = 20
                    currentPage = 10
                    -- set current page to simulate that we have paginated before
                    initialState' =
                        set (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                            (PageNumber currentPage)
                            initialState
                    effModel = update (ReceiveGenesisAddressInfoTotalPages $ Right totalPages) initialState'
                    state = _.state effModel
                    currentPageResult = unwrap $ state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                in currentPageResult `shouldEqual` currentPage
            it "to update gblMaxAddressInfosPagination untouched"
                let totalPages = 10
                    currentPage = 20
                    -- set current page to simulate that we have paginated before
                    initialState' =
                        set (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                            (PageNumber currentPage)
                            initialState
                    effModel = update (ReceiveGenesisAddressInfoTotalPages $ Right totalPages) initialState'
                    state = _.state effModel
                    currentPageResult = unwrap $ state ^. (viewStates <<< genesisBlockViewState <<< gblAddressInfosPagination)
                in currentPageResult `shouldEqual` totalPages

        describe "uses action SocketConnected" do
            it "to update connection to connected"
                let effModel = update (SocketConnected true) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` true
            it "to update connection to disconnected"
                let effModel = update (SocketConnected false) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` false

        describe "uses action SocketAddSubscription" do
            it "to add a first subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in (gShow result) `shouldEqual` (gShow [subItem])
            it "to add another subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        ]
                                        initialState
                    subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                    expected =  [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "uses action SocketRemoveSubscription" do
            it "to not remove anything, if we do have an empty list of subscriptions"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketRemoveSubscription subItem) initialState
                    state = _.state effModel
                    result = length $ state ^. socket <<< subscriptions
                in result `shouldEqual` 0
            it "to remove a subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update (SocketRemoveSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in  (gShow result) `shouldEqual`
                    (gShow [mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData])

        describe "uses action SocketClearSubscriptions" do

            it "to remove nothing if no subscription available"
                let effModel = update SocketClearSubscriptions initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0

            it "to remove all subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update SocketClearSubscriptions initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0

module Explorer.Update.Test where

import Prelude

import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Array (index, length, (..), (:))
import Data.Either (Either(..))
import Data.Generic (gShow)
import Data.Identity (Identity)
import Data.Lens ((^.), set)
import Data.Maybe (fromMaybe)
import Data.Newtype (unwrap)
import Data.Time.NominalDiffTime (mkTime)
import Data.Tuple (Tuple(..))
import Explorer.Api.Types (SocketSubscription(..), SocketSubscriptionData(..))
import Explorer.I18n.Lang (Language(..))
import Explorer.Lenses.State (connected, currentAddressSummary, dbViewBlockPagination, dbViewLoadingBlockPagination, dbViewMaxBlockPagination, lang, latestBlocks, latestTransactions, loading, socket, subscriptions)
import Explorer.State (initialState, mkSocketSubscriptionItem)
import Explorer.Test.MockFactory (mkCBlockEntry, mkCTxBrief, mkEmptyCAddressSummary, mkEmptyCTxEntry, mkCTxBriefs, setEpochSlotOfBlock, setHashOfBlock, setIdOfTx, setTimeOfTx, setTxOfAddressSummary)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (PageNumber(..), PageSize(..))
import Explorer.Update (update)
import Explorer.Util.Factory (mkCHash, mkCTxId)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.RemoteData (RemoteData(..), _Success, isLoading, isNotAsked, withDefault)
import Pos.Explorer.Socket.Methods (Subscription(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CAddressSummary, caTxList)
import Test.Spec (Group, describe, it)
import Test.Spec.Assertions (shouldEqual)

testUpdate :: forall r. StateT (Array (Group (Aff r Unit))) Identity Unit
testUpdate =
    describe "Explorer.Update" do

        describe "uses action SetLanguage" do
            it "to update language"
                let effModel =  update (SetLanguage German) initialState
                    state = _.state effModel
                    result = state ^. lang
                in result `shouldEqual` German

        describe "uses action SocketBlocksPageUpdated" do
            -- Mock blocks with epoch, slots and hashes
            let totalPages = 70
                blockA = setEpochSlotOfBlock 0 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 0 2 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 0 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 1 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
            it "to update latestBlocks (but not currentPage number) at the last (current) page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        , blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "to update latestBlocks and currentPage number to switch to the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        , blockC
                        ]
                    newBlocks =
                        [ blockD
                        ]
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber totalPages) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success <<< PageNumber $ totalPages - 1)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blocksResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blocksResult) `shouldEqual` (gShow newBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber totalPages)
            it "not to update latestBlocks and current page number since we are not at the last page" do
                let currentBlocks =
                        [ blockA
                        , blockB
                        ]
                    newBlocks =
                        [ blockB
                        , blockC
                        , blockD
                        ]
                    currentPage = totalPages - 2
                    initialState' = set latestBlocks (Success currentBlocks) $
                        set (dashboardViewState <<< dbViewBlockPagination) (PageNumber currentPage) $
                        set (dashboardViewState <<< dbViewMaxBlockPagination) (Success $ PageNumber totalPages)
                        initialState
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages newBlocks))) initialState'
                    state = _.state effModel
                    blockResult = withDefault [] $ state ^. latestBlocks
                    pageResult = state ^. (dashboardViewState <<< dbViewBlockPagination)
                (gShow blockResult) `shouldEqual` (gShow currentBlocks)
                (gShow pageResult) `shouldEqual` (gShow $ PageNumber currentPage)
            it "to count total pages"
                let blocks = [ blockC ]
                    effModel = update (SocketBlocksPageUpdated (Right (Tuple totalPages blocks))) initialState
                    state = _.state effModel
                    result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "handles SocketAddressTxsUpdated action" do
            -- mock `currentAddressSummary` first
            let addrs = setTxOfAddressSummary (mkCTxBriefs (9..0)) mkEmptyCAddressSummary
                initialState' =
                    set currentAddressSummary (Success addrs) initialState
                latestTx = mkCTxBrief 19
                txs = latestTx : mkCTxBriefs (18..10)
                effModel = update (SocketAddressTxsUpdated (Right txs)) initialState'
                state = _.state effModel
                updatedAddrs = state ^. (currentAddressSummary <<< _Success <<< _CAddressSummary <<< caTxList)

            it "to add all new transactions" do
                length updatedAddrs `shouldEqual` 20
            it "to add latest transactions on top of txs list"
                let mAddr = index updatedAddrs 0 in
                fromMaybe "not-found" (gShow <$> mAddr) `shouldEqual` (gShow latestTx)

        describe "handles RequestPaginatedBlocks action" do
            let effModel = update DashboardRequestBlocksTotalPages initialState
                state = _.state effModel
            it "to set loading state of dbViewMaxBlockPaginations" do
                (isLoading $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination)) `shouldEqual` true

        describe "handles RequestPaginatedBlocks action" do
            let pageNumber = PageNumber 2
                effModel = update (RequestPaginatedBlocks pageNumber (PageSize 1)) initialState
                state = _.state effModel
            it "to set dbViewLoadingBlockPagination to true" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination)) `shouldEqual` true
            it "to not update state of latestBlocks" do
                (isNotAsked $ state ^. latestBlocks) `shouldEqual` true
            it "to update dbViewBlockPagination"
                let result = (state ^. (dashboardViewState <<< dbViewBlockPagination))
                in (gShow result) `shouldEqual` (gShow pageNumber)

        describe "handles DashboardReceiveBlocksTotalPages action" do
            let totalPages = 70
                effModel = update (DashboardReceiveBlocksTotalPages $ Right totalPages) initialState
                state = _.state effModel
            it "to update dbViewMaxBlockPagination to number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages

        describe "uses action ReceivePaginatedBlocks" do
            -- Mock blocks with epoch, slots and hashes
            let blockA = setEpochSlotOfBlock 2 1 $ setHashOfBlock (mkCHash "A") mkCBlockEntry
                blockB = setEpochSlotOfBlock 2 0 $ setHashOfBlock (mkCHash "B") mkCBlockEntry
                blockC = setEpochSlotOfBlock 1 9 $ setHashOfBlock (mkCHash "C") mkCBlockEntry
                blockD = setEpochSlotOfBlock 1 8 $ setHashOfBlock (mkCHash "D") mkCBlockEntry
                blockE = setEpochSlotOfBlock 1 7 $ setHashOfBlock (mkCHash "E") mkCBlockEntry
                currentBlocks =
                    [ blockA
                    , blockB
                    , blockC
                    ]
                pageNumber = PageNumber 2
                -- set `latestBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) initialState
                paginatedBlocks =
                    [ blockC
                    , blockD
                    , blockE
                    ]
                totalPages = 10
                effModel = update (ReceivePaginatedBlocks (Right (Tuple totalPages paginatedBlocks))) initialState'
                state = _.state effModel
            it "to add blocks to latestBlocks"
                let result = withDefault [] $ state ^. latestBlocks
                in (gShow result) `shouldEqual` (gShow paginatedBlocks)
            it "to update number of total pages"
                let result = unwrap <<< withDefault (PageNumber 0) $ state ^. (dashboardViewState <<< dbViewMaxBlockPagination )
                in result `shouldEqual` totalPages
            it "to set loading to false" do
                (state ^. loading) `shouldEqual` false
            it "to set dbViewLoadingBlockPagination to false" do
                (state ^. (dashboardViewState <<< dbViewLoadingBlockPagination))
                    `shouldEqual` false

        describe "uses action SocketTxsUpdated" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                txD = setTimeOfTx (mkTime 2.1) $ setIdOfTx (mkCTxId "D") mkEmptyCTxEntry
                currentTxs =
                    [ txA
                    , txB
                    ]
                -- set `latestTransactions` to simulate that we have already txs before
                initialState' =
                    set latestTransactions (Success currentTxs) initialState
                newTxs =
                    [ txA
                    , txC
                    , txD
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState'
                state = _.state effModel
            it "to update latestTransactions w/o duplicates and sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txD
                        , txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "handles ReceiveLastTxs action" do
            -- Mock txs
            let txA = setTimeOfTx (mkTime 0.1) $ setIdOfTx (mkCTxId "A") mkEmptyCTxEntry
                txB = setTimeOfTx (mkTime 0.2) $ setIdOfTx (mkCTxId "B") mkEmptyCTxEntry
                txC = setTimeOfTx (mkTime 1.0) $ setIdOfTx (mkCTxId "C") mkEmptyCTxEntry
                newTxs =
                    [ txA
                    , txC
                    , txB
                    ]
                effModel = update (SocketTxsUpdated (Right newTxs)) initialState
                state = _.state effModel
            it "to update latestTransactions sorted by time"
                let result = withDefault [] $ state ^. latestTransactions
                    expected =
                        [ txC
                        , txB
                        , txA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "uses action SocketConnected" do
            it "to update connection to connected"
                let effModel = update (SocketConnected true) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` true
            it "to update connection to disconnected"
                let effModel = update (SocketConnected false) initialState
                    state = _.state effModel
                    result = state ^. socket <<< connected
                in result `shouldEqual` false

        describe "uses action SocketAddSubscription" do
            it "to add a first subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in (gShow result) `shouldEqual` (gShow [subItem])
            it "to add another subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        ]
                                        initialState
                    subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketAddSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                    expected =  [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                ]
                in (gShow result) `shouldEqual` (gShow expected)

        describe "uses action SocketRemoveSubscription" do
            it "to not remove anything, if we do have an empty list of subscriptions"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    effModel = update (SocketRemoveSubscription subItem) initialState
                    state = _.state effModel
                    result = length $ state ^. socket <<< subscriptions
                in result `shouldEqual` 0
            it "to remove a subscription"
                let subItem = mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                    initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update (SocketRemoveSubscription subItem) initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in  (gShow result) `shouldEqual`
                    (gShow [mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData])

        describe "uses action SocketClearSubscriptions" do

            it "to remove nothing if no subscription available"
                let effModel = update SocketClearSubscriptions initialState
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0

            it "to remove all subscription"
                let initialState' = set (socket <<< subscriptions)
                                        [ mkSocketSubscriptionItem (SocketSubscription SubTx) SocketNoData
                                        , mkSocketSubscriptionItem (SocketSubscription SubAddr) SocketNoData
                                        ]
                                        initialState
                    effModel = update SocketClearSubscriptions initialState'
                    state = _.state effModel
                    result = state ^. socket <<< subscriptions
                in length result `shouldEqual` 0


Switch to the notebook view even if file creation fails

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Controller.File where

import Prelude
import Control.Apply ((*>))
import Control.Bind ((=<<))
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Error.Class (throwError)
import Control.Plus (empty)
import Controller.File.Common (Event(), toInput, showError)
import Controller.File.Item (itemURL)
import Data.Array (head, last)
import Data.DOM.Simple.Element (querySelector)
import Data.DOM.Simple.Types (HTMLElement())
import Data.Either (Either(..), either)

import Data.Foreign (F(), parseJSON)
import Data.Foreign.Class (readProp)

import Data.Inject1 (inj)
import Data.Maybe (Maybe(..))
import Data.Path.Pathy ((</>), file, dir)
import Data.String (split)
import Data.These (These(..))
import EffectTypes (FileAppEff())
import Halogen.HTML.Events.Monad (andThen)
import Input.File (Input(), FileInput(..))
import Input.File.Item (ItemInput(..), inputItem)
import Input.File.Mount (MountInput(..), inputMount)
import Model.Action (Action(Edit))
import Model.File (State(), _dialog, _showHiddenFiles, _path, _sort, _salt, _items, isSearching)
import Model.File.Breadcrumb (Breadcrumb())
import Model.File.Dialog (Dialog(..))
import Model.File.Dialog.Mount (MountDialogRec(), initialMountDialog, _inProgress, _externalValidationError)
import Model.File.Item (Item(..), itemResource)
import Network.HTTP.MimeType.Common (textCSV)
import Optic.Core
import Optic.Refractor.Prism (_Just)
import Utils (clearValue, setLocation)
import Utils.Event (raiseEvent)

import qualified Api.Fs as API
import qualified Api.Common as API
import qualified Model.Notebook.Domain as N
import qualified Model.Resource as R
import qualified Utils.File as Uf

handleCreateNotebook :: forall e. State -> Event e
handleCreateNotebook state = do
  let notebook = N.emptyNotebook # N._path .~ (state ^. _path)
  f <- liftAff $ attempt $ API.saveNotebook notebook
  let notebook' = either (const (notebook # N._name .~ That Config.newNotebookName)) id f
  case N.notebookURL notebook' Edit of
    Just url -> liftEff (setLocation url) *> empty
    Nothing -> empty

handleFileListChanged :: forall e. HTMLElement -> State -> Event e
handleFileListChanged el state = do
  fileArr <- Uf.fileListToArray <$> (liftAff $ Uf.files el)
  liftEff $ clearValue el
  case head fileArr of
    Nothing ->
      let err :: Aff (FileAppEff e) Input
          err = throwError $ error "empty filelist"
      in liftAff err
    Just f -> do
      let newReader :: Eff (FileAppEff e) _
          newReader = Uf.newReaderEff

          readAsBinaryString :: _ -> _ -> Aff (FileAppEff e) _
          readAsBinaryString = Uf.readAsBinaryString

      name <- liftAff $ API.getNewName (state ^. _path) =<< liftEff (Uf.name f)
      let path = state ^. _path
          fileName = path </> file name
          fileItem = PhantomItem $ R.File $ path </> file name
          ext = last (split "." name)
          mime = if ext == Just "csv" then textCSV else API.ldJSON

      reader <- liftEff newReader
      content <- liftAff $ readAsBinaryString f reader

      toInput (ItemAdd fileItem) `andThen` \_ -> do
        f <- liftAff $ attempt $ API.makeFile fileName mime content
        case f of
          Left err ->
            -- TODO: compiler issue? using `showError` here doesn't typecheck
            toInput (WithState (_dialog ?~ (ErrorDialog $ "There was a problem uploading the file: " ++ message err)))
              `andThen` \_ -> toInput (ItemRemove fileItem)
          Right _ ->
            liftEff (setLocation $ itemURL (state ^. _sort) (state ^. _salt) Edit fileItem) *> empty

handleUploadFile :: forall e. HTMLElement -> Event e
handleUploadFile el = do
  mbInput <- liftEff $ querySelector "input" el
  case mbInput of
    Nothing -> empty
    Just input -> do
      liftEff $ raiseEvent "click" input
      empty

-- | clicked on _Folder_ link, create phantom folder
handleCreateFolder :: forall e. State -> Event e
handleCreateFolder state = do
  let path = state ^. _path
  dirName <- liftAff $ API.getNewName path Config.newFolderName
  let dirPath = path </> dir dirName
      dirItem = PhantomItem $ R.Directory dirPath
      hiddenFile = dirPath </> file (Config.folderMark)
  (toInput (ItemAdd dirItem)) `andThen` \_ -> do
    added <- liftAff $ attempt $ API.makeFile hiddenFile API.ldJSON "{}"
    toInput (ItemRemove dirItem) `andThen` \_ ->
      case added of
        Left err -> showError ("There was a problem creating the directory: " ++ message err)
        Right _ -> toInput $ ItemAdd $ Item $ R.Directory dirPath

handleHiddenFiles :: forall e a. Boolean -> Event e
handleHiddenFiles b = toInput $ WithState (_showHiddenFiles .~ b)

handleMountDatabase :: forall e. State -> Event e
handleMountDatabase state =
  toInput $ WithState (_dialog ?~ MountDialog initialMountDialog { parent = state ^. _path })

saveMount :: forall e. MountDialogRec -> Event e
saveMount rec = do
  let resource = R.Database $ rec.parent </> dir rec.name
  toInput (WithState $ setInProgress true .. setErrorMessage Nothing) `andThen` \_ -> do
    result <- liftAff $ attempt $ API.saveMount resource rec.connectionURI
    toInput (WithState $ setInProgress false) `andThen` \_ -> do
      case result of
        Left err ->  do
          let msg = "There was a problem saving the mount: " ++ extractErrorMessage (message err)
          toInput $ WithState $ setErrorMessage $ Just msg
        Right _ ->
          toInput $ WithState $
            (_dialog .~ Nothing)
              .. stateInputItem (ItemAdd $ Item resource)

  where
    setInProgress b = updateMountDialog $ _inProgress .~ b
    setErrorMessage msg = updateMountDialog $ (_externalValidationError .~ msg)
    updateMountDialog f = _dialog .. _Just %~ inputMount (ValueChanged f)

    stateInputItem it st = st # _items %~ inputItem (st ^. _sort) (isSearching st) it

    extractErrorMessage :: String -> String
    extractErrorMessage msg =
      case parseJSON msg >>= readProp "error" of
         Left _ -> msg
         Right msg' -> msg'

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Controller.File where

import Prelude
import Control.Apply ((*>))
import Control.Bind ((=<<))
import Control.Monad.Aff (Aff(), attempt)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (error, message)
import Control.Monad.Error.Class (throwError)
import Control.Plus (empty)
import Controller.File.Common (Event(), toInput, showError)
import Controller.File.Item (itemURL)
import Data.Array (head, last)
import Data.DOM.Simple.Element (querySelector)
import Data.DOM.Simple.Types (HTMLElement())
import Data.Either (Either(..))

import Data.Foreign (F(), parseJSON)
import Data.Foreign.Class (readProp)

import Data.Inject1 (inj)
import Data.Maybe (Maybe(..))
import Data.Path.Pathy ((</>), file, dir)
import Data.String (split)
import Data.These (These(..))
import EffectTypes (FileAppEff())
import Halogen.HTML.Events.Monad (andThen)
import Input.File (Input(), FileInput(..))
import Input.File.Item (ItemInput(..), inputItem)
import Input.File.Mount (MountInput(..), inputMount)
import Model.Action (Action(Edit))
import Model.File (State(), _dialog, _showHiddenFiles, _path, _sort, _salt, _items, isSearching)
import Model.File.Breadcrumb (Breadcrumb())
import Model.File.Dialog (Dialog(..))
import Model.File.Dialog.Mount (MountDialogRec(), initialMountDialog, _inProgress, _externalValidationError)
import Model.File.Item (Item(..), itemResource)
import Network.HTTP.MimeType.Common (textCSV)
import Optic.Core
import Optic.Refractor.Prism (_Just)
import Utils (clearValue, setLocation)
import Utils.Event (raiseEvent)

import qualified Api.Fs as API
import qualified Api.Common as API
import qualified Model.Notebook.Domain as N
import qualified Model.Resource as R
import qualified Utils.File as Uf

handleCreateNotebook :: forall e. State -> Event e
handleCreateNotebook state = do
  f <- liftAff $ attempt $ API.saveNotebook (N.emptyNotebook # N._path .~ (state ^. _path))
  case f of
    Left err -> showError ("There was a problem creating the notebook: " ++ message err)
    Right notebook -> case N.notebookURL notebook Edit of
      Just url -> liftEff (setLocation url) *> empty
      Nothing -> empty

handleFileListChanged :: forall e. HTMLElement -> State -> Event e
handleFileListChanged el state = do
  fileArr <- Uf.fileListToArray <$> (liftAff $ Uf.files el)
  liftEff $ clearValue el
  case head fileArr of
    Nothing ->
      let err :: Aff (FileAppEff e) Input
          err = throwError $ error "empty filelist"
      in liftAff err
    Just f -> do
      let newReader :: Eff (FileAppEff e) _
          newReader = Uf.newReaderEff

          readAsBinaryString :: _ -> _ -> Aff (FileAppEff e) _
          readAsBinaryString = Uf.readAsBinaryString

      name <- liftAff $ API.getNewName (state ^. _path) =<< liftEff (Uf.name f)
      let path = state ^. _path
          fileName = path </> file name
          fileItem = PhantomItem $ R.File $ path </> file name
          ext = last (split "." name)
          mime = if ext == Just "csv" then textCSV else API.ldJSON

      reader <- liftEff newReader
      content <- liftAff $ readAsBinaryString f reader

      toInput (ItemAdd fileItem) `andThen` \_ -> do
        f <- liftAff $ attempt $ API.makeFile fileName mime content
        case f of
          Left err ->
            -- TODO: compiler issue? using `showError` here doesn't typecheck
            toInput (WithState (_dialog ?~ (ErrorDialog $ "There was a problem uploading the file: " ++ message err)))
              `andThen` \_ -> toInput (ItemRemove fileItem)
          Right _ ->
            liftEff (setLocation $ itemURL (state ^. _sort) (state ^. _salt) Edit fileItem) *> empty

handleUploadFile :: forall e. HTMLElement -> Event e
handleUploadFile el = do
  mbInput <- liftEff $ querySelector "input" el
  case mbInput of
    Nothing -> empty
    Just input -> do
      liftEff $ raiseEvent "click" input
      empty

-- | clicked on _Folder_ link, create phantom folder
handleCreateFolder :: forall e. State -> Event e
handleCreateFolder state = do
  let path = state ^. _path
  dirName <- liftAff $ API.getNewName path Config.newFolderName
  let dirPath = path </> dir dirName
      dirItem = PhantomItem $ R.Directory dirPath
      hiddenFile = dirPath </> file (Config.folderMark)
  (toInput (ItemAdd dirItem)) `andThen` \_ -> do
    added <- liftAff $ attempt $ API.makeFile hiddenFile API.ldJSON "{}"
    toInput (ItemRemove dirItem) `andThen` \_ ->
      case added of
        Left err -> showError ("There was a problem creating the directory: " ++ message err)
        Right _ -> toInput $ ItemAdd $ Item $ R.Directory dirPath

handleHiddenFiles :: forall e a. Boolean -> Event e
handleHiddenFiles b = toInput $ WithState (_showHiddenFiles .~ b)

handleMountDatabase :: forall e. State -> Event e
handleMountDatabase state =
  toInput $ WithState (_dialog ?~ MountDialog initialMountDialog { parent = state ^. _path })

saveMount :: forall e. MountDialogRec -> Event e
saveMount rec = do
  let resource = R.Database $ rec.parent </> dir rec.name
  toInput (WithState $ setInProgress true .. setErrorMessage Nothing) `andThen` \_ -> do
    result <- liftAff $ attempt $ API.saveMount resource rec.connectionURI
    toInput (WithState $ setInProgress false) `andThen` \_ -> do
      case result of
        Left err ->  do
          let msg = "There was a problem saving the mount: " ++ extractErrorMessage (message err)
          toInput $ WithState $ setErrorMessage $ Just msg
        Right _ ->
          toInput $ WithState $
            (_dialog .~ Nothing)
              .. stateInputItem (ItemAdd $ Item resource)

  where
    setInProgress b = updateMountDialog $ _inProgress .~ b
    setErrorMessage msg = updateMountDialog $ (_externalValidationError .~ msg)
    updateMountDialog f = _dialog .. _Just %~ inputMount (ValueChanged f)

    stateInputItem it st = st # _items %~ inputItem (st ^. _sort) (isSearching st) it

    extractErrorMessage :: String -> String
    extractErrorMessage msg =
      case parseJSON msg >>= readProp "error" of
         Left _ -> msg
         Right msg' -> msg'


Make pulp version happy

Make pulp version happy

module Data.TimeSeries
    ( DataPoint
    , Series
    , dataPoint
    -- * Constructors
    , empty
    , fromDataPoints
    , fromValues
    , series
    , mkIndex
    -- Data operations
    , filter
    , length
    , slice
    , toDataPoints
    , zipWith
    ) where

import Prelude
import Data.Array as A
import Data.Int (toNumber)
import Data.Maybe (fromMaybe, fromJust)
import Data.Tuple (Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

import Data.TimeSeries.Time(Timestamp)

-- | Data point is a time indexed value
type DataPoint a = { index :: Timestamp, value :: a }

-- | Data structure for holding Series.
type Series a = { index :: Array Timestamp
                , values :: Array a
                }

-- | Create data point
dataPoint :: ∀ a. Timestamp -> a -> DataPoint a
dataPoint i v = { index: i, value: v }

--  | Create series from indexes and values
series :: ∀ a. Array Timestamp -> Array a -> Series a
series is vs = {index: is, values: vs}

-- | Create an empty series
empty :: ∀ a. Series a
empty = series [] []

-- | Create series from DateTime and value.
fromDataPoints :: ∀ a. Array (DataPoint a) -> Series a
fromDataPoints xs = series (map _.index xs) (map _.value xs)

-- | Conver to array of data points
toDataPoints :: ∀ a. Series a -> Array (DataPoint a)
toDataPoints xs = (\t -> dataPoint (fst t) (snd t)) <$> A.zip xs.index xs.values

-- | Create series from values.
-- | Index will be based on Timestamp starting from 0
fromValues :: ∀ a. Array a -> Series a
fromValues xs = series (mkIndex (A.length xs)) xs

-- | Create index starting from lowest date (bottom)
-- | In each step time is increased by 1 second
mkIndex :: Int -> Array Timestamp
mkIndex n = map (\x -> 1000.0 * (toNumber x)) (A.range 0 (n-1))

-- | Get series length.
length :: ∀ a. Series a -> Int
length xs = A.length xs.index

-- | Get subseries
slice :: ∀ a. Timestamp     -- ^ Start time (inclusive)
      -> Timestamp          -- ^ End time (inclusive)
      -> Series a           -- ^ Input series
      -> Series a           -- ^ Sliced Series
slice start end xs = series (A.slice i j xs.index) (A.slice i j xs.values)
    where
        n = length xs
        i = fromMaybe n $ A.findIndex (\x -> x >= start) xs.index
        j = fromMaybe n $ A.findLastIndex (\x -> x <= end) xs.index

-- | Filter a series, keeping the elements which satisfy a predicate function, creating a new series.
filter :: ∀ a. (a -> Boolean) -> Series a -> Series a
filter pred xs = series (fst tu) (snd tu)
    where
        -- zip
        xs1 = A.zip xs.index xs.values
        -- filter zipped
        xs2 = A.filter (\t -> pred (snd t)) xs1
        -- Unzip
        tu = A.unzip xs2

-- | Join 2 series using given function
-- | Series will be joinned on index. It means that both series need to have the same index entries
-- | If only 1 series contains given index then this item will be dropped
zipWith :: ∀ a b c. (a -> b -> c) -> Series a -> Series b -> Series c
zipWith f xs ys = fromDataPoints $ zipWith' f (toDataPoints xs) (toDataPoints ys)

-- Helper function which works on data points
zipWith' :: ∀ a b c. (a -> b -> c) -> Array (DataPoint a) -> Array (DataPoint b) -> Array (DataPoint c)
zipWith' f xs ys = snd $ A.foldl g (Tuple ys []) xs
    where
        g :: Tuple (Array (DataPoint b)) (Array (DataPoint c)) -> DataPoint a -> Tuple (Array (DataPoint b)) (Array (DataPoint c))
        g tu x = if A.null ys' then tu
                 else if y'.index > x.index then Tuple ys' (snd tu)
                 else Tuple yt' (A.snoc (snd tu) (dataPoint x.index (f x.value y'.value)))
            where
                ys' = A.dropWhile (\y -> y.index < x.index) (fst tu)
                y' = unsafePartial $ fromJust $ A.head ys'
                yt' = unsafePartial $ fromJust $ A.tail ys'

module Data.TimeSeries
    ( DataPoint
    , Series
    , dataPoint
    -- * Constructors
    , empty
    , fromDataPoints
    , fromValues
    , series
    , mkIndex
    -- Data operations
    , filter
    , length
    , slice
    , toDataPoints
    , zipWith
    ) where

import Prelude
import Data.Array as A
import Data.Int (toNumber)
import Data.Maybe (fromMaybe, fromJust)
import Data.Tuple (Tuple(..), fst, snd)
import Partial.Unsafe (unsafePartial)

import Data.TimeSeries.Time(Timestamp)

-- | Data point is a time indexed value
type DataPoint a = { index :: Timestamp, value :: a }

-- | Data structure for holding Series.
type Series a = { index :: Array Timestamp
                , values :: Array a
                }

-- | Create data point
dataPoint :: ∀ a. Timestamp -> a -> DataPoint a
dataPoint i v = { index: i, value: v }

--  | Create series from indexes and values
series :: ∀ a. Array Timestamp -> Array a -> Series a
series is vs = {index: is, values: vs}

-- | Create an empty series
empty :: ∀ a. Series a
empty = series [] []

-- | Create series from DateTime and value.
fromDataPoints :: ∀ a. Array (DataPoint a) -> Series a
fromDataPoints xs = series (map _.index xs) (map _.value xs)

-- | Conver to array of data points
toDataPoints :: ∀ a. Series a -> Array (DataPoint a)
toDataPoints xs = (\t -> dataPoint (fst t) (snd t)) <$> A.zip xs.index xs.values

-- | Create series from values.
-- | Index will be based on Timestamp starting from 0
fromValues :: ∀ a. Array a -> Series a
fromValues xs = series (mkIndex (A.length xs)) xs

-- | Create index starting from lowest date (bottom)
-- | In each step time is increased by 1 second
mkIndex :: Int -> Array Timestamp
mkIndex n = map (\x -> 1000.0 * (toNumber x)) (A.range 0 (n-1))

-- | Get series length.
length :: ∀ a. Series a -> Int
length xs = A.length xs.index

-- | Get subseries
slice :: ∀ a. Timestamp     -- ^ Start time (inclusive)
      -> Timestamp          -- ^ End time (inclusive)
      -> Series a           -- ^ Input series
      -> Series a           -- ^ Sliced Series
slice start end xs = series (A.slice i j xs.index) (A.slice i j xs.values)
    where
        n = length xs
        i = fromMaybe n $ A.findIndex (\x -> x >= start) xs.index
        j = fromMaybe n $ A.findLastIndex (\x -> x <= end) xs.index

-- | Filter a series, keeping the elements which satisfy a predicate function, creating a new series.
filter :: ∀ a. (a -> Boolean) -> Series a -> Series a
filter pred xs = series is vs
    where
        -- zip
        xs1 = A.zip xs.index xs.values
        -- filter zipped
        xs2 = A.filter (\t -> pred (snd t)) xs1
        -- Unzip
        Tuple is vs = A.unzip xs2

-- | Join 2 series using given function
-- | Series will be joinned on index. It means that both series need to have the same index entries
-- | If only 1 series contains given index then this item will be dropped
zipWith :: ∀ a b c. (a -> b -> c) -> Series a -> Series b -> Series c
zipWith f xs ys = fromDataPoints $ zipWith' f (toDataPoints xs) (toDataPoints ys)

-- Helper function which works on data points
zipWith' :: ∀ a b c. (a -> b -> c) -> Array (DataPoint a) -> Array (DataPoint b) -> Array (DataPoint c)
zipWith' f xs ys = snd $ A.foldl g (Tuple ys []) xs
    where
        g :: Tuple (Array (DataPoint b)) (Array (DataPoint c)) -> DataPoint a -> Tuple (Array (DataPoint b)) (Array (DataPoint c))
        g tu x = if A.null ys' then tu
                 else if y'.index > x.index then Tuple ys' (snd tu)
                 else Tuple yt' (A.snoc (snd tu) (dataPoint x.index (f x.value y'.value)))
            where
                ys' = A.dropWhile (\y -> y.index < x.index) (fst tu)
                y' = unsafePartial $ fromJust $ A.head ys'
                yt' = unsafePartial $ fromJust $ A.tail ys'


Let CellSlamDownEvent trigger an autosave (fix #431)

module Driver.Notebook where

import Prelude
import Api.Fs (loadNotebook, saveNotebook)
import Control.Monad (when, unless)
import Control.Monad.Aff (Aff(), runAff, attempt)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (Error(), message)
import Control.Monad.Eff.Ref (Ref(), readRef, modifyRef, writeRef)
import Control.Plus (empty)
import Control.Timer (Timeout(), timeout, clearTimeout, interval)
import Controller.Notebook (handleMenuSignal)
import Controller.Notebook.Cell (requestCellContent)
import Controller.Notebook.Cell.Explore (runExplore)
import Controller.Notebook.Common (run)
import Data.Date (now)
import Data.DOM.Simple.Document
import Data.DOM.Simple.Events (KeyboardEventType(KeydownEvent), metaKey, shiftKey, ctrlKey, keyCode, addKeyboardEventListener, preventDefault)
import Data.DOM.Simple.Types (DOMEvent())
import Data.DOM.Simple.Window (globalWindow, document)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Array (filter)
import Data.Inject1 (inj)
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.These (These(..), theseRight, theseLeft)
import Data.Tuple (Tuple(..), fst)
import Driver.Notebook.Routing (Routes(..), routing)
import EffectTypes (NotebookComponentEff(), NotebookAppEff())
import Halogen (Driver())
import Halogen.HTML.Events.Monad (runEvent, andThen)
import Input.Notebook (Input(..))
import Model.Action (Action(Edit), isEdit)
import Model.Notebook
import Model.Notebook.Cell (Cell(), CellId(), CellContent(..), _cellId, _hasRun, _content, _output, _parent)
import Model.Notebook.Cell.Explore (initialExploreRec, _input)
import Model.Notebook.Cell.FileInput
import Model.Notebook.Domain (addCell, emptyNotebook, _activeCellId, _path, _name, _cells, notebookURL, cellOut, replacePendingPorts, _dependencies, Dependencies())
import Model.Notebook.Menu
import Model.Notebook.Port
import Model.Path (decodeURIPath, dropNotebookExt)
import Model.Resource (Resource(), resourceName, resourceDir)
import Optic.Core
import Routing (matches')
import Utils (replaceLocation)
import Data.Map (lookup)
import qualified Data.Maybe.Unsafe as U
import qualified Config as Config

tickDriver :: forall e. Driver Input (NotebookComponentEff e)
                     -> Eff (NotebookAppEff e) Unit
tickDriver k = void $ interval Config.tickTick $ now >>= k <<< WithState <<< (_tickDate .~) <<< Just

driver :: forall e. Ref State
                 -> Driver Input (NotebookComponentEff e)
                 -> Eff (NotebookAppEff e) Unit
driver ref k =
  matches' decodeURIPath routing \old new -> do
    case new of
      CellRoute res cellId editable -> notebook res editable $ Just cellId
      NotebookRoute res editable -> notebook res editable Nothing
      ExploreRoute res -> do
        let newNotebook = emptyNotebook # _path .~ resourceDir res
            newCell = Explore (initialExploreRec # _input .. _file .~ Right res)
        case addCell newCell newNotebook of
          Tuple notebook cell -> do
            update $ (_editable .~ true)
                  .. (_loaded .~ true)
                  .. (_error .~ Nothing)
                  .. (_notebook .~ notebook)
            runEvent (runError "runExplore") k $ run cell `andThen` \_ -> runExplore cell

  where

  update :: (State -> State) -> Eff (NotebookAppEff e) Unit
  update = k <<< WithState

  cellUpdate :: Cell -> (Cell -> Cell) -> Eff (NotebookAppEff e) Unit
  cellUpdate cell = k <<< (UpdateCell (cell ^._cellId))

  runError :: String -> Error -> Eff (NotebookAppEff e) Unit
  runError from err = log $ "Error for " ++ from ++ " in driver: " ++ show err

  notebook :: Resource -> Action -> Maybe CellId -> Eff (NotebookAppEff e) Unit
  notebook res editable viewing = do
    state <- readRef ref
    let name = dropNotebookExt (resourceName res)
        path = resourceDir res
        oldNotebook = state ^. _notebook
        pathChanged = oldNotebook ^. _path /= path
        oldName = theseLeft (oldNotebook ^. _name)
        nameChanged = oldName /= Just name
    when (pathChanged || nameChanged) do
      runAff' (loadNotebook res) \result -> do
        update $ (_loaded .~ true)
              .. (_notebook .. _name .~ This "")
              .. (_editable .~ isEdit editable)
              .. (_viewingCell .~ viewing)
        case result of
          Left err -> update (_error ?~ message err)
          Right nb -> do
            update (_notebook .~ nb)
            if isEdit editable
              then
              for_ (filter (filterFn (nb ^._dependencies))
                    (nb ^._cells)) \cell -> do
                update (_requesting <>~ [cell ^._cellId])
                k $ RequestCellContent cell
              else
              for_ (filter (^._hasRun) (nb ^._cells)) (k <<< ViewCellContent)

            for_ (nb ^. _cells) \cell -> do
              case Tuple (cell ^. _content) (cell ^._output) of
                Tuple (Search _) Closed ->
                  cellUpdate cell
                  (_output .~ cellOut cell nb)
                _ -> pure unit
  filterFn :: Dependencies -> Cell -> Boolean
  filterFn dpMap cell =
    (maybe true (const false) $ lookup (cell ^._cellId) dpMap) && (cell ^._hasRun)

handleShortcuts :: forall e. Ref State
                          -> Driver Input (NotebookComponentEff e)
                          -> Eff (NotebookAppEff e) Unit
handleShortcuts ref k =
  document globalWindow >>= addKeyboardEventListener KeydownEvent (handler ref)
  where
  handler :: Ref State -> DOMEvent -> _
  handler ref e = void do
    meta <- (||) <$> ctrlKey e <*> metaKey e
    shift <- shiftKey e
    code <- keyCode e
    state <- readRef ref
    when (state ^. _editable) $ do
      let handle signal = do
            preventDefault e
            pure $ handleMenuSignal state signal
      event <- case code of
        83 | meta && shift -> handle $ inj $ RenameNotebook
        80 | meta -> handle $ inj $ PublishNotebook
        49 | meta -> handle $ inj $ QueryInsert
        50 | meta -> handle $ inj $ MarkdownInsert
        51 | meta -> handle $ inj $ ExploreInsert
        52 | meta -> handle $ inj $ SearchInsert
        13 | meta -> handle $ inj $ EvaluateCell
        _ -> pure empty
      runEvent (\_ -> log "Error in handleShortcuts") k event

notebookAutosave :: forall e. Ref State
                           -> Ref Timeout
                           -> Input
                           -> Driver Input (NotebookComponentEff e)
                           -> Eff (NotebookAppEff e) Unit
notebookAutosave refState refTimer input k = do
  state <- readRef refState
  let notebook = state ^. _notebook
      hasBeenSaved = isJust $ theseRight (notebook ^. _name)
      save = do
        t <- readRef refTimer
        clearTimeout t
        t' <- timeout Config.autosaveTick $ runAff' (saveNotebook notebook) \result -> do
          case result of
            Left err -> k $ WithState (_error ?~ message err)
            Right nb -> do
              let update = (_notebook %~ replacePendingPorts)
                       <<< (_notebook .. _name .~ (nb ^. _name))

              k $ WithState update
              -- This crime is to update the state so that when NotebookRoute is
              -- triggered in the router, the state will have the saved-name for
              -- the notebook, which will prevent it from re-loading it. We need
              -- to do this now because the stateRef is updated in postRender,
              -- but changing the URL happens immediately.
              modifyRef refState update
              unless hasBeenSaved $ replaceLocation $ U.fromJust $ notebookURL nb Edit
        writeRef refTimer t'
  case input of
    ForceSave -> save
    AddCell _ -> save
    InsertCell _ _ -> save
    UpdateCell _ _ | hasBeenSaved -> save
    CellResult _ _ _ | hasBeenSaved -> save
    TrashCell _ | hasBeenSaved -> save
    CellSlamDownEvent _ _ | hasBeenSaved -> save
    _ -> pure unit

runAff' :: forall e a. Aff e a -> (Either Error a -> Eff e Unit) -> Eff e Unit
runAff' aff f = runAff (const $ pure unit) f (attempt aff)

module Driver.Notebook where

import Prelude
import Api.Fs (loadNotebook, saveNotebook)
import Control.Monad (when, unless)
import Control.Monad.Aff (Aff(), runAff, attempt)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Console (log)
import Control.Monad.Eff.Exception (Error(), message)
import Control.Monad.Eff.Ref (Ref(), readRef, modifyRef, writeRef)
import Control.Plus (empty)
import Control.Timer (Timeout(), timeout, clearTimeout, interval)
import Controller.Notebook (handleMenuSignal)
import Controller.Notebook.Cell (requestCellContent)
import Controller.Notebook.Cell.Explore (runExplore)
import Controller.Notebook.Common (run)
import Data.Date (now)
import Data.DOM.Simple.Document
import Data.DOM.Simple.Events (KeyboardEventType(KeydownEvent), metaKey, shiftKey, ctrlKey, keyCode, addKeyboardEventListener, preventDefault)
import Data.DOM.Simple.Types (DOMEvent())
import Data.DOM.Simple.Window (globalWindow, document)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Array (filter)
import Data.Inject1 (inj)
import Data.Maybe (Maybe(..), isJust, isNothing, maybe)
import Data.These (These(..), theseRight, theseLeft)
import Data.Tuple (Tuple(..), fst)
import Driver.Notebook.Routing (Routes(..), routing)
import EffectTypes (NotebookComponentEff(), NotebookAppEff())
import Halogen (Driver())
import Halogen.HTML.Events.Monad (runEvent, andThen)
import Input.Notebook (Input(..))
import Model.Action (Action(Edit), isEdit)
import Model.Notebook
import Model.Notebook.Cell (Cell(), CellId(), CellContent(..), _cellId, _hasRun, _content, _output, _parent)
import Model.Notebook.Cell.Explore (initialExploreRec, _input)
import Model.Notebook.Cell.FileInput
import Model.Notebook.Domain (addCell, emptyNotebook, _activeCellId, _path, _name, _cells, notebookURL, cellOut, replacePendingPorts, _dependencies, Dependencies())
import Model.Notebook.Menu
import Model.Notebook.Port
import Model.Path (decodeURIPath, dropNotebookExt)
import Model.Resource (Resource(), resourceName, resourceDir)
import Optic.Core
import Routing (matches')
import Utils (replaceLocation)
import Data.Map (lookup)
import qualified Data.Maybe.Unsafe as U
import qualified Config as Config

tickDriver :: forall e. Driver Input (NotebookComponentEff e)
                     -> Eff (NotebookAppEff e) Unit
tickDriver k = void $ interval Config.tickTick $ now >>= k <<< WithState <<< (_tickDate .~) <<< Just

driver :: forall e. Ref State
                 -> Driver Input (NotebookComponentEff e)
                 -> Eff (NotebookAppEff e) Unit
driver ref k =
  matches' decodeURIPath routing \old new -> do
    case new of
      CellRoute res cellId editable -> notebook res editable $ Just cellId
      NotebookRoute res editable -> notebook res editable Nothing
      ExploreRoute res -> do
        let newNotebook = emptyNotebook # _path .~ resourceDir res
            newCell = Explore (initialExploreRec # _input .. _file .~ Right res)
        case addCell newCell newNotebook of
          Tuple notebook cell -> do
            update $ (_editable .~ true)
                  .. (_loaded .~ true)
                  .. (_error .~ Nothing)
                  .. (_notebook .~ notebook)
            runEvent (runError "runExplore") k $ run cell `andThen` \_ -> runExplore cell

  where

  update :: (State -> State) -> Eff (NotebookAppEff e) Unit
  update = k <<< WithState

  cellUpdate :: Cell -> (Cell -> Cell) -> Eff (NotebookAppEff e) Unit
  cellUpdate cell = k <<< (UpdateCell (cell ^._cellId))

  runError :: String -> Error -> Eff (NotebookAppEff e) Unit
  runError from err = log $ "Error for " ++ from ++ " in driver: " ++ show err

  notebook :: Resource -> Action -> Maybe CellId -> Eff (NotebookAppEff e) Unit
  notebook res editable viewing = do
    state <- readRef ref
    let name = dropNotebookExt (resourceName res)
        path = resourceDir res
        oldNotebook = state ^. _notebook
        pathChanged = oldNotebook ^. _path /= path
        oldName = theseLeft (oldNotebook ^. _name)
        nameChanged = oldName /= Just name
    when (pathChanged || nameChanged) do
      runAff' (loadNotebook res) \result -> do
        update $ (_loaded .~ true)
              .. (_notebook .. _name .~ This "")
              .. (_editable .~ isEdit editable)
              .. (_viewingCell .~ viewing)
        case result of
          Left err -> update (_error ?~ message err)
          Right nb -> do
            update (_notebook .~ nb)
            if isEdit editable
              then
              for_ (filter (filterFn (nb ^._dependencies))
                    (nb ^._cells)) \cell -> do
                update (_requesting <>~ [cell ^._cellId])
                k $ RequestCellContent cell
              else
              for_ (filter (^._hasRun) (nb ^._cells)) (k <<< ViewCellContent)

            for_ (nb ^. _cells) \cell -> do
              case Tuple (cell ^. _content) (cell ^._output) of
                Tuple (Search _) Closed ->
                  cellUpdate cell
                  (_output .~ cellOut cell nb)
                _ -> pure unit
  filterFn :: Dependencies -> Cell -> Boolean
  filterFn dpMap cell =
    (maybe true (const false) $ lookup (cell ^._cellId) dpMap) && (cell ^._hasRun)

handleShortcuts :: forall e. Ref State
                          -> Driver Input (NotebookComponentEff e)
                          -> Eff (NotebookAppEff e) Unit
handleShortcuts ref k =
  document globalWindow >>= addKeyboardEventListener KeydownEvent (handler ref)
  where
  handler :: Ref State -> DOMEvent -> _
  handler ref e = void do
    meta <- (||) <$> ctrlKey e <*> metaKey e
    shift <- shiftKey e
    code <- keyCode e
    state <- readRef ref
    when (state ^. _editable) $ do
      let handle signal = do
            preventDefault e
            pure $ handleMenuSignal state signal
      event <- case code of
        83 | meta && shift -> handle $ inj $ RenameNotebook
        80 | meta -> handle $ inj $ PublishNotebook
        49 | meta -> handle $ inj $ QueryInsert
        50 | meta -> handle $ inj $ MarkdownInsert
        51 | meta -> handle $ inj $ ExploreInsert
        52 | meta -> handle $ inj $ SearchInsert
        13 | meta -> handle $ inj $ EvaluateCell
        _ -> pure empty
      runEvent (\_ -> log "Error in handleShortcuts") k event

notebookAutosave :: forall e. Ref State
                           -> Ref Timeout
                           -> Input
                           -> Driver Input (NotebookComponentEff e)
                           -> Eff (NotebookAppEff e) Unit
notebookAutosave refState refTimer input k = do
  state <- readRef refState
  let notebook = state ^. _notebook
      hasBeenSaved = isJust $ theseRight (notebook ^. _name)
      save = do
        t <- readRef refTimer
        clearTimeout t
        t' <- timeout Config.autosaveTick $ runAff' (saveNotebook notebook) \result -> do
          case result of
            Left err -> k $ WithState (_error ?~ message err)
            Right nb -> do
              let update = (_notebook %~ replacePendingPorts)
                       <<< (_notebook .. _name .~ (nb ^. _name))

              k $ WithState update
              -- This crime is to update the state so that when NotebookRoute is
              -- triggered in the router, the state will have the saved-name for
              -- the notebook, which will prevent it from re-loading it. We need
              -- to do this now because the stateRef is updated in postRender,
              -- but changing the URL happens immediately.
              modifyRef refState update
              unless hasBeenSaved $ replaceLocation $ U.fromJust $ notebookURL nb Edit
        writeRef refTimer t'
  case input of
    ForceSave -> save
    AddCell _ -> save
    InsertCell _ _ -> save
    UpdateCell _ _ | hasBeenSaved -> save
    CellResult _ _ _ | hasBeenSaved -> save
    TrashCell _ | hasBeenSaved -> save
    _ -> pure unit

runAff' :: forall e a. Aff e a -> (Either Error a -> Eff e Unit) -> Eff e Unit
runAff' aff f = runAff (const $ pure unit) f (attempt aff)


Updated central-counter example

Updated central-counter example

to take advantage of new subscriber code-gen.

module Main where

import Control.Bind ((<=<))
import Control.Monad.Aff
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except.Trans
import Control.Monad.Reader.Trans
import Counter.ServerTypes
import Counter.WebAPI
import DOM.Node.Node (baseURI)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Aeson
import Data.Argonaut.Parser (jsonParser)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.Either
import Data.Foldable (foldr, fold)
import Data.Generic
import Data.List (List(Nil, Cons))
import Data.Maybe
import Data.Tuple (Tuple(Tuple))
import Network.HTTP.Affjax (AJAX, get)
import Prelude
import Pux (renderToDOM, fromSimple, start, EffModel, noEffects)
import Pux.Html (Html, text, button, span, div, p)
import Pux.Html.Events (onClick)
import Servant.PureScript.Affjax
import Servant.PureScript.Settings
import Servant.Subscriber.Request (HttpRequest(..))
import Servant.Subscriber.Types (Path(Path))
import Signal (Signal)
import Signal.Channel (Channel, subscribe, send, channel, CHANNEL)
import Unsafe.Coerce (unsafeCoerce)
import WebSocket (WEBSOCKET)
import Servant.Subscriber (Subscriber, makeSubscriber, SubscriberEff, Config, makeSubscriptions)
import Servant.Subscriber as Subscriber
import Counter.WebAPI.Subscriber as Sub

data Action = Increment
            | Decrement
            | Update Int
            | ReportError AjaxError
            | SubscriberLog String
            | Nop

type State = {
    counter :: Int
  , lastError :: Maybe AjaxError
  , settings :: MySettings
  , subscriberLog :: List String
  }

type MySettings = SPSettings_ SPParams_

type APIEffect eff = ReaderT MySettings (ExceptT AjaxError (Aff ( ajax :: AJAX, channel :: CHANNEL | eff)))

type ServantModel =
    { state :: State
    , effects :: Array (APIEffect () Action)
    }

update :: Action -> State -> EffModel State Action (ajax :: AJAX)
update Increment state = runEffectActions state [Update <$> putCounter (CounterAdd 1)]
update Decrement state = runEffectActions state [Update <$> putCounter (CounterAdd (-1))]
update (Update val) state  = { state : state { counter = val }, effects : []}
update (ReportError err ) state = { state : state { lastError = Just err}, effects : []}
update (SubscriberLog msg) state = { state : state { subscriberLog = Cons msg state.subscriberLog}, effects : []}
update Nop state = noEffects state

view :: State -> Html Action
view state =
  div []
    [ div
        []
        [ button [ onClick (const Increment) ] [ text "+" ]
        , span [] [ text (show state.counter) ]
        , button [ onClick (const Decrement) ] [ text "-" ]
        ]
    , div []
        [ span [] [ text $ "Error: " <> show state.lastError ]
        , div  []
            [ text $ "Subscriber Log: "
            , div []
                (foldr Array.cons [] <<< map (\l -> p [] [ text l ]) $ state.subscriberLog)
            ]
        ]
    ]

runEffectActions :: State -> Array (APIEffect () Action) -> EffModel State Action (ajax :: AJAX)
runEffectActions state effects = { state : state, effects : map (runEffect state.settings) effects }

runEffect :: MySettings -> APIEffect () Action -> Aff (channel :: CHANNEL, ajax :: AJAX) Action
runEffect settings m = do
    er <- runExceptT $ runReaderT m settings
    case er of
      Left err -> pure $ ReportError err
      Right v -> pure v

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}

initSubscriber :: forall eff. MySettings -> SubscriberEff (channel :: CHANNEL | eff) (SubscriberData (channel :: CHANNEL | eff))
initSubscriber settings = do
  ch <- channel Nop
  let
    c :: Config (channel :: CHANNEL | eff) Action
    c = {
        url : "ws://localhost:8081/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = subscribe ch
  subs <- flip runReaderT settings $ Sub.getCounter (maybe Nop Update)
  Subscriber.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

-- main :: forall e. Eff (ajax :: AJAX, err :: EXCEPTION, channel :: CHANNEL | e) Unit
main :: forall eff. Eff (ajax :: AJAX, err :: EXCEPTION, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff) Unit
main = do
  let settings = SPSettings_ {
                    encodeJson : encodeJson
                  , decodeJson : decodeJson
                  , toURLPiece : gShow
                  , params : SPParams_ {
                      authToken : VerySecret "topsecret"
                    , baseURL : "http://localhost:8081/"
                    }
                  }
  let initState = { counter : 0, settings : settings, lastError : Nothing, subscriberLog : Nil }
  sub <- initSubscriber settings
  app <- coerceEffects <<< start $
    { initialState: initState
    , update: update
    , view: view
    , inputs: [sub.messages]
    --, inputs : []
    }

  renderToDOM "#app" app.html

coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a
coerceEffects = unsafeCoerce

module Main where

import Control.Bind ((<=<))
import Control.Monad.Aff
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except.Trans
import Control.Monad.Reader.Trans
import Counter.ServerTypes
import Counter.WebAPI
import DOM.Node.Node (baseURI)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Generic.Aeson
import Data.Argonaut.Parser (jsonParser)
import Data.Array as Array
import Data.Bifunctor (lmap)
import Data.Either
import Data.Foldable (foldr, fold)
import Data.Generic
import Data.List (List(Nil, Cons))
import Data.Maybe
import Data.Tuple (Tuple(Tuple))
import Network.HTTP.Affjax (AJAX, get)
import Prelude
import Pux (renderToDOM, fromSimple, start, EffModel, noEffects)
import Pux.Html (Html, text, button, span, div, p)
import Pux.Html.Events (onClick)
import Servant.PureScript.Affjax
import Servant.PureScript.Settings
import Servant.Subscriber.Request (HttpRequest(..))
import Servant.Subscriber.Types (Path(Path))
import Signal (Signal)
import Signal.Channel (Channel, subscribe, send, channel, CHANNEL)
import Unsafe.Coerce (unsafeCoerce)
import WebSocket (WEBSOCKET)
import Servant.Subscriber (Subscriber, makeSubscriber, SubscriberEff, Config, makeSubscriptions)
import Servant.Subscriber as Subscriber

data Action = Increment
            | Decrement
            | Update Int
            | ReportError AjaxError
            | SubscriberLog String
            | Nop

type State = {
    counter :: Int
  , lastError :: Maybe AjaxError
  , settings :: MySettings
  , subscriberLog :: List String
  }

type MySettings = SPSettings_ SPParams_

type APIEffect eff = ReaderT MySettings (ExceptT AjaxError (Aff ( ajax :: AJAX, channel :: CHANNEL | eff)))

type ServantModel =
    { state :: State
    , effects :: Array (APIEffect () Action)
    }

subscriberRequest :: HttpRequest
subscriberRequest = HttpRequest {
    httpMethod : "GET"
  , httpPath : Path ["counter"]
  , httpHeaders : [ Tuple "authtoken" "\"topsecret\""]
  , httpQuery : []
  , httpBody : ""
  }

update :: Action -> State -> EffModel State Action (ajax :: AJAX)
update Increment state = runEffectActions state [Update <$> putCounter (CounterAdd 1)]
update Decrement state = runEffectActions state [Update <$> putCounter (CounterAdd (-1))]
update (Update val) state  = { state : state { counter = val }, effects : []}
update (ReportError err ) state = { state : state { lastError = Just err}, effects : []}
update (SubscriberLog msg) state = { state : state { subscriberLog = Cons msg state.subscriberLog}, effects : []}
update Nop state = noEffects state

view :: State -> Html Action
view state =
  div []
    [ div
        []
        [ button [ onClick (const Increment) ] [ text "+" ]
        , span [] [ text (show state.counter) ]
        , button [ onClick (const Decrement) ] [ text "-" ]
        ]
    , div []
        [ span [] [ text $ "Error: " <> show state.lastError ]
        , div  []
            [ text $ "Subscriber Log: "
            , div []
                (foldr Array.cons [] <<< map (\l -> p [] [ text l ]) $ state.subscriberLog)
            ]
        ]
    ]

runEffectActions :: State -> Array (APIEffect () Action) -> EffModel State Action (ajax :: AJAX)
runEffectActions state effects = { state : state, effects : map (runEffect state.settings) effects }

runEffect :: MySettings -> APIEffect () Action -> Aff (channel :: CHANNEL, ajax :: AJAX) Action
runEffect settings m = do
    er <- runExceptT $ runReaderT m settings
    case er of
      Left err -> pure $ ReportError err
      Right v -> pure v

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL | eff) (SubscriberData (channel :: CHANNEL | eff))
initSubscriber = do
  ch <- channel Nop
  let
    c :: Config (channel :: CHANNEL | eff) Action
    c = {
        url : "ws://localhost:8081/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = subscribe ch
  let subs = makeSubscriptions subscriberRequest handleResponse
  Subscriber.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

-- toAction :: Maybe Notification -> Action
-- toAction Nothing                 = SubscriberLog "Received Nothing"
-- toAction (Just notification)     = case notification of
--   Modified path val -> handleModify val
--   _ -> SubscriberLog $ gShow notification

handleResponse :: Maybe Json -> Either String Action
handleResponse Nothing = pure Nop
handleResponse (Just v) = map Update <<< decodeJson $ v

-- main :: forall e. Eff (ajax :: AJAX, err :: EXCEPTION, channel :: CHANNEL | e) Unit
main :: forall eff. Eff (ajax :: AJAX, err :: EXCEPTION, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff) Unit
main = do
  sub <- initSubscriber
  let settings = SPSettings_ {
                    encodeJson : encodeJson
                  , decodeJson : decodeJson
                  , toURLPiece : gShow
                  , params : SPParams_ {
                      authToken : VerySecret "topsecret"
                    , baseURL : "http://localhost:8081/"
                    }
                  }
  let initState = { counter : 0, settings : settings, lastError : Nothing, subscriberLog : Nil }
  app <- coerceEffects <<< start $
    { initialState: initState
    , update: update
    , view: view
    , inputs: [sub.messages]
    --, inputs : []
    }

  renderToDOM "#app" app.html

coerceEffects :: forall eff0 eff1 a. Eff eff0 a -> Eff eff1 a
coerceEffects = unsafeCoerce


Added known issue to FT

Added known issue to FT

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.SlamData.Feature.Test.Search where

import Prelude
import Control.Apply ((*>))
import Test.Feature.Log (successMsg)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.SlamData.Feature.Interactions as Interact
import Test.Feature.Scenario (scenario)

searchScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
searchScenario =
  scenario
    "Search"
    (Interact.createWorkspaceInTestFolder "Search")
    (Interact.deleteFileInTestFolder "Search.slam"
       *> Interact.browseRootFolder)

test ∷ SlamFeature Unit
test = do
  searchScenario "Search for a city" [] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "springfield"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "pop"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 25 "city" "SPRINGFIELD"
    successMsg "Successfully searched for a city"

  searchScenario "Search within results" [] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "springfield"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "OR"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "state"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 2 "city" "SPRINGFIELD"
    Expect.cardsInTableColumnInLastCardToContain 2 "state" "OR"
    successMsg "Successfully searched within results"

  searchScenario "Search with field names" ["https://github.com/slamdata/slamdata/issues/1190"] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard
      "city:springfield state:or pop:>20000"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "state"
    Interact.addColumn "pop"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 1 "city" "SPRINGFIELD"
    Expect.cardsInTableColumnInLastCardToContain 1 "state" "OR"
    Expect.cardsInTableColumnInLastCardToBeGT 1 "pop" "30000"
    successMsg "Successfully searched with field names"

  searchScenario "Suppress search results" ["https://github.com/slamdata/slamdata/issues/1196"] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "city:portland -state:OR"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "state"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 10 "city" "PORTLAND"
    Expect.cardsInTableColumnInLastCardToNotEq 10 "state" "OR"
    successMsg "Successfully suppressed search results"

{-
Copyright 2015 SlamData, Inc.

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

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

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

module Test.SlamData.Feature.Test.Search where

import Prelude
import Control.Apply ((*>))
import Test.Feature.Log (successMsg)
import Test.SlamData.Feature.Expectations as Expect
import Test.SlamData.Feature.Monad (SlamFeature)
import Test.SlamData.Feature.Interactions as Interact
import Test.Feature.Scenario (scenario)

searchScenario ∷ String → Array String → SlamFeature Unit → SlamFeature Unit
searchScenario =
  scenario
    "Search"
    (Interact.createWorkspaceInTestFolder "Search")
    (Interact.deleteFileInTestFolder "Search.slam"
       *> Interact.browseRootFolder)

test ∷ SlamFeature Unit
test = do
  searchScenario "Search for a city" [] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "springfield"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "pop"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 25 "city" "SPRINGFIELD"
    successMsg "Successfully searched for a city"

  searchScenario "Search within results" [] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "springfield"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "OR"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "state"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 2 "city" "SPRINGFIELD"
    Expect.cardsInTableColumnInLastCardToContain 2 "state" "OR"
    successMsg "Successfully searched within results"

  searchScenario "Search with field names" ["https://github.com/slamdata/slamdata/issues/1190"] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard
      "city:springfield state:or pop:>20000"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "state"
    Interact.addColumn "pop"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 1 "city" "SPRINGFIELD"
    Expect.cardsInTableColumnInLastCardToContain 1 "state" "OR"
    Expect.cardsInTableColumnInLastCardToBeGT 1 "pop" "30000"
    successMsg "Successfully searched with field names"

  searchScenario "Suppress search results" [] do
    Interact.insertOpenCardInLastDeck
    Interact.selectFileForLastOpenCard "/test-mount/testDb/zips"
    Interact.accessNextCardInLastDeck
    Interact.insertSearchCardInLastDeck
    Interact.provideSearchStringInLastSearchCard "city:portland -state:OR"
    Interact.accessNextCardInLastDeck
    Interact.selectBuildChart
    Interact.insertPivotCard
    Interact.addColumn "city"
    Interact.addColumn "state"
    Interact.accessNextCardInLastDeck
    Interact.insertChartCardInLastDeck
    Expect.cardsInTableColumnInLastCardToContain 10 "city" "PORTLAND"
    Expect.cardsInTableColumnInLastCardToNotEq 10 "state" "OR"
    successMsg "Successfully suppressed search results"