Skip to content

Commit 4788466

Browse files
functorafunctora
committed
wip
1 parent 6bb4d5c commit 4788466

File tree

6 files changed

+107
-44
lines changed

6 files changed

+107
-44
lines changed

‎ghcjs/lightning-verifier/src/App/Types.hs‎

Lines changed: 31 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -190,7 +190,7 @@ stQuery st = do
190190
(URI.mkQueryValue <=< encodeText)
191191
. encodeBinary
192192
$ fromMaybe
193-
(Aes.encryptHmac aes . encodeBinary $ st ^. #stDoc)
193+
(Aes.encryptHmac aes . encodeBinary . compressViewers $ st ^. #stDoc)
194194
(st ^. #stCpt)
195195
kKm <- URI.mkQueryKey "k"
196196
vKm <-
@@ -236,6 +236,36 @@ stUri st = do
236236
{ URI.uriQuery = qxs
237237
}
238238

239+
compressViewers :: StDoc Identity -> StDoc Identity
240+
compressViewers st =
241+
st
242+
& #stDocSuccessViewer
243+
%~ fmap compress
244+
& #stDocFailureViewer
245+
%~ fmap compress
246+
& #stDocLnPreimageViewer
247+
%~ fmap compress
248+
& #stDocLnInvoiceViewer
249+
%~ fmap compress
250+
where
251+
compress ::
252+
FieldPair DynamicField Identity ->
253+
FieldPair DynamicField Identity
254+
compress pair =
255+
pair
256+
& #fieldPairKey
257+
. #fieldInput
258+
.~ Identity (mempty :: MisoString)
259+
& #fieldPairKey
260+
. #fieldOutput
261+
.~ (mempty :: MisoString)
262+
& #fieldPairValue
263+
. #fieldInput
264+
.~ Identity (mempty :: MisoString)
265+
& #fieldPairValue
266+
. #fieldOutput
267+
.~ DynamicFieldText mempty
268+
239269
baseUri :: MisoString
240270
#ifdef GHCID
241271
baseUri =

‎ghcjs/lightning-verifier/src/App/Widgets/Bolt11.hs‎

Lines changed: 45 additions & 35 deletions
Original file line numberDiff line numberDiff line change
@@ -1,13 +1,13 @@
11
module App.Widgets.Bolt11
22
( bolt11Viewer,
3-
evalBolt11,
3+
makeBolt11Viewer,
4+
mergeBolt11Viewers,
45
)
56
where
67

78
import App.Types
89
import qualified Bitcoin.Address as Btc
910
import qualified Data.Aeson as A
10-
import Data.Bitraversable (bimapM)
1111
import qualified Data.ByteString.Base16 as B16
1212
import qualified Data.ByteString.Lazy as BL
1313
import qualified Data.Text.Encoding as T
@@ -88,36 +88,34 @@ inspectTimestamp =
8888
. Prelude.fromInteger
8989
. from @Int @Integer
9090

91-
evalBolt11 :: (MonadIO m) => StDoc Unique -> m (StDoc Unique)
92-
evalBolt11 st = do
93-
lnFields <-
94-
if rawLn == mempty
95-
then pure $ Right mempty
96-
else bimapM plainM (mapM identityToUnique . invoiceFields) ln
97-
preFields <-
98-
if rawR == mempty
99-
then pure $ Right mempty
100-
else bimapM plainM (mapM identityToUnique . preimageFields rawR) r
101-
verifierFields <-
102-
if any @[MisoString] (== mempty) [rawLn, rawR]
103-
then pure $ Right mempty
104-
else case verifyPreimage <$> rh <*> r of
105-
Left {} -> pure $ Right mempty
106-
Right x -> bimapM plainM plainM x
107-
pure
108-
$ st
109-
& #stDocSuccessViewer
110-
%~ mergeFieldPairs (fromRight mempty verifierFields)
111-
& #stDocFailureViewer
112-
%~ mergeFieldPairs
113-
( fromLeft mempty lnFields
114-
<> fromLeft mempty preFields
115-
<> fromLeft mempty verifierFields
116-
)
117-
& #stDocLnInvoiceViewer
118-
%~ mergeFieldPairs (fromRight mempty lnFields)
119-
& #stDocLnPreimageViewer
120-
%~ mergeFieldPairs (fromRight mempty preFields)
91+
makeBolt11Viewer :: StDoc Identity -> StDoc Identity
92+
makeBolt11Viewer st =
93+
let lnFields =
94+
if rawLn == mempty
95+
then pure mempty
96+
else bimap plain invoiceFields ln
97+
preFields =
98+
if rawR == mempty
99+
then pure mempty
100+
else bimap plain (preimageFields rawR) r
101+
verifierFields =
102+
if any @[MisoString] (== mempty) [rawLn, rawR]
103+
then pure mempty
104+
else case verifyPreimage <$> rh <*> r of
105+
Left {} -> pure mempty
106+
Right x -> bimap plain plain x
107+
in st
108+
& #stDocSuccessViewer
109+
.~ fromRight mempty verifierFields
110+
& #stDocFailureViewer
111+
.~ ( fromLeft mempty lnFields
112+
<> fromLeft mempty preFields
113+
<> fromLeft mempty verifierFields
114+
)
115+
& #stDocLnInvoiceViewer
116+
.~ fromRight mempty lnFields
117+
& #stDocLnPreimageViewer
118+
.~ fromRight mempty preFields
121119
where
122120
rawLn :: MisoString
123121
rawLn = st ^. #stDocLnInvoice . #fieldOutput
@@ -133,9 +131,21 @@ evalBolt11 st = do
133131
r :: Either MisoString ByteString
134132
r = parsePreimage rawR
135133

136-
plainM :: (MonadIO m) => MisoString -> m [FieldPair DynamicField Unique]
137-
plainM =
138-
fmap (: mempty) . newFieldPair mempty . DynamicFieldText
134+
mergeBolt11Viewers :: (Foldable1 f) => StDoc f -> StDoc f -> StDoc f
135+
mergeBolt11Viewers next prev =
136+
prev
137+
& #stDocSuccessViewer
138+
%~ mergeFieldPairs (stDocSuccessViewer next)
139+
& #stDocFailureViewer
140+
%~ mergeFieldPairs (stDocFailureViewer next)
141+
& #stDocLnInvoiceViewer
142+
%~ mergeFieldPairs (stDocLnInvoiceViewer next)
143+
& #stDocLnPreimageViewer
144+
%~ mergeFieldPairs (stDocLnPreimageViewer next)
145+
146+
plain :: MisoString -> [FieldPair DynamicField Identity]
147+
plain =
148+
(: mempty) . newFieldPairId mempty . DynamicFieldText
139149

140150
parsePreimage :: MisoString -> Either MisoString ByteString
141151
parsePreimage rawR =

‎ghcjs/lightning-verifier/src/App/Widgets/Decrypt.hs‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -4,6 +4,7 @@ module App.Widgets.Decrypt
44
where
55

66
import App.Types
7+
import qualified App.Widgets.Bolt11 as B11
78
import Data.Functor.Barbie
89
import qualified Functora.Aes as Aes
910
import Functora.Cfg
@@ -62,7 +63,9 @@ decryptDoc st@Model {modelState = St {stCpt = Just cpt}} = do
6263
bDoc <-
6364
maybe (Left "Incorrect password!") Right
6465
$ Aes.unHmacDecrypt @ByteString aes cpt
65-
first thd3
66+
bimap
67+
thd3
68+
(\doc -> B11.mergeBolt11Viewers (B11.makeBolt11Viewer doc) doc)
6669
$ decodeBinary bDoc
6770
case eDoc of
6871
Left e -> do

‎ghcjs/lightning-verifier/src/App/Widgets/Templates.hs‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,7 @@ module App.Widgets.Templates
55
where
66

77
import App.Types
8+
import qualified App.Widgets.Bolt11 as B11
89
import qualified Functora.Aes as Aes
910
import Functora.Cfg
1011
import Functora.Miso.Prelude
@@ -72,7 +73,15 @@ newModel mSt uri = do
7273
cpt
7374
doc <-
7475
identityToUnique
75-
=<< either (throwString . thd3) pure (decodeBinary bDoc)
76+
=<< either
77+
(throwString . thd3)
78+
( \doc ->
79+
pure
80+
$ B11.mergeBolt11Viewers
81+
(B11.makeBolt11Viewer doc)
82+
doc
83+
)
84+
(decodeBinary bDoc)
7685
pure
7786
$ st
7887
& #stDoc

‎ghcjs/lightning-verifier/src/Main.hs‎

Lines changed: 6 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -295,15 +295,19 @@ evalModel st@Model {modelState = st0} = do
295295
then Aes.randomKm 32
296296
else pure $ st0 ^. #stKm
297297
doc <-
298-
B11.evalBolt11 $ st0 ^. #stDoc
298+
identityToUnique
299+
. B11.makeBolt11Viewer
300+
. uniqueToIdentity
301+
$ st0
302+
^. #stDoc
299303
pure
300304
$ st
301305
& #modelState
302306
. #stKm
303307
.~ km
304308
& #modelState
305309
. #stDoc
306-
.~ doc
310+
%~ B11.mergeBolt11Viewers doc
307311

308312
syncUri :: URI -> JSM ()
309313
syncUri uri = do

‎ghcjs/miso-widgets/src/Functora/Miso/Types.hs‎

Lines changed: 11 additions & 4 deletions
Original file line numberDiff line numberDiff line change
@@ -55,7 +55,7 @@ module Functora.Miso.Types
5555
)
5656
where
5757

58-
import Data.Foldable (Foldable (..))
58+
import Data.Foldable (foldMap)
5959
import Data.Functor.Barbie
6060
import qualified Data.Generics as Syb
6161
import Functora.Cfg
@@ -320,10 +320,17 @@ mergeFieldPairs ::
320320
[FieldPair t f] ->
321321
[FieldPair t f]
322322
mergeFieldPairs next prev =
323-
if fmap inputs next /= fmap inputs prev
324-
then next
325-
else fmap (uncurry merge) $ zip next prev
323+
if ( (length next == length prev)
324+
&& (all (== (mempty, mempty)) prevInputs)
325+
)
326+
|| (nextInputs == prevInputs)
327+
then fmap (uncurry merge) $ zip next prev
328+
else next
326329
where
330+
nextInputs :: [(MisoString, MisoString)]
331+
nextInputs = fmap inputs next
332+
prevInputs :: [(MisoString, MisoString)]
333+
prevInputs = fmap inputs prev
327334
merge :: FieldPair t f -> FieldPair t f -> FieldPair t f
328335
merge new old =
329336
old

0 commit comments

Comments
 (0)