{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE NoImplicitPrelude #-} module BtcLsp.Yesod.Handler.SwapIntoLnCreate ( getSwapIntoLnCreateR, postSwapIntoLnCreateR, ) where import BtcLsp.Data.Kind import BtcLsp.Data.Type import BtcLsp.Grpc.Combinator import qualified BtcLsp.Grpc.Server.HighLevel as Server import BtcLsp.Storage.Model import BtcLsp.Storage.Model.User as User import BtcLsp.Yesod.Data.Widget import BtcLsp.Yesod.Import import Lens.Micro import qualified LndClient.Data.PayReq as Lnd import qualified LndClient.RPC.Katip as Lnd import qualified Proto.BtcLsp.Data.HighLevel as Proto import qualified Proto.BtcLsp.Method.SwapIntoLn as SwapIntoLn import qualified Proto.BtcLsp.Method.SwapIntoLn_Fields as SwapIntoLn import Yesod.Form.Bootstrap3 data SwapRequest = SwapRequest { SwapRequest -> LnInvoice 'Fund swapRequestInvoice :: LnInvoice 'Fund, SwapRequest -> UnsafeOnChainAddress 'Refund swapRequestRefund :: UnsafeOnChainAddress 'Refund, SwapRequest -> Privacy swapRequestPrivacy :: Privacy } deriving stock ( SwapRequest -> SwapRequest -> Bool (SwapRequest -> SwapRequest -> Bool) -> (SwapRequest -> SwapRequest -> Bool) -> Eq SwapRequest forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a /= :: SwapRequest -> SwapRequest -> Bool $c/= :: SwapRequest -> SwapRequest -> Bool == :: SwapRequest -> SwapRequest -> Bool $c== :: SwapRequest -> SwapRequest -> Bool Eq, Int -> SwapRequest -> ShowS [SwapRequest] -> ShowS SwapRequest -> String (Int -> SwapRequest -> ShowS) -> (SwapRequest -> String) -> ([SwapRequest] -> ShowS) -> Show SwapRequest forall a. (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a showList :: [SwapRequest] -> ShowS $cshowList :: [SwapRequest] -> ShowS show :: SwapRequest -> String $cshow :: SwapRequest -> String showsPrec :: Int -> SwapRequest -> ShowS $cshowsPrec :: Int -> SwapRequest -> ShowS Show, (forall x. SwapRequest -> Rep SwapRequest x) -> (forall x. Rep SwapRequest x -> SwapRequest) -> Generic SwapRequest forall x. Rep SwapRequest x -> SwapRequest forall x. SwapRequest -> Rep SwapRequest x forall a. (forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a $cto :: forall x. Rep SwapRequest x -> SwapRequest $cfrom :: forall x. SwapRequest -> Rep SwapRequest x Generic ) instance Out SwapRequest getSwapIntoLnCreateR :: Handler Html getSwapIntoLnCreateR :: Handler Markup getSwapIntoLnCreateR = do (Widget formWidget, Enctype formEnctype) <- (Markup -> MForm (HandlerFor App) (FormResult SwapRequest, Widget)) -> Handler (Widget, Enctype) forall (m :: * -> *) a xml. (RenderMessage (HandlerSite m) FormMessage, MonadHandler m) => (Markup -> MForm m (FormResult a, xml)) -> m (xml, Enctype) generateFormPost ((Markup -> MForm (HandlerFor App) (FormResult SwapRequest, Widget)) -> Handler (Widget, Enctype)) -> (Markup -> MForm (HandlerFor App) (FormResult SwapRequest, Widget)) -> Handler (Widget, Enctype) forall a b. (a -> b) -> a -> b $ BootstrapFormLayout -> FormRender (HandlerFor App) SwapRequest forall (m :: * -> *) a. Monad m => BootstrapFormLayout -> FormRender m a renderBootstrap3 BootstrapFormLayout BootstrapBasicForm AForm (HandlerFor App) SwapRequest aForm BootstrapColor -> Widget -> Enctype -> Handler Markup renderPage BootstrapColor Info Widget formWidget Enctype formEnctype postSwapIntoLnCreateR :: Handler Html postSwapIntoLnCreateR :: Handler Markup postSwapIntoLnCreateR = do ((FormResult SwapRequest formResult, Widget formWidget), Enctype formEnctype) <- (Markup -> MForm (HandlerFor App) (FormResult SwapRequest, Widget)) -> Handler ((FormResult SwapRequest, Widget), Enctype) forall (m :: * -> *) a xml. (RenderMessage (HandlerSite m) FormMessage, MonadResource m, MonadHandler m) => (Markup -> MForm m (FormResult a, xml)) -> m ((FormResult a, xml), Enctype) runFormPost ((Markup -> MForm (HandlerFor App) (FormResult SwapRequest, Widget)) -> Handler ((FormResult SwapRequest, Widget), Enctype)) -> (Markup -> MForm (HandlerFor App) (FormResult SwapRequest, Widget)) -> Handler ((FormResult SwapRequest, Widget), Enctype) forall a b. (a -> b) -> a -> b $ BootstrapFormLayout -> FormRender (HandlerFor App) SwapRequest forall (m :: * -> *) a. Monad m => BootstrapFormLayout -> FormRender m a renderBootstrap3 BootstrapFormLayout BootstrapBasicForm AForm (HandlerFor App) SwapRequest aForm case FormResult SwapRequest formResult of FormSuccess SwapRequest req -> do let fundInv :: LnInvoice 'Fund fundInv = SwapRequest -> LnInvoice 'Fund swapRequestInvoice SwapRequest req App {appMRunner :: () appMRunner = UnliftIO forall a. m a -> IO a run} <- HandlerFor App App forall (m :: * -> *). MonadHandler m => m (HandlerSite m) getYesod Either Response (Entity SwapIntoLn) eSwap <- IO (Either Response (Entity SwapIntoLn)) -> HandlerFor App (Either Response (Entity SwapIntoLn)) forall (m :: * -> *) a. MonadIO m => IO a -> m a liftIO (IO (Either Response (Entity SwapIntoLn)) -> HandlerFor App (Either Response (Entity SwapIntoLn))) -> (ExceptT Response m (Entity SwapIntoLn) -> IO (Either Response (Entity SwapIntoLn))) -> ExceptT Response m (Entity SwapIntoLn) -> HandlerFor App (Either Response (Entity SwapIntoLn)) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . m (Either Response (Entity SwapIntoLn)) -> IO (Either Response (Entity SwapIntoLn)) forall a. m a -> IO a run (m (Either Response (Entity SwapIntoLn)) -> IO (Either Response (Entity SwapIntoLn))) -> (ExceptT Response m (Entity SwapIntoLn) -> m (Either Response (Entity SwapIntoLn))) -> ExceptT Response m (Entity SwapIntoLn) -> IO (Either Response (Entity SwapIntoLn)) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . ExceptT Response m (Entity SwapIntoLn) -> m (Either Response (Entity SwapIntoLn)) forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a) runExceptT (ExceptT Response m (Entity SwapIntoLn) -> HandlerFor App (Either Response (Entity SwapIntoLn))) -> ExceptT Response m (Entity SwapIntoLn) -> HandlerFor App (Either Response (Entity SwapIntoLn)) forall a b. (a -> b) -> a -> b $ do PayReq fundInvLnd <- (LndEnv -> PaymentRequest -> m (Either LndError PayReq)) -> ((PaymentRequest -> m (Either LndError PayReq)) -> m (Either LndError PayReq)) -> ExceptT Response m PayReq forall (m :: * -> *) res failure specific a b. (Env m, GrpcRes res failure specific) => (LndEnv -> a) -> (a -> m (Either LndError b)) -> ExceptT res m b withLndServerT LndEnv -> PaymentRequest -> m (Either LndError PayReq) forall (m :: * -> *). (KatipContext m, MonadUnliftIO m) => LndEnv -> PaymentRequest -> m (Either LndError PayReq) Lnd.decodePayReq ((PaymentRequest -> m (Either LndError PayReq)) -> PaymentRequest -> m (Either LndError PayReq) forall a b. (a -> b) -> a -> b $ LnInvoice 'Fund -> PaymentRequest forall source target. (From source target, 'False ~ (source == target)) => source -> target from LnInvoice 'Fund fundInv) Entity User userEnt <- (Failure -> Response) -> ExceptT Failure m (Entity User) -> ExceptT Response m (Entity User) forall (m :: * -> *) e e' a. Functor m => (e -> e') -> ExceptT e m a -> ExceptT e' m a withExceptT ( Response -> Failure -> Response forall a b. a -> b -> a const (Response -> Failure -> Response) -> Response -> Failure -> Response forall a b. (a -> b) -> a -> b $ InputFailureKind -> ReversedFieldLocation -> Response forall res failure specific. GrpcRes res failure specific => InputFailureKind -> ReversedFieldLocation -> res newGenFailure InputFailureKind Proto.VERIFICATION_FAILED $( mkFieldLocation @SwapIntoLn.Request [ "ctx", "nonce" ] ) ) (ExceptT Failure m (Entity User) -> ExceptT Response m (Entity User)) -> (m (Either Failure (Entity User)) -> ExceptT Failure m (Entity User)) -> m (Either Failure (Entity User)) -> ExceptT Response m (Entity User) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . m (Either Failure (Entity User)) -> ExceptT Failure m (Entity User) forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a ExceptT (m (Either Failure (Entity User)) -> ExceptT Response m (Entity User)) -> m (Either Failure (Entity User)) -> ExceptT Response m (Entity User) forall a b. (a -> b) -> a -> b $ m Nonce forall (m :: * -> *). MonadIO m => m Nonce newNonce m Nonce -> (Nonce -> m (Either Failure (Entity User))) -> m (Either Failure (Entity User)) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= ReaderT SqlBackend m (Either Failure (Entity User)) -> m (Either Failure (Entity User)) forall (m :: * -> *) a. Storage m => ReaderT SqlBackend m a -> m a runSql (ReaderT SqlBackend m (Either Failure (Entity User)) -> m (Either Failure (Entity User))) -> (Nonce -> ReaderT SqlBackend m (Either Failure (Entity User))) -> Nonce -> m (Either Failure (Entity User)) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . NodePubKey -> Nonce -> ReaderT SqlBackend m (Either Failure (Entity User)) forall (m :: * -> *). MonadIO m => NodePubKey -> Nonce -> ReaderT SqlBackend m (Either Failure (Entity User)) User.createVerifySql (PayReq -> NodePubKey Lnd.destination PayReq fundInvLnd) Entity User -> UnsafeOnChainAddress 'Refund -> Privacy -> ExceptT Response m (Entity SwapIntoLn) forall (m :: * -> *). Env m => Entity User -> UnsafeOnChainAddress 'Refund -> Privacy -> ExceptT Response m (Entity SwapIntoLn) Server.swapIntoLnT Entity User userEnt (SwapRequest -> UnsafeOnChainAddress 'Refund swapRequestRefund SwapRequest req) (SwapRequest -> Privacy swapRequestPrivacy SwapRequest req) case Either Response (Entity SwapIntoLn) eSwap of Left Response e -> do AppMessage -> HandlerFor App () forall (m :: * -> *) msg. (MonadHandler m, RenderMessage (HandlerSite m) msg) => msg -> m () setMessageI (AppMessage -> HandlerFor App ()) -> AppMessage -> HandlerFor App () forall a b. (a -> b) -> a -> b $ Response -> AppMessage explainFailure Response e BootstrapColor -> Widget -> Enctype -> Handler Markup renderPage BootstrapColor Danger Widget formWidget Enctype formEnctype Right Entity SwapIntoLn swapEnt -> Route App -> Handler Markup forall (m :: * -> *) url a. (MonadHandler m, RedirectUrl (HandlerSite m) url) => url -> m a redirect (Route App -> Handler Markup) -> (SwapIntoLn -> Route App) -> SwapIntoLn -> Handler Markup forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . Uuid'SwapIntoLnTable -> Route App SwapIntoLnSelectR (Uuid'SwapIntoLnTable -> Route App) -> (SwapIntoLn -> Uuid'SwapIntoLnTable) -> SwapIntoLn -> Route App forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . SwapIntoLn -> Uuid'SwapIntoLnTable swapIntoLnUuid (SwapIntoLn -> Handler Markup) -> SwapIntoLn -> Handler Markup forall a b. (a -> b) -> a -> b $ Entity SwapIntoLn -> SwapIntoLn forall record. Entity record -> record entityVal Entity SwapIntoLn swapEnt FormResult SwapRequest _ -> BootstrapColor -> Widget -> Enctype -> Handler Markup renderPage BootstrapColor Danger Widget formWidget Enctype formEnctype explainFailure :: SwapIntoLn.Response -> AppMessage explainFailure :: Response -> AppMessage explainFailure Response res = AppMessage -> (Response'Failure'InputFailure -> AppMessage) -> Maybe Response'Failure'InputFailure -> AppMessage forall b a. b -> (a -> b) -> Maybe a -> b maybe AppMessage MsgInputFailure ( \case Response'Failure'InputFailure SwapIntoLn.Response'Failure'DEFAULT -> AppMessage MsgInputFailure Response'Failure'InputFailure SwapIntoLn.Response'Failure'REFUND_ON_CHAIN_ADDRESS_IS_NOT_VALID -> AppMessage MsgSwapIntoLnFailureRefundOnChainAddressIsNotValid Response'Failure'InputFailure SwapIntoLn.Response'Failure'REFUND_ON_CHAIN_ADDRESS_IS_NOT_SEGWIT -> AppMessage MsgSwapIntoLnFailureRefundOnChainAddressIsNotSegwit SwapIntoLn.Response'Failure'InputFailure'Unrecognized {} -> AppMessage MsgInputFailure ) (Maybe Response'Failure'InputFailure -> AppMessage) -> Maybe Response'Failure'InputFailure -> AppMessage forall a b. (a -> b) -> a -> b $ Response res Response -> Getting (First [Response'Failure'InputFailure]) Response [Response'Failure'InputFailure] -> Maybe [Response'Failure'InputFailure] forall s a. s -> Getting (First a) s a -> Maybe a ^? LensLike' (Const (First [Response'Failure'InputFailure])) Response (Maybe Response'Failure) forall (f :: * -> *) s a. (Functor f, HasField s "maybe'failure" a) => LensLike' f s a SwapIntoLn.maybe'failure LensLike' (Const (First [Response'Failure'InputFailure])) Response (Maybe Response'Failure) -> (([Response'Failure'InputFailure] -> Const (First [Response'Failure'InputFailure]) [Response'Failure'InputFailure]) -> Maybe Response'Failure -> Const (First [Response'Failure'InputFailure]) (Maybe Response'Failure)) -> Getting (First [Response'Failure'InputFailure]) Response [Response'Failure'InputFailure] forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . (Response'Failure -> Const (First [Response'Failure'InputFailure]) Response'Failure) -> Maybe Response'Failure -> Const (First [Response'Failure'InputFailure]) (Maybe Response'Failure) forall a a'. Traversal (Maybe a) (Maybe a') a a' _Just ((Response'Failure -> Const (First [Response'Failure'InputFailure]) Response'Failure) -> Maybe Response'Failure -> Const (First [Response'Failure'InputFailure]) (Maybe Response'Failure)) -> (([Response'Failure'InputFailure] -> Const (First [Response'Failure'InputFailure]) [Response'Failure'InputFailure]) -> Response'Failure -> Const (First [Response'Failure'InputFailure]) Response'Failure) -> ([Response'Failure'InputFailure] -> Const (First [Response'Failure'InputFailure]) [Response'Failure'InputFailure]) -> Maybe Response'Failure -> Const (First [Response'Failure'InputFailure]) (Maybe Response'Failure) forall {k} (cat :: k -> k -> *) (b :: k) (c :: k) (a :: k). Category cat => cat b c -> cat a b -> cat a c . ([Response'Failure'InputFailure] -> Const (First [Response'Failure'InputFailure]) [Response'Failure'InputFailure]) -> Response'Failure -> Const (First [Response'Failure'InputFailure]) Response'Failure forall (f :: * -> *) s a. (Functor f, HasField s "specific" a) => LensLike' f s a SwapIntoLn.specific Maybe [Response'Failure'InputFailure] -> ([Response'Failure'InputFailure] -> Maybe Response'Failure'InputFailure) -> Maybe Response'Failure'InputFailure forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b >>= [Response'Failure'InputFailure] -> Maybe Response'Failure'InputFailure forall a. [a] -> Maybe a listToMaybe renderPage :: BootstrapColor -> Widget -> Enctype -> Handler Html renderPage :: BootstrapColor -> Widget -> Enctype -> Handler Markup renderPage BootstrapColor color Widget formWidget Enctype formEnctype = do let formRoute :: Route App formRoute = Route App SwapIntoLnCreateR let formMsgSubmit :: AppMessage formMsgSubmit = AppMessage MsgContinue BootstrapColor -> AppMessage -> AppMessage -> Widget -> Handler Markup panelLayout BootstrapColor color AppMessage MsgSwapIntoLnInfoShort AppMessage MsgSwapIntoLnInfoLong (Widget -> Handler Markup) -> Widget -> Handler Markup forall a b. (a -> b) -> a -> b $ do AppMessage -> Widget forall (m :: * -> *) msg. (MonadWidget m, RenderMessage (HandlerSite m) msg) => msg -> m () setTitleI AppMessage MsgSwapIntoLnCreateRTitle $(widgetFile "simple_form") aForm :: AForm Handler SwapRequest aForm :: AForm (HandlerFor App) SwapRequest aForm = LnInvoice 'Fund -> UnsafeOnChainAddress 'Refund -> Privacy -> SwapRequest SwapRequest (LnInvoice 'Fund -> UnsafeOnChainAddress 'Refund -> Privacy -> SwapRequest) -> AForm (HandlerFor App) (LnInvoice 'Fund) -> AForm (HandlerFor App) (UnsafeOnChainAddress 'Refund -> Privacy -> SwapRequest) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b <$> Field (HandlerFor App) (LnInvoice 'Fund) -> FieldSettings App -> Maybe (LnInvoice 'Fund) -> AForm (HandlerFor App) (LnInvoice 'Fund) forall site (m :: * -> *) a. (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> AForm m a areq Field (HandlerFor App) (LnInvoice 'Fund) forall (m :: * -> *) a. (Monad m, From Text a, From a Text, 'False ~ (Text == a), 'False ~ (a == Text), RenderMessage (HandlerSite m) FormMessage) => Field m a fromTextField (AppMessage -> FieldSettings App forall site msg. RenderMessage site msg => msg -> FieldSettings site bfsAutoFocus AppMessage MsgSwapIntoLnFundInvoice) Maybe (LnInvoice 'Fund) forall a. Maybe a Nothing AForm (HandlerFor App) (UnsafeOnChainAddress 'Refund -> Privacy -> SwapRequest) -> AForm (HandlerFor App) (UnsafeOnChainAddress 'Refund) -> AForm (HandlerFor App) (Privacy -> SwapRequest) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Field (HandlerFor App) (UnsafeOnChainAddress 'Refund) -> FieldSettings App -> Maybe (UnsafeOnChainAddress 'Refund) -> AForm (HandlerFor App) (UnsafeOnChainAddress 'Refund) forall site (m :: * -> *) a. (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> AForm m a areq Field (HandlerFor App) (UnsafeOnChainAddress 'Refund) forall (m :: * -> *) a. (Monad m, From Text a, From a Text, 'False ~ (Text == a), 'False ~ (a == Text), RenderMessage (HandlerSite m) FormMessage) => Field m a fromTextField (AppMessage -> FieldSettings App forall site msg. RenderMessage site msg => msg -> FieldSettings site bfs AppMessage MsgSwapIntoLnRefundAddress) Maybe (UnsafeOnChainAddress 'Refund) forall a. Maybe a Nothing AForm (HandlerFor App) (Privacy -> SwapRequest) -> AForm (HandlerFor App) Privacy -> AForm (HandlerFor App) SwapRequest forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b <*> Field (HandlerFor App) Privacy -> FieldSettings App -> Maybe Privacy -> AForm (HandlerFor App) Privacy forall site (m :: * -> *) a. (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m) => Field m a -> FieldSettings site -> Maybe a -> AForm m a areq ( HandlerFor App (OptionList Privacy) -> Field (HandlerFor App) Privacy forall a site. (Eq a, RenderMessage site FormMessage) => HandlerFor site (OptionList a) -> Field (HandlerFor site) a selectField (HandlerFor App (OptionList Privacy) -> Field (HandlerFor App) Privacy) -> HandlerFor App (OptionList Privacy) -> Field (HandlerFor App) Privacy forall a b. (a -> b) -> a -> b $ [(AppMessage, Privacy)] -> HandlerFor App (OptionList Privacy) forall (m :: * -> *) msg a. (MonadHandler m, RenderMessage (HandlerSite m) msg) => [(msg, a)] -> m (OptionList a) optionsPairs [ (AppMessage MsgChanPublic, Privacy Public), (AppMessage MsgChanPrivate, Privacy Private) ] ) (AppMessage -> FieldSettings App forall site msg. RenderMessage site msg => msg -> FieldSettings site bfs AppMessage MsgChannelPrivacy) (Privacy -> Maybe Privacy forall a. a -> Maybe a Just Privacy Public)