lnurl-authenticator (empty) → 0.1.0.0
raw patch · 6 files changed
+584/−0 lines, 6 filesdep +Clipboarddep +aesondep +base
Dependencies added: Clipboard, aeson, base, bech32, bytestring, containers, cryptonite, directory, filepath, haskeline, haskoin-core, http-client, http-client-tls, lnurl, lnurl-authenticator, memory, optparse-applicative, text, time
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- exec/Main.hs +105/−0
- lnurl-authenticator.cabal +66/−0
- src/LnUrl/Authenticator.hs +190/−0
- src/LnUrl/Authenticator/Storage.hs +188/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for lnurl-authenticator++## 0.1.0.0 -- 2021-07-29++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -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.
+ exec/Main.hs view
@@ -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
+ lnurl-authenticator.cabal view
@@ -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
+ src/LnUrl/Authenticator.hs view
@@ -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
+ src/LnUrl/Authenticator/Storage.hs view
@@ -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: @<SALT><IV><CIPHERTEXT>@ 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+ <https://blog.filippo.io/the-scrypt-parameters/>+-}+stretchKey ::+ -- | Salt+ ByteString ->+ -- | Pasword+ ScrubbedBytes ->+ ByteString+stretchKey = generate params+ where+ params = Parameters (2 ^ (20 :: Int)) 8 1 32++paddingScheme :: Format+paddingScheme = PKCS7 16