Skip to content

Commit a13f697

Browse files
functorafunctora
committed
simplify stExt -> stCpt
1 parent 2e2fe5d commit a13f697

File tree

6 files changed

+125
-197
lines changed

6 files changed

+125
-197
lines changed

‎ghcjs/currency-converter/src/App/Types.hs‎

Lines changed: 44 additions & 89 deletions
Original file line numberDiff line numberDiff line change
@@ -6,20 +6,20 @@ module App.Types
66
Action (..),
77
St (..),
88
StDoc (..),
9-
StExt (..),
9+
newStDoc,
1010
Screen (..),
1111
isQrCode,
1212
unQrCode,
1313
pureUpdate,
1414
unShareUri,
1515
stUri,
16-
stExtUri,
1716
baseUri,
1817
setScreenPure,
1918
setScreenAction,
20-
setExtScreenAction,
2119
shareLink,
2220
vsn,
21+
usd,
22+
btc,
2323
module X,
2424
)
2525
where
@@ -59,7 +59,7 @@ data Model = Model
5959

6060
data Action
6161
= Noop
62-
| InitUpdate (Maybe (StExt Unique))
62+
| InitUpdate (Maybe Aes.Crypto)
6363
| TimeUpdate
6464
| SyncInputs
6565
| ChanUpdate Model
@@ -71,7 +71,7 @@ data St f = St
7171
stDoc :: StDoc f,
7272
stPre :: Field DynamicField f,
7373
stScreen :: Screen,
74-
stExt :: Maybe (StExt f)
74+
stCpt :: Maybe Aes.Crypto
7575
}
7676
deriving stock (Generic)
7777

@@ -89,29 +89,6 @@ instance TraversableB St
8989

9090
deriving via GenericType (St Identity) instance Binary (St Identity)
9191

92-
data StExt f = StExt
93-
{ stExtKm :: Aes.Km,
94-
stExtIkm :: Field MisoString f,
95-
stExtDoc :: Aes.Crypto,
96-
stExtPre :: Field DynamicField f,
97-
stExtScreen :: Screen
98-
}
99-
deriving stock (Generic)
100-
101-
deriving stock instance (Hkt f) => Eq (StExt f)
102-
103-
deriving stock instance (Hkt f) => Ord (StExt f)
104-
105-
deriving stock instance (Hkt f) => Show (StExt f)
106-
107-
deriving stock instance (Hkt f) => Data (StExt f)
108-
109-
instance FunctorB StExt
110-
111-
instance TraversableB StExt
112-
113-
deriving via GenericType (StExt Identity) instance Binary (StExt Identity)
114-
11592
data StDoc f = StDoc
11693
{ stDocTopMoney :: Money f,
11794
stDocBottomMoney :: Money f,
@@ -137,6 +114,23 @@ instance TraversableB StDoc
137114

138115
deriving via GenericType (StDoc Identity) instance Binary (StDoc Identity)
139116

117+
newStDoc :: (MonadIO m) => m (StDoc Unique)
118+
newStDoc = do
119+
ct <- getCurrentTime
120+
topMoney <- newMoney 1 btc
121+
bottomMoney <- newMoney 0 usd
122+
preFavName <- newTextField mempty
123+
pure
124+
StDoc
125+
{ stDocTopMoney = topMoney,
126+
stDocBottomMoney = bottomMoney,
127+
stDocTopOrBottom = Top,
128+
stDocPreFavName = preFavName,
129+
stDocFieldPairs = mempty,
130+
stDocOnlineOrOffline = Online,
131+
stDocCreatedAt = ct
132+
}
133+
140134
data Screen
141135
= Converter
142136
| QrCode Screen
@@ -167,7 +161,7 @@ unShareUri ::
167161
MonadIO m
168162
) =>
169163
URI ->
170-
m (Maybe (StExt Unique))
164+
m (Maybe (St Unique))
171165
unShareUri uri = do
172166
kKm <- URI.mkQueryKey "k"
173167
kDoc <- URI.mkQueryKey "d"
@@ -180,25 +174,27 @@ unShareUri uri = do
180174
<*> qsGet kSc qs
181175
<*> qsGet kPre qs of
182176
Nothing -> pure Nothing
183-
Just (vDoc, vKm, vSc, vPre) -> do
177+
Just (vCpt, vKm, vSc, vPre) -> do
184178
bKm <- either throwString pure . B64URL.decode $ encodeUtf8 vKm
185-
bDoc <- either throwString pure . B64URL.decode $ encodeUtf8 vDoc
179+
bCpt <- either throwString pure . B64URL.decode $ encodeUtf8 vCpt
186180
bSc <- either throwString pure . B64URL.decode $ encodeUtf8 vSc
187181
bPre <- either throwString pure . B64URL.decode $ encodeUtf8 vPre
188182
km <- either (throwString . thd3) pure $ decodeBinary bKm
189183
ikm <- newPasswordField mempty
190-
doc <- either (throwString . thd3) pure $ decodeBinary bDoc
184+
cpt <- either (throwString . thd3) pure $ decodeBinary bCpt
191185
sc <- either (throwString . thd3) pure $ decodeBinary bSc
192186
iPre <- either (throwString . thd3) pure $ decodeBinary bPre
193187
pre <- identityToUnique iPre
188+
doc <- newStDoc
194189
pure
195190
$ Just
196-
StExt
197-
{ stExtKm = km,
198-
stExtIkm = ikm,
199-
stExtDoc = doc,
200-
stExtPre = pre,
201-
stExtScreen = sc
191+
St
192+
{ stKm = km,
193+
stIkm = ikm,
194+
stDoc = doc,
195+
stPre = pre,
196+
stScreen = sc,
197+
stCpt = Just cpt
202198
}
203199

204200
stQuery :: (MonadThrow m) => St Identity -> m [URI.QueryParam]
@@ -207,8 +203,9 @@ stQuery st = do
207203
vDoc <-
208204
(URI.mkQueryValue <=< encodeText)
209205
. encodeBinary
210-
. Aes.encryptHmac aes
211-
$ encodeBinary (st ^. #stDoc)
206+
$ fromMaybe
207+
(Aes.encryptHmac aes . encodeBinary $ st ^. #stDoc)
208+
(st ^. #stCpt)
212209
kKm <- URI.mkQueryKey "k"
213210
vKm <-
214211
(URI.mkQueryValue <=< encodeText)
@@ -244,58 +241,15 @@ stQuery st = do
244241
. B64URL.encode
245242
. from @BL.ByteString @ByteString
246243

247-
stExtQuery :: (MonadThrow m) => StExt Identity -> m [URI.QueryParam]
248-
stExtQuery st = do
249-
kDoc <- URI.mkQueryKey "d"
250-
vDoc <-
251-
(URI.mkQueryValue <=< encodeText)
252-
$ encodeBinary (st ^. #stExtDoc)
253-
kKm <- URI.mkQueryKey "k"
254-
vKm <-
255-
(URI.mkQueryValue <=< encodeText)
256-
$ encodeBinary (st ^. #stExtKm)
257-
kSc <- URI.mkQueryKey "s"
258-
vSc <-
259-
(URI.mkQueryValue <=< encodeText)
260-
$ encodeBinary (st ^. #stExtScreen)
261-
kPre <- URI.mkQueryKey "p"
262-
vPre <-
263-
(URI.mkQueryValue <=< encodeText)
264-
$ encodeBinary (st ^. #stExtPre)
265-
pure
266-
[ URI.QueryParam kDoc vDoc,
267-
URI.QueryParam kKm vKm,
268-
URI.QueryParam kSc vSc,
269-
URI.QueryParam kPre vPre
270-
]
271-
where
272-
encodeText :: (MonadThrow m) => BL.ByteString -> m Prelude.Text
273-
encodeText =
274-
either throw pure
275-
. decodeUtf8'
276-
. B64URL.encode
277-
. from @BL.ByteString @ByteString
278-
279244
stUri :: (MonadThrow m) => Model -> m URI
280-
stUri Model {modelState = St {stExt = Just ext}} =
281-
stExtUri ext
282-
stUri st@Model {modelState = St {stExt = Nothing}} = do
245+
stUri st = do
283246
uri <- mkURI $ from @MisoString @Prelude.Text baseUri
284247
qxs <- stQuery . uniqueToIdentity $ st ^. #modelState
285248
pure
286249
$ uri
287250
{ URI.uriQuery = qxs
288251
}
289252

290-
stExtUri :: (MonadThrow m) => StExt Unique -> m URI
291-
stExtUri ext = do
292-
uri <- mkURI $ from @MisoString @Prelude.Text baseUri
293-
qxs <- stExtQuery $ uniqueToIdentity ext
294-
pure
295-
$ uri
296-
{ URI.uriQuery = qxs
297-
}
298-
299253
baseUri :: MisoString
300254
#ifdef GHCID
301255
baseUri =
@@ -308,16 +262,11 @@ baseUri =
308262
setScreenPure :: Screen -> Model -> Model
309263
setScreenPure sc =
310264
(& #modelState . #stScreen .~ sc)
311-
. (& #modelState . #stExt . _Just . #stExtScreen .~ sc)
312265

313266
setScreenAction :: Screen -> Action
314267
setScreenAction =
315268
pureUpdate 0 . setScreenPure
316269

317-
setExtScreenAction :: Screen -> Action
318-
setExtScreenAction sc =
319-
pureUpdate 0 (& #modelState . #stExt . _Just . #stExtScreen .~ sc)
320-
321270
shareLink :: forall a. (From Prelude.Text a) => Model -> a
322271
shareLink =
323272
from @Prelude.Text @a
@@ -330,3 +279,9 @@ vsn =
330279
. T.intercalate "."
331280
. fmap Prelude.inspect
332281
$ Version.versionBranch Paths.version
282+
283+
usd :: CurrencyInfo
284+
usd = CurrencyInfo (CurrencyCode "usd") mempty
285+
286+
btc :: CurrencyInfo
287+
btc = CurrencyInfo (CurrencyCode "btc") mempty

‎ghcjs/currency-converter/src/App/Widgets/Decrypt.hs‎

Lines changed: 11 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -23,9 +23,7 @@ decrypt st =
2323
$ Field.passwordField
2424
st
2525
( #modelState
26-
. #stExt
27-
. _Just
28-
. #stExtIkm
26+
. #stIkm
2927
)
3028
( Field.defOpts
3129
& #optsOnKeyDownAction
@@ -42,26 +40,26 @@ decrypt st =
4240
]
4341

4442
decryptDoc :: Model -> Action
45-
decryptDoc st@Model {modelState = St {stExt = Nothing}} =
43+
decryptDoc st@Model {modelState = St {stCpt = Nothing}} =
4644
PushUpdate $ do
4745
Misc.textPopup @MisoString st "Nothing to decrypt!"
4846
pure $ ChanItem 0 id
49-
decryptDoc Model {modelState = St {stExt = Just {}}} =
47+
decryptDoc Model {modelState = St {stCpt = Just {}}} =
5048
PushUpdate $ do
5149
rnd0 <- liftIO Random.newStdGen
5250
pure $ ChanItem 0 $ \case
53-
st@Model {modelState = St {stExt = Nothing}} -> st
54-
st@Model {modelState = St {stExt = Just ext}} ->
55-
let ikm = ext ^. #stExtIkm . #fieldOutput
51+
st@Model {modelState = St {stCpt = Nothing}} -> st
52+
st@Model {modelState = St {stCpt = Just cpt}} ->
53+
let ikm = st ^. #modelState . #stIkm . #fieldOutput
5654
aes =
5755
Aes.drvSomeAesKey @Aes.Word256
58-
$ (ext ^. #stExtKm)
56+
$ (st ^. #modelState . #stKm)
5957
& #kmIkm
6058
.~ Ikm (encodeUtf8 ikm)
6159
eDoc = do
6260
bDoc <-
6361
maybe (Left "Incorrect password!") Right
64-
$ Aes.unHmacDecrypt @ByteString aes (ext ^. #stExtDoc)
62+
$ Aes.unHmacDecrypt @ByteString aes cpt
6563
first thd3
6664
$ decodeBinary bDoc
6765
in case eDoc of
@@ -81,7 +79,7 @@ decryptDoc Model {modelState = St {stExt = Just {}}} =
8179
pure
8280
$ st
8381
& #modelState
84-
. #stExt
82+
. #stCpt
8583
.~ Nothing
8684
& #modelState
8785
. #stIkm
@@ -97,10 +95,10 @@ decryptDoc Model {modelState = St {stExt = Just {}}} =
9795
.~ uDoc
9896
& #modelState
9997
. #stPre
100-
.~ (ext ^. #stExtPre)
98+
.~ (st ^. #modelState . #stPre)
10199
& #modelState
102100
. #stScreen
103-
.~ unQrCode (ext ^. #stExtScreen)
101+
.~ unQrCode (st ^. #modelState . #stScreen)
104102
& Misc.textPopupClear
105103

106104
onKeyDownAction :: Model -> Uid -> KeyCode -> Action

‎ghcjs/currency-converter/src/App/Widgets/Main.hs‎

Lines changed: 8 additions & 7 deletions
Original file line numberDiff line numberDiff line change
@@ -58,19 +58,20 @@ mainWidget st =
5858
)
5959

6060
screenWidget :: Model -> [View Action]
61-
screenWidget st@Model {modelState = St {stExt = Just ext}} =
62-
case ext ^. #stExtScreen of
61+
screenWidget st@Model {modelState = St {stCpt = Just {}}} =
62+
case st ^. #modelState . #stScreen of
6363
QrCode sc ->
6464
Header.headerWrapper
65-
( Field.dynamicFieldViewer st (ext ^. #stExtPre)
65+
( Field.dynamicFieldViewer st (st ^. #modelState . #stPre)
6666
)
6767
<> Qr.qr
6868
st
6969
( toMisoString
7070
. either impureThrow URI.render
71-
. stExtUri
72-
$ ext
73-
& #stExtScreen
71+
. stUri
72+
$ st
73+
& #modelState
74+
. #stScreen
7475
%~ unQrCode
7576
)
7677
( Qr.defOpts
@@ -79,7 +80,7 @@ screenWidget st@Model {modelState = St {stExt = Just ext}} =
7980
( Button.config
8081
& Button.setIcon (Just "login")
8182
& Button.setAttributes [class_ "fill"]
82-
& Button.setOnClick (setExtScreenAction $ unQrCode sc)
83+
& Button.setOnClick (setScreenAction $ unQrCode sc)
8384
)
8485
"Open"
8586
]

‎ghcjs/currency-converter/src/App/Widgets/Menu.hs‎

Lines changed: 2 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,6 @@ import qualified App.Widgets.Cell as Cell
99
import qualified App.Widgets.Fav as Fav
1010
import qualified App.Widgets.Field as Field
1111
import qualified App.Widgets.FieldPairs as FieldPairs
12-
import App.Widgets.Templates
1312
import Functora.Miso.Prelude
1413
import qualified Language.Javascript.JSaddle as JS
1514
import qualified Material.Button as Button
@@ -48,7 +47,7 @@ menu st =
4847
pure
4948
. ChanItem 0
5049
$ (& #modelState . #stDoc .~ doc)
51-
. (& #modelState . #stExt .~ Nothing)
50+
. (& #modelState . #stCpt .~ Nothing)
5251
. (& #modelState . #stScreen .~ Converter)
5352
]
5453
[ text "Converter"
@@ -272,11 +271,8 @@ menu st =
272271
$ (& #modelMenu .~ Closed)
273272
. (& #modelLoading .~ isQrCode next)
274273
. (& #modelState . #stScreen .~ next)
275-
. (& #modelState . #stExt . _Just . #stExtScreen .~ next)
276274
sc =
277-
fromMaybe
278-
(st ^. #modelState . #stScreen)
279-
(st ^? #modelState . #stExt . _Just . #stExtScreen)
275+
st ^. #modelState . #stScreen
280276
navItemLeft x =
281277
div_
282278
[ TopAppBar.title,

0 commit comments

Comments
 (0)