packages feed

lnurl (empty) → 0.1.0.0

raw patch · 10 files changed

+989/−0 lines, 10 filesdep +aesondep +basedep +base16

Dependencies added: aeson, base, base16, base64, bytestring, cereal, cryptonite, extra, haskoin-core, http-types, memory, network-uri, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for lnurl++## 0.1.0.0 -- 2021-07-29 ++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2021, Ian Shipman++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Ian Shipman nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ lnurl.cabal view
@@ -0,0 +1,56 @@+cabal-version: 2.4+name: lnurl+synopsis: Support for developing against the LNURL protocol+description: See https://github.com/GambolingPangolin/lnurl/blob/master/lnurl/README.md+version: 0.1.0.0+license: BSD-3-Clause+license-file: LICENSE+author: Ian Shipman+maintainer: ics@gambolingpangolin.com+homepage: https://github.com/GambolingPangolin/lnurl+bug-reports: https://github.com/GambolingPangolin/lnurl/issues+extra-source-files: CHANGELOG.md++source-repository head+    type: git+    location: https://github.com/GambolingPangolin/lnurl.git++library+    default-language: Haskell2010+    hs-source-dirs: src+    ghc-options:+        -Wall+        -Wunused-packages+        -Wmissing-home-modules+        -Widentities+        -Wincomplete-uni-patterns+        -Wincomplete-record-updates+        -Wpartial-fields+        -Wmissing-export-lists+        -fno-warn-unused-do-bind++    exposed-modules:+        LnUrl.Auth+        LnUrl.Channel+        LnUrl.Pay+        LnUrl.Withdraw++    other-modules:+        LnUrl+        LnUrl.Utils+        Network.URI.Utils++    build-depends:+          aeson ^>=1.5+        , base >=4.14 && <4.15+        , base16 ^>=0.3+        , base64 ^>=0.4+        , bytestring >=0.10 && <0.12+        , cereal ^>=0.5+        , cryptonite ^>=0.29+        , extra ^>=1.7+        , haskoin-core ^>=0.20+        , http-types ^>=0.12+        , memory ^>=0.16+        , network-uri >=2.6 && <2.8+        , text ^>=1.2
+ src/LnUrl.hs view
@@ -0,0 +1,68 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++module LnUrl (+    Response (..),+    AckResponse (..),+    NodeId,+) where++import Data.Aeson (+    FromJSON,+    ToJSON,+    object,+    parseJSON,+    toJSON,+    withObject,+    (.:),+    (.:?),+    (.=),+ )+import Data.ByteString (ByteString)+import Data.Text (Text)+import qualified Data.Text as Text++data AckResponse+    = AckSuccess+    | AckError Text+    deriving (Eq, Show)++instance FromJSON AckResponse where+    parseJSON = withObject "AckResponse" $ \obj ->+        obj .: "status" >>= \case+            "OK" -> pure AckSuccess+            "ERROR" -> AckError <$> obj .: "reason"+            other -> fail $ "Unknown status: " <> other++instance ToJSON AckResponse where+    toJSON = \case+        AckSuccess ->+            object ["status" .= ("OK" :: Text)]+        AckError msg ->+            object+                [ "status" .= ("ERROR" :: Text)+                , "reason" .= msg+                ]++type NodeId = ByteString++data Response a = Success a | ErrorResponse Text+    deriving (Eq, Show)++instance FromJSON a => FromJSON (Response a) where+    parseJSON v = withObject "ResponseContainer" inspect v+      where+        inspect obj =+            obj .:? "status" >>= \case+                Just "ERROR" -> ErrorResponse <$> obj .: "reason"+                Just other -> fail $ "Unknown status: " <> Text.unpack other+                Nothing -> Success <$> parseJSON v++instance ToJSON a => ToJSON (Response a) where+    toJSON = \case+        Success x -> toJSON x+        ErrorResponse reason ->+            object+                [ "status" .= ("ERROR" :: Text)+                , "reason" .= reason+                ]
+ src/LnUrl/Auth.hs view
@@ -0,0 +1,189 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{- |+ Module: LnUrl.Auth++ See <https://github.com/fiatjaf/lnurl-rfc/blob/master/lnurl-auth.md>.++ == Workflow++ 1. @LN SERVICE@ Use 'mkAuthUrl' to generate.+ 2. @LN WALLET@ Decode @LNURL@ and parse with 'parseAuthUrl'.+ 3. @LN WALLET@ Display 'AuthUrl' details and get consent from user to authorize.+ 4. @LN WALLET@ Use 'getSignedCallback' to prepare follow-up @GET@ request+ 5. @LN SERVICE@ Responds with 'AckResponse'.+-}+module LnUrl.Auth (+    -- * Server+    mkAuthUrl,++    -- * Client+    parseAuthUrl,+    authDomain,+    getSignedCallback,++    -- * Types+    AuthUrl (..),+    Action (..),+    actionText,+    parseAction,+    AckResponse (..),++    -- * Utilities+    deriveLinkingKey,+    deriveLinkingPubKey,+) where++import Control.Monad (join, replicateM, (>=>))+import Crypto.Hash (SHA256)+import Crypto.MAC.HMAC (HMAC, hmac)+import Data.ByteArray (convert)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Base16 (decodeBase16, encodeBase16')+import Data.Either.Extra (eitherToMaybe)+import Data.Serialize (getWord32be, runGet)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Haskoin (+    DerivPath,+    DerivPathI (..),+    Msg,+    PubKey,+    SecKey,+    XPrvKey,+    derivePath,+    derivePubKey,+    exportPubKey,+    exportSig,+    getMsg,+    getSecKey,+    listToPath,+    msg,+    signMsg,+    xPrvKey,+    (++/),+ )+import LnUrl (AckResponse (..))+import Network.HTTP.Types (parseQuery)+import Network.URI (URI, parseURI, uriAuthority, uriQuery, uriRegName)+import Network.URI.Utils (addQueryParams)++-- | Add the challenge and action parameters to a URI+mkAuthUrl :: URI -> Msg -> Maybe Action -> URI+mkAuthUrl origURI challenge maybeAction =+    addQueryParams+        origURI+        $ ("k1", Just hexChallenge) : maybe mempty (pure . mkActionParam) maybeAction+  where+    hexChallenge = encodeBase16' $ getMsg challenge+    mkActionParam theAction =+        ( "action"+        , (Just . encodeUtf8 . actionText) theAction+        )++data Action+    = Register+    | Login+    | Link+    | Auth+    deriving (Eq, Show)++actionText :: Action -> Text+actionText = \case+    Register -> "register"+    Login -> "login"+    Link -> "link"+    Auth -> "auth"++data AuthUrl = AuthUrl+    { uri :: URI+    , k1 :: Msg+    , action :: Maybe Action+    }+    deriving (Eq, Show)++authDomain :: AuthUrl -> String+authDomain = maybe mempty uriRegName . uriAuthority . uri++-- | Attempt to interpret a URL as an LNURL-auth URL+parseAuthUrl :: String -> Maybe AuthUrl+parseAuthUrl = parseURI >=> onURI+  where+    onURI uri = do+        let q = parseQuery . encodeUtf8 . Text.pack $ uriQuery uri+        k1 <- (join . lookup "k1") q >>= eitherToMaybe . decodeBase16 >>= msg+        action <-+            maybe+                (pure Nothing)+                (fmap pure . parseAction . decodeUtf8)+                $ (join . lookup "action") q+        pure AuthUrl{uri, k1, action}++parseAction :: Text -> Maybe Action+parseAction = \case+    "register" -> pure Register+    "login" -> pure Login+    "link" -> pure Link+    "auth" -> pure Auth+    _ -> Nothing++-- LNURL-auth uses a fixed path for the hashing key+hashingPath :: DerivPath+hashingPath = Deriv :| 138 :/ 0++-- Key used to calculate the key path for a domain+hashingKey :: XPrvKey -> SecKey+hashingKey = xPrvKey . derivePath hashingPath++-- | Derive the linking key from the domain+deriveLinkingKey ::+    XPrvKey ->+    -- | domain+    ByteString ->+    SecKey+deriveLinkingKey prv domain = xPrvKey $ derivePath linkingPath prv+  where+    linkingPath, linkingPathPrefix :: DerivPath+    linkingPathPrefix = Deriv :| 138+    Right linkingPath =+        fmap ((linkingPathPrefix ++/) . listToPath . take 4)+            . runGet (replicateM 4 getWord32be)+            . BS.take 16+            . convert @(HMAC SHA256)+            $ (hmac . getSecKey) (hashingKey prv) domain++-- | Derive a public signing key+deriveLinkingPubKey ::+    XPrvKey ->+    -- | domain+    ByteString ->+    PubKey+deriveLinkingPubKey prv = derivePubKey . deriveLinkingKey prv++-- | Use the linking key to sign a challenge+getSignedCallback ::+    -- | Root key+    XPrvKey ->+    AuthUrl ->+    -- | Callback url with client-provided LNURL-auth paramaters+    URI+getSignedCallback prv authUrl =+    addQueryParams+        (uri authUrl)+        [ ("sig", Just (encodeBase16' sig))+        , ("key", Just (encodeBase16' linkingKey))+        ]+  where+    Just domain = getDomain authUrl+    linkingPrvKey = deriveLinkingKey prv domain+    linkingKey = (exportPubKey True . derivePubKey) linkingPrvKey+    sig = (exportSig . signMsg linkingPrvKey . k1) authUrl++getDomain :: AuthUrl -> Maybe ByteString+getDomain = fmap (encodeUtf8 . Text.pack . uriRegName) . uriAuthority . uri
+ src/LnUrl/Channel.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}++{- |+ Module: LnUrl.Channel++ See <https://github.com/fiatjaf/lnurl-rfc/blob/master/lnurl-channel.md>.++ == Workflow++ 1. @LN SERVICE@ provides a URL for @LNURL-channel@.+ 2. @LN WALLET@ makes a @GET@ request to this URL.+ 3. @LN SERVICE@ responds with 'Response' 'SuccessResponse'.+ 4. @LN WALLET@ connects to the node at 'remoteNode'.+ 5. @LN WALLET@ prepare and make a @GET@ request using 'proceed' (followed+    possibly by 'cancel').+ 6. @LN SERVICE@ responds with 'AckResponse'.+ 7. @LN WALLET@ awaits an @OpenChannel@ message.+-}+module LnUrl.Channel (+    -- * Client+    proceed,+    cancel,++    -- * Types+    NodeId,+    SuccessResponse (..),+    Response (..),+    AckResponse (..),+) where++import Data.Aeson (+    FromJSON,+    ToJSON,+    object,+    parseJSON,+    toJSON,+    withObject,+    (.:),+    (.=),+ )+import Data.Bool (bool)+import Data.ByteString (ByteString)+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import LnUrl (AckResponse (..), NodeId, Response (..))+import LnUrl.Utils (Base16 (..), JsonURI (..), getBase16)+import Network.URI (URI)+import Network.URI.Utils (addQueryParams)++-- | @LN SERVICE@ responds with 'Response' 'SuccessResponse'+data SuccessResponse = SuccessResponse+    { -- | Remote node URI+      remoteNode :: ByteString+    , -- | Service URL+      callback :: URI+    , -- | Wallet identifier+      k1 :: ByteString+    }+    deriving (Eq, Show)++instance FromJSON SuccessResponse where+    parseJSON = withObject "SuccessResponse" $ \obj ->+        obj .: "tag" >>= \case+            "channelRequest" ->+                SuccessResponse+                    <$> (encodeUtf8 <$> obj .: "uri")+                    <*> (getJsonURI <$> obj .: "callback")+                    <*> (getBase16 <$> obj .: "k1")+            tag -> fail $ "Unknown tag: " <> tag++instance ToJSON SuccessResponse where+    toJSON success =+        object+            [ "uri" .= (decodeUtf8 . remoteNode) success+            , "callback" .= (show . callback) success+            , "k1" .= Base16 (k1 success)+            ]++{- | Create the URL for the follow up LNURL-channel request. @LN SERVICE@+ responds with 'AckResponse'.+-}+proceed :: SuccessResponse -> NodeId -> Bool -> URI+proceed payload theRemoteNode isPrivate =+    addQueryParams+        (callback payload)+        [ ("k1", Just $ k1 payload)+        , ("remoteid", Just theRemoteNode)+        , ("private", Just $ bool "0" "1" isPrivate)+        ]++{- | Create the URL to cancel a LNURL-channel request. @LN SERVICE@ responds+ with 'AckResponse'.+-}+cancel :: SuccessResponse -> NodeId -> URI+cancel payload theRemoteNode =+    addQueryParams+        (callback payload)+        [ ("k1", Just $ k1 payload)+        , ("remoteid", Just theRemoteNode)+        , ("cancel", Just "1")+        ]
+ src/LnUrl/Pay.hs view
@@ -0,0 +1,360 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++{- |+Module: LnUrl.Pay++See <https://github.com/fiatjaf/lnurl-rfc/blob/master/lnurl-pay.md>.++== Workflow++1. @LN WALLET@ decodes URL using 'getPayURL' and makes a @GET@ request.+2. @LN SERVICE@ responds with 'Response' 'SuccessResponse'.+3. @LN WALLET@ get parameters from the user.+4. @LN WALLET@ prepare a callback URL using 'getCallbackUrl'.+5. @LN SERVICE@ responds with 'Response' 'CallbackSuccessResponse'.+6. @LN WALLET@ verifies: (a) @h@ tag in 'paymentRequest' is @SHA256(metadata)@,+   (b) the amount in 'paymentRequest' matches the requested amount, and (c)+   signatures on @ChannelUpdate@ messages.+7. @LN WALLET@ pays invoice.+8. @LN WALLET@ after paying the invoice, execute the 'successAction' if defined.+-}+module LnUrl.Pay (+    -- * Client+    getPayURL,+    getCallbackUrl,+    decrypt,++    -- * Server+    encrypt,++    -- * Types+    Response (..),+    SuccessResponse (..),+    Metadata (..),+    CallbackSuccessResponse (..),+    Hop (..),+    SuccessAction (..),+    UrlAction (..),+    AesAction (..),+    AesError (..),+) where++import Control.Exception (Exception)+import Control.Monad (unless)+import Crypto.Cipher.AES (AES256)+import Crypto.Cipher.Types (cbcDecrypt, cbcEncrypt, makeIV)+import qualified Crypto.Cipher.Types as Crypto+import Crypto.Data.Padding (Format (PKCS7), pad, unpad)+import Crypto.Error (eitherCryptoError)+import Crypto.Random (getRandomBytes)+import Data.Aeson (+    FromJSON,+    ToJSON,+    Value (String),+    object,+    parseJSON,+    toJSON,+    withArray,+    withObject,+    (.:),+    (.:?),+    (.=),+ )+import qualified Data.Aeson as Ae+import Data.Bifunctor (first)+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Base16 (encodeBase16')+import Data.ByteString.Base64 (decodeBase64, encodeBase64)+import qualified Data.ByteString.Char8 as BS8+import Data.Foldable (toList)+import Data.Functor ((<&>))+import Data.Maybe (catMaybes, fromMaybe)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text.Lazy.Encoding as TL+import Data.Word (Word64)+import Haskoin (PubKey, exportPubKey)+import LnUrl (NodeId, Response (..))+import LnUrl.Utils (Base64 (..), JsonURI (..), (.=?))+import Network.URI (URI (..), parseURI, uriRegName, uriUserInfo)+import Network.URI.Utils (addQueryParams, param)++-- | Apply the LNURL-pay uri transform logic.  @LN SERVICE@ should respond to the resulting URL with 'Response'.+getPayURL :: URI -> URI+getPayURL theURI+    | Just userInfo <- uriUserInfo <$> uriAuthority theURI =+        theURI+            { uriScheme = if isOnion then "http:" else "https:"+            , uriAuthority = stompUserInfo <$> uriAuthority theURI+            , uriPath = "/.well-known/lnurlp/" <> takeWhile (`notElem` specialChars) userInfo+            , uriFragment = mempty+            }+    | otherwise = theURI+  where+    isOnion = drop (length domain - 6) domain == ".onion"+    Just domain = uriRegName <$> uriAuthority theURI+    stompUserInfo uriAuth = uriAuth{uriUserInfo = mempty}+    specialChars = [':', '@']++instance FromJSON SuccessResponse where+    parseJSON = withObject "LNURL-pay Response" $ \obj -> do+        tag <- obj .: "tag"+        unless (tag == ("payRequest" :: Text)) $ fail "Must have payRequest tag"+        SuccessResponse+            <$> (getJsonURI <$> obj .: "callback")+            <*> obj .: "maxSendable"+            <*> obj .: "minSendable"+            <*> (obj .: "metadata" >>= either fail pure . Ae.eitherDecode . TL.encodeUtf8)+            <*> obj .:? "commentAllowed"++instance ToJSON SuccessResponse where+    toJSON response =+        object $+            [ "callback" .= (JsonURI . callback) response+            , "maxSendable" .= maxSendable response+            , "minSendable" .= minSendable response+            , "metadata" .= (TL.decodeUtf8 . Ae.encode . metadata) response+            ]+                <> catMaybes ["commentAllowed" .=? commentAllowed response]++data SuccessResponse = SuccessResponse+    { callback :: URI+    , -- | millisatoshi+      maxSendable :: Word64+    , -- | millisatoshi+      minSendable :: Word64+    , metadata :: [Metadata]+    , commentAllowed :: Maybe Int+    }+    deriving (Eq, Show)++{- | The metadata array++ * Must contain a 'PlainText' value+ * May contain at most one of 'ImagePNG' or 'ImageJPEG'+ * May contain at most one of 'Email' or 'Ident'+-}+data Metadata+    = PlainText Text+    | ImagePNG ByteString+    | ImageJPEG ByteString+    | Email Text+    | Ident Text+    deriving (Eq, Show)++instance FromJSON Metadata where+    parseJSON = withArray "Metadata" $ parseTuple . toList+      where+        parseTuple = \case+            [String mimeType, String val] -> case mimeType of+                "text/plain" -> pure $ PlainText val+                "text/email" -> pure $ Email val+                "text/identifier" -> pure $ Ident val+                "image/png;base64" ->+                    either (fail . Text.unpack) (pure . ImagePNG)+                        . decodeBase64+                        $ encodeUtf8 val+                "image/jpeg;base64" ->+                    either (fail . Text.unpack) (pure . ImageJPEG)+                        . decodeBase64+                        $ encodeUtf8 val+                other -> fail $ "Unknown mimetype: " <> Text.unpack other+            _ -> fail "Expected tuple"++instance ToJSON Metadata where+    toJSON =+        \case+            PlainText x -> tuple "text/plain" x+            ImagePNG x -> tuple "image/png;base64" (encodeBase64 x)+            ImageJPEG x -> tuple "image/jpeg;base64" (encodeBase64 x)+            Email x -> tuple "text/email" x+            Ident x -> tuple "text/identifier" x+      where+        tuple :: Text -> Text -> Value+        tuple = curry toJSON++-- | Prepare a callback url to use to retrieve the payment request+getCallbackUrl ::+    SuccessResponse ->+    -- | amount (millisatoshis)+    Word64 ->+    -- | cache prevention+    Maybe ByteString ->+    -- | starting points (node ids)+    [NodeId] ->+    -- | comment+    Maybe Text ->+    -- | proof of payer+    Maybe PubKey ->+    Maybe URI+getCallbackUrl response amount maybeNonce fromNodes maybeComment maybeProofOfPayer+    | commentLengthOk = Just $ addQueryParams (callback response) params+    | otherwise = Nothing+  where+    commentLengthOk = fromMaybe True $ checkComment <$> commentAllowed response <*> maybeComment+    checkComment commentSizeBound = (<= commentSizeBound) . Text.length++    params =+        catMaybes+            [ Just $ param "amount" (BS8.pack . show) amount+            , param "nonce" encodeBase16' <$> maybeNonce+            , if null fromNodes+                then mempty+                else Just $ param "fromnodes" toNodeList fromNodes+            , param "comment" encodeUtf8 <$> maybeComment+            , param "proofofpayer" (exportPubKey True) <$> maybeProofOfPayer+            ]+    toNodeList = BS.intercalate ","++data CallbackSuccessResponse = CallbackSuccessResponse+    { paymentRequest :: Text+    , successAction :: Maybe SuccessAction+    , disposable :: Bool+    , routes :: [[Hop]]+    }+    deriving (Eq, Show)++instance FromJSON CallbackSuccessResponse where+    parseJSON = withObject "CallbackSuccessResponse" $ \obj ->+        CallbackSuccessResponse+            <$> obj .: "pr"+            <*> obj .:? "successAction"+            <*> (fromMaybe True <$> obj .:? "disposable")+            <*> obj .: "routes"++instance ToJSON CallbackSuccessResponse where+    toJSON successResponse =+        object+            [ "pr" .= paymentRequest successResponse+            , "successAction" .= successAction successResponse+            , "disposable" .= disposable successResponse+            , "routes" .= routes successResponse+            ]++data SuccessAction+    = Url UrlAction+    | Message Text+    | Aes AesAction+    deriving (Eq, Show)++instance FromJSON SuccessAction where+    parseJSON = withObject "SuccessAction" $ \obj ->+        obj .: "tag" >>= \case+            "url" ->+                fmap Url $+                    UrlAction+                        <$> obj .: "description"+                        <*> (obj .: "url" >>= maybe badUrl pure . parseURI)+            "message" -> Message <$> obj .: "message"+            "aes" ->+                fmap Aes $+                    AesAction+                        <$> obj .: "description"+                        <*> (getBase64 <$> obj .: "ciphertext")+                        <*> (getBase64 <$> obj .: "iv")+            other -> fail $ "Unknown tag: " <> Text.unpack other+      where+        badUrl = fail "Unable to parse url"++instance ToJSON SuccessAction where+    toJSON = \case+        Url urlAction ->+            object+                [ "tag" .= ("url" :: Text)+                , "description" .= urlDescription urlAction+                , "url" .= show (url urlAction)+                ]+        Message msg ->+            object+                [ "tag" .= ("message" :: Text)+                , "message" .= msg+                ]+        Aes aes ->+            object+                [ "tag" .= ("aes" :: Text)+                , "description" .= aesDescription aes+                , "ciphertext" .= (Base64 . ciphertext) aes+                , "iv" .= (Base64 . iv) aes+                ]++data UrlAction = UrlAction+    { urlDescription :: Text+    , url :: URI+    }+    deriving (Eq, Show)++data AesAction = AesAction+    { aesDescription :: Text+    , ciphertext :: ByteString+    , iv :: ByteString+    }+    deriving (Eq, Show)++data Hop = Hop+    { nodeId :: Text+    , channelUpdate :: ByteString+    }+    deriving (Eq, Show)++instance FromJSON Hop where+    parseJSON = withObject "Hop" $ \obj ->+        Hop+            <$> obj .: "nodeId"+            <*> (getBase64 <$> obj .: "channelUpdate")++instance ToJSON Hop where+    toJSON theRoute =+        object+            [ "nodeId" .= nodeId theRoute+            , "channelUpdate" .= (Base64 . channelUpdate) theRoute+            ]++-- | Use the payment preimage to build an encrypted payload+encrypt ::+    -- | Payment preimage+    ByteString ->+    -- | Description+    Text ->+    -- | Message to encrypt+    ByteString ->+    IO (Either AesError AesAction)+encrypt key aesDescription plaintext = do+    iv <- getRandomBytes 16+    let Just cryptoniteIV = makeIV iv+    pure $+        cipherInit key <&> \cipher ->+            AesAction+                { aesDescription+                , iv+                , ciphertext = cbcEncrypt cipher cryptoniteIV (pad paddingConfig plaintext)+                }++-- | Use the payment preimage to get the encrypted payload+decrypt ::+    -- | Payment preimage+    ByteString ->+    AesAction ->+    Either AesError ByteString+decrypt key aes = do+    cipher <- cipherInit key+    theIV <- maybe (Left IvError) Right $ makeIV (iv aes)+    maybe (Left PaddingError) pure+        . unpad paddingConfig+        $ cbcDecrypt cipher theIV (ciphertext aes)++cipherInit :: ByteString -> Either AesError AES256+cipherInit = first (const KeyError) . eitherCryptoError . Crypto.cipherInit @AES256++paddingConfig :: Format+paddingConfig = PKCS7 16++data AesError = KeyError | IvError | PaddingError+    deriving (Eq, Show)++instance Exception AesError
+ src/LnUrl/Utils.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE OverloadedStrings #-}++module LnUrl.Utils (+    Base16 (..),+    Base64 (..),+    JsonURI (..),+    (.=?),+) where++import Data.Aeson (+    FromJSON,+    ToJSON,+    Value,+    parseJSON,+    toJSON,+    withText,+    (.=),+ )+import Data.ByteString (ByteString)+import Data.ByteString.Base16 (decodeBase16, encodeBase16)+import Data.ByteString.Base64 (decodeBase64, encodeBase64)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)+import Network.URI (URI, parseURI)++newtype Base16 = Base16 {getBase16 :: ByteString}+    deriving (Eq, Show)++instance FromJSON Base16 where+    parseJSON =+        withText "Base16" $+            either (fail . Text.unpack) (pure . Base16)+                . decodeBase16+                . encodeUtf8++instance ToJSON Base16 where+    toJSON = toJSON . encodeBase16 . getBase16++newtype Base64 = Base64 {getBase64 :: ByteString}+    deriving (Eq, Show)++instance FromJSON Base64 where+    parseJSON =+        withText "Base64" $+            either (fail . Text.unpack) (pure . Base64)+                . decodeBase64+                . encodeUtf8++instance ToJSON Base64 where+    toJSON = toJSON . encodeBase64 . getBase64++newtype JsonURI = JsonURI {getJsonURI :: URI}+    deriving (Eq, Show)++instance FromJSON JsonURI where+    parseJSON = withText "JsonURI" $ maybe noParse (pure . JsonURI) . parseURI . Text.unpack+      where+        noParse = fail "Unable to parse URI"++instance ToJSON JsonURI where+    toJSON = toJSON . show . getJsonURI++(.=?) :: ToJSON a => Text -> Maybe a -> Maybe (Text, Value)+k .=? mv = (k .=) <$> mv
+ src/LnUrl/Withdraw.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE OverloadedStrings #-}++{- |+Module: LnUrl.Withdraw++See <https://github.com/fiatjaf/lnurl-rfc/blob/master/lnurl-withdraw.md>.++== Workflow++1. @LN WALLET@ makes @GET@ request+2. @LN SERVICE@ responds with 'Response' 'SuccessResponse'.+3. @LN WALLET@ get withdrawal amount from user.+4. @LN WALLET@ prepare and make @GET@ request using 'getCallbackURL'.+5. @LN SERVICE@ responds with 'AckResponse'.+-}+module LnUrl.Withdraw (+    -- * Client+    getCallbackURL,++    -- * Types+    Response (..),+    SuccessResponse (..),+    AckResponse (..),+) where++import Data.Aeson (+    FromJSON,+    ToJSON,+    object,+    parseJSON,+    toJSON,+    withObject,+    (.:),+    (.:?),+    (.=),+ )+import Data.Maybe (catMaybes)+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Text.Encoding (encodeUtf8)+import Data.Word (Word64)+import LnUrl (AckResponse (..), Response (..))+import LnUrl.Utils (JsonURI (..), (.=?))+import Network.URI (URI)+import Network.URI.Utils (addQueryParams, param)++-- | The initial GET request responds with 'Response' 'SuccessResponse'+data SuccessResponse = SuccessResponse+    { callback :: URI+    , challenge :: Text+    , defaultDescription :: Text+    , -- | millisatoshis+      minWithdrawable :: Word64+    , -- | millisatoshis+      maxWithdrawable :: Word64+    , -- | URL to use to make a subsequent LNURL-withdraw request, response with 'SuccessResponse'+      balanceCheck :: Maybe URI+    }+    deriving (Eq, Show)++instance FromJSON SuccessResponse where+    parseJSON = withObject "SuccessResponse" $ \obj ->+        SuccessResponse+            <$> (getJsonURI <$> obj .: "callback")+            <*> obj .: "k1"+            <*> obj .: "defaultDescription"+            <*> obj .: "minWithdrawable"+            <*> obj .: "maxWithdrawable"+            <*> (fmap getJsonURI <$> obj .:? "balanceCheck")++instance ToJSON SuccessResponse where+    toJSON response =+        object $+            [ "callback" .= (JsonURI . callback) response+            , "k1" .= challenge response+            , "defaultDescription" .= defaultDescription response+            , "minWithdrawable" .= minWithdrawable response+            , "maxWithdrawable" .= maxWithdrawable response+            ]+                <> catMaybes ["balanceCheck" .=? (JsonURI <$> balanceCheck response)]++-- | Use the first response to build the callback url+getCallbackURL ::+    SuccessResponse ->+    Text ->+    -- | URL where @LN SERVICE@ can POST 'SuccessResponse' values to notify the wallet+    Maybe URI ->+    URI+getCallbackURL response thePaymentRequest balanceNotifyURI =+    addQueryParams (callback response) $+        catMaybes+            [ Just $ param "k1" (encodeUtf8 . challenge) response+            , Just $ param "pr" encodeUtf8 thePaymentRequest+            , param "balanceNotify" (encodeUtf8 . Text.pack . show) <$> balanceNotifyURI+            ]
+ src/Network/URI/Utils.hs view
@@ -0,0 +1,20 @@+module Network.URI.Utils (+    addQueryParams,+    param,+) where++import Data.ByteString (ByteString)+import qualified Data.Text as Text+import Data.Text.Encoding (decodeUtf8, encodeUtf8)+import Network.HTTP.Types (Query, QueryItem, parseQuery, renderQuery)+import Network.URI (URI, uriQuery)++addQueryParams :: URI -> Query -> URI+addQueryParams uri extraQuery = uri{uriQuery = newQuery}+  where+    newQuery = Text.unpack . decodeUtf8 $ renderQuery True fullQuery+    fullQuery = extraQuery <> oldQuery+    oldQuery = (parseQuery . encodeUtf8 . Text.pack . uriQuery) uri++param :: ByteString -> (a -> ByteString) -> a -> QueryItem+param label f x = (label, Just (f x))