{-# 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 :: URI -> Msg -> Maybe Action -> URI
mkAuthUrl URI
origURI Msg
challenge Maybe Action
maybeAction =
    URI -> Query -> URI
addQueryParams
        URI
origURI
        (Query -> URI) -> Query -> URI
forall a b. (a -> b) -> a -> b
$ (ByteString
"k1", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
hexChallenge) (ByteString, Maybe ByteString) -> Query -> Query
forall a. a -> [a] -> [a]
: Query -> (Action -> Query) -> Maybe Action -> Query
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Query
forall a. Monoid a => a
mempty ((ByteString, Maybe ByteString) -> Query
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((ByteString, Maybe ByteString) -> Query)
-> (Action -> (ByteString, Maybe ByteString)) -> Action -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> (ByteString, Maybe ByteString)
forall a. IsString a => Action -> (a, Maybe ByteString)
mkActionParam) Maybe Action
maybeAction
  where
    hexChallenge :: ByteString
hexChallenge = ByteString -> ByteString
encodeBase16' (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Msg -> ByteString
getMsg Msg
challenge
    mkActionParam :: Action -> (a, Maybe ByteString)
mkActionParam Action
theAction =
        ( a
"action"
        , (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Action -> ByteString) -> Action -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (Action -> Text) -> Action -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Action -> Text
actionText) Action
theAction
        )

data Action
    = Register
    | Login
    | Link
    | Auth
    deriving (Action -> Action -> Bool
(Action -> Action -> Bool)
-> (Action -> Action -> Bool) -> Eq Action
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Action -> Action -> Bool
$c/= :: Action -> Action -> Bool
== :: Action -> Action -> Bool
$c== :: Action -> Action -> Bool
Eq, Int -> Action -> ShowS
[Action] -> ShowS
Action -> String
(Int -> Action -> ShowS)
-> (Action -> String) -> ([Action] -> ShowS) -> Show Action
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Action] -> ShowS
$cshowList :: [Action] -> ShowS
show :: Action -> String
$cshow :: Action -> String
showsPrec :: Int -> Action -> ShowS
$cshowsPrec :: Int -> Action -> ShowS
Show)

actionText :: Action -> Text
actionText :: Action -> Text
actionText = \case
    Action
Register -> Text
"register"
    Action
Login -> Text
"login"
    Action
Link -> Text
"link"
    Action
Auth -> Text
"auth"

data AuthUrl = AuthUrl
    { AuthUrl -> URI
uri :: URI
    , AuthUrl -> Msg
k1 :: Msg
    , AuthUrl -> Maybe Action
action :: Maybe Action
    }
    deriving (AuthUrl -> AuthUrl -> Bool
(AuthUrl -> AuthUrl -> Bool)
-> (AuthUrl -> AuthUrl -> Bool) -> Eq AuthUrl
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AuthUrl -> AuthUrl -> Bool
$c/= :: AuthUrl -> AuthUrl -> Bool
== :: AuthUrl -> AuthUrl -> Bool
$c== :: AuthUrl -> AuthUrl -> Bool
Eq, Int -> AuthUrl -> ShowS
[AuthUrl] -> ShowS
AuthUrl -> String
(Int -> AuthUrl -> ShowS)
-> (AuthUrl -> String) -> ([AuthUrl] -> ShowS) -> Show AuthUrl
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AuthUrl] -> ShowS
$cshowList :: [AuthUrl] -> ShowS
show :: AuthUrl -> String
$cshow :: AuthUrl -> String
showsPrec :: Int -> AuthUrl -> ShowS
$cshowsPrec :: Int -> AuthUrl -> ShowS
Show)

authDomain :: AuthUrl -> String
authDomain :: AuthUrl -> String
authDomain = String -> (URIAuth -> String) -> Maybe URIAuth -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
forall a. Monoid a => a
mempty URIAuth -> String
uriRegName (Maybe URIAuth -> String)
-> (AuthUrl -> Maybe URIAuth) -> AuthUrl -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Maybe URIAuth
uriAuthority (URI -> Maybe URIAuth)
-> (AuthUrl -> URI) -> AuthUrl -> Maybe URIAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthUrl -> URI
uri

-- | Attempt to interpret a URL as an LNURL-auth URL
parseAuthUrl :: String -> Maybe AuthUrl
parseAuthUrl :: String -> Maybe AuthUrl
parseAuthUrl = String -> Maybe URI
parseURI (String -> Maybe URI)
-> (URI -> Maybe AuthUrl) -> String -> Maybe AuthUrl
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> URI -> Maybe AuthUrl
onURI
  where
    onURI :: URI -> Maybe AuthUrl
onURI URI
uri = do
        let q :: Query
q = ByteString -> Query
parseQuery (ByteString -> Query) -> (String -> ByteString) -> String -> Query
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (String -> Text) -> String -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Query) -> String -> Query
forall a b. (a -> b) -> a -> b
$ URI -> String
uriQuery URI
uri
        Msg
k1 <- (Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ByteString) -> Maybe ByteString)
-> (Query -> Maybe (Maybe ByteString)) -> Query -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Query -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"k1") Query
q Maybe ByteString
-> (ByteString -> Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Either Text ByteString -> Maybe ByteString
forall a b. Either a b -> Maybe b
eitherToMaybe (Either Text ByteString -> Maybe ByteString)
-> (ByteString -> Either Text ByteString)
-> ByteString
-> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either Text ByteString
decodeBase16 Maybe ByteString -> (ByteString -> Maybe Msg) -> Maybe Msg
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ByteString -> Maybe Msg
msg
        Maybe Action
action <-
            Maybe (Maybe Action)
-> (ByteString -> Maybe (Maybe Action))
-> Maybe ByteString
-> Maybe (Maybe Action)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
                (Maybe Action -> Maybe (Maybe Action)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Action
forall a. Maybe a
Nothing)
                ((Action -> Maybe Action) -> Maybe Action -> Maybe (Maybe Action)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Action -> Maybe Action
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Action -> Maybe (Maybe Action))
-> (ByteString -> Maybe Action)
-> ByteString
-> Maybe (Maybe Action)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Maybe Action
parseAction (Text -> Maybe Action)
-> (ByteString -> Text) -> ByteString -> Maybe Action
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
decodeUtf8)
                (Maybe ByteString -> Maybe (Maybe Action))
-> Maybe ByteString -> Maybe (Maybe Action)
forall a b. (a -> b) -> a -> b
$ (Maybe (Maybe ByteString) -> Maybe ByteString
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe ByteString) -> Maybe ByteString)
-> (Query -> Maybe (Maybe ByteString)) -> Query -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Query -> Maybe (Maybe ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup ByteString
"action") Query
q
        AuthUrl -> Maybe AuthUrl
forall (f :: * -> *) a. Applicative f => a -> f a
pure AuthUrl :: URI -> Msg -> Maybe Action -> AuthUrl
AuthUrl{URI
uri :: URI
uri :: URI
uri, Msg
k1 :: Msg
k1 :: Msg
k1, Maybe Action
action :: Maybe Action
action :: Maybe Action
action}

parseAction :: Text -> Maybe Action
parseAction :: Text -> Maybe Action
parseAction = \case
    Text
"register" -> Action -> Maybe Action
forall (f :: * -> *) a. Applicative f => a -> f a
pure Action
Register
    Text
"login" -> Action -> Maybe Action
forall (f :: * -> *) a. Applicative f => a -> f a
pure Action
Login
    Text
"link" -> Action -> Maybe Action
forall (f :: * -> *) a. Applicative f => a -> f a
pure Action
Link
    Text
"auth" -> Action -> Maybe Action
forall (f :: * -> *) a. Applicative f => a -> f a
pure Action
Auth
    Text
_ -> Maybe Action
forall a. Maybe a
Nothing

-- LNURL-auth uses a fixed path for the hashing key
hashingPath :: DerivPath
hashingPath :: DerivPath
hashingPath = DerivPath
forall t. DerivPathI t
Deriv DerivPath -> KeyIndex -> DerivPath
forall t. HardOrAny t => DerivPathI t -> KeyIndex -> DerivPathI t
:| KeyIndex
138 DerivPath -> KeyIndex -> DerivPath
forall t. AnyOrSoft t => DerivPathI t -> KeyIndex -> DerivPathI t
:/ KeyIndex
0

-- Key used to calculate the key path for a domain
hashingKey :: XPrvKey -> SecKey
hashingKey :: XPrvKey -> SecKey
hashingKey = XPrvKey -> SecKey
xPrvKey (XPrvKey -> SecKey) -> (XPrvKey -> XPrvKey) -> XPrvKey -> SecKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DerivPath -> XPrvKey -> XPrvKey
forall t. DerivPathI t -> XPrvKey -> XPrvKey
derivePath DerivPath
hashingPath

-- | Derive the linking key from the domain
deriveLinkingKey ::
    XPrvKey ->
    -- | domain
    ByteString ->
    SecKey
deriveLinkingKey :: XPrvKey -> ByteString -> SecKey
deriveLinkingKey XPrvKey
prv ByteString
domain = XPrvKey -> SecKey
xPrvKey (XPrvKey -> SecKey) -> XPrvKey -> SecKey
forall a b. (a -> b) -> a -> b
$ DerivPath -> XPrvKey -> XPrvKey
forall t. DerivPathI t -> XPrvKey -> XPrvKey
derivePath DerivPath
linkingPath XPrvKey
prv
  where
    linkingPath, linkingPathPrefix :: DerivPath
    linkingPathPrefix :: DerivPath
linkingPathPrefix = DerivPath
forall t. DerivPathI t
Deriv DerivPath -> KeyIndex -> DerivPath
forall t. HardOrAny t => DerivPathI t -> KeyIndex -> DerivPathI t
:| KeyIndex
138
    Right DerivPath
linkingPath =
        ([KeyIndex] -> DerivPath)
-> Either String [KeyIndex] -> Either String DerivPath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((DerivPath
linkingPathPrefix DerivPath -> DerivPath -> DerivPath
forall t1 t2. DerivPathI t1 -> DerivPathI t2 -> DerivPath
++/) (DerivPath -> DerivPath)
-> ([KeyIndex] -> DerivPath) -> [KeyIndex] -> DerivPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [KeyIndex] -> DerivPath
listToPath ([KeyIndex] -> DerivPath)
-> ([KeyIndex] -> [KeyIndex]) -> [KeyIndex] -> DerivPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> [KeyIndex] -> [KeyIndex]
forall a. Int -> [a] -> [a]
take Int
4)
            (Either String [KeyIndex] -> Either String DerivPath)
-> (HMAC SHA256 -> Either String [KeyIndex])
-> HMAC SHA256
-> Either String DerivPath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get [KeyIndex] -> ByteString -> Either String [KeyIndex]
forall a. Get a -> ByteString -> Either String a
runGet (Int -> Get KeyIndex -> Get [KeyIndex]
forall (m :: * -> *) a. Applicative m => Int -> m a -> m [a]
replicateM Int
4 Get KeyIndex
getWord32be)
            (ByteString -> Either String [KeyIndex])
-> (HMAC SHA256 -> ByteString)
-> HMAC SHA256
-> Either String [KeyIndex]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
BS.take Int
16
            (ByteString -> ByteString)
-> (HMAC SHA256 -> ByteString) -> HMAC SHA256 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall bout.
(ByteArrayAccess (HMAC SHA256), ByteArray bout) =>
HMAC SHA256 -> bout
forall bin bout.
(ByteArrayAccess bin, ByteArray bout) =>
bin -> bout
convert @(HMAC SHA256)
            (HMAC SHA256 -> Either String DerivPath)
-> HMAC SHA256 -> Either String DerivPath
forall a b. (a -> b) -> a -> b
$ (ByteString -> ByteString -> HMAC SHA256
forall key message a.
(ByteArrayAccess key, ByteArrayAccess message, HashAlgorithm a) =>
key -> message -> HMAC a
hmac (ByteString -> ByteString -> HMAC SHA256)
-> (SecKey -> ByteString) -> SecKey -> ByteString -> HMAC SHA256
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecKey -> ByteString
getSecKey) (XPrvKey -> SecKey
hashingKey XPrvKey
prv) ByteString
domain

-- | Derive a public signing key
deriveLinkingPubKey ::
    XPrvKey ->
    -- | domain
    ByteString ->
    PubKey
deriveLinkingPubKey :: XPrvKey -> ByteString -> PubKey
deriveLinkingPubKey XPrvKey
prv = SecKey -> PubKey
derivePubKey (SecKey -> PubKey)
-> (ByteString -> SecKey) -> ByteString -> PubKey
forall b c a. (b -> c) -> (a -> b) -> a -> c
. XPrvKey -> ByteString -> SecKey
deriveLinkingKey XPrvKey
prv

-- | Use the linking key to sign a challenge
getSignedCallback ::
    -- | Root key
    XPrvKey ->
    AuthUrl ->
    -- | Callback url with client-provided LNURL-auth paramaters
    URI
getSignedCallback :: XPrvKey -> AuthUrl -> URI
getSignedCallback XPrvKey
prv AuthUrl
authUrl =
    URI -> Query -> URI
addQueryParams
        (AuthUrl -> URI
uri AuthUrl
authUrl)
        [ (ByteString
"sig", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> ByteString
encodeBase16' ByteString
sig))
        , (ByteString
"key", ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> ByteString
encodeBase16' ByteString
linkingKey))
        ]
  where
    Just ByteString
domain = AuthUrl -> Maybe ByteString
getDomain AuthUrl
authUrl
    linkingPrvKey :: SecKey
linkingPrvKey = XPrvKey -> ByteString -> SecKey
deriveLinkingKey XPrvKey
prv ByteString
domain
    linkingKey :: ByteString
linkingKey = (Bool -> PubKey -> ByteString
exportPubKey Bool
True (PubKey -> ByteString)
-> (SecKey -> PubKey) -> SecKey -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecKey -> PubKey
derivePubKey) SecKey
linkingPrvKey
    sig :: ByteString
sig = (Sig -> ByteString
exportSig (Sig -> ByteString) -> (AuthUrl -> Sig) -> AuthUrl -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SecKey -> Msg -> Sig
signMsg SecKey
linkingPrvKey (Msg -> Sig) -> (AuthUrl -> Msg) -> AuthUrl -> Sig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthUrl -> Msg
k1) AuthUrl
authUrl

getDomain :: AuthUrl -> Maybe ByteString
getDomain :: AuthUrl -> Maybe ByteString
getDomain = (URIAuth -> ByteString) -> Maybe URIAuth -> Maybe ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> (URIAuth -> Text) -> URIAuth -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
Text.pack (String -> Text) -> (URIAuth -> String) -> URIAuth -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URIAuth -> String
uriRegName) (Maybe URIAuth -> Maybe ByteString)
-> (AuthUrl -> Maybe URIAuth) -> AuthUrl -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> Maybe URIAuth
uriAuthority (URI -> Maybe URIAuth)
-> (AuthUrl -> URI) -> AuthUrl -> Maybe URIAuth
forall b c a. (b -> c) -> (a -> b) -> a -> c
. AuthUrl -> URI
uri