Skip to content

Commit 6bb4d5c

Browse files
functorafunctora
committed
generic field viewers wip
1 parent 716530a commit 6bb4d5c

File tree

7 files changed

+276
-218
lines changed

7 files changed

+276
-218
lines changed

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

Lines changed: 7 additions & 13 deletions
Original file line numberDiff line numberDiff line change
@@ -6,7 +6,6 @@ module App.Types
66
Action (..),
77
St (..),
88
StDoc (..),
9-
StViewer (..),
109
newStDoc,
1110
Screen (..),
1211
isQrCode,
@@ -50,6 +49,7 @@ data Model = Model
5049
modelState :: St Unique,
5150
modelFavMap :: Map MisoString Fav,
5251
modelFavName :: Field MisoString Unique,
52+
modelUriViewer :: [FieldPair DynamicField Unique],
5353
modelProducerQueue :: TChan (InstantOrDelayed (Model -> JSM Model)),
5454
modelConsumerQueue :: TChan (InstantOrDelayed (Model -> JSM Model))
5555
}
@@ -86,21 +86,14 @@ instance TraversableB St
8686

8787
deriving via GenericType (St Identity) instance Binary (St Identity)
8888

89-
data StViewer = StViewer
90-
{ stViewerQr :: OpenedOrClosed,
91-
stViewerTruncate :: OpenedOrClosed
92-
}
93-
deriving stock (Eq, Ord, Show, Data, Generic)
94-
95-
deriving via GenericType StViewer instance Binary StViewer
96-
9789
data StDoc f = StDoc
9890
{ stDocFieldPairs :: [FieldPair DynamicField f],
99-
stDocFieldPairsViewer :: Map Int StViewer,
91+
stDocSuccessViewer :: [FieldPair DynamicField f],
92+
stDocFailureViewer :: [FieldPair DynamicField f],
10093
stDocLnPreimage :: Field MisoString f,
101-
stDocLnPreimageViewer :: Map Int StViewer,
94+
stDocLnPreimageViewer :: [FieldPair DynamicField f],
10295
stDocLnInvoice :: Field MisoString f,
103-
stDocLnInvoiceViewer :: Map Int StViewer
96+
stDocLnInvoiceViewer :: [FieldPair DynamicField f]
10497
}
10598
deriving stock (Generic)
10699

@@ -125,7 +118,8 @@ newStDoc = do
125118
pure
126119
StDoc
127120
{ stDocFieldPairs = mempty,
128-
stDocFieldPairsViewer = mempty,
121+
stDocSuccessViewer = mempty,
122+
stDocFailureViewer = mempty,
129123
stDocLnPreimage = r,
130124
stDocLnPreimageViewer = mempty,
131125
stDocLnInvoice = ln,

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

Lines changed: 165 additions & 145 deletions
Original file line numberDiff line numberDiff line change
@@ -1,11 +1,13 @@
11
module App.Widgets.Bolt11
2-
( bolt11,
2+
( bolt11Viewer,
3+
evalBolt11,
34
)
45
where
56

67
import App.Types
78
import qualified Bitcoin.Address as Btc
89
import qualified Data.Aeson as A
10+
import Data.Bitraversable (bimapM)
911
import qualified Data.ByteString.Base16 as B16
1012
import qualified Data.ByteString.Lazy as BL
1113
import qualified Data.Text.Encoding as T
@@ -14,25 +16,113 @@ import Functora.Miso.Prelude
1416
import qualified Functora.Miso.Widgets.FieldPairs as FieldPairs
1517
import qualified Functora.Miso.Widgets.Header as Header
1618
import qualified Functora.Prelude as Prelude
17-
import Type.Reflection
1819
import qualified Prelude
1920

20-
bolt11 :: Model -> [View Action]
21-
bolt11 st =
22-
parserWidget rawLn ln
23-
<> (if isRight ln then parserWidget rawLn rh else mempty)
24-
<> parserWidget rawR r
25-
<> fromRight mempty (verifierWidget [rawLn, rawR] <$> rh <*> r)
26-
<> either (const mempty) (invoiceWidget st) ln
27-
<> either
28-
(const mempty)
29-
(\bsR -> if bsR == mempty then mempty else preimageWidget st rawR bsR)
30-
r
21+
bolt11Viewer :: Model -> [View Action]
22+
bolt11Viewer st =
23+
success
24+
( pairs st mempty
25+
$ #modelState
26+
. #stDoc
27+
. #stDocSuccessViewer
28+
)
29+
<> failure
30+
( pairs st mempty
31+
$ #modelState
32+
. #stDoc
33+
. #stDocFailureViewer
34+
)
35+
<> pairs
36+
st
37+
( Header.headerViewer "Invoice Details"
38+
)
39+
( #modelState . #stDoc . #stDocLnInvoiceViewer
40+
)
41+
<> pairs
42+
st
43+
( Header.headerViewer "Preimage Details"
44+
)
45+
( #modelState . #stDoc . #stDocLnPreimageViewer
46+
)
47+
48+
pairs ::
49+
( Foldable1 f
50+
) =>
51+
Model ->
52+
[View Action] ->
53+
ATraversal' Model [FieldPair DynamicField f] ->
54+
[View Action]
55+
pairs st header optic =
56+
if null widget
57+
then mempty
58+
else header <> widget
59+
where
60+
widget =
61+
FieldPairs.fieldPairsViewer
62+
FieldPairs.Args
63+
{ FieldPairs.argsModel = st,
64+
FieldPairs.argsOptic = optic,
65+
FieldPairs.argsAction = PushUpdate . Instant
66+
}
67+
68+
pair :: MisoString -> MisoString -> FieldPair DynamicField Identity
69+
pair x =
70+
newFieldPairId x
71+
. DynamicFieldText
72+
73+
success :: [View Action] -> [View Action]
74+
success = css "app-success"
75+
76+
failure :: [View Action] -> [View Action]
77+
failure = css "app-failure"
78+
79+
css :: MisoString -> [View action] -> [View action]
80+
css x = fmap $ \case
81+
Node x0 x1 x2 x3 x4 -> Node x0 x1 x2 (class_ x : x3) x4
82+
html -> html
83+
84+
inspectTimestamp :: Int -> MisoString
85+
inspectTimestamp =
86+
inspect
87+
. posixSecondsToUTCTime
88+
. Prelude.fromInteger
89+
. from @Int @Integer
90+
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)
31121
where
32122
rawLn :: MisoString
33-
rawLn = st ^. #modelState . #stDoc . #stDocLnInvoice . #fieldOutput
123+
rawLn = st ^. #stDocLnInvoice . #fieldOutput
34124
rawR :: MisoString
35-
rawR = st ^. #modelState . #stDoc . #stDocLnPreimage . #fieldOutput
125+
rawR = st ^. #stDocLnPreimage . #fieldOutput
36126
ln :: Either MisoString B11.Bolt11
37127
ln =
38128
first (mappend "Bad invoice - " . from @Prelude.String @MisoString)
@@ -43,55 +133,65 @@ bolt11 st =
43133
r :: Either MisoString ByteString
44134
r = parsePreimage rawR
45135

46-
parserWidget :: MisoString -> Either MisoString a -> [View Action]
47-
parserWidget src = \case
48-
Left e | src /= mempty -> failure e
49-
_ -> mempty
136+
plainM :: (MonadIO m) => MisoString -> m [FieldPair DynamicField Unique]
137+
plainM =
138+
fmap (: mempty) . newFieldPair mempty . DynamicFieldText
50139

51-
verifierWidget :: [MisoString] -> ByteString -> ByteString -> [View Action]
52-
verifierWidget src rh r =
53-
if any (== mempty) src
54-
then mempty
55-
else
56-
if rh == sha256Hash r
57-
then success "The preimage matches the invoice"
58-
else failure "The preimage does not match the invoice"
59-
60-
invoiceWidget :: Model -> B11.Bolt11 -> [View Action]
61-
invoiceWidget st ln =
62-
Header.headerViewer "Invoice Details"
63-
<> pairs
64-
st
65-
( [ pair "Network"
66-
$ case B11.bolt11HrpNet $ B11.bolt11Hrp ln of
67-
B11.BitcoinMainnet -> "Bitcoin Mainnet"
68-
B11.BitcoinTestnet -> "Bitcoin Testnet"
69-
B11.BitcoinRegtest -> "Bitcoin Regtest"
70-
B11.BitcoinSignet -> "Bitcoin Signet",
71-
pair "Amount"
72-
. maybe "0" B11.inspectBolt11HrpAmt
73-
. B11.bolt11HrpAmt
74-
$ B11.bolt11Hrp ln,
75-
pair "Created At"
76-
. inspectTimestamp
77-
$ B11.bolt11Timestamp ln
78-
]
79-
<> ( B11.bolt11Tags ln
80-
>>= invoiceTag ln
81-
)
82-
<> [ pair "Signature"
83-
. B11.inspectHex
84-
$ B11.bolt11SigVal sig,
85-
pair "Pubkey Recovery Flag"
86-
. inspect
87-
$ B11.bolt11SigRecoveryFlag sig
88-
]
89-
)
140+
parsePreimage :: MisoString -> Either MisoString ByteString
141+
parsePreimage rawR =
142+
case B16.decode . T.encodeUtf8 $ from @MisoString @Prelude.Text rawR of
143+
(r, "") -> Right r
144+
(_, e) ->
145+
Left
146+
$ "Bad preimage - non hex leftover "
147+
<> from @Prelude.String @MisoString (Prelude.show e)
148+
149+
parsePreimageHash :: B11.Bolt11 -> Either MisoString ByteString
150+
parsePreimageHash ln =
151+
case find B11.isPaymentHash $ B11.bolt11Tags ln of
152+
Just (B11.PaymentHash (B11.Hex rh)) -> Right rh
153+
_ -> Left "Bad invoice - no preimage hash"
154+
155+
verifyPreimage ::
156+
ByteString ->
157+
ByteString ->
158+
Either MisoString MisoString
159+
verifyPreimage rh r =
160+
if rh == sha256Hash r
161+
then Right "The preimage matches the invoice"
162+
else Left "The preimage does not match the invoice"
163+
164+
invoiceFields :: B11.Bolt11 -> [FieldPair DynamicField Identity]
165+
invoiceFields ln =
166+
[ pair "Network"
167+
$ case B11.bolt11HrpNet $ B11.bolt11Hrp ln of
168+
B11.BitcoinMainnet -> "Bitcoin Mainnet"
169+
B11.BitcoinTestnet -> "Bitcoin Testnet"
170+
B11.BitcoinRegtest -> "Bitcoin Regtest"
171+
B11.BitcoinSignet -> "Bitcoin Signet",
172+
pair "Amount"
173+
. maybe "0" B11.inspectBolt11HrpAmt
174+
. B11.bolt11HrpAmt
175+
$ B11.bolt11Hrp ln,
176+
pair "Created At"
177+
. inspectTimestamp
178+
$ B11.bolt11Timestamp ln
179+
]
180+
<> ( B11.bolt11Tags ln
181+
>>= invoiceFieldsTag ln
182+
)
183+
<> [ pair "Signature"
184+
. B11.inspectHex
185+
$ B11.bolt11SigVal sig,
186+
pair "Pubkey Recovery Flag"
187+
. inspect
188+
$ B11.bolt11SigRecoveryFlag sig
189+
]
90190
where
91191
sig = B11.bolt11Signature ln
92192

93-
invoiceTag :: B11.Bolt11 -> B11.Tag -> [FieldPair DynamicField Identity]
94-
invoiceTag ln = \case
193+
invoiceFieldsTag :: B11.Bolt11 -> B11.Tag -> [FieldPair DynamicField Identity]
194+
invoiceFieldsTag ln = \case
95195
B11.PaymentHash x -> hex "Preimage Hash" x
96196
B11.PaymentSecret x -> hex "Payment Secret" x
97197
B11.Description x -> pure . pair "Description" $ inspect x
@@ -131,88 +231,8 @@ invoiceTag ln = \case
131231
. pair x
132232
. B11.inspectHex
133233

134-
preimageWidget :: Model -> MisoString -> ByteString -> [View Action]
135-
preimageWidget st rawR r =
136-
Header.headerViewer "Preimage Details"
137-
<> pairs
138-
st
139-
[ pair "Preimage" rawR,
140-
pair "Preimage Hash" . inspect @ByteString $ sha256Hash r
141-
]
142-
143-
parsePreimage :: MisoString -> Either MisoString ByteString
144-
parsePreimage rawR =
145-
case B16.decode . T.encodeUtf8 $ from @MisoString @Prelude.Text rawR of
146-
(r, "") -> Right r
147-
(_, e) ->
148-
Left
149-
$ "Bad preimage - non hex leftover "
150-
<> from @Prelude.String @MisoString (Prelude.show e)
151-
152-
parsePreimageHash :: B11.Bolt11 -> Either MisoString ByteString
153-
parsePreimageHash ln =
154-
case find B11.isPaymentHash $ B11.bolt11Tags ln of
155-
Just (B11.PaymentHash (B11.Hex rh)) -> Right rh
156-
_ -> Left "Bad invoice - no preimage hash"
157-
158-
pair :: MisoString -> MisoString -> FieldPair DynamicField Identity
159-
pair x =
160-
newFieldPairId x
161-
. DynamicFieldText
162-
163-
pairs ::
164-
( Typeable model,
165-
Foldable1 f
166-
) =>
167-
model ->
168-
[FieldPair DynamicField f] ->
169-
[View Action]
170-
pairs st raw =
171-
case typeOf st `eqTypeRep` typeRep @Model of
172-
Just HRefl ->
173-
FieldPairs.fieldPairsViewer
174-
FieldPairs.Args
175-
{ FieldPairs.argsModel = st,
176-
FieldPairs.argsOptic = constTraversal xs,
177-
FieldPairs.argsAction = PushUpdate . Instant
178-
}
179-
Nothing ->
180-
FieldPairs.fieldPairsViewer
181-
FieldPairs.Args
182-
{ FieldPairs.argsModel = st,
183-
FieldPairs.argsOptic = constTraversal xs,
184-
FieldPairs.argsAction =
185-
\fun -> PushUpdate . Instant $ \next -> do
186-
void $ fun st
187-
pure next
188-
}
189-
where
190-
xs =
191-
filter
192-
( \x ->
193-
inspectDynamicField (x ^. #fieldPairValue . #fieldOutput)
194-
/= mempty
195-
)
196-
raw
197-
198-
success :: MisoString -> [View Action]
199-
success msg =
200-
css "app-success"
201-
$ pairs () [newFieldPairId mempty $ DynamicFieldText msg]
202-
203-
failure :: MisoString -> [View Action]
204-
failure msg =
205-
css "app-failure"
206-
$ pairs () [newFieldPairId mempty $ DynamicFieldText msg]
207-
208-
css :: MisoString -> [View action] -> [View action]
209-
css x = fmap $ \case
210-
Node x0 x1 x2 x3 x4 -> Node x0 x1 x2 (class_ x : x3) x4
211-
html -> html
212-
213-
inspectTimestamp :: Int -> MisoString
214-
inspectTimestamp =
215-
inspect
216-
. posixSecondsToUTCTime
217-
. Prelude.fromInteger
218-
. from @Int @Integer
234+
preimageFields :: MisoString -> ByteString -> [FieldPair DynamicField Identity]
235+
preimageFields rawR r =
236+
[ pair "Preimage" rawR,
237+
pair "Preimage Hash" . inspect @ByteString $ sha256Hash r
238+
]

0 commit comments

Comments
 (0)