diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for lnurl + +## 0.1.0.0 -- 2021-07-29 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/lnurl.cabal b/lnurl.cabal new file mode 100644 --- /dev/null +++ b/lnurl.cabal @@ -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 diff --git a/src/LnUrl.hs b/src/LnUrl.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl.hs @@ -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 + ] diff --git a/src/LnUrl/Auth.hs b/src/LnUrl/Auth.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl/Auth.hs @@ -0,0 +1,189 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- | + Module: LnUrl.Auth + + See . + + == 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 diff --git a/src/LnUrl/Channel.hs b/src/LnUrl/Channel.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl/Channel.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} + +{- | + Module: LnUrl.Channel + + See . + + == 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") + ] diff --git a/src/LnUrl/Pay.hs b/src/LnUrl/Pay.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl/Pay.hs @@ -0,0 +1,360 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +{- | +Module: LnUrl.Pay + +See . + +== 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 diff --git a/src/LnUrl/Utils.hs b/src/LnUrl/Utils.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl/Utils.hs @@ -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 diff --git a/src/LnUrl/Withdraw.hs b/src/LnUrl/Withdraw.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl/Withdraw.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +{- | +Module: LnUrl.Withdraw + +See . + +== 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 + ] diff --git a/src/Network/URI/Utils.hs b/src/Network/URI/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Utils.hs @@ -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))