{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module LnUrl.Auth (
mkAuthUrl,
parseAuthUrl,
authDomain,
getSignedCallback,
AuthUrl (..),
Action (..),
actionText,
parseAction,
AckResponse (..),
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)
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
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
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
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
deriveLinkingKey ::
XPrvKey ->
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
deriveLinkingPubKey ::
XPrvKey ->
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
getSignedCallback ::
XPrvKey ->
AuthUrl ->
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