{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# OPTIONS_GHC -Wno-type-defaults #-}
module LnUrl.Authenticator (
handleInit,
handleAuth,
handleLog,
handleList,
AuthenticatorError (..),
) where
import Codec.Binary.Bech32 (DecodingError)
import qualified Codec.Binary.Bech32 as Bech32
import Control.Exception (Exception, throwIO)
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Crypto.Random (getRandomBytes)
import qualified Data.Aeson as Ae
import Data.Bifunctor (bimap)
import Data.ByteArray (ScrubbedBytes, convert)
import Data.Char (toLower)
import qualified Data.Map as Map
import Data.Text (Text)
import qualified Data.Text as Text
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
import Data.Time (defaultTimeLocale, formatTime)
import Haskoin (makeXPrvKey)
import LnUrl.Auth (
AckResponse (..),
Action (Register),
AuthUrl,
action,
actionText,
authDomain,
getSignedCallback,
parseAuthUrl,
)
import LnUrl.Authenticator.Storage (
AuthIdentity (..),
LogEntry,
addLogEntry,
decryptJsonFile,
encryptJsonFile,
getLog,
)
import qualified LnUrl.Authenticator.Storage as S
import Network.HTTP.Client (httpLbs, parseRequest, responseBody)
import Network.HTTP.Client.TLS (newTlsManager)
import System.Console.Haskeline (
InputT,
defaultSettings,
getInputChar,
outputStrLn,
runInputT,
)
import qualified System.Console.Haskeline as HL
-- | Create a new LNURL-auth vault
handleInit :: FilePath -> IO ()
handleInit identFile = do
putStrLn $ "Creating a new identity file: " <> identFile
xprv <- makeXPrvKey <$> getRandomBytes 32
password <- passwordInit
encryptJsonFile password identFile $ AuthIdentity{xprv, activityLog = mempty, version = 1}
putStrLn "Success!"
passwordInit :: IO ScrubbedBytes
passwordInit = runInputT defaultSettings $ do
mpassword <- HL.getPassword Nothing "Encryption password: "
mconfirmation <- HL.getPassword Nothing "Confirm encryption password: "
case (mpassword, mconfirmation) of
(Just password, Just confirmation)
| password == confirmation -> (pure . convert . encodeUtf8 . Text.pack) password
_ -> liftIO . throwIO $ PasswordEntryError
getPassword :: InputT IO ScrubbedBytes
getPassword =
maybe
mempty
( convert
. encodeUtf8
. Text.pack
)
<$> HL.getPassword Nothing "Encryption password: "
-- | Run LNURL-auth against a bech32-encoded URL
handleAuth :: FilePath -> String -> IO ()
handleAuth identFile bech32Url = do
putStrLn "Starting LNURL-auth flow"
either throwIO onUrl $
decodeBech32 (Text.pack bech32Url)
>>= \case
("lnurl", Just bytes) -> pure . Text.unpack $ decodeUtf8 bytes
_ -> Left Bech32Error
where
decodeBech32 =
bimap
Bech32DecodingError
(bimap Bech32.humanReadablePartToText Bech32.dataPartToBytes)
. Bech32.decodeLenient
onUrl theURL = runInputT defaultSettings $ do
password <- getPassword
authIdent <- liftIO $ getIdentity password identFile
authUrl <- liftIO $ maybe noParse pure $ parseAuthUrl theURL
let domain = authDomain authUrl
domainLog = getLog domain authIdent
possibleAction = action authUrl
response <- promptUser domain domainLog possibleAction
when response . liftIO $
handleCallback authIdent authUrl
>>= \case
AckSuccess -> do
addLogEntry domain possibleAction authIdent
>>= encryptJsonFile password identFile
putStrLn "Success!"
AckError reason -> throwIO $ ResponseError reason
noParse = throwIO AuthUrlParseError
getIdentity :: ScrubbedBytes -> FilePath -> IO AuthIdentity
getIdentity password identFile =
maybe noIdent pure =<< decryptJsonFile @AuthIdentity password identFile
where
noIdent = throwIO IdentityFileError
handleCallback ::
AuthIdentity ->
AuthUrl ->
IO AckResponse
handleCallback authIdent authUrl = do
mgr <- newTlsManager
parseRequest theCallback
>>= fmap (Ae.decode . responseBody) . flip httpLbs mgr
>>= maybe onResponseDecodingError pure
where
onResponseDecodingError = throwIO ResponseDecodingError
theCallback = show $ getSignedCallback (xprv authIdent) authUrl
promptUser :: String -> [LogEntry] -> Maybe Action -> InputT IO Bool
promptUser domain domainLog possibleAction = do
outputStrLn $ maybe noAction onAction possibleAction
when (alreadyRegistered possibleAction) $
outputStrLn "This domain has already registered."
userAccepts <$> getInputChar "Proceed (y/n)? "
where
noAction = domain <> " did not supply an action."
onAction theAction = domain <> " requests " <> Text.unpack (actionText theAction)
alreadyRegistered = \case
Just Register -> Just Register `elem` (S.action <$> domainLog)
_ -> False
userAccepts = (== Just 'y') . fmap toLower
handleLog :: FilePath -> String -> IO ()
handleLog identFile domain = runInputT defaultSettings $ do
password <- getPassword
authIdent <- liftIO $ getIdentity password identFile
mapM_ outputLog $ getLog domain authIdent
where
outputLog logEntry = outputStrLn $ "* " <> timeToString logEntry <> " - " <> activityString logEntry
timeToString = formatTime defaultTimeLocale "%F %T" . S.timestamp
activityString = maybe "No action" (Text.unpack . actionText) . S.action
handleList :: FilePath -> IO ()
handleList identFile = runInputT defaultSettings $ do
password <- getPassword
theLog <- liftIO $ activityLog <$> getIdentity password identFile
when (null theLog) $ outputStrLn "No domain registrations"
mapM_ (outputStrLn . Text.unpack) $ Map.keys theLog
data AuthenticatorError
= NoUrl
| PasswordEntryError
| AuthUrlParseError
| IdentityFileError
| Bech32Error
| Bech32DecodingError DecodingError
| ResponseDecodingError
| ResponseError Text
deriving (Eq, Show)
instance Exception AuthenticatorError