bolt11 wip

Author: functora

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

@@ -14,61 +14,60 @@ import qualified Prelude
 
 bolt11 :: Model -> [View Action]
 bolt11 st =
-  if ln == mempty
-    then mempty
-    else case B11.decodeBolt11 ln of
-      Left e ->
-        red
-          $ pairs
-            [ newFieldPairId mempty
-                . DynamicFieldText
-                $ from @Prelude.String @MisoString e
-            ]
-      Right b11 ->
-        ( case B11.bolt11Tags b11 >>= verifier r of
-            [] | r /= mempty -> failure "Bad invoice without preimage hash!"
-            xs -> xs
-        )
-          <> ( 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
-                   ]
-             )
+  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
   where
-    r = st ^. #modelState . #stDoc . #stDocLnPreimage . #fieldOutput
     ln = st ^. #modelState . #stDoc . #stDocLnInvoice . #fieldOutput
+    b11 = first inspect $ B11.decodeBolt11 ln
+    rh = b11 >>= getPreimageHash
+    hexR = st ^. #modelState . #stDoc . #stDocLnPreimage . #fieldOutput
+    r = getPreimage hexR
+
+parserWidget :: MisoString -> Either MisoString a -> [View Action]
+parserWidget src = \case
+  Left e | src /= mempty -> failure e
+  _ -> mempty
+
+verifierWidget :: [MisoString] -> ByteString -> ByteString -> [View Action]
+verifierWidget src rh r =
+  if any (== mempty) src
+    then mempty
+    else
+      if rh == sha256Hash r
+        then success "Invoice and preimage match!"
+        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
+       ]
+  where
     simple x =
       newFieldPairId x
         . DynamicFieldText
         . from @Prelude.String @MisoString
         . Prelude.show
 
-verifier :: MisoString -> B11.Tag -> [View Action]
-verifier "" _ =
-  mempty
-verifier r (B11.PaymentHash (B11.Hex expected)) =
+getPreimage :: MisoString -> Either MisoString ByteString
+getPreimage r =
   case B16.decode . T.encodeUtf8 $ from @MisoString @Prelude.Text r of
-    (rbs, "") -> do
-      let provided = sha256Hash rbs
-      if expected == provided
-        then success "Invoice and preimage match!"
-        else failure "Invoice and preimage mismatch!"
-    res ->
-      failure $ "Bad preimage " <> inspect res
-verifier _ _ =
-  mempty
+    (x, "") -> Right x
+    res -> Left $ "Bad preimage " <> inspect res
 
-success :: MisoString -> [View Action]
-success msg =
-  green $ pairs [newFieldPairId mempty $ DynamicFieldText msg]
-
-failure :: MisoString -> [View Action]
-failure msg =
-  red $ pairs [newFieldPairId mempty $ DynamicFieldText msg]
+getPreimageHash :: B11.Bolt11 -> Either MisoString ByteString
+getPreimageHash b11 =
+  case find B11.isPaymentHash $ B11.bolt11Tags b11 of
+    Just (B11.PaymentHash (B11.Hex rh)) -> Right rh
+    _ -> Left "Bad invoice without preimage hash!"
 
 pairs :: [FieldPair DynamicField f] -> [View Action]
 pairs xs =
@@ -82,16 +81,17 @@ pairs xs =
             pure next
       }
 
-red :: [View action] -> [View action]
-red = fmap $ \case
-  Node x0 x1 x2 x3 x4 ->
-    Node x0 x1 x2 (class_ "app-failure" : x3) x4
-  html ->
-    html
+success :: MisoString -> [View Action]
+success msg =
+  addCssClass "app-success"
+    $ pairs [newFieldPairId mempty $ DynamicFieldText msg]
+
+failure :: MisoString -> [View Action]
+failure msg =
+  addCssClass "app-failure"
+    $ pairs [newFieldPairId mempty $ DynamicFieldText msg]
 
-green :: [View action] -> [View action]
-green = fmap $ \case
-  Node x0 x1 x2 x3 x4 ->
-    Node x0 x1 x2 (class_ "app-success" : x3) x4
-  html ->
-    html
+addCssClass :: MisoString -> [View action] -> [View action]
+addCssClass css = fmap $ \case
+  Node x0 x1 x2 x3 x4 -> Node x0 x1 x2 (class_ css : x3) x4
+  html -> html