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-authenticator + +## 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/exec/Main.hs b/exec/Main.hs new file mode 100644 --- /dev/null +++ b/exec/Main.hs @@ -0,0 +1,105 @@ +{-# LANGUAGE LambdaCase #-} + +module Main (main) where + +import Control.Applicative (optional, (<**>)) +import Control.Exception (throwIO) +import LnUrl.Authenticator ( + AuthenticatorError (..), + handleAuth, + handleInit, + handleList, + handleLog, + ) +import qualified Options.Applicative as Opt +import System.Clipboard (getClipboardString) +import System.Environment (getEnv) + +data CliOptions = CliOptions + { identityFile :: Maybe FilePath + , command :: Command + } + deriving (Eq, Show) + +data Command + = Init + | Auth AuthOptions + | Log LogOptions + | List + deriving (Eq, Show) + +newtype AuthOptions = AuthOptions {authOptionsURL :: Maybe String} + deriving (Eq, Show) + +newtype LogOptions = LogOptions {logOptionsDomain :: String} + deriving (Eq, Show) + +getOptions :: IO CliOptions +getOptions = Opt.execParser $ Opt.info (opts <**> Opt.helper) desc + where + opts = CliOptions <$> optional optIdentFile <*> optCommand + + optIdentFile = + Opt.strOption $ + Opt.long "file" + <> Opt.short 'f' + <> Opt.help + ( "File in which to store identity (default: ~" + <> defaultIdentFilePath + <> ")" + ) + + optCommand = + Opt.hsubparser $ + Opt.command "init" cmdInit + <> Opt.command "auth" cmdRun + <> Opt.command "log" cmdLog + <> Opt.command "list" cmdList + + cmdInit = Opt.info (pure Init) descInit + descInit = Opt.progDesc "Initialize a new identity" + + cmdRun = Opt.info optsRun descRun + descRun = Opt.progDesc "Identify to a service using LNURL-auth" + optsRun = fmap Auth $ AuthOptions <$> optional optURL + + optURL = + Opt.strOption $ + Opt.long "url" + <> Opt.help "Service URL (default is to take the URL from the clipboard)" + + cmdLog = Opt.info optsLog descLog + descLog = Opt.progDesc "Print an activity log for a domain" + optsLog = fmap Log $ LogOptions <$> optDomain + + optDomain = Opt.strArgument $ Opt.metavar "DOMAIN" + + cmdList = Opt.info (pure List) descList + descList = Opt.progDesc "List all domains with which we have interacted" + + desc = Opt.progDesc "LNURL-auth helper" + +defaultIdentFile :: IO FilePath +defaultIdentFile = identFile <$> getEnv "HOME" + where + identFile = (<> defaultIdentFilePath) + +defaultIdentFilePath :: FilePath +defaultIdentFilePath = "/.lnurl-auth/default.auth" + +getIdentFile :: CliOptions -> IO FilePath +getIdentFile = maybe defaultIdentFile pure . identityFile + +main :: IO () +main = do + options <- getOptions + identFile <- getIdentFile options + case command options of + Init -> handleInit identFile + Auth theOpts -> + maybe getUrlFromClipboard pure (authOptionsURL theOpts) >>= handleAuth identFile + Log theOpts -> handleLog identFile $ logOptionsDomain theOpts + List -> handleList identFile + where + getUrlFromClipboard = getClipboardString >>= maybe noURL pure + noURL = throwIO NoUrl diff --git a/lnurl-authenticator.cabal b/lnurl-authenticator.cabal new file mode 100644 --- /dev/null +++ b/lnurl-authenticator.cabal @@ -0,0 +1,66 @@ +cabal-version: 2.4 +name: lnurl-authenticator +synopsis: A command line tool to manage LNURL auth identities +description: See https://github.com/GambolingPangolin/lnurl/blob/master/lnurl-authenticator/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 + +common core + default-language: Haskell2010 + 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 + + build-depends: + base >=4.14 && <4.16 + +library + import: core + hs-source-dirs: src + build-depends: + aeson ^>=1.5 + , bech32 ^>=1.1 + , bytestring >=0.10 && <0.12 + , containers ^>=0.6 + , cryptonite ^>=0.29 + , directory ^>=1.3 + , filepath ^>=1.4 + , haskeline ^>=0.8 + , haskoin-core ^>=0.20 + , http-client ^>=0.7 + , http-client-tls ^>=0.3 + , lnurl ^>=0.1 + , memory ^>=0.16 + , text ^>=1.2 + , time >=1.9 && <1.13 + + exposed-modules: + LnUrl.Authenticator + LnUrl.Authenticator.Storage + +executable lnurl-authenticator + import: core + hs-source-dirs: exec + main-is: Main.hs + ghc-options: -O2 -threaded + build-depends: + Clipboard ^>=2.3 + , lnurl-authenticator + , optparse-applicative ^>=0.16 diff --git a/src/LnUrl/Authenticator.hs b/src/LnUrl/Authenticator.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl/Authenticator.hs @@ -0,0 +1,190 @@ +{-# 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 diff --git a/src/LnUrl/Authenticator/Storage.hs b/src/LnUrl/Authenticator/Storage.hs new file mode 100644 --- /dev/null +++ b/src/LnUrl/Authenticator/Storage.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} + +module LnUrl.Authenticator.Storage ( + -- * File format + LogEntry (..), + AuthIdentity (..), + addLogEntry, + getLog, + + -- * Generic encrypted storage + encryptJsonFile, + decryptJsonFile, +) where + +import Control.Monad ((<=<)) +import Crypto.Cipher.AES (AES256) +import Crypto.Cipher.Types (cbcDecrypt, cbcEncrypt, cipherInit, makeIV) +import Crypto.Data.Padding (Format (PKCS7), pad, unpad) +import Crypto.Error (throwCryptoErrorIO) +import Crypto.KDF.Scrypt (Parameters (Parameters), generate) +import Crypto.Random (getRandomBytes) +import Data.Aeson ( + FromJSON, + ToJSON, + decode, + encode, + object, + parseJSON, + toJSON, + withObject, + (.:), + (.=), + ) +import Data.Aeson.Types (Parser) +import Data.ByteArray (ScrubbedBytes, convert) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import Data.Map.Lazy (Map, findWithDefault) +import qualified Data.Map.Lazy as Map +import Data.Text (Text) +import qualified Data.Text as Text +import Data.Time (UTCTime, getCurrentTime) +import Data.Word (Word32) +import Haskoin (XPrvKey, btc, xPrvFromJSON, xPrvToJSON) +import LnUrl.Auth (Action (..), actionText) +import qualified LnUrl.Auth as Auth +import System.Directory (createDirectoryIfMissing) +import System.FilePath (takeDirectory) + +{- | Each LNURL-auth interaction generates a log entry recording the action and + the timestamp. +-} +data LogEntry = LogEntry + { action :: Maybe Action + , timestamp :: UTCTime + } + deriving (Eq, Show) + +instance FromJSON LogEntry where + parseJSON = withObject "LogEntry" $ \obj -> + LogEntry + <$> (obj .: "action" >>= parseAction) + <*> obj .: "timestamp" + where + parseAction = maybe (pure Nothing) $ maybe noParse (pure . Just) . Auth.parseAction + noParse = fail "Unknown action" + +instance ToJSON LogEntry where + toJSON logEntry = + object + [ "action" .= (fmap actionText . action) logEntry + , "timestamp" .= timestamp logEntry + ] + +type Version = Word32 + +-- | An identity is a private key together with an activity log +data AuthIdentity = AuthIdentity + { xprv :: XPrvKey + , activityLog :: Map Text [LogEntry] + , version :: Version + } + deriving (Eq, Show) + +instance FromJSON AuthIdentity where + parseJSON = withObject "AuthIdentity" $ \obj -> + AuthIdentity + <$> (obj .: "xprv" >>= xPrvFromJSON btc) + <*> obj .: "log" + <*> (obj .: "version" >>= versionGuard) + where + versionGuard :: Word32 -> Parser Word32 + versionGuard = \case + 1 -> pure 1 + _ -> fail "Unknown version" + +instance ToJSON AuthIdentity where + toJSON AuthIdentity{xprv, activityLog, version} = + object + [ "xprv" .= xPrvToJSON btc xprv + , "log" .= activityLog + , "version" .= version + ] + +-- | Add an entry to the activity log for a domain +addLogEntry :: String -> Maybe Action -> AuthIdentity -> IO AuthIdentity +addLogEntry domain possibleAction a@AuthIdentity{activityLog} = do + now <- getCurrentTime + let logEntry = LogEntry possibleAction now + pure a{activityLog = Map.insertWith (<>) (Text.pack domain) [logEntry] activityLog} + +-- | Retrieve the activity log for a particular domain +getLog :: String -> AuthIdentity -> [LogEntry] +getLog domain AuthIdentity{activityLog} = + findWithDefault mempty (Text.pack domain) activityLog + +{- | Encrypt a JSON blob to a file, formatted like: @@ where + + * @SALT@ is 32 bytes used for key derivation + * @IV@ is the 16 byte AES-256 iv + * @CIPHERTEXT@ is the encrypted plaintext, padded with 16-byte PKCS7 +-} +encryptJsonFile :: + ToJSON a => + -- | User key + ScrubbedBytes -> + -- | Path to ident file + FilePath -> + -- | Data to encrypt + a -> + IO () +encryptJsonFile userKey path value = do + createDirectoryIfMissing True (takeDirectory path) + salt <- getRandomBytes 32 + let key = stretchKey salt userKey + aes <- throwCryptoErrorIO $ cipherInit @AES256 key + Just iv <- makeIV <$> getRandomBytes @_ @ByteString 16 + BS.writeFile path $ + salt + <> convert iv + <> ( cbcEncrypt aes iv . pad paddingScheme + . BSL.toStrict + . encode + ) + value + +-- | Extract a JSON payload from a file. See 'encryptJsonFile' for the layout. +decryptJsonFile :: + FromJSON a => + -- | User key + ScrubbedBytes -> + FilePath -> + IO (Maybe a) +decryptJsonFile userKey path = do + content <- BS.readFile path + + let salt = BS.take 32 content + Just iv = (makeIV . BS.take 16 . BS.drop 32) content + ciphertext = BS.drop 48 content + key = stretchKey salt userKey + + if BS.length content < 48 + then pure Nothing + else do + aes <- throwCryptoErrorIO $ cipherInit @AES256 key + pure . (decode . BSL.fromStrict <=< unpad paddingScheme) $ + cbcDecrypt aes iv ciphertext + +{- | Stretch a key using scrypt + +-} +stretchKey :: + -- | Salt + ByteString -> + -- | Pasword + ScrubbedBytes -> + ByteString +stretchKey = generate params + where + params = Parameters (2 ^ (20 :: Int)) 8 1 32 + +paddingScheme :: Format +paddingScheme = PKCS7 16