[CSE-133] Add new tests for pagination

[CSE-133] Add new tests for pagination

module Explorer.Update.Test where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Array (length)
import Data.Either (Either(..))
import Data.Generic (gShow)
import Data.Identity (Identity)
import Data.Lens ((^.), set)
import Data.Time.NominalDiffTime (mkTime)
import Explorer.Api.Types (RequestLimit(..), RequestOffset(..))
import Explorer.I18n.Lang (Language(..))
import Explorer.Lenses.State (dbViewBlockPagination, dbViewLoadingBlockPagination, dbViewLoadingTotalBlocks, dbViewNextBlockPagination, lang, latestBlocks, latestTransactions, loading, pullLatestBlocks, syncAction, totalBlocks)
import Explorer.State (initialState)
import Explorer.Test.MockFactory (mkCBlockEntry, mkEmptyCTxEntry, setEpochSlotOfBlock, setHashOfBlock, setIdOfTx, setTimeOfTx)
import Explorer.Types.Actions (Action(..))
import Explorer.Update (update)
import Explorer.Util.Config (SyncAction(..))
import Explorer.Util.Factory (mkCHash, mkCTxId)
import Explorer.View.Dashboard.Lenses (dashboardViewState)
import Network.RemoteData (RemoteData(..), isNotAsked, withDefault)
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 SocketBlocksUpdated" do
            -- Mock blocks with epoch, slots and hashes
            let 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
                currentBlocks =
                    [ blockA
                    , blockB
                    ]
                -- set `latestBlocks` + `totalBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) $
                    set totalBlocks (Success $ length currentBlocks) initialState
                newBlocks =
                    [ blockB
                    , blockC
                    , blockD
                    ]
                effModel = update (SocketBlocksUpdated (Right newBlocks)) initialState'
                state = _.state effModel
            it "to update latestBlocks w/o duplicates"
                let result = withDefault [] $ state ^. latestBlocks
                    expected =
                        [ blockD
                        , blockC
                        , blockB
                        , blockA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)
            it "to count totalBlocks"
                let result = withDefault 0 $ state ^. totalBlocks
                in result `shouldEqual` 4

        describe "handles RequestTotalBlocksToPaginateBlocks action" do
            let effModel = update RequestTotalBlocksToPaginateBlocks initialState
                state = _.state effModel
            it "to update pullLatestBlocks"
                let result = state ^. pullLatestBlocks
                in result `shouldEqual` false
            it "to update dbViewLoadingTotalBlocks"
                let result = state ^. (dashboardViewState <<< dbViewLoadingTotalBlocks)
                in result `shouldEqual` true

        describe "handles ReceiveTotalBlocksToPaginateBlocks action" do
            let total = 101
            it "to update totalBlocks"
                let effModel = update (ReceiveTotalBlocksToPaginateBlocks $ Right total) initialState
                    state = _.state effModel
                    result = withDefault 0 $ state ^. totalBlocks
                in
                result `shouldEqual` total
            it "to enable pullLatestBlocks"
                let initialState' = set syncAction SyncByPolling initialState
                    effModel = update (ReceiveTotalBlocksToPaginateBlocks $ Right total) initialState'
                    state = _.state effModel
                    result = state ^. pullLatestBlocks
                in
                result `shouldEqual` true
            it "to disable pullLatestBlocks"
                let initialState' = set syncAction SyncBySocket initialState
                    effModel = update (ReceiveTotalBlocksToPaginateBlocks $ Right total) initialState'
                    state = _.state effModel
                    result = state ^. pullLatestBlocks
                in
                result `shouldEqual` false

        describe "handles RequestPaginatedBlocks action" do
            let effModel = update (RequestPaginatedBlocks (RequestLimit 1) (RequestOffset 0)) 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

        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
                    ]
                newPage = 2
                -- set `latestBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) $
                    set (dashboardViewState <<< dbViewNextBlockPagination) newPage
                    initialState
                paginatedBlocks =
                    [ blockC
                    , blockD
                    , blockE
                    ]
                effModel = update (ReceivePaginatedBlocks (Right paginatedBlocks)) initialState'
                state = _.state effModel
            it "to add blocks to latestBlocks"
                let result = withDefault [] $ state ^. latestBlocks
                in (gShow result) `shouldEqual` (gShow paginatedBlocks)
            it "to set loading to false" do
                (state ^. loading) `shouldEqual` false
            it "to update dbViewBlockPagination by using dbViewNextBlockPagination" do
                (state ^. (dashboardViewState <<< dbViewBlockPagination))
                    `shouldEqual` newPage
            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 ReceiveInitialTxs 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 DashboardPaginateBlocks action" do
            let newPage = 4
                effModel = update (DashboardPaginateBlocks newPage) initialState
                state = _.state effModel
            it "to set dbViewNextBlockPagination"
                let result = state ^. (dashboardViewState <<< dbViewNextBlockPagination)
                in result `shouldEqual` newPage

module Explorer.Update.Test where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.State (StateT)
import Data.Array (length)
import Data.Either (Either(..))
import Data.Generic (gShow)
import Data.Identity (Identity)
import Data.Lens ((^.), set)
import Data.Time.NominalDiffTime (mkTime)
import Explorer.I18n.Lang (Language(..))
import Explorer.Lenses.State (lang, latestBlocks, latestTransactions, totalBlocks)
import Explorer.State (initialState)
import Explorer.Test.MockFactory (mkCBlockEntry, mkEmptyCTxEntry, setEpochSlotOfBlock, setHashOfBlock, setIdOfTx, setTimeOfTx)
import Explorer.Types.Actions (Action(..))
import Explorer.Update (update)
import Explorer.Util.Factory (mkCHash, mkCTxId)
import Network.RemoteData (RemoteData(..), withDefault)
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 SocketBlocksUpdated" do
            -- Mock blocks with epoch, slots and hashes
            let 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
                currentBlocks =
                    [ blockA
                    , blockB
                    ]
                -- set `latestBlocks` + `totalBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) $
                    set totalBlocks (Success $ length currentBlocks) initialState
                newBlocks =
                    [ blockB
                    , blockC
                    , blockD
                    ]
                effModel = update (SocketBlocksUpdated (Right newBlocks)) initialState'
                state = _.state effModel
            it "to update latestBlocks w/o duplicates"
                let result = withDefault [] $ state ^. latestBlocks
                    expected =
                        [ blockD
                        , blockC
                        , blockB
                        , blockA
                        ]
                in (gShow result) `shouldEqual` (gShow expected)
            it "to count totalBlocks"
                let result = withDefault 0 $ state ^. totalBlocks
                in result `shouldEqual` 4

        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
                    ]
                -- set `latestBlocks` to simulate that we have already blocks before
                initialState' =
                    set latestBlocks (Success currentBlocks) initialState
                paginatedBlocks =
                    [ blockC
                    , blockD
                    , blockE
                    ]
                effModel = update (ReceivePaginatedBlocks (Right paginatedBlocks)) initialState'
                state = _.state effModel
            it "to add blocks to latestBlocks"
                let result = withDefault [] $ state ^. latestBlocks
                in (gShow result) `shouldEqual` (gShow paginatedBlocks)

        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 ReceiveInitialTxs 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)


Adds a function to get a clauses' type.

Adds a function to get a clauses' type.

Also genericizes the sortBy functions, and adds a missing parameter to
`Database.saveDatabase`.

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, Collection
	, Pagination
	, limit
	, skip
	, SortOrder
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
	, clause
	, LogicConnector
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, class Database
	, createDatabase
	, deleteDatabase
	, importDatabase
	, exportDatabase
	, openDatabase
	, saveDatabase
	, closeDatabase
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, ($)
	, (<>)
	, (==)
	, (<<<)
	, (>>>)
	)

import Control.Alt            (class Alt, (<|>))
import Control.Monad.Eff      (Eff)
import Control.Monad.Eff.Ref  (REF, Ref)
import Data.Foreign           (Foreign)
import Data.Foreign.Class     (class AsForeign, class IsForeign, write)
import Data.Foreign.Undefined (writeUndefined)
import Data.Either            (Either(Left, Right))
import Data.List              (List, singleton, uncons)
import Data.Maybe             (Maybe(Just, Nothing))
import Data.Monoid            (class Monoid, mempty)
import Unsafe.Coerce          (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy SortOrder
	    | Custom String -- ^ The name of the custom clause.
	    | Negate Clause

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          = "SortBy (" <> show s <> ")"
	show (Custom c)          = "Custom (" <> show c <> ")"
	show (Negate c)          = "Negate (" <> show c <> ")"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy desc
	, custom             : getClauseType $ Custom mempty
	, negate             : getClauseType $ Negate Equals
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(IsForeign a)"
	<> ", predicate: "      <> "(t -> (IsForeign a))"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (AsForeign a) =>
		 Clause                              ->
		 a                                   ->
		 String                              ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : write clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (AsForeign a) =>
		  Clause                              ->
		  a                                   ->
		  (t -> a)                            ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : write clauseValue
	, predicate     : Right (fn >>> write)
	}

equals' :: forall t e. (AsForeign e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (AsForeign e, Eq e) =>
		  String                          ->
		  e                               ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (AsForeign e, Eq e) => e -> (t -> e) -> Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (AsForeign e, Eq e) =>
		 (t -> e)                        ->
		 e                               ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (AsForeign e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (AsForeign e, Eq e) =>
		     String                          ->
		     e                               ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (AsForeign e, Eq e) => e -> (t -> e) -> Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (AsForeign e, Eq e) =>
		    (t -> e)                        ->
		    e                               ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (AsForeign o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                           ->
		    o                                ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (AsForeign o, Ord o) => o -> (t -> o) -> Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                        ->
		    o                               ->
		    Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (AsForeign o, Ord o) =>
		     o                                ->
		     String                           ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                                   ->
		    o                                        ->
		    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (AsForeign o, Ord o) =>
		    o                                ->
		    (t -> o)                         ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                                ->
		    o                                       ->
		    Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (AsForeign o, Ord o) => o -> String -> Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                              ->
		    o                                   ->
		    Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (AsForeign o, Ord o) => o -> (t -> o) -> Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                           ->
		    o                                  ->
		    Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (AsForeign o, Ord o) =>
		     o                                   ->
		     String                              ->
		     Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                                      ->
		    o                                           ->
		    Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (AsForeign o, Ord o) =>
		    o                                   ->
		    (t -> o)                            ->
		    Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                                   ->
		    o                                          ->
		    Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy order
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder -> (t -> Ordering) -> Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy order
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> write)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom name
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom name
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> write)
	}

class Database d where
	createDatabase :: forall e. String  -> Eff (db :: DATABASE | e) Unit
	deleteDatabase :: forall e. String  -> Eff (db :: DATABASE | e) Unit
	importDatabase :: forall e. Foreign -> Eff (db :: DATABASE | e) Unit
	exportDatabase :: forall e. Eff (db :: DATABASE | e) Foreign
	openDatabase   :: forall e. String  -> Eff (db :: DATABASE | e) Unit
	saveDatabase   :: forall e. String  -> Eff (db :: DATABASE | e) Unit
	closeDatabase  :: forall e. String  -> Eff (db :: DATABASE | e) Unit

	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e a t. IsForeign t =>
		    Maybe Pagination          ->
		    Query a t                 ->
		    Ref (Collection t)        ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e a t. IsForeign t =>
		    Maybe Pagination           ->
		    Query a t                  ->
		    (Ref (Collection t))       ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e a t. IsForeign t =>
		      Query a t                 ->
		      Ref (Collection t)        ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. IsForeign t =>
		  t                         ->
		  Ref (Collection t)        ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. IsForeign t =>
		   List t                    ->
		   Ref (Collection t)        ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t a b. IsForeign t =>
		       Query a t                   ->
		       Ref (Collection t)          ->
		       Eff (db :: DATABASE, ref :: REF | e) b

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, Collection
	, Pagination
	, limit
	, skip
	, SortOrder
	, asc
	, desc
	, sortOrder
	, Clause
	, clause
	, LogicConnector
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, class Database
	, createDatabase
	, deleteDatabase
	, importDatabase
	, exportDatabase
	, openDatabase
	, saveDatabase
	, closeDatabase
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, ($)
	, (<>)
	, (==)
	, (<<<)
	, (>>>)
	)

import Control.Alt            (class Alt, (<|>))
import Control.Monad.Eff      (Eff)
import Control.Monad.Eff.Ref  (REF, Ref)
import Data.Foreign           (Foreign)
import Data.Foreign.Class     (class AsForeign, class IsForeign, write)
import Data.Foreign.Undefined (writeUndefined)
import Data.Either            (Either(Left, Right))
import Data.List              (List, singleton, uncons)
import Data.Maybe             (Maybe(Just, Nothing))
import Data.Monoid            (class Monoid, mempty)
import Unsafe.Coerce          (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy SortOrder
	    | Custom String -- ^ The name of the custom clause.
	    | Negate Clause

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          = "SortBy (" <> show s <> ")"
	show (Custom c)          = "Custom (" <> show c <> ")"
	show (Negate c)          = "Negate (" <> show c <> ")"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

clause :: { equals              :: Clause
	  , notEquals           :: Clause
	  , lessThan            :: Clause
	  , lessThanOrEquals    :: Clause
	  , greaterThan         :: Clause
	  , greaterThanOrEquals :: Clause
	  , sortBy              :: SortOrder -> Clause
	  , custom              :: String    -> Clause
	  , negate              :: Clause    -> Clause
	  }
clause =
	{ equals             : Equals
	, notEquals          : NotEquals
	, lessThan           : LessThan
	, lessThanOrEquals   : LessThanOrEquals
	, greaterThan        : GreaterThan
	, greaterThanOrEquals: GreaterThanOrEquals
	, sortBy             : SortBy
	, custom             : Custom
	, negate             : Negate
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(IsForeign a)"
	<> ", predicate: "      <> "(t -> (IsForeign a))"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (AsForeign a) =>
		 Clause                              ->
		 a                                   ->
		 String                              ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : write clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (AsForeign a) =>
		  Clause                              ->
		  a                                   ->
		  (t -> a)                            ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : write clauseValue
	, predicate     : Right (fn >>> write)
	}

equals' :: forall t e. (AsForeign e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (AsForeign e, Eq e) =>
		  String                          ->
		  e                               ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (AsForeign e, Eq e) => e -> (t -> e) -> Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (AsForeign e, Eq e) =>
		 (t -> e)                        ->
		 e                               ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (AsForeign e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (AsForeign e, Eq e) =>
		     String                          ->
		     e                               ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (AsForeign e, Eq e) => e -> (t -> e) -> Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (AsForeign e, Eq e) =>
		    (t -> e)                        ->
		    e                               ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (AsForeign o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                           ->
		    o                                ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (AsForeign o, Ord o) => o -> (t -> o) -> Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                        ->
		    o                               ->
		    Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (AsForeign o, Ord o) =>
		     o                                ->
		     String                           ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                                   ->
		    o                                        ->
		    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (AsForeign o, Ord o) =>
		    o                                ->
		    (t -> o)                         ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                                ->
		    o                                       ->
		    Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (AsForeign o, Ord o) => o -> String -> Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                              ->
		    o                                   ->
		    Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (AsForeign o, Ord o) => o -> (t -> o) -> Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                           ->
		    o                                  ->
		    Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (AsForeign o, Ord o) =>
		     o                                   ->
		     String                              ->
		     Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (AsForeign o, Ord o) =>
		    String                                      ->
		    o                                           ->
		    Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (AsForeign o, Ord o) =>
		    o                                   ->
		    (t -> o)                            ->
		    Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (AsForeign o, Ord o) =>
		    (t -> o)                                   ->
		    o                                          ->
		    Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall t. SortOrder -> String -> Query SQL t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy order
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall t. SortOrder -> (t -> Ordering) -> Query Native t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy order
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> write)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom name
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom name
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> write)
	}

class Database d where
	createDatabase :: forall e. String  -> Eff (db :: DATABASE | e) Unit
	deleteDatabase :: forall e. String  -> Eff (db :: DATABASE | e) Unit
	importDatabase :: forall e. Foreign -> Eff (db :: DATABASE | e) Unit
	exportDatabase :: forall e. Eff (db :: DATABASE | e) Foreign
	openDatabase   :: forall e. String  -> Eff (db :: DATABASE | e) Unit
	saveDatabase   :: forall e. Eff (db :: DATABASE | e) Unit
	closeDatabase  :: forall e. String  -> Eff (db :: DATABASE | e) Unit

	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e a t. IsForeign t =>
		    Maybe Pagination          ->
		    Query a t                 ->
		    Ref (Collection t)        ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e a t. IsForeign t =>
		    Maybe Pagination           ->
		    Query a t                  ->
		    (Ref (Collection t))       ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e a t. IsForeign t =>
		      Query a t                 ->
		      Ref (Collection t)        ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. IsForeign t =>
		  t                         ->
		  Ref (Collection t)        ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. IsForeign t =>
		   List t                    ->
		   Ref (Collection t)        ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t a b. IsForeign t =>
		       Query a t                   ->
		       Ref (Collection t)          ->
		       Eff (db :: DATABASE, ref :: REF | e) b


Let user know when invalid network is used

remove whitespace

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable, mapWithIndex)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, ContractLoadingError(..), getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, mod, not, show, ($), (-), (<<<), (<>), (==))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" $ text "Account"
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ contracts: Contracts.Error error } = do
  renderSectionWarning do
    case error of
      NotDeployedToNetwork networkId ->
        sectionStatus (renderIcon "fa-repeat") do
          text "Please switch to Main Ethereum network"
viewContent state@{ location: Verify } = do
  withFileDetails state.file $ \file -> do
    viewFileSigners state file
viewContent state@{ location: Sign } = do
  withFileDetails state.file $ \file -> do
    sectionHeader "Signing address"
    guardAccountUnlocked state.myAccount $
      viewSigningDetails state file

withFileDetails ::
  Maybe Files.State
  -> (Files.State -> HTML Event)
  -> HTML Event
withFileDetails file viewDetails = do
  viewFileInput (isJust file)
  case file of
    Nothing -> empty
    Just file -> do
      viewFile file
      viewDetails file

viewFileSigners :: State -> Files.State -> HTML Event
viewFileSigners state file = do
  div $ signerStatus file.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just NoSigner -> do
        renderSectionWarning do
          sectionStatus (renderIcon "fa-times") do
            text "This file has not been signed."
          a
            ! A.className "Button"
            #! onClick (navigate Sign)
            $ text "Sign it"

      Just (HashSigner address) -> do
        let selfSigned = case state.myAccount of
              Contracts.Available myAccount -> myAccount == address
              _ -> false
        sectionHeader "Signers"
        renderSection do
          if selfSigned then
            sectionStatus (renderIcon "fa-check-circle-o") do
            text "You have signed this file."
            else empty

          case state ^. signerLens address of
            Nothing -> div do
              text loading
              hr
            Just value -> do
              renderList
                [ child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                ]
        if not selfSigned then
          a
            ! A.className "Button block"
            #! onClick (navigate Sign)
            $ text "Add your signature"
          else empty

viewSigningDetails :: State -> Files.State -> Address -> HTML Event
viewSigningDetails state file address = do
  div ! dataQA "my-id" $ do
    let myDetails = expectResult $ state ^. signerLens address
    renderSectionHighlighted do
      child (Signer address) viewSigner $ myDetails
    case file.result of
      Nothing -> empty
      Just fileDetails ->
        case state.signingTx of
          Nothing ->
            a
              ! A.href "#"
              ! dataQA "sign"
              ! A.className "Button block"
              #! onClickAction (SignFile fileDetails.hash)
              $ do
                text "Sign it"
                renderLinkIcon "fa-paper-plane-o"
          Just (Left err) ->
            div
              ! A.className "Button block disabled"
              $ text "Error while issuing transaction"

          Just (Right hash) -> do
            let txStatus = Contracts.viewTxResult hash state.contracts
            div
              ! A.className "Button block disabled"
              $ txLink hash txStatus

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  let msg = case err of
        NotDeployedToNetwork id ->
          "Contracts have not been deployed to selected network"
  div $ text msg

viewFileInput :: Boolean -> HTML Event
viewFileInput small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text (if small then "Upload another file" else "Upload file")
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

guardAccountUnlocked ::
  Contracts.ETHAccountState Address -> (Address -> HTML Event) -> HTML Event
guardAccountUnlocked state view = do
  case state of
    Contracts.Unavailable -> do
      renderSectionWarning do
        sectionStatus (renderIcon "fa-wrench") do
          text "Please install MetaMask extension"
    Contracts.Locked ->
      renderSectionWarning do
        sectionStatus (renderIcon "fa-unlock-alt") do
          text "Please unlock MetaMask extension"
    Contracts.Available address -> view address

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderSection :: forall a. HTML a -> HTML a
renderSection = div ! className "Section"

renderSectionWarning :: forall a. HTML a -> HTML a
renderSectionWarning = div ! className "Section warning"

renderSectionHighlighted :: forall a. HTML a -> HTML a
renderSectionHighlighted = div ! className "Section highlighted"

sectionStatus :: forall a. HTML a -> HTML a -> HTML a
sectionStatus i content =
  div ! className "status" $ do
    div ! className "status-icon" $ i
    content

sectionHighlight :: Attribute
sectionHighlight = className "highlighted"

sectionWarning :: Attribute
sectionWarning = className "warning"

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderLinkIcon :: forall a. String -> HTML a
renderLinkIcon name = i ! className ("Link-icon fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

renderList :: forall a. Array (HTML a) -> HTML a
renderList elements = do
  let indexed = mapWithIndex Tuple elements
  div ! className "List" $
    for_ indexed \(Tuple i el) ->
      if i `mod` 2 == 1 then
        div ! className "row row-even" $ el
      else
        div ! className "row row-odd" $ el

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  div ! dataQA "tx-status" $ do
    text case status of
      Nothing -> "Tx " <> (take 8 $ show hash ) <> "..."
      Just result -> case result of
        TxPending -> "Tx Pending..."
        TxFailed -> "Tx Failed"
        TxOk -> "Tx Successful"
    a
      ! A.href (txURL hash)
      ! A.target "_blank"
      $ renderIcon "Link-icon fa-external-link"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a

module App.View where

import Text.Smolder.HTML hiding (address)

import App.Routing (Location(..))
import App.State (Event(..), State, signerLens)
import App.State.Contracts as Contracts
import App.State.FileInputs as FileInputs
import App.State.Files as Files
import App.State.Locations as Locations
import App.State.Signers as Signers
import Data.Array (fromFoldable, mapWithIndex)
import Data.Either (Either(..))
import Data.Lens ((^.))
import Data.Map (toUnfoldable, values)
import Data.Maybe (Maybe(..), fromJust, isJust, maybe)
import Data.String (drop, length, take, toLower)
import Data.Traversable (for_)
import Data.Tuple (Tuple(..))
import Lib.Eth.Contracts (class EthContract, ContractLoadingError(..), getAddress)
import Lib.Eth.Web3 (TxHash(..), TxStatus(..))
import Lib.SignHash.Proofs.Display (SignerDisplayStatus(..), signerDisplayStatus)
import Lib.SignHash.Proofs.Methods (ProofMethod(..), canonicalName)
import Lib.SignHash.Proofs.Types (ProofState(..), ProofVerification(..))
import Lib.SignHash.Proofs.Values as ProofValues
import Lib.SignHash.Types (Address(..), HashSigner(..))
import Partial.Unsafe (unsafePartial)
import Prelude (discard, mod, not, show, ($), (-), (<<<), (<>), (==))
import Pux.DOM.Events (DOMEvent, onChange, onClick, onDragOver, onDrop)
import Pux.DOM.HTML (HTML, child)
import Text.Smolder.HTML.Attributes (className, for, id, src, type')
import Text.Smolder.HTML.Attributes as A
import Text.Smolder.Markup (Attribute, EventHandlers, attribute, text, (!), (#!))

foreign import images ::
  { logo :: String
  , ethIcon :: String }

dataQA :: String -> Attribute
dataQA = attribute "data-qa"

view :: State -> HTML Event
view state =
  do
    div ! className "Content" $ do
      div ! className "Header" $ do
        img ! src images.logo
        span ! className "title" $ text "SignHash"

      nav ! className "Navbar" $ do
        ul do
          li $ a ! A.href "#" $ text "Account"
          li $ a ! A.href "#" #! onClick (navigate Sign) $ text "Sign"
          li $ a ! A.href "#" #! onClick (navigate Verify) $ text "Verify"

      viewContent state

      hr
      div ! className "Contracts-info" $ do
        viewContracts state.contracts
      clear

viewContent :: State -> HTML Event
viewContent state@{ location: Verify } = do
  withFileDetails state.file $ \file -> do
    viewFileSigners state file
viewContent state@{ location: Sign } = do
  withFileDetails state.file $ \file -> do
    sectionHeader "Signing address"
    guardAccountUnlocked state.myAccount $
      viewSigningDetails state file

withFileDetails ::
  Maybe Files.State
  -> (Files.State -> HTML Event)
  -> HTML Event
withFileDetails file viewDetails = do
  viewFileInput (isJust file)
  case file of
    Nothing -> empty
    Just file -> do
      viewFile file
      viewDetails file

viewFileSigners :: State -> Files.State -> HTML Event
viewFileSigners state file = do
  div $ signerStatus file.signer
  where
    signerStatus = case _ of
      Nothing -> sectionHeader "Loading signer..."
      Just NoSigner -> do
        renderSectionWarning do
          sectionStatus (renderIcon "fa-times") do
            text "This file has not been signed."
          a
            ! A.className "Button"
            #! onClick (navigate Sign)
            $ text "Sign it"

      Just (HashSigner address) -> do
        let selfSigned = case state.myAccount of
              Contracts.Available myAccount -> myAccount == address
              _ -> false
        sectionHeader "Signers"
        renderSection do
          if selfSigned then
            sectionStatus (renderIcon "fa-check-circle-o") do
            text "You have signed this file."
            else empty

          case state ^. signerLens address of
            Nothing -> div do
              text loading
              hr
            Just value -> do
              renderList
                [ child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                , child (Signer address) viewSigner $ value
                ]
        if not selfSigned then
          a
            ! A.className "Button block"
            #! onClick (navigate Sign)
            $ text "Add your signature"
          else empty

viewSigningDetails :: State -> Files.State -> Address -> HTML Event
viewSigningDetails state file address = do
  div ! dataQA "my-id" $ do
    let myDetails = expectResult $ state ^. signerLens address
    renderSectionHighlighted do
      child (Signer address) viewSigner $ myDetails
    case file.result of
      Nothing -> empty
      Just fileDetails ->
        case state.signingTx of
          Nothing ->
            a
              ! A.href "#"
              ! dataQA "sign"
              ! A.className "Button block"
              #! onClickAction (SignFile fileDetails.hash)
              $ do
                text "Sign it"
                renderLinkIcon "fa-paper-plane-o"
          Just (Left err) ->
            div
              ! A.className "Button block disabled"
              $ text "Error while issuing transaction"

          Just (Right hash) -> do
            let txStatus = Contracts.viewTxResult hash state.contracts
            div
              ! A.className "Button block disabled"
              $ txLink hash txStatus

viewContracts :: Contracts.State -> HTML Event
viewContracts Contracts.Loading =
  text $ "Loading contract..."
viewContracts (Contracts.Loaded state) = do
  contractLink "SignHash" state.signHash
  br
  contractLink "SignProof" state.signProof
  where
    contractLink :: forall c. EthContract c => String -> c -> HTML Event
    contractLink name contract = do
      span $ text $ name <> ": "
      (addressLink $ getAddress contract)
        ! dataQA ((toLower name) <> "-address")

viewContracts (Contracts.Error err) = do
  let msg = case err of
        NotDeployedToNetwork id ->
          "Contracts have not been deployed to selected network"
  div $ text msg

viewFileInput :: Boolean -> HTML Event
viewFileInput small =
  div do
    label
      ! for "file-upload"
      ! className ("File-upload" <> if small then " small" else "")
      #! onDrop handleNewFiles
      #! onDragOver ignoreEvent
      $ do
        renderIcon "fa-file-o"
        text (if small then "Upload another file" else "Upload file")
        if small then empty else
          div ! className "hint"
          $ text "Click or drag and drop on the page"
    input
      ! id "file-upload"
      ! type' "file"
      #! onChange handleNewFiles
  where
    handleNewFiles ev =
      preventingDefault (FileInput $ FileInputs.newFilesEvent ev) ev

viewFile :: Files.State -> HTML Event
viewFile { meta, result, signer } = do
  div ! className "Files Section" $ do
    div ! className "row" $ do
      renderRow "Filename" $ text $ meta.name
      renderRow "SHA256" $ maybe (text loading) renderHash result
      renderRow "Size" $ renderSize meta.size

  where
    renderRow label value =
      div ! className "columns attribute four" $ do
        span ! className "header" $ text (label <> ":")
        span ! className "value" $ value

    renderSigner (HashSigner address) = show address
    renderSigner NoSigner = "Not signed"

    renderHash { hash } =
      let visibleOffset = 6
      in a
         ! dataQA "checksum"
         ! A.title hash
         ! A.href "#"
         $ text $ take visibleOffset hash
           <> "..."
           <> drop (length hash - visibleOffset) hash

    renderSize size = text $ show meta.size <> " B"

viewSigner :: Signers.State -> HTML Signers.Event
viewSigner { address, proofs, blockie } = do
  div ! className "Signer" $ do
    div ! className "header" $ do
      span ! className "status" $ do
        viewSignerStatus
    viewProofs address proofArray
    clear
  where
    proofStates = fromFoldable $ values proofs

    proofArray :: Array (Tuple ProofMethod ProofState)
    proofArray = toUnfoldable proofs

    viewSignerStatus =
      case signerDisplayStatus proofStates of
        SignerLoading -> renderIcon "fa-circle-o-notch loading"
        SignerVerified -> renderBlockie blockie
        SignerVerificationFailed -> renderIcon "fa-exclamation-circle failed"
        SignerNetworkError -> renderIcon "fa-question-circle-o network-error"

viewProofs ::
  Address
  -> Array (Tuple ProofMethod ProofState)
  -> HTML Signers.Event
viewProofs address proofs =
  div ! className "proofs" $ do
    renderEthProof
    for_ proofs renderProof
  where
    renderProof (Tuple method state) = do
      case state of
        Finished result -> renderFinishedProof method result
        NetworkError -> renderNetworkError method
        Pending -> empty

    renderFinishedProof method Unavailable = empty
    renderFinishedProof method (Unverified error) =
      div
        ! className ("proof " <> "failed")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          span ! dataQA "error" ! A.title (show error)
            $ text $ show method <> " verification failed"

    renderFinishedProof method (Verified proofValue) =
      div
        ! className ("proof " <> "verified")
        ! dataQA ("proof-details-" <> canonicalName method)
        $ do
          methodIcon method
          a ! A.href (methodHref method proof) ! A.target "_blank" $ text proof
      where
        proof = ProofValues.extract proofValue

    renderNetworkError method =
      div ! className ("proof" <> "network-error") $ do
        methodIcon method
        text $ "Network error while fetching proof"

    renderEthProof =
      div ! className "proof" $ do
        renderEthIcon
        (addressLink address) ! dataQA "proof-details-eth"

    methodIcon GitHub = renderIcon "fa-github"
    methodIcon HTTP = renderIcon "fa-world"

    methodHref GitHub username =
      "https://github.com/" <> username
    methodHref HTTP domain =
      "http://" <> domain

guardAccountUnlocked ::
  Contracts.ETHAccountState Address -> (Address -> HTML Event) -> HTML Event
guardAccountUnlocked state view = do
  case state of
    Contracts.Unavailable -> do
      renderSectionWarning do
        sectionStatus (renderIcon "fa-wrench") do
          text "Please install MetaMask extension"
    Contracts.Locked ->
      renderSectionWarning do
        sectionStatus (renderIcon "fa-unlock-alt") do
          text "Please unlock MetaMask extension"
    Contracts.Available address -> view address

sectionHeader :: forall a. String -> HTML a
sectionHeader msg =
  h4 ! className "Section-header" $ text msg

renderSection :: forall a. HTML a -> HTML a
renderSection = div ! className "Section"

renderSectionWarning :: forall a. HTML a -> HTML a
renderSectionWarning = div ! className "Section warning"

renderSectionHighlighted :: forall a. HTML a -> HTML a
renderSectionHighlighted = div ! className "Section highlighted"

sectionStatus :: forall a. HTML a -> HTML a -> HTML a
sectionStatus i content =
  div ! className "status" $ do
    div ! className "status-icon" $ i
    content

sectionHighlight :: Attribute
sectionHighlight = className "highlighted"

sectionWarning :: Attribute
sectionWarning = className "warning"

renderIcon :: forall a. String -> HTML a
renderIcon name = i ! className ("fa fa-lg " <> name) $ text ""

renderLinkIcon :: forall a. String -> HTML a
renderLinkIcon name = i ! className ("Link-icon fa fa-lg " <> name) $ text ""

renderEthIcon :: forall a. Html a
renderEthIcon =
  img
  ! className "Icon"
  ! src images.ethIcon

renderBlockie :: forall a. String -> HTML a
renderBlockie blockieSrc =
  img ! className "blockie" ! src blockieSrc

renderList :: forall a. Array (HTML a) -> HTML a
renderList elements = do
  let indexed = mapWithIndex Tuple elements
  div ! className "List" $
    for_ indexed \(Tuple i el) ->
      if i `mod` 2 == 1 then
        div ! className "row row-even" $ el
      else
        div ! className "row row-odd" $ el

loading :: String
loading = "Loading..."

empty :: forall a. HTML a
empty = text ""

clear :: forall a. HTML a
clear = div ! className "Clear" $ empty

addressLink :: forall a. Address -> HTML a
addressLink address = do
  a
  ! A.href (addressURL address)
  ! className "AddressURL"
  ! A.target "_blank"
  $ text $ show address

txLink :: forall a. TxHash -> Maybe TxStatus -> HTML a
txLink hash status = do
  div ! dataQA "tx-status" $ do
    text case status of
      Nothing -> "Tx " <> (take 8 $ show hash ) <> "..."
      Just result -> case result of
        TxPending -> "Tx Pending..."
        TxFailed -> "Tx Failed"
        TxOk -> "Tx Successful"
    a
      ! A.href (txURL hash)
      ! A.target "_blank"
      $ renderIcon "Link-icon fa-external-link"

addressURL :: Address -> String
addressURL (Address address) =
  "https://etherscan.io/address/" <> address

txURL :: TxHash -> String
txURL (TxHash hash) =
  "https://etherscan.io/tx/" <> hash

navigate :: Location -> DOMEvent -> Event
navigate location = Routing <<< Locations.Navigate location

ignoreEvent :: DOMEvent -> Event
ignoreEvent = PreventDefault Nothing

preventingDefault :: Event -> DOMEvent -> Event
preventingDefault next = PreventDefault $ Just next

onClickAction :: Event -> EventHandlers (DOMEvent -> Event)
onClickAction next = onClick $ preventingDefault next

-- | Use where result is expected to be always `Just` due to the app logic,
-- | eg. in internal store lookups
expectResult :: forall a. Maybe a -> a
expectResult a = unsafePartial $ fromJust $ a


Add docs for Body.read (#119)

Add docs for Body.read (#119)

module HTTPure.Body
  ( class Body
  , defaultHeaders
  , read
  , write
  ) where

import Prelude

import Data.Either as Either
import Data.Foldable as Foldable
import Effect as Effect
import Effect.Aff as Aff
import HTTPure.Headers as Headers
import Node.Buffer as Buffer
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.Stream as Stream
import Type.Equality as TypeEquals

-- | Types that implement the `Body` class can be used as a body to an HTTPure
-- | response, and can be used with all the response helpers.
class Body b where

  -- | Return any default headers that need to be sent with this body type,
  -- | things like `Content-Type`, `Content-Length`, and `Transfer-Encoding`.
  -- | Note that any headers passed in a response helper such as `ok'` will take
  -- | precedence over these.
  defaultHeaders :: b -> Effect.Effect Headers.Headers

  -- | Given a body value and a Node HTTP `Response` value, write the body value
  -- | to the Node response.
  write :: b -> HTTP.Response -> Aff.Aff Unit

-- | The instance for `String` will convert the string to a buffer first in
-- | order to determine it's additional headers.  This is to ensure that the
-- | `Content-Length` header properly accounts for UTF-8 characters in the
-- | string.  Writing is simply implemented by writing the string to the
-- | response stream and closing the response stream.
instance bodyString :: Body String where

  defaultHeaders body = Buffer.fromString body Encoding.UTF8 >>= defaultHeaders

  write body response = Aff.makeAff \done -> do
    let stream = HTTP.responseAsStream response
    _ <- Stream.writeString stream Encoding.UTF8 body $ pure unit
    _ <- Stream.end stream $ pure unit
    done $ Either.Right unit
    pure Aff.nonCanceler

-- | The instance for `Buffer` is trivial--we add a `Content-Length` header
-- | using `Buffer.size`, and to send the response, we just write the buffer to
-- | the stream and end the stream.
instance bodyBuffer :: Body Buffer.Buffer where

  defaultHeaders buf =
    Headers.header "Content-Length" <$> show <$> Buffer.size buf

  write body response = Aff.makeAff \done -> do
    let stream = HTTP.responseAsStream response
    _ <- Stream.write stream body $ pure unit
    _ <- Stream.end stream $ pure unit
    done $ Either.Right unit
    pure Aff.nonCanceler

-- | This instance can be used to send chunked data.  Here, we add a
-- | `Transfer-Encoding` header to indicate chunked data.  To write the data, we
-- | simply pipe the newtype-wrapped `Stream` to the response.
instance bodyChunked ::
  TypeEquals.TypeEquals (Stream.Stream r) (Stream.Readable ()) =>
  Body (Stream.Stream r) where

  defaultHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked"

  write body response = Aff.makeAff \done -> do
    let stream = TypeEquals.to body
    _ <- Stream.pipe stream $ HTTP.responseAsStream response
    Stream.onEnd stream $ done $ Either.Right unit
    pure Aff.nonCanceler

-- | Given a readable stream accumulates incomming chunks preserving
-- | their original order.
-- |
-- | We want to append every chunk using single function call
-- | to ensure "atomicity" of this action. If we use any additional
-- | function calls inside our data handler Javascript scheduler can interleave
-- | processing of multiple chunks and we can't be sure if they end up
-- | in correct order.
-- |
-- | Please refer to #117 for more details.
foreign import aggregateChunks :: forall w. Stream.Readable w ->
                                  (Array Buffer.Buffer -> Effect.Effect Unit) ->
                                  Effect.Effect Unit

-- | Extract the contents of the body of the HTTP `Request`.
read :: HTTP.Request -> Aff.Aff String
read request = Aff.makeAff \done -> do
  let
    stream = HTTP.requestAsStream request
    decode = Buffer.toString Encoding.UTF8
  aggregateChunks stream $
    Foldable.foldMap decode >=> Either.Right >>> pure >=> done
  pure Aff.nonCanceler

module HTTPure.Body
  ( class Body
  , defaultHeaders
  , read
  , write
  ) where

import Prelude

import Data.Either as Either
import Data.Foldable as Foldable
import Effect as Effect
import Effect.Aff as Aff
import HTTPure.Headers as Headers
import Node.Buffer as Buffer
import Node.Encoding as Encoding
import Node.HTTP as HTTP
import Node.Stream as Stream
import Type.Equality as TypeEquals

-- | Types that implement the `Body` class can be used as a body to an HTTPure
-- | response, and can be used with all the response helpers.
class Body b where

  -- | Return any default headers that need to be sent with this body type,
  -- | things like `Content-Type`, `Content-Length`, and `Transfer-Encoding`.
  -- | Note that any headers passed in a response helper such as `ok'` will take
  -- | precedence over these.
  defaultHeaders :: b -> Effect.Effect Headers.Headers

  -- | Given a body value and a Node HTTP `Response` value, write the body value
  -- | to the Node response.
  write :: b -> HTTP.Response -> Aff.Aff Unit

-- | The instance for `String` will convert the string to a buffer first in
-- | order to determine it's additional headers.  This is to ensure that the
-- | `Content-Length` header properly accounts for UTF-8 characters in the
-- | string.  Writing is simply implemented by writing the string to the
-- | response stream and closing the response stream.
instance bodyString :: Body String where

  defaultHeaders body = Buffer.fromString body Encoding.UTF8 >>= defaultHeaders

  write body response = Aff.makeAff \done -> do
    let stream = HTTP.responseAsStream response
    _ <- Stream.writeString stream Encoding.UTF8 body $ pure unit
    _ <- Stream.end stream $ pure unit
    done $ Either.Right unit
    pure Aff.nonCanceler

-- | The instance for `Buffer` is trivial--we add a `Content-Length` header
-- | using `Buffer.size`, and to send the response, we just write the buffer to
-- | the stream and end the stream.
instance bodyBuffer :: Body Buffer.Buffer where

  defaultHeaders buf =
    Headers.header "Content-Length" <$> show <$> Buffer.size buf

  write body response = Aff.makeAff \done -> do
    let stream = HTTP.responseAsStream response
    _ <- Stream.write stream body $ pure unit
    _ <- Stream.end stream $ pure unit
    done $ Either.Right unit
    pure Aff.nonCanceler

-- | This instance can be used to send chunked data.  Here, we add a
-- | `Transfer-Encoding` header to indicate chunked data.  To write the data, we
-- | simply pipe the newtype-wrapped `Stream` to the response.
instance bodyChunked ::
  TypeEquals.TypeEquals (Stream.Stream r) (Stream.Readable ()) =>
  Body (Stream.Stream r) where

  defaultHeaders _ = pure $ Headers.header "Transfer-Encoding" "chunked"

  write body response = Aff.makeAff \done -> do
    let stream = TypeEquals.to body
    _ <- Stream.pipe stream $ HTTP.responseAsStream response
    Stream.onEnd stream $ done $ Either.Right unit
    pure Aff.nonCanceler

foreign import aggregateChunks :: forall w. Stream.Readable w ->
                                  (Array Buffer.Buffer -> Effect.Effect Unit) ->
                                  Effect.Effect Unit

-- | Extract the contents of the body of the HTTP `Request`.
read :: HTTP.Request -> Aff.Aff String
read request = Aff.makeAff \done -> do
  let
    stream = HTTP.requestAsStream request
    decode = Buffer.toString Encoding.UTF8
  aggregateChunks stream $
    Foldable.foldMap decode >=> Either.Right >>> pure >=> done
  pure Aff.nonCanceler