content: {-# LANGUAGE ConstraintKinds #-}
  {-# LANGUAGE CPP #-}
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE RecursiveDo #-}
  {-# LANGUAGE TypeApplications #-}
  -- | Dialog for viewing the details of a key.
  -- Copyright   :  (C) 2020-2022 Kadena
  -- License     :  BSD-style (see the file LICENSE)
  module Frontend.UI.Dialogs.KeyDetails
    ( uiKeyDetails
    ) where
  
  ------------------------------------------------------------------------------
  #if !defined(ghcjs_HOST_OS)
  import qualified Codec.QRCode as QR
  import qualified Codec.QRCode.JuicyPixels as QR
  #endif
  import           Control.Error
  import           Control.Lens
  import           Control.Monad (join)
  import qualified Data.Aeson as A
  import           Data.Aeson.Parser.Internal (jsonEOF')
  import           Data.Attoparsec.ByteString
  import           Data.Bifunctor (first)
  import qualified Data.ByteString as B
  import qualified Data.ByteString.Lazy as LB
  import           Data.Functor (void)
  import qualified Data.Text as T
  import qualified Data.Text.Encoding as T
  import qualified Data.Text.Lazy as LT
  import qualified Data.IntMap as IntMap
  import           Data.YAML
  import qualified Data.YAML.Aeson as Y
  import           Pact.Types.ChainMeta (PublicMeta)
  import           Pact.Types.Command
  import           Pact.Types.Hash (hash, toUntypedHash, unHash)
  import           Pact.Types.SigData
  import           Pact.Types.Util             (decodeBase64UrlUnpadded)
  ------------------------------------------------------------------------------
  import           Reflex
  import           Reflex.Dom hiding (Command, Key)
  ------------------------------------------------------------------------------
  import           Frontend.Crypto.Class
  import           Frontend.Foundation
  import           Frontend.UI.Modal
  import           Frontend.UI.Widgets
  import           Frontend.UI.Widgets.Helpers (dialogSectionHeading)
  import           Frontend.Wallet
  ------------------------------------------------------------------------------
  
  data DataToBeSigned
    = JsonSigData (SigData T.Text)
    | JsonPayload (Payload PublicMeta T.Text) B.ByteString
    | YamlSigData (SigData T.Text)
    | ErrorString String
    | EmptyString
  
  uiKeyDetails
    :: ( Monoid mConf
       , HasCrypto key m
       , MonadWidget t m
       )
    => IntMap.Key
    -> Key key
    -> Event t ()
    -> m (mConf, Event t ())
  uiKeyDetails _keyIndex key _onCloseExternal = mdo
    onClose <- modalHeader $ text "Key Details"
    let withSecretKey f = case _keyPair_privateKey . _key_pair $ key of
          Nothing -> text "Public key does not have a matching secret key - use a keypair generated by Chainweaver instead"
          Just x -> f x
  
        publicKey = keyToText $ _keyPair_publicKey $ _key_pair key
  
        -- Create an input textbox, along with an output textbox
        -- The output textbox will also have an associated copy button,
        -- whenever it is non-empty.
        inputOutputBoxesWithCopy headerText =
          withSecretKey $ \pk ->
            divClass "group" $ do
              txt <- fmap value $ mkLabeledClsInput False headerText $ \cls -> uiTextAreaElement $ def
                & initialAttributes .~ "class" =: renderClass cls
  
              let
                -- Read bytes from user input, taking into consideration both JSON and YAML
                parseBytes "" = EmptyString
                parseBytes bytes =
                  -- Parse the JSON, and consume all the input
                  case parseOnly jsonEOF' bytes of
                      -- If we do receive JSON, it can be of two types: either a SigData Text,
                      -- or a Payload PublicMeta Text
                    Right val -> case A.fromJSON val of
                      A.Success sigData -> JsonSigData sigData
                      A.Error _ -> case A.fromJSON val of
                        A.Success payload -> JsonPayload payload bytes
                        A.Error errorStr -> ErrorString errorStr
                    -- We did not receive JSON, try parsing it as YAML
                    Left _ -> case Y.decode1Strict bytes of
                      Right sigData -> YamlSigData sigData
                      Left (pos, errorStr) -> ErrorString $ prettyPosWithSource pos (LB.fromStrict bytes) errorStr
  
                -- Convert received text into DataToBeSigned
                signingDataEv = (parseBytes . T.encodeUtf8) <$> updated txt
  
                -- Convert a functor value into a pair with a given header
                withHeader h t = fmap ((,) h) t
  
                -- Parse payload from given text
                parsePayload :: T.Text -> Either T.Text (Payload PublicMeta T.Text)
                parsePayload cmdText =
                  first (const "Invalid cmd field inside SigData.") $
                    A.eitherDecodeStrict (T.encodeUtf8 cmdText)
  
                -- Hash the given text, and match it with a given hash
                matchHash oldHash textToBeHashed =
                  if oldHash == hash (T.encodeUtf8 textToBeHashed)
                    then Right oldHash
                    else Left "Hash does not match the payload."
  
                -- Sign the given hash with user's private key
                signHashWithKey h = keyToText <$> cryptoSign (unHash $ toUntypedHash h) pk
  
                -- Sign the given hash only if current user is a signer
                signHashIfUserIsSigner hashToSign payload =
                  if publicKey `elem` map _siPubKey (_pSigners payload)
                    then Right <$> signHashWithKey hashToSign
                    else pure $ Left "You are not one of the signers."
  
                -- Match hash and then parse the payload from text one after the other.
                -- Succeeds if all steps succeed, otherwise returns the first error.
                matchHashAndParsePayload h cmd = do
                  verifiedHash <- matchHash h cmd
                  payload <- parsePayload cmd
                  pure (verifiedHash, payload)
  
              -- Sign the appropriate DataToBeSigned, and return a header and a hash on success.
              -- On failure, return an error.
              ((), headerAndHashEv) <- runWithReplace blank $ ffor signingDataEv $ \case
                JsonSigData (SigData sdHash _ (Just cmd)) -> do
                  withHeader "Signature" $ do
                    fmap join
                      $ mapM (uncurry signHashIfUserIsSigner)
                      $ matchHashAndParsePayload sdHash cmd
                JsonPayload payload payloadBytes -> do
                  let
                    unsignedCmd = Command (T.decodeUtf8 payloadBytes) [] $ hash payloadBytes
                    signCommand cmd signedHash = cmd  & cmdSigs .~ [signedHash]
                  withHeader "Signed Command"
                    $ fmap
                      ( T.decodeUtf8
                      . LB.toStrict
                      . A.encode
                      . signCommand unsignedCmd
                      . UserSig
                      )
                    <$> signHashIfUserIsSigner (_cmdHash unsignedCmd) payload
                YamlSigData sigData@(SigData sdHash sigList (Just cmd)) -> do
                  let
                    -- `sigList` (that we parsed from user text) may or may not have all the signers.
                    -- It may have only those signers who have signed already.
                    -- Generate signatures for all signers, signers who have not yet signed have signature as Nothing.
                    allSignatures signature payload = map (\s ->
                      let
                        pKey = PublicKeyHex $ _siPubKey s
                        myKey = PublicKeyHex publicKey
                      in
                        ( pKey
                        , if pKey == myKey
                            then Just $ UserSig signature
                            else join $ lookup pKey sigList
                        )
                      ) $ _pSigners payload
                    updateSigData sd allSigs = sd { _sigDataSigs = allSigs}
                  withHeader "Signed SigData" $ do
                    let hashAndPayload = matchHashAndParsePayload sdHash cmd
                    signature <- join <$> mapM (uncurry signHashIfUserIsSigner) hashAndPayload
                    pure
                      $ fmap
                        ( T.decodeUtf8
                        . Y.encode1Strict
                        . updateSigData sigData
                        )
                      $ allSignatures <$> signature <*> (snd <$> hashAndPayload)
                ErrorString errorStr -> withHeader "Signature" $ pure $ Left $ T.pack errorStr
                -- Empty string is not an error, but we wrap it inside a Left
                -- so that we don't show a Copy button when user input is empty.
                EmptyString -> withHeader "Signature" $ pure $ Left ""
                _ -> withHeader "Signature" $ pure $ Left "Could not parse data."
  
              let (headerEv, hashEv) = splitE headerAndHashEv
  
              widgetHold_ blank $ ffor hashEv $ \case
                Right _ -> blank
                -- Since empty string is not an error, we don't show an error here.
                Left "" -> blank
                Left errorStr -> elClass "p" "error_inline" $ text errorStr
  
              headerDyn <- holdDyn "Signature" headerEv
              void $ mkLabeledClsInput False headerDyn $ \cls -> uiTextAreaElement $ def
                & initialAttributes .~ mconcat
                  [ "class" =: renderClass cls
                  , "disabled" =: ""
                  , "placeholder" =: "Enter some text in the above field"
                  ]
                & textAreaElementConfig_setValue .~ fmap fold hashEv
  
              hashDyn <- holdDyn (Left "") hashEv
              eitherHashDyn <- eitherDyn hashDyn
              dyn_ $ ffor eitherHashDyn $ \case
                Left _ -> blank
                Right ev -> uiDetailsCopyButton $ current ev
  
    divClass "modal__main key-details" $ do
      dialogSectionHeading mempty "Public Key"
      -- We need the `group__header` class to provide some margin after the
      -- Public key input box.
      divClass "group group__header" $ do
        void $ uiInputElement $ def
          & inputElementConfig_initialValue .~ publicKey
          & initialAttributes <>~ ("disabled" =: "true" <> "class" =: " key-details__pubkey input labeled-input__input")
  
      inputOutputBoxesWithCopy "Data to sign ( JSON/YAML )"
  
      void $ accordionItemWithClick False mempty (accordionHeaderBtn "Advanced") $ withSecretKey $ \pk -> do
        divClass "group" $ do
          txt <- fmap value $ mkLabeledClsInput False "Data to sign (Base64Url Unpadded)" $ \cls -> uiTextAreaElement $ def
            & initialAttributes .~ "class" =: renderClass cls
  
          ((), sigEv) <- runWithReplace blank $ ffor (fmapMaybe (hush . decodeBase64UrlUnpadded . T.encodeUtf8) $ updated txt) $ \case
            "" -> pure Nothing
            b -> Just . keyToText <$> cryptoSign b pk
  
          sig <- maybeDyn =<< holdDyn Nothing sigEv
  
  
          void $ mkLabeledClsInput False "Signature" $ \cls -> uiTextAreaElement $ def
            & initialAttributes .~ mconcat
              [ "class" =: renderClass cls
              , "disabled" =: ""
              , "placeholder" =: "Enter some text in the above field"
              ]
            & textAreaElementConfig_setValue .~ ffor sigEv fold
  
          dyn_ $ ffor sig $ \case
            Nothing -> blank
            Just sig' -> do
              uiDetailsCopyButton $ current sig'
  #if !defined(ghcjs_HOST_OS)
              let qrImage = QR.encodeText (QR.defaultQRCodeOptions QR.L) QR.Iso8859_1OrUtf8WithECI <$> sig'
                  img = maybe "Error creating QR code" (QR.toPngDataUrlT 4 6) <$> qrImage
              el "br" blank
              elDynAttr "img" (("src" =:) . LT.toStrict <$> img) blank
  #endif
  
    modalFooter $ do
      onDone <- confirmButton def "Done"
  
      let done = leftmost [onClose, onDone]
  
      pure (mempty, done)
  