WIP

Author: functora

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

@@ -9,22 +9,27 @@ import qualified Data.Text.Encoding as T
 import qualified Functora.Bolt11 as B11
 import Functora.Miso.Prelude
 import qualified Functora.Miso.Widgets.FieldPairs as FieldPairs
+import qualified Functora.Miso.Widgets.Header as Header
 import qualified Functora.Prelude as Prelude
 import qualified Prelude
 
 bolt11 :: Model -> [View Action]
 bolt11 st =
-  parserWidget ln b11
-    <> (if isRight b11 then parserWidget ln rh else mempty)
-    <> parserWidget hexR r
-    <> fromRight mempty (verifierWidget [ln, hexR] <$> rh <*> r)
-    <> either (const mempty) invoiceWidget b11
+  parserWidget rawLn ln
+    <> (if isRight ln then parserWidget rawLn rh else mempty)
+    <> parserWidget rawR r
+    <> fromRight mempty (verifierWidget [rawLn, rawR] <$> rh <*> r)
+    <> either (const mempty) invoiceWidget ln
+    <> either
+      (const mempty)
+      (\x -> if x == mempty then mempty else preimageWidget x)
+      r
   where
-    ln = st ^. #modelState . #stDoc . #stDocLnInvoice . #fieldOutput
-    b11 = first inspect $ B11.decodeBolt11 ln
-    rh = b11 >>= getPreimageHash
-    hexR = st ^. #modelState . #stDoc . #stDocLnPreimage . #fieldOutput
-    r = getPreimage hexR
+    rawLn = st ^. #modelState . #stDoc . #stDocLnInvoice . #fieldOutput
+    rawR = st ^. #modelState . #stDoc . #stDocLnPreimage . #fieldOutput
+    ln = first inspect $ B11.decodeBolt11 rawLn
+    rh = ln >>= parsePreimageHash
+    r = parsePreimage rawR
 
 parserWidget :: MisoString -> Either MisoString a -> [View Action]
 parserWidget src = \case
@@ -41,31 +46,48 @@ verifierWidget src rh r =
         else failure "Invoice and preimage mismatch!"
 
 invoiceWidget :: B11.Bolt11 -> [View Action]
-invoiceWidget b11 =
-  pairs
-    $ [ simple "Network" . B11.bolt11Currency $ B11.bolt11HRP b11,
-        simple "Amount" . B11.bolt11Amount $ B11.bolt11HRP b11,
-        simple "Timestamp" $ B11.bolt11Timestamp b11
-      ]
-    <> fmap (simple "Tag") (B11.bolt11Tags b11)
-    <> [ simple "Signature" $ B11.bolt11Signature b11
-       ]
+invoiceWidget ln =
+  Header.headerViewer "Invoice Details"
+    <> pairs
+      ( [ simple "Network" . B11.bolt11Currency $ B11.bolt11HRP ln,
+          simple "Amount" . B11.bolt11Amount $ B11.bolt11HRP ln,
+          simple "Timestamp" $ B11.bolt11Timestamp ln
+        ]
+          <> fmap (simple "Tag") (B11.bolt11Tags ln)
+          <> [ simple "Signature" $ B11.bolt11Signature ln
+             ]
+      )
   where
+    simple :: (Show a) => MisoString -> a -> FieldPair DynamicField Identity
     simple x =
       newFieldPairId x
         . DynamicFieldText
         . from @Prelude.String @MisoString
         . Prelude.show
 
-getPreimage :: MisoString -> Either MisoString ByteString
-getPreimage r =
-  case B16.decode . T.encodeUtf8 $ from @MisoString @Prelude.Text r of
-    (x, "") -> Right x
+preimageWidget :: ByteString -> [View Action]
+preimageWidget r =
+  Header.headerViewer "Preimage Details"
+    <> pairs
+      [ simple "Preimage" r,
+        simple "Preimage Hash" $ sha256Hash r
+      ]
+  where
+    simple :: MisoString -> ByteString -> FieldPair DynamicField Identity
+    simple x =
+      newFieldPairId x
+        . DynamicFieldText
+        . inspect
+
+parsePreimage :: MisoString -> Either MisoString ByteString
+parsePreimage rawR =
+  case B16.decode . T.encodeUtf8 $ from @MisoString @Prelude.Text rawR of
+    (r, "") -> Right r
     res -> Left $ "Bad preimage " <> inspect res
 
-getPreimageHash :: B11.Bolt11 -> Either MisoString ByteString
-getPreimageHash b11 =
-  case find B11.isPaymentHash $ B11.bolt11Tags b11 of
+parsePreimageHash :: B11.Bolt11 -> Either MisoString ByteString
+parsePreimageHash ln =
+  case find B11.isPaymentHash $ B11.bolt11Tags ln of
     Just (B11.PaymentHash (B11.Hex rh)) -> Right rh
     _ -> Left "Bad invoice without preimage hash!"
 
@@ -83,15 +105,15 @@ pairs xs =
 
 success :: MisoString -> [View Action]
 success msg =
-  addCssClass "app-success"
+  css "app-success"
     $ pairs [newFieldPairId mempty $ DynamicFieldText msg]
 
 failure :: MisoString -> [View Action]
 failure msg =
-  addCssClass "app-failure"
+  css "app-failure"
     $ pairs [newFieldPairId mempty $ DynamicFieldText msg]
 
-addCssClass :: MisoString -> [View action] -> [View action]
-addCssClass css = fmap $ \case
-  Node x0 x1 x2 x3 x4 -> Node x0 x1 x2 (class_ css : x3) x4
+css :: MisoString -> [View action] -> [View action]
+css x = fmap $ \case
+  Node x0 x1 x2 x3 x4 -> Node x0 x1 x2 (class_ x : x3) x4
   html -> html