-
Notifications
You must be signed in to change notification settings - Fork 461
/
State.purs
169 lines (150 loc) · 6.84 KB
/
State.purs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
module MainFrame.State (mkMainFrame) where
import Prelude
import Control.Monad.Except (runExcept)
import Control.Monad.Reader (class MonadAsk)
import Data.Either (Either(..))
import Data.Foldable (for_)
import Data.Lens (assign, over, set, use)
import Data.Map (empty, insert, member)
import Data.Map.Extra (findIndex)
import Data.Maybe (Maybe(..))
import Data.Tuple (fst, snd)
import Effect.Aff.Class (class MonadAff)
import Effect.Random (random)
import Env (Env)
import Foreign.Generic (decodeJSON, encodeJSON)
import Halogen (Component, HalogenM, liftEffect, mkComponent, mkEval, modify_)
import Halogen.HTML (HTML)
import LocalStorage (getItem, removeItem, setItem)
import MainFrame.Lenses (_card, _newWalletNicknameKey, _pickupState, _subState, _templates, _playState, _wallets, _webSocketStatus)
import MainFrame.Types (Action(..), ChildSlots, Msg, Query(..), State, WebSocketStatus(..))
import MainFrame.View (render)
import Pickup.State (handleAction, initialState) as Pickup
import Pickup.Types (Action(..), Card(..)) as Pickup
import Play.State (handleAction, mkInitialState) as Play
import Play.Types (Action(..)) as Play
import Plutus.PAB.Webserver.Types (StreamToClient(..))
import StaticData (walletLocalStorageKey, walletsLocalStorageKey)
import Template.Library (templates)
import WalletData.Lenses (_key, _nickname)
import WalletData.Types (WalletDetails)
import WebSocket.Support as WS
mkMainFrame ::
forall m.
MonadAff m =>
MonadAsk Env m =>
Component HTML Query Action Msg m
mkMainFrame =
mkComponent
{ initialState: const initialState
, render: render
, eval:
mkEval
{ handleQuery
, handleAction
, receive: const Nothing
, initialize: Just Init
, finalize: Nothing
}
}
initialState :: State
initialState =
{ wallets: empty
, newWalletNicknameKey: mempty
, templates: mempty
, subState: Left Pickup.initialState
, webSocketStatus: WebSocketClosed Nothing
}
defaultWalletDetails :: WalletDetails
defaultWalletDetails = { userHasPickedUp: false }
handleQuery :: forall a m. Query a -> HalogenM State Action ChildSlots Msg m (Maybe a)
handleQuery (ReceiveWebSocketMessage msg next) = do
case msg of
WS.WebSocketOpen -> assign _webSocketStatus WebSocketOpen
(WS.WebSocketClosed reason) -> assign _webSocketStatus (WebSocketClosed (Just reason))
(WS.ReceiveMessage (Left errors)) -> pure unit -- failed to decode message, do nothing for now
-- TODO: This is where the main logic of dealing with messages goes
(WS.ReceiveMessage (Right stc)) -> case stc of
(NewChainReport report) -> pure unit
(NewContractReport report) -> pure unit
(NewChainEvents events) -> pure unit
(FetchedProperties subjectProperties) -> pure unit
(FetchedProperty subject properties) -> pure unit
(ErrorResponse error) -> pure unit
pure $ Just next
-- Note [State]: Some actions belong logically in one part of the state, but
-- from the user's point of view in another. For example, the action of picking
-- up a wallet belongs logically in the MainFrame state (because it modifies
-- that state), but from the user's point of view it belongs in the Pickup
-- state (because that's the state the app is in when you perform it). To work
-- around this, we can either make our `handleAction` functions a bit awkward,
-- or our `render` functions a bit awkward. I prefer the former. Hence some
-- submodule actions (triggered straightforwardly in the submodule's `render`
-- functions) are handled by their parent module's `handleAction` function.
handleAction ::
forall m.
MonadAff m =>
MonadAsk Env m =>
Action -> HalogenM State Action ChildSlots Msg m Unit
handleAction Init = do
mCachedWalletsJson <- liftEffect $ getItem walletsLocalStorageKey
for_ mCachedWalletsJson \json ->
for_ (runExcept $ decodeJSON json) \cachedWallets ->
assign _wallets cachedWallets
mCachedWalletJson <- liftEffect $ getItem walletLocalStorageKey
for_ mCachedWalletJson \json ->
for_ (runExcept $ decodeJSON json) \cachedWallet ->
assign _subState $ Right $ Play.mkInitialState cachedWallet
-- TODO: fetch contract templates from the library ??
assign _templates templates
handleAction (SetNewWalletNickname nickname) = assign (_newWalletNicknameKey <<< _nickname) nickname
handleAction AddNewWallet = do
oldWallets <- use _wallets
newWalletNicknameKey <- use _newWalletNicknameKey
when (not $ member newWalletNicknameKey oldWallets) do
modify_
$ (over _wallets) (insert newWalletNicknameKey defaultWalletDetails)
<<< (set _newWalletNicknameKey) mempty
<<< (_playState <<< set _card) Nothing
newWallets <- use _wallets
liftEffect $ setItem walletsLocalStorageKey $ encodeJSON newWallets
-- pickup actions that need to be handled here
handleAction (PickupAction (Pickup.SetNewWalletNickname nickname)) = handleAction $ SetNewWalletNickname nickname
handleAction (PickupAction Pickup.PickupNewWallet) = do
newPubKey <- use (_newWalletNicknameKey <<< _key)
handleAction AddNewWallet
handleAction $ PickupAction $ Pickup.PickupWallet newPubKey
handleAction (PickupAction (Pickup.PickupWallet pubKey)) = do
modify_
$ (set _subState) (Right $ Play.mkInitialState pubKey)
<<< (_pickupState <<< set _card) Nothing
liftEffect $ setItem walletLocalStorageKey $ encodeJSON pubKey
-- TODO: generate wallet on the backend; for now just create a random number
handleAction (PickupAction Pickup.GenerateNewWallet) = do
randomNumber <- liftEffect random
let
key = show $ randomNumber
modify_
$ (_newWalletNicknameKey <<< set _key) key
<<< (_pickupState <<< set _card) (Just Pickup.PickupNewWalletCard)
handleAction (PickupAction (Pickup.LookupWallet string)) = do
wallets <- use _wallets
-- check for a matching nickname in the wallet library first
case findIndex (\key -> fst key == string) wallets of
Just key -> assign (_pickupState <<< _card) $ Just $ Pickup.PickupWalletCard key
-- failing that, check for a matching pubkey in the wallet library
Nothing -> case findIndex (\key -> snd key == string) wallets of
Just key -> assign (_pickupState <<< _card) $ Just $ Pickup.PickupWalletCard key
-- TODO: lookup pubkey on the blockchain
Nothing -> pure unit
-- other pickup actions
handleAction (PickupAction pickupAction) = Pickup.handleAction pickupAction
-- play actions that need to be handled here
handleAction (PlayAction Play.PutdownWallet) = do
assign _subState $ Left Pickup.initialState
liftEffect $ removeItem walletLocalStorageKey
handleAction (PlayAction (Play.SetNewWalletNickname nickname)) = handleAction $ SetNewWalletNickname nickname
handleAction (PlayAction (Play.SetNewWalletKey key)) = assign (_newWalletNicknameKey <<< _key) key
handleAction (PlayAction Play.AddNewWallet) = handleAction AddNewWallet
-- other play actions
handleAction (PlayAction playAction) = Play.handleAction playAction