diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,12 @@ +Version 0.1.2.0 +================ + +*January 15, 2024* + + + +* Json output for view command + Version 0.1.1.0 ================ diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,43 +1,44 @@ -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeOperators #-} - -import Authenticator.Actions -import Authenticator.Options -import Authenticator.Vault -import Control.Exception -import Control.Monad -import Data.Functor -import Data.Maybe -import Data.Traversable -import Encrypted -import Prelude hiding (filter) -import System.Exit -import System.IO.Error -import Text.Printf -import qualified Crypto.Gpgme as G -import qualified Data.Aeson as J -import qualified Data.Binary as B -import qualified Data.ByteString.Lazy as BSL -import qualified Data.Text.Encoding as T -import qualified Data.Text.IO as T -import qualified Data.Yaml as Y +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +import Authenticator.Actions +import Authenticator.Options +import Authenticator.Vault +import Control.Exception +import Control.Monad +import qualified Crypto.Gpgme as G +import qualified Data.Aeson as J +import qualified Data.Binary as B +import qualified Data.ByteString.Lazy as BSL +import Data.Functor +import Data.Maybe +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import Data.Traversable +import qualified Data.Yaml as Y +import Encrypted +import System.Exit +import System.IO.Error +import Text.Printf +import Prelude hiding (filter) main :: IO () main = G.withCtx "~/.gnupg" "C" G.OpenPGP $ \ctx -> do - (cmd, echoPass, vault, fingerprint) <- getOptions + (cmd, echoPass, vault, fingerprint) <- getOptions - k <- for fingerprint $ \fing -> G.getKey ctx fing G.NoSecret >>= \case + k <- for fingerprint $ \fing -> + G.getKey ctx fing G.NoSecret >>= \case Nothing -> do printf "No key found for fingerprint %s!\n" (T.decodeUtf8 fing) exitFailure Just k' -> return k' - (e, mkNewVault) <- ((,False) <$> B.decodeFile @(Enc Vault) vault) `catch` \e -> + (e, mkNewVault) <- + ((,False) <$> B.decodeFile @(Enc Vault) vault) `catch` \e -> if isDoesNotExistError e then case (,) <$> k <*> fingerprint of Nothing -> do @@ -49,39 +50,41 @@ (,True) <$> mkEnc ctx k' (Vault []) else throwIO e - e' <- case cmd of - View l filts -> (Nothing <$) . viewVault l filts =<< getEnc ctx e - Add u -> case k of - Nothing -> do - putStrLn "Adding a key requires a fingerprint." - exitFailure - Just k' -> Just <$> overEnc ctx k' e (addSecret echoPass u) - Gen n -> do - vtmsg <- genSecret n =<< getEnc ctx e - forM vtmsg $ \(s, vt) -> case k of - Nothing -> do - putStrLn "Generating a counter-based (HOTP) key requires a fingerprint." - exitFailure - Just k' -> do - putStrLn s - mkEnc ctx k' vt - Edit n -> case k of - Nothing -> do - putStrLn "Editing keys requires a fingerprint." - exitFailure - Just k' -> Just <$> overEnc ctx k' e (editSecret n) - Delete n -> case k of + e' <- case cmd of + View l j filts -> (Nothing <$) . viewVault l j filts =<< getEnc ctx e + Add u -> case k of + Nothing -> do + putStrLn "Adding a key requires a fingerprint." + exitFailure + Just k' -> Just <$> overEnc ctx k' e (addSecret echoPass u) + Gen n -> do + vtmsg <- genSecret n =<< getEnc ctx e + forM vtmsg $ \(s, vt) -> case k of Nothing -> do - putStrLn "Deleting keys requires a fingerprint." + putStrLn "Generating a counter-based (HOTP) key requires a fingerprint." exitFailure - Just k' -> Just <$> overEnc ctx k' e (deleteSecret n) - Dump t -> getEnc ctx e >>= \vt -> do + Just k' -> do + putStrLn s + mkEnc ctx k' vt + Edit n -> case k of + Nothing -> do + putStrLn "Editing keys requires a fingerprint." + exitFailure + Just k' -> Just <$> overEnc ctx k' e (editSecret n) + Delete n -> case k of + Nothing -> do + putStrLn "Deleting keys requires a fingerprint." + exitFailure + Just k' -> Just <$> overEnc ctx k' e (deleteSecret n) + Dump t -> + getEnc ctx e >>= \vt -> do T.putStrLn . T.decodeUtf8 $ case t of - DTJSON -> BSL.toStrict $ J.encode vt - DTYaml -> Y.encode vt + DTJSON -> BSL.toStrict $ J.encode vt + DTYaml -> Y.encode vt return Nothing - case e' of - Just changed -> B.encodeFile vault changed - Nothing | mkNewVault -> B.encodeFile vault e - | otherwise -> return () + case e' of + Just changed -> B.encodeFile vault changed + Nothing + | mkNewVault -> B.encodeFile vault e + | otherwise -> return () diff --git a/otp-authenticator.cabal b/otp-authenticator.cabal --- a/otp-authenticator.cabal +++ b/otp-authenticator.cabal @@ -1,13 +1,11 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.31.2. +-- This file has been generated from package.yaml by hpack version 0.35.2. -- -- see: https://github.com/sol/hpack --- --- hash: 2c3280bb44648673b1ae4f40b7244c3dc6da72f3f2b5bf1304c964e277af6e61 name: otp-authenticator -version: 0.1.1.0 +version: 0.1.2.0 synopsis: OTP Authenticator (a la google) command line client description: Simple tool for keeping track of your one-time pad two-factor authentication keys; basically a command-line @@ -28,8 +26,9 @@ copyright: (c) Justin Le 2017 license: BSD3 license-file: LICENSE -tested-with: GHC >= 8.2 && < 8.8 build-type: Simple +tested-with: + GHC >= 8.2 && < 8.8 extra-source-files: README.md CHANGELOG.md diff --git a/src/Authenticator/Actions.hs b/src/Authenticator/Actions.hs --- a/src/Authenticator/Actions.hs +++ b/src/Authenticator/Actions.hs @@ -1,8 +1,8 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} -- | -- Module : Authenticator.Actions @@ -17,87 +17,144 @@ -- a thin wrapper over these actions. -- -- See 'Cmd'. --- +module Authenticator.Actions + ( viewVault, + addSecret, + genSecret, + editSecret, + deleteSecret, + ) +where +import Authenticator.Common +import Authenticator.Vault +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Trans.Class +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.State +import Control.Monad.Trans.Writer +import qualified Crypto.OTP as OTP +import qualified Data.Aeson as J +import qualified Data.Aeson.Encoding as J +import qualified Data.ByteString.Lazy as BSL +import Data.Char +import Data.Dependent.Sum +import Data.Foldable +import Data.Functor +import Data.Maybe +import Data.Monoid +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Text.IO as T +import GHC.Generics +import Lens.Micro +import Options.Applicative +import qualified System.Console.Haskeline as L +import System.Exit +import Text.Printf +import Text.Read (readMaybe) +import Prelude hiding (filter) -module Authenticator.Actions ( - viewVault - , addSecret - , genSecret - , editSecret - , deleteSecret - ) where +data ViewOut = ViewOut + { voId :: Int, + voAccount :: T.Text, + voIssuer :: Maybe T.Text, + voValue :: Maybe T.Text, + voMode :: Mode + } -import Authenticator.Common -import Authenticator.Vault -import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.Maybe -import Control.Monad.Trans.State -import Control.Monad.Trans.Writer -import Data.Char -import Data.Dependent.Sum -import Data.Foldable -import Data.Functor -import Data.Maybe -import Data.Monoid -import Data.String -import GHC.Generics -import Lens.Micro -import Options.Applicative -import Prelude hiding (filter) -import System.Exit -import Text.Printf -import Text.Read (readMaybe) -import qualified Crypto.OTP as OTP -import qualified Data.Text as T -import qualified System.Console.Haskeline as L +instance J.ToJSON ViewOut where + toEncoding ViewOut {..} = + J.pairs + ( "id" J..= voId + <> "account" J..= voAccount + <> maybe mempty ("issuer" J..=) voIssuer + <> maybe mempty ("value" J..=) voValue + <> "mode" J..= voMode + ) + toJSON ViewOut {..} = + J.object $ + [ "id" J..= voId, + "account" J..= voAccount, + "mode" J..= voMode + ] + ++ maybe [] ((: []) . ("issuer" J..=)) voIssuer + ++ maybe [] ((: []) . ("value" J..=)) voValue -- | View secrets, generating codes for time-based keys. -viewVault - :: Bool -- ^ List key names only; do not generate any codes. - -> Either Int (Maybe T.Text, Maybe T.Text) -- ^ Filter by ID or possibly by account name and issuer - -> Vault - -> IO () -viewVault l filts vt = do - (n,found) <- runWriterT . (`execStateT` 1) $ (`vaultSecrets` vt) $ \m sc ms -> do - i <- state $ \x -> (x :: Int, x + 1) - fmap (fromMaybe ms) . runMaybeT $ do - case filts of - Left n -> guard (i == n) - Right (fAcc, fIss) -> do - traverse_ (guard . (== secAccount sc)) fAcc - traverse_ (guard . (== secIssuer sc) . Just) fIss - lift . lift $ tell (Any True) - liftIO $ if l - then printf "(%d) %s\n" i (describeSecret sc) $> ms - else case m of - SHOTP -> ms <$ - printf "(%d) %s: [ counter-based, use gen ]\n" i (describeSecret sc) - STOTP -> do - p <- totp sc - printf "(%d) %s: %s\n" i (describeSecret sc) p - return ms - printf "Searched %d total entries.\n" (n - 1) - unless (getAny found) $ case filts of - Left i -> printf "ID %d not found!\n" i *> exitFailure - Right _ -> putStrLn "No matches found!" +viewVault :: + -- | List key names only; do not generate any codes. + Bool -> + -- | json output + Bool -> + -- | Filter by ID or possibly by account name and issuer + Either Int (Maybe T.Text, Maybe T.Text) -> + Vault -> + IO () +viewVault l j filts vt = do + (n, res) <- runWriterT . (`execStateT` 1) $ (`vaultSecrets` vt) $ \m sc ms -> do + i <- state $ \x -> (x :: Int, x + 1) + fmap (fromMaybe ms) . runMaybeT $ do + case filts of + Left n -> guard (i == n) + Right (fAcc, fIss) -> do + traverse_ (guard . (== secAccount sc)) fAcc + traverse_ (guard . (== secIssuer sc) . Just) fIss + val <- case m of + STOTP | not l -> Just <$> liftIO (totp sc) + _ -> pure Nothing + lift . lift . tell . (: []) $ + ViewOut + { voId = i, + voAccount = secAccount sc, + voIssuer = secIssuer sc, + voValue = val, + voMode = fromSMode m + } + return ms + if j + then + T.putStrLn . T.decodeUtf8 . BSL.toStrict . J.encodingToLazyByteString $ + J.pairs + ( "total" J..= n + <> "values" J..= res + ) + else do + printf "Searched %d total entries.\n" (n - 1) + forM_ res $ \ViewOut {..} -> + let described = voAccount <> case voIssuer of + Nothing -> "" + Just i -> " / " <> i + in case voMode of + HOTP -> printf "(%d) %s: [ counter-based, use gen ]\n" voId described + TOTP -> printf "(%d) %s%s\n" voId described $ case voValue of + Nothing -> "" + Just v -> ": " <> v + when (null res) $ case filts of + Left i -> printf "ID %d not found!\n" i *> exitFailure + Right _ -> putStrLn "No matches found!" -- | Add a secret, interactively. -addSecret - :: Bool -- ^ Echo back password entry - -> Bool -- ^ If 'True', add via otpauth protocol URI - -> Vault - -> IO Vault +addSecret :: + -- | Echo back password entry + Bool -> + -- | If 'True', add via otpauth protocol URI + Bool -> + Vault -> + IO Vault addSecret echoPass u vt = do - -- TODO: verify b32? - dsc <- if u + -- TODO: verify b32? + dsc <- + if u then do - q <- L.runInputT hlSettings $ - fromMaybe "" <$> if echoPass - then L.getInputLine "URI Secret?: " - else L.getPassword (Just '*') "URI Secret?: " + q <- + L.runInputT hlSettings $ + fromMaybe "" + <$> if echoPass + then L.getInputLine "URI Secret?: " + else L.getPassword (Just '*') "URI Secret?: " putStrLn "parsing" case parseSecretURI q of Left err -> do @@ -107,130 +164,140 @@ Right d -> return d else mkSecret echoPass - putStrLn "Added succesfully!" - return $ - vt & _Vault %~ (++ [dsc]) + putStrLn "Added succesfully!" + return $ + vt & _Vault %~ (++ [dsc]) -- | Generate a secret code, forcing a new HOTP code if it is -- counter-based. -genSecret - :: Int -- ^ ID # of secret to generate - -> Vault - -> IO (Maybe (String, Vault)) +genSecret :: + -- | ID # of secret to generate + Int -> + Vault -> + IO (Maybe (String, Vault)) genSecret n vt = do - res <- runMaybeT . runWriterT . forOf (_Vault . ix (n - 1)) vt $ \case - s :=> sc :*: ms -> - case s of - SHOTP -> do - let (p, ms') = hotp sc ms - out = printf "(%d) %s: %s\n" n (describeSecret sc) p - tell (First (Just out)) - return $ s :=> sc :*: ms' - STOTP -> do - liftIO $ do - p <- totp sc - printf "(%d) %s: %s\n" n (describeSecret sc) p - empty - forM res $ \(r, changed) -> - case getFirst changed of - Just msg -> return (msg, r) - Nothing -> do - printf "No item with ID %d found.\n" n - exitFailure - --- | Edit a secret's metadata (account name, issuer) -editSecret - :: Int -- ^ ID # of secret to edit - -> Vault - -> IO Vault -editSecret n vt = do - (vt', found) <- runWriterT . forOf (_Vault . ix (n - 1)) vt $ \case - (s :=> sc :*: ms) -> do - sc' <- liftIO $ do - printf "Editing (%d) %s ...\n" n (describeSecret sc) - liftIO (mkSecretFrom sc) - tell (First (Just (describeSecret sc'))) - return $ s :=> sc' :*: ms - case getFirst found of + res <- runMaybeT . runWriterT . forOf (_Vault . ix (n - 1)) vt $ \case + s :=> sc :*: ms -> + case s of + SHOTP -> do + let (p, ms') = hotp sc ms + out = printf "(%d) %s: %s\n" n (describeSecret sc) p + tell (First (Just out)) + return $ s :=> sc :*: ms' + STOTP -> do + liftIO $ do + p <- totp sc + printf "(%d) %s: %s\n" n (describeSecret sc) p + empty + forM res $ \(r, changed) -> + case getFirst changed of + Just msg -> return (msg, r) Nothing -> do printf "No item with ID %d found.\n" n exitFailure - Just desc -> do - printf "%s edited successfuly!\n" desc - return vt' --- | Delete a secret. -deleteSecret - :: Int -- ^ ID # of secret to delete - -> Vault - -> IO Vault -deleteSecret n vt = do - (vt', found) <- runWriterT . flip evalStateT 1 . forOf (_Vault . wither) vt $ \case - ds@(_ :=> sc :*: _) -> do - i <- state $ \x -> (x :: Int, x + 1) - if n == i - then do - lift $ tell (Any True) - a <- liftIO . L.runInputT hlSettings $ - L.getInputChar (printf "Delete %s? y/[n]: " (describeSecret sc)) - case toLower <$> a of - Just 'y' -> do - liftIO $ putStrLn "Deleted!" - return Nothing - _ -> return (Just ds) - else return (Just ds) - unless (getAny found) $ do +-- | Edit a secret's metadata (account name, issuer) +editSecret :: + -- | ID # of secret to edit + Int -> + Vault -> + IO Vault +editSecret n vt = do + (vt', found) <- runWriterT . forOf (_Vault . ix (n - 1)) vt $ \case + (s :=> sc :*: ms) -> do + sc' <- liftIO $ do + printf "Editing (%d) %s ...\n" n (describeSecret sc) + liftIO (mkSecretFrom sc) + tell (First (Just (describeSecret sc'))) + return $ s :=> sc' :*: ms + case getFirst found of + Nothing -> do printf "No item with ID %d found.\n" n exitFailure - return vt' + Just desc -> do + printf "%s edited successfuly!\n" desc + return vt' + +-- | Delete a secret. +deleteSecret :: + -- | ID # of secret to delete + Int -> + Vault -> + IO Vault +deleteSecret n vt = do + (vt', found) <- runWriterT . flip evalStateT 1 . forOf (_Vault . wither) vt $ \case + ds@(_ :=> sc :*: _) -> do + i <- state $ \x -> (x :: Int, x + 1) + if n == i + then do + lift $ tell (Any True) + a <- + liftIO . L.runInputT hlSettings $ + L.getInputChar (printf "Delete %s? y/[n]: " (describeSecret sc)) + case toLower <$> a of + Just 'y' -> do + liftIO $ putStrLn "Deleted!" + return Nothing + _ -> return (Just ds) + else return (Just ds) + unless (getAny found) $ do + printf "No item with ID %d found.\n" n + exitFailure + return vt' where wither f = fmap catMaybes . traverse f mkSecret :: Bool -> IO SomeSecretState mkSecret echoPass = L.runInputT hlSettings $ do - a <- (mfilter (not . null) <$> L.getInputLine "Account?: ") >>= \case + a <- + (mfilter (not . null) <$> L.getInputLine "Account?: ") >>= \case Nothing -> liftIO $ putStrLn "Account required" >> exitFailure - Just r -> return r - i <- L.getInputLine "Issuer? (optional): " - k <- fromMaybe "" <$> if echoPass - then L.getInputLine "Secret?: " - else L.getPassword (Just '*') "Secret?: " - m <- L.getInputChar "[t]ime- or (c)ounter-based?: " - let i' = mfilter (not . null) i - k' = decodePad . T.pack $ k - s :: Maybe (Secret m) - s = Sec (T.pack a) (T.pack <$> i') HASHA1 (OTPDigits OTP.OTP6) <$> k' - case toLower <$> m of - Just 'c' -> do - n <- mfilter (not . null) <$> L.getInputLine "Initial counter? [0]: " - n' <- case n of - Nothing -> return 0 - Just n' -> case readMaybe n' of - Just r -> return r - Nothing -> liftIO $ putStrLn "Invalid initial counter. Using 0." $> 0 - case s of - Nothing -> liftIO $ do - printf "Invalid secret key: %s\n" k - exitFailure - Just s' -> return $ SHOTP :=> s' :*: HOTPState n' - _ -> case s of + Just r -> return r + i <- L.getInputLine "Issuer? (optional): " + k <- + fromMaybe "" + <$> if echoPass + then L.getInputLine "Secret?: " + else L.getPassword (Just '*') "Secret?: " + m <- L.getInputChar "[t]ime- or (c)ounter-based?: " + let i' = mfilter (not . null) i + k' = decodePad . T.pack $ k + s :: Maybe (Secret m) + s = Sec (T.pack a) (T.pack <$> i') HASHA1 (OTPDigits OTP.OTP6) <$> k' + case toLower <$> m of + Just 'c' -> do + n <- mfilter (not . null) <$> L.getInputLine "Initial counter? [0]: " + n' <- case n of + Nothing -> return 0 + Just n' -> case readMaybe n' of + Just r -> return r + Nothing -> liftIO $ putStrLn "Invalid initial counter. Using 0." $> 0 + case s of Nothing -> liftIO $ do printf "Invalid secret key: %s\n" k exitFailure - Just s' -> return $ STOTP :=> (s' :*: TOTPState) + Just s' -> return $ SHOTP :=> s' :*: HOTPState n' + _ -> case s of + Nothing -> liftIO $ do + printf "Invalid secret key: %s\n" k + exitFailure + Just s' -> return $ STOTP :=> (s' :*: TOTPState) mkSecretFrom :: Secret m -> IO (Secret m) mkSecretFrom sc = L.runInputT hlSettings $ do - a <- mfilter (not . null) <$> L.getInputLineWithInitial "Account?: " (T.unpack (secAccount sc), "") - i <- mfilter (not . null) <$> case secIssuer sc of - Nothing -> L.getInputLine "Issuer? (optional): " - Just si -> L.getInputLineWithInitial "Issuer? (optional): " (T.unpack si, "") - let a' = case a of - Nothing -> secAccount sc - Just r -> T.pack r - i' = case i of - Nothing -> secIssuer sc - Just r -> Just $ T.pack r - return $ sc { secAccount = a' - , secIssuer = i' - } + a <- mfilter (not . null) <$> L.getInputLineWithInitial "Account?: " (T.unpack (secAccount sc), "") + i <- + mfilter (not . null) <$> case secIssuer sc of + Nothing -> L.getInputLine "Issuer? (optional): " + Just si -> L.getInputLineWithInitial "Issuer? (optional): " (T.unpack si, "") + let a' = case a of + Nothing -> secAccount sc + Just r -> T.pack r + i' = case i of + Nothing -> secIssuer sc + Just r -> Just $ T.pack r + return $ + sc + { secAccount = a', + secIssuer = i' + } diff --git a/src/Authenticator/Common.hs b/src/Authenticator/Common.hs --- a/src/Authenticator/Common.hs +++ b/src/Authenticator/Common.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Authenticator.Common @@ -12,36 +12,37 @@ -- Portability : portable -- -- Common utility functions and values used throughout the library. --- - - -module Authenticator.Common ( - hlSettings - , decodePad - ) where +module Authenticator.Common + ( hlSettings, + decodePad, + ) +where -import Control.Monad.IO.Class -import Data.Char -import Prelude.Compat -import qualified Codec.Binary.Base32 as B32 -import qualified Data.ByteString as BS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T +import qualified Codec.Binary.Base32 as B32 +import Control.Monad.IO.Class +import qualified Data.ByteString as BS +import Data.Char +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Prelude.Compat import qualified System.Console.Haskeline as L -- | Default settings for haskeline. -hlSettings :: forall m. MonadIO m => L.Settings m -hlSettings = (L.defaultSettings @m) { L.complete = L.noCompletion - , L.autoAddHistory = False - } +hlSettings :: forall m. (MonadIO m) => L.Settings m +hlSettings = + (L.defaultSettings @m) + { L.complete = L.noCompletion, + L.autoAddHistory = False + } -- | Pad and decode a base32-encoded value from its 'Text' prepresentation. decodePad :: T.Text -> Maybe BS.ByteString -decodePad = either (const Nothing) Just - . B32.decode - . (\s' -> s' <> BS.replicate ((8 - BS.length s') `mod` 8) p) - . T.encodeUtf8 - . T.map toUpper - . T.filter isAlphaNum +decodePad = + either (const Nothing) Just + . B32.decode + . (\s' -> s' <> BS.replicate ((8 - BS.length s') `mod` 8) p) + . T.encodeUtf8 + . T.map toUpper + . T.filter isAlphaNum where p = fromIntegral $ ord '=' diff --git a/src/Authenticator/Options.hs b/src/Authenticator/Options.hs --- a/src/Authenticator/Options.hs +++ b/src/Authenticator/Options.hs @@ -1,6 +1,6 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} -- | @@ -13,213 +13,289 @@ -- Portability : portable -- -- Load options for the @otp-auth@ executable. --- - - -module Authenticator.Options ( - Cmd(..) - , DumpType(..) - , getOptions - ) where - -import Authenticator.Common -import Control.Exception -import Control.Monad -import Data.Functor -import Data.Maybe -import Data.Monoid -import Data.String -import GHC.Generics (Generic) -import Options.Applicative hiding (str) -import Prelude hiding (filter) -import System.FilePath -import System.IO.Error -import System.Posix.User -import Text.Printf -import qualified Crypto.Gpgme as G -import qualified Data.Aeson as J -import qualified Data.ByteString as BS -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Yaml as Y -import qualified Options.Applicative as O -import qualified System.Console.Haskeline as L +module Authenticator.Options + ( Cmd (..), + DumpType (..), + getOptions, + ) +where +import Authenticator.Common +import Control.Exception +import Control.Monad +import qualified Crypto.Gpgme as G +import qualified Data.Aeson as J +import qualified Data.ByteString as BS +import Data.Functor +import Data.Maybe +import Data.Monoid +import Data.String +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Yaml as Y +import GHC.Generics (Generic) +import Options.Applicative hiding (str) +import qualified Options.Applicative as O +import qualified System.Console.Haskeline as L +import System.FilePath +import System.IO +import System.IO.Error +import System.Posix.User +import Text.Printf +import Prelude hiding (filter) -- | Should the data dump be yaml, or json? data DumpType = DTYaml | DTJSON -- | A command to exercute. See "Authenticator.Actions". -data Cmd = Add Bool - | View Bool (Either Int (Maybe T.Text, Maybe T.Text)) - | Gen Int - | Edit Int - | Delete Int - | Dump DumpType +data Cmd + = Add Bool + | View Bool Bool (Either Int (Maybe T.Text, Maybe T.Text)) + | Gen Int + | Edit Int + | Delete Int + | Dump DumpType -data Opts = Opts { oFingerprint :: Maybe BS.ByteString - , oVault :: Maybe FilePath - , oConfig :: Maybe FilePath - , oGPG :: FilePath - , oEchoPass :: Bool - , oCmd :: Cmd - } +data Opts = Opts + { oFingerprint :: Maybe BS.ByteString, + oVault :: Maybe FilePath, + oConfig :: Maybe FilePath, + oGPG :: FilePath, + oEchoPass :: Bool, + oCmd :: Cmd + } -data Config = Conf { cFingerprint :: Maybe T.Text - , cVault :: Maybe FilePath - } +data Config = Conf + { cFingerprint :: Maybe T.Text, + cVault :: Maybe FilePath + } deriving (Generic) confJsonOpts :: J.Options -confJsonOpts = J.defaultOptions +confJsonOpts = + J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '-' . drop 1 } + instance J.FromJSON Config where - parseJSON = J.genericParseJSON confJsonOpts + parseJSON = J.genericParseJSON confJsonOpts + instance J.ToJSON Config where - toEncoding = J.genericToEncoding confJsonOpts - toJSON = J.genericToJSON confJsonOpts + toEncoding = J.genericToEncoding confJsonOpts + toJSON = J.genericToJSON confJsonOpts parseOpts :: Parser Opts -parseOpts = Opts <$> optional ( - option str ( long "fingerprint" - <> short 'p' - <> metavar "KEY" - <> help "Fingerprint of key to use" - ) - ) - <*> option (Just <$> str) ( long "vault" - <> short 'v' - <> metavar "PATH" - <> value Nothing - <> showDefaultWith (const "~/.otp-auth.vault") - <> help "Location of vault" - ) - <*> option (Just <$> str) ( long "config" - <> short 'c' - <> metavar "PATH" - <> value Nothing - <> showDefaultWith (const "~/.otp-auth.yaml") - <> help "Location of configuration file" - ) - <*> strOption ( long "gnupg" - <> short 'g' - <> metavar "PATH" - <> value "~/.gnupg" - <> showDefaultWith id - <> help ".gnupg file" - ) - <*> switch ( long "echo" - <> short 'e' - <> help "Visible (echoing) password entry mode" - ) - <*> subparser ( command "add" (info (parseAdd <**> helper) - (progDesc "Add an OTP key") - ) - <> command "view" (info (parseView <**> helper) - (progDesc "View keys (with optional filter or specific ID)") - ) - <> command "gen" (info (parseGen <**> helper) - (progDesc "Generate code for specific key #, for use with counter-based keys.") - ) - <> command "edit" (info (parseEdit <**> helper) - (progDesc "Edit a key") - ) - <> command "delete" (info (parseDelete <**> helper) - (progDesc "Delete a key") - ) - <> command "dump" (info (parseDump <**> helper) - (progDesc "Dump all data as json") - ) - ) +parseOpts = + Opts + <$> optional + ( option + str + ( long "fingerprint" + <> short 'p' + <> metavar "KEY" + <> help "Fingerprint of key to use" + ) + ) + <*> option + (Just <$> str) + ( long "vault" + <> short 'v' + <> metavar "PATH" + <> value Nothing + <> showDefaultWith (const "~/.otp-auth.vault") + <> help "Location of vault" + ) + <*> option + (Just <$> str) + ( long "config" + <> short 'c' + <> metavar "PATH" + <> value Nothing + <> showDefaultWith (const "~/.otp-auth.yaml") + <> help "Location of configuration file" + ) + <*> strOption + ( long "gnupg" + <> short 'g' + <> metavar "PATH" + <> value "~/.gnupg" + <> showDefaultWith id + <> help ".gnupg file" + ) + <*> switch + ( long "echo" + <> short 'e' + <> help "Visible (echoing) password entry mode" + ) + <*> subparser + ( command + "add" + ( info + (parseAdd <**> helper) + (progDesc "Add an OTP key") + ) + <> command + "view" + ( info + (parseView <**> helper) + (progDesc "View keys (with optional filter or specific ID)") + ) + <> command + "gen" + ( info + (parseGen <**> helper) + (progDesc "Generate code for specific key #, for use with counter-based keys.") + ) + <> command + "edit" + ( info + (parseEdit <**> helper) + (progDesc "Edit a key") + ) + <> command + "delete" + ( info + (parseDelete <**> helper) + (progDesc "Delete a key") + ) + <> command + "dump" + ( info + (parseDump <**> helper) + (progDesc "Dump all data as json") + ) + ) where - parseAdd = Add <$> switch ( long "uri" - <> short 'u' - <> help "Enter account using secret URI (from QR Code)" + parseAdd = + Add + <$> switch + ( long "uri" + <> short 'u' + <> help "Enter account using secret URI (from QR Code)" + ) + parseView = + View + <$> switch + ( long "list" + <> short 'l' + <> help "Only list accounts; do not generate any keys." + ) + <*> switch + ( long "json" + <> short 'j' + <> help "Output as json." + ) + <*> ( Left + <$> argument + auto + ( metavar "ID" + <> help "Specific ID number of account" + ) + <|> Right + <$> ( (,) + <$> optional + ( option + str + ( long "account" + <> short 'a' + <> metavar "NAME" + <> help "Optional filter by account" ) - parseView = View <$> switch ( long "list" - <> short 'l' - <> help "Only list accounts; do not generate any keys." - ) - <*> (Left <$> argument auto ( metavar "ID" - <> help "Specific ID number of account" - ) - <|> Right <$> ((,) <$> optional (option str ( long "account" - <> short 'a' - <> metavar "NAME" - <> help "Optional filter by account" - ) - ) - <*> optional (option str ( long "issuer" - <> short 'i' - <> metavar "SITE" - <> help "Optional filter by issuer" - ) - )) ) - parseGen = Gen <$> argument auto ( metavar "ID" - <> help "ID number of account" - ) - parseEdit = Edit <$> argument auto ( metavar "ID" - <> help "ID number of account" - ) - parseDelete = Delete <$> argument auto ( metavar "ID" - <> help "ID number of account" - ) - parseDump = Dump <$> flag DTJSON DTYaml ( long "yaml" - <> short 'y' - <> help "Yaml output" - ) + <*> optional + ( option + str + ( long "issuer" + <> short 'i' + <> metavar "SITE" + <> help "Optional filter by issuer" + ) + ) + ) + ) + parseGen = + Gen + <$> argument + auto + ( metavar "ID" + <> help "ID number of account" + ) + parseEdit = + Edit + <$> argument + auto + ( metavar "ID" + <> help "ID number of account" + ) + parseDelete = + Delete + <$> argument + auto + ( metavar "ID" + <> help "ID number of account" + ) + parseDump = + Dump + <$> flag + DTJSON + DTYaml + ( long "yaml" + <> short 'y' + <> help "Yaml output" + ) -- | Return command, visible password entry, vault filepath, and fingerprint getOptions :: IO (Cmd, Bool, FilePath, Maybe G.Fpr) getOptions = do - Opts{..} <- execParser $ info (parseOpts <**> helper) - ( fullDesc - <> progDesc "OTP Viewer" - <> header "otp-authenticator: authenticate me, cap'n" - ) + Opts {..} <- + execParser $ + info + (parseOpts <**> helper) + ( fullDesc + <> progDesc "OTP Viewer" + <> header "otp-authenticator: authenticate me, cap'n" + ) - oConfig' <- case oConfig of - Just fp -> return fp - Nothing -> do - ue <- getUserEntryForID =<< getEffectiveUserID - return $ homeDirectory ue ".otp-auth.yaml" + oConfig' <- case oConfig of + Just fp -> return fp + Nothing -> do + ue <- getUserEntryForID =<< getEffectiveUserID + return $ homeDirectory ue ".otp-auth.yaml" - (Conf{..}, mkNewConf) <- do - (c0, mkNew) <- fmap (,False) (Y.decodeFileEither @Config oConfig') `catch` \e -> + (Conf {..}, mkNewConf) <- do + (c0, mkNew) <- + fmap (,False) (Y.decodeFileEither @Config oConfig') `catch` \e -> if isDoesNotExistError e then return (Right (Conf Nothing Nothing), True) else throwIO e - case c0 of - Left e -> do - putStrLn "Could not parse configuration file. Ignoring." - putStrLn . Y.prettyPrintParseException $ e - return (Conf Nothing Nothing, False) - Right c1 -> return (c1, mkNew) - - vault <- case oVault <|> cVault of - Just fp -> return fp - Nothing -> do - ue <- getUserEntryForID =<< getEffectiveUserID - return $ homeDirectory ue ".otp-auth.vault" + case c0 of + Left e -> do + hPutStrLn stderr "Could not parse configuration file. Ignoring." + hPutStrLn stderr . Y.prettyPrintParseException $ e + return (Conf Nothing Nothing, False) + Right c1 -> return (c1, mkNew) + vault <- case oVault <|> cVault of + Just fp -> return fp + Nothing -> do + ue <- getUserEntryForID =<< getEffectiveUserID + return $ homeDirectory ue ".otp-auth.vault" - cFingerprint' <- if mkNewConf + cFingerprint' <- + if mkNewConf then do printf "Config file not found; generating default file at %s\n" oConfig' fing <- case oFingerprint of - Just p -> return $ Just (T.decodeUtf8 p) + Just p -> return $ Just (T.decodeUtf8 p) Nothing -> L.runInputT hlSettings $ fmap T.pack <$> L.getInputLine "Fingerprint? " Y.encodeFile oConfig' $ Conf fing (Just vault) return fing - else - return cFingerprint + else return cFingerprint - let fingerprint = oFingerprint <|> (T.encodeUtf8 <$> cFingerprint') + let fingerprint = oFingerprint <|> (T.encodeUtf8 <$> cFingerprint') - return (oCmd, oEchoPass, vault, fingerprint) + return (oCmd, oEchoPass, vault, fingerprint) -- | is str from optparse-applicative 0.14 and above -str :: IsString s => ReadM s +str :: (IsString s) => ReadM s str = fromString <$> O.str diff --git a/src/Authenticator/Vault.hs b/src/Authenticator/Vault.hs --- a/src/Authenticator/Vault.hs +++ b/src/Authenticator/Vault.hs @@ -1,19 +1,20 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeInType #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE NoImplicitPrelude #-} -- | -- Module : Authenticator.Vault @@ -28,107 +29,111 @@ -- type-level programming here for no reason because I have issues. -- -- Based off of . --- - - -module Authenticator.Vault ( - Mode(..), SMode(..), withSMode, fromSMode - , HashAlgo(..) - , parseAlgo - , Secret(..), OTPDigits(..), pattern OTPDigitsInt - , ModeState(..) - , SomeSecretState - , Vault(..) - , _Vault - , hotp - , totp - , totp_ - , otp - , someSecret - , vaultSecrets - , describeSecret - , secretURI - , parseSecretURI - ) where +module Authenticator.Vault + ( Mode (..), + SMode (..), + withSMode, + fromSMode, + HashAlgo (..), + parseAlgo, + Secret (..), + OTPDigits (..), + pattern OTPDigitsInt, + ModeState (..), + SomeSecretState, + Vault (..), + _Vault, + hotp, + totp, + totp_, + otp, + someSecret, + vaultSecrets, + describeSecret, + secretURI, + parseSecretURI, + ) +where -import Authenticator.Common -import Control.Applicative -import Control.Monad hiding (fail) -import Crypto.Hash.Algorithms -import Data.Bifunctor -import Data.Bitraversable -import Data.Char -import Data.Dependent.Sum -import Data.Function -import Data.GADT.Show -import Data.Kind -import Data.Maybe -import Data.Ord -import Data.Some -import Data.Time.Clock.POSIX -import Data.Vinyl -import Data.Void -import Data.Word -import GHC.Generics -import Prelude.Compat -import Text.Printf -import Text.Read (readMaybe) -import qualified Codec.Binary.Base32 as B32 -import qualified Crypto.OTP as OTP -import qualified Data.Aeson as J -import qualified Data.Binary as B -import qualified Data.ByteString as BS -import qualified Data.Map as M -import qualified Data.Set as S -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Network.URI.Encode as U -import qualified Text.Megaparsec as P -import qualified Text.Megaparsec.Char as P +import Authenticator.Common +import qualified Codec.Binary.Base32 as B32 +import Control.Applicative +import Control.Monad hiding (fail) +import Crypto.Hash.Algorithms +import qualified Crypto.OTP as OTP +import qualified Data.Aeson as J +import Data.Bifunctor +import qualified Data.Binary as B +import Data.Bitraversable +import qualified Data.ByteString as BS +import Data.Char +import Data.Dependent.Sum +import Data.Function +import Data.GADT.Show +import Data.Kind +import qualified Data.Map as M +import Data.Maybe +import Data.Ord +import qualified Data.Set as S +import Data.Some +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Time.Clock.POSIX +import Data.Vinyl +import Data.Void +import Data.Word +import GHC.Generics +import qualified Network.URI.Encode as U +import Prelude.Compat +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P +import Text.Printf +import Text.Read (readMaybe) -- | OTP generation mode data Mode - -- | Counter-based - = HOTP - -- | Time-based - | TOTP + = -- | Counter-based + HOTP + | -- | Time-based + TOTP deriving (Generic, Show) -- | Singleton for 'Mode' data SMode :: Mode -> Type where - SHOTP :: SMode 'HOTP - STOTP :: SMode 'TOTP + SHOTP :: SMode 'HOTP + STOTP :: SMode 'TOTP deriving instance Show (SMode m) instance GShow SMode where - gshowsPrec = showsPrec + gshowsPrec = showsPrec instance B.Binary Mode + instance J.ToJSON Mode where - toJSON HOTP = J.toJSON @T.Text "hotp" - toJSON TOTP = J.toJSON @T.Text "totp" + toJSON HOTP = J.toJSON @T.Text "hotp" + toJSON TOTP = J.toJSON @T.Text "totp" -- | Reify a 'Mode' to its singleton -withSMode - :: Mode - -> (forall m. SMode m -> r) - -> r +withSMode :: + Mode -> + (forall m. SMode m -> r) -> + r withSMode = \case - HOTP -> ($ SHOTP) - TOTP -> ($ STOTP) + HOTP -> ($ SHOTP) + TOTP -> ($ STOTP) -- | Reflect a 'SMode' to its value. fromSMode :: SMode m -> Mode fromSMode = \case - SHOTP -> HOTP - STOTP -> TOTP + SHOTP -> HOTP + STOTP -> TOTP -- | A data family consisting of the state required by each mode. data family ModeState :: Mode -> Type -- | For 'HOTP' (counter-based) mode, the state is the current counter. -data instance ModeState 'HOTP = HOTPState { hotpCounter :: Word64 } +data instance ModeState 'HOTP = HOTPState {hotpCounter :: Word64} deriving (Generic, Show) -- | For 'TOTP' (time-based) mode, there is no state. @@ -136,32 +141,36 @@ deriving (Generic, Show) instance B.Binary (ModeState 'HOTP) + instance B.Binary (ModeState 'TOTP) + instance J.ToJSON (ModeState 'HOTP) where - toEncoding HOTPState{..} = J.pairs $ "counter" J..= hotpCounter - toJSON HOTPState{..} = J.object - [ "counter" J..= hotpCounter ] + toEncoding HOTPState {..} = J.pairs $ "counter" J..= hotpCounter + toJSON HOTPState {..} = + J.object + ["counter" J..= hotpCounter] instance J.ToJSON (ModeState 'TOTP) modeStateBinary :: SMode m -> DictOnly B.Binary (ModeState m) modeStateBinary = \case - SHOTP -> DictOnly - STOTP -> DictOnly + SHOTP -> DictOnly + STOTP -> DictOnly -- | Which OTP-approved hash algorithm to use? data HashAlgo = HASHA1 | HASHA256 | HASHA512 deriving (Generic, Show) instance B.Binary HashAlgo + instance J.ToJSON HashAlgo where - toJSON HASHA1 = J.toJSON @T.Text "sha1" - toJSON HASHA256 = J.toJSON @T.Text "sha256" - toJSON HASHA512 = J.toJSON @T.Text "sha512" + toJSON HASHA1 = J.toJSON @T.Text "sha1" + toJSON HASHA256 = J.toJSON @T.Text "sha256" + toJSON HASHA512 = J.toJSON @T.Text "sha512" -- | Generate the /cryptonite/ 'HashAlgorithm' instance. hashAlgo :: HashAlgo -> Some (Dict HashAlgorithm) -hashAlgo HASHA1 = Some $ Dict SHA1 +hashAlgo HASHA1 = Some $ Dict SHA1 hashAlgo HASHA256 = Some $ Dict SHA256 hashAlgo HASHA512 = Some $ Dict SHA512 @@ -169,133 +178,149 @@ parseAlgo :: String -> Maybe HashAlgo parseAlgo = (`lookup` algos) . map toLower . unwords . words where - algos = [("sha1" , HASHA1 ) - ,("sha256", HASHA256) - ,("sha512", HASHA512) - ] + algos = + [ ("sha1", HASHA1), + ("sha256", HASHA256), + ("sha512", HASHA512) + ] -- | Newtype wrapper to provide 'Eq', 'Ord', 'B.Binary', and 'J.ToJSON' -- instances. You can convert to and from this and the 'Int' -- representation using 'OTPDigitsInt' -newtype OTPDigits = OTPDigits { otpDigits :: OTP.OTPDigits } - deriving Show +newtype OTPDigits = OTPDigits {otpDigits :: OTP.OTPDigits} + deriving (Show) instance Eq OTPDigits where - (==) = (==) `on` show + (==) = (==) `on` show instance Ord OTPDigits where - compare = comparing show + compare = comparing show otpDigitsSet :: S.Set OTPDigits -otpDigitsSet = S.fromList $ +otpDigitsSet = + S.fromList $ OTPDigits <$> [OTP.OTP4, OTP.OTP5, OTP.OTP6, OTP.OTP7, OTP.OTP8, OTP.OTP9] pattern OTPDigitsInt :: OTPDigits -> Int -pattern OTPDigitsInt o <- ((`safeElemAt` otpDigitsSet) . subtract 4->Just o) +pattern OTPDigitsInt o <- ((`safeElemAt` otpDigitsSet) . subtract 4 -> Just o) where OTPDigitsInt o = S.findIndex o otpDigitsSet + 4 instance B.Binary OTPDigits where - get = do - OTPDigitsInt o <- B.get - pure o - put = B.put . OTPDigitsInt + get = do + OTPDigitsInt o <- B.get + pure o + put = B.put . OTPDigitsInt instance J.ToJSON OTPDigits where - toEncoding = J.toEncoding . OTPDigitsInt - toJSON = J.toJSON . OTPDigitsInt + toEncoding = J.toEncoding . OTPDigitsInt + toJSON = J.toJSON . OTPDigitsInt -- | A standards-compliant secret key type. Well, almost. It doesn't -- include configuration for the time period if it's time-based. data Secret :: Mode -> Type where - Sec :: { secAccount :: T.Text - , secIssuer :: Maybe T.Text - , secAlgo :: HashAlgo - , secDigits :: OTPDigits - , secKey :: BS.ByteString - } - -> Secret m + Sec :: + { secAccount :: T.Text, + secIssuer :: Maybe T.Text, + secAlgo :: HashAlgo, + secDigits :: OTPDigits, + secKey :: BS.ByteString + } -> + Secret m deriving (Generic, Show) instance B.Binary (Secret m) + instance J.ToJSON (Secret m) where - toEncoding Sec{..} = J.pairs - ( "account" J..= secAccount - <> maybe mempty ("issuer" J..=) secIssuer - <> "algorithm" J..= secAlgo - <> "digits" J..= secDigits - <> "key" J..= formatKey 4 (T.decodeUtf8 (B32.encode secKey)) - ) - toJSON Sec{..} = J.object $ - [ "account" J..= secAccount - , "algorithm" J..= secAlgo - , "digits" J..= secDigits - , "key" J..= formatKey 4 (T.decodeUtf8 (B32.encode secKey)) - ] ++ maybe [] ((:[]) . ("issuer" J..=)) secIssuer + toEncoding Sec {..} = + J.pairs + ( "account" J..= secAccount + <> maybe mempty ("issuer" J..=) secIssuer + <> "algorithm" J..= secAlgo + <> "digits" J..= secDigits + <> "key" J..= formatKey 4 (T.decodeUtf8 (B32.encode secKey)) + ) + toJSON Sec {..} = + J.object $ + [ "account" J..= secAccount, + "algorithm" J..= secAlgo, + "digits" J..= secDigits, + "key" J..= formatKey 4 (T.decodeUtf8 (B32.encode secKey)) + ] + ++ maybe [] ((: []) . ("issuer" J..=)) secIssuer -formatKey - :: Int -- ^ chunk size - -> T.Text - -> T.Text -formatKey c = T.unwords - . T.chunksOf c - . T.map toLower - . T.filter isAlphaNum +formatKey :: + -- | chunk size + Int -> + T.Text -> + T.Text +formatKey c = + T.unwords + . T.chunksOf c + . T.map toLower + . T.filter isAlphaNum -- | Print out the metadata (account name and issuer) of a 'Secret'. -describeSecret - :: Secret m - -> T.Text -describeSecret s = secAccount s <> case secIssuer s of - Nothing -> "" - Just i -> " / " <> i +describeSecret :: + Secret m -> + T.Text +describeSecret s = + secAccount s <> case secIssuer s of + Nothing -> "" + Just i -> " / " <> i instance B.Binary SomeSecretState where - get = do - m <- B.get - withSMode m $ \s -> case modeStateBinary s of - DictOnly -> do - sc <- B.get - ms <- B.get - return $ s :=> sc :*: ms - put = \case - s :=> sc :*: ms -> case modeStateBinary s of - DictOnly -> do - B.put $ fromSMode s - B.put sc - B.put ms + get = do + m <- B.get + withSMode m $ \s -> case modeStateBinary s of + DictOnly -> do + sc <- B.get + ms <- B.get + return $ s :=> sc :*: ms + put = \case + s :=> sc :*: ms -> case modeStateBinary s of + DictOnly -> do + B.put $ fromSMode s + B.put sc + B.put ms instance J.ToJSON SomeSecretState where - toEncoding (s :=> sc :*: ms) = J.pairs - ( "type" J..= fromSMode s - <> "secret" J..= sc - <> (case s of SHOTP -> "state" J..= ms - STOTP -> mempty - ) - ) - toJSON (s :=> sc :*: ms) = J.object $ - [ "type" J..= fromSMode s - , "secret" J..= sc - ] ++ case s of SHOTP -> ["state" J..= ms] - STOTP -> [] + toEncoding (s :=> sc :*: ms) = + J.pairs + ( "type" J..= fromSMode s + <> "secret" J..= sc + <> ( case s of + SHOTP -> "state" J..= ms + STOTP -> mempty + ) + ) + toJSON (s :=> sc :*: ms) = + J.object $ + [ "type" J..= fromSMode s, + "secret" J..= sc + ] + ++ case s of + SHOTP -> ["state" J..= ms] + STOTP -> [] -- | A 'Secret' coupled with its 'ModeState', existentially quantified over -- its 'Mode'. type SomeSecretState = DSum SMode (Secret :*: ModeState) -- | A list of secrets and their states, of various modes. -newtype Vault = Vault { vaultList :: [SomeSecretState] } - deriving Generic +newtype Vault = Vault {vaultList :: [SomeSecretState]} + deriving (Generic) instance B.Binary Vault + instance J.ToJSON Vault where - toEncoding l = J.pairs $ "vault" J..= vaultList l - toJSON l = J.object ["vault" J..= vaultList l] + toEncoding l = J.pairs $ "vault" J..= vaultList l + toJSON l = J.object ["vault" J..= vaultList l] -- | Generate an HTOP (counter-based) code, returning a modified state. hotp :: Secret 'HOTP -> ModeState 'HOTP -> (T.Text, ModeState 'HOTP) -hotp Sec{..} (HOTPState i) = - (formatKey 3 . T.pack $ printf fmt p, HOTPState (i + 1)) +hotp Sec {..} (HOTPState i) = + (formatKey 3 . T.pack $ printf fmt p, HOTPState (i + 1)) where fmt = "%0" ++ show (OTPDigitsInt secDigits) ++ "d" p = withSome (hashAlgo secAlgo) $ \case @@ -303,13 +328,14 @@ -- | (Purely) generate a TOTP (time-based) code, for a given time. totp_ :: Secret 'TOTP -> POSIXTime -> T.Text -totp_ Sec{..} t = withSome (hashAlgo secAlgo) $ \case - Dict a -> - let Right tparam = - OTP.mkTOTPParams a 0 30 (otpDigits secDigits) OTP.TwoSteps - in formatKey 3 . T.pack $ - printf fmt $ - OTP.totp tparam secKey (round t) +totp_ Sec {..} t = withSome (hashAlgo secAlgo) $ \case + Dict a -> + let tparam = case OTP.mkTOTPParams a 0 30 (otpDigits secDigits) OTP.TwoSteps of + Left e -> error $ "totp_: " <> e + Right x -> x + in formatKey 3 . T.pack $ + printf fmt $ + OTP.totp tparam secKey (round t) where fmt = "%0" ++ show (OTPDigitsInt secDigits) ++ "d" @@ -320,8 +346,8 @@ -- | Abstract over both 'hotp' and 'totp'. otp :: SMode m -> Secret m -> ModeState m -> IO (T.Text, ModeState m) otp = \case - SHOTP -> curry $ return . uncurry hotp - STOTP -> curry $ bitraverse totp return + SHOTP -> curry $ return . uncurry hotp + STOTP -> curry $ bitraverse totp return -- | Some sort of RankN lens and traversal over a 'SomeSecret'. Allows you -- to traverse (effectfully map) over the 'ModeState' in @@ -329,30 +355,30 @@ -- -- With this you can implement getters and setters. It's also used by the -- library to update the 'ModeState' in IO. -someSecret - :: Functor f - => (forall m. SMode m -> Secret m -> ModeState m -> f (ModeState m)) - -> SomeSecretState - -> f SomeSecretState +someSecret :: + (Functor f) => + (forall m. SMode m -> Secret m -> ModeState m -> f (ModeState m)) -> + SomeSecretState -> + f SomeSecretState someSecret f = \case - s :=> (sc :*: ms) -> (s :=>) . (sc :*:) <$> f s sc ms + s :=> (sc :*: ms) -> (s :=>) . (sc :*:) <$> f s sc ms -- | A RankN traversal over all of the 'Secret's and 'ModeState's in -- a 'Vault'. -vaultSecrets - :: Applicative f - => (forall m. SMode m -> Secret m -> ModeState m -> f (ModeState m)) - -> Vault - -> f Vault +vaultSecrets :: + (Applicative f) => + (forall m. SMode m -> Secret m -> ModeState m -> f (ModeState m)) -> + Vault -> + f Vault vaultSecrets f = (_Vault . traverse) (someSecret f) -- | A lens into the list of 'SomeSecretState's in a 'Vault'. Should be an -- Iso but we don't want a lens dependency now, do we. -_Vault - :: Functor f - => ([SomeSecretState] -> f [SomeSecretState]) - -> Vault - -> f Vault +_Vault :: + (Functor f) => + ([SomeSecretState] -> f [SomeSecretState]) -> + Vault -> + f Vault _Vault f s = Vault <$> f (vaultList s) type Parser = P.Parsec Void String @@ -360,78 +386,83 @@ -- | A parser for a otpauth URI. secretURI :: Parser SomeSecretState secretURI = do - _ <- P.string "otpauth://" - m <- otpMode - _ <- P.char '/' - (a,i) <- otpLabel - ps <- M.fromList <$> P.try param `P.sepBy` P.char '&' - sec <- case M.lookup "secret" ps of - Nothing -> fail "Required parameter 'secret' not present" - Just s -> - case decodePad s of - Just s' -> return s' - Nothing -> fail $ "Not a valid base-32 string: " ++ T.unpack s - let dig = fromMaybe (OTPDigits OTP.OTP6) $ do - d <- M.lookup "digits" ps - OTPDigitsInt o <- readMaybe $ T.unpack d - pure o - i' = i <|> M.lookup "issuer" ps - alg = fromMaybe HASHA1 $ do - al <- M.lookup "algorithm" ps - parseAlgo . T.unpack . T.map toLower $ al - secr :: forall m. Secret m - secr = Sec a i' alg dig sec + _ <- P.string "otpauth://" + m <- otpMode + _ <- P.char '/' + (a, i) <- otpLabel + ps <- M.fromList <$> P.try param `P.sepBy` P.char '&' + sec <- case M.lookup "secret" ps of + Nothing -> fail "Required parameter 'secret' not present" + Just s -> + case decodePad s of + Just s' -> return s' + Nothing -> fail $ "Not a valid base-32 string: " ++ T.unpack s + let dig = fromMaybe (OTPDigits OTP.OTP6) $ do + d <- M.lookup "digits" ps + OTPDigitsInt o <- readMaybe $ T.unpack d + pure o + i' = i <|> M.lookup "issuer" ps + alg = fromMaybe HASHA1 $ do + al <- M.lookup "algorithm" ps + parseAlgo . T.unpack . T.map toLower $ al + secr :: forall m. Secret m + secr = Sec a i' alg dig sec - withSMode m $ \case - SHOTP -> case M.lookup "counter" ps of - Nothing -> fail "Paramater 'counter' required for hotp mode" - Just (T.unpack->c) -> case readMaybe c of - Nothing -> fail $ "Could not parse 'counter' parameter: " ++ c - Just c' -> return $ SHOTP :=> secr :*: HOTPState c' - STOTP -> return $ STOTP :=> secr :*: TOTPState + withSMode m $ \case + SHOTP -> case M.lookup "counter" ps of + Nothing -> fail "Paramater 'counter' required for hotp mode" + Just (T.unpack -> c) -> case readMaybe c of + Nothing -> fail $ "Could not parse 'counter' parameter: " ++ c + Just c' -> return $ SHOTP :=> secr :*: HOTPState c' + STOTP -> return $ STOTP :=> secr :*: TOTPState where otpMode :: Parser Mode - otpMode = HOTP <$ P.string "hotp" - <|> HOTP <$ P.string "HOTP" - <|> TOTP <$ P.string "totp" - <|> TOTP <$ P.string "TOTP" + otpMode = + HOTP <$ P.string "hotp" + <|> HOTP <$ P.string "HOTP" + <|> TOTP <$ P.string "totp" + <|> TOTP <$ P.string "TOTP" otpLabel :: Parser (T.Text, Maybe T.Text) otpLabel = do - x <- P.some (P.try (mfilter (/= ':') uriChar)) - rest <- Just <$> ( colon - *> P.manyTill (P.try uriChar <|> uriSpace) (P.char '?') - ) + x <- P.some (P.try (mfilter (/= ':') uriChar)) + rest <- + Just + <$> ( colon + *> P.manyTill (P.try uriChar <|> uriSpace) (P.char '?') + ) <|> Nothing <$ P.char '?' return $ case rest of Nothing -> (T.pack . U.decode $ x, Nothing) - Just y -> (T.pack . U.decode $ y, Just . T.pack . U.decode $ x) + Just y -> (T.pack . U.decode $ y, Just . T.pack . U.decode $ x) param :: Parser (T.Text, T.Text) param = do k <- T.map toLower . T.pack <$> P.some (P.try uriChar) _ <- P.char '=' v <- T.pack <$> P.some (P.try uriChar) return (k, v) - uriChar = P.try (P.satisfy U.isAllowed) - <|> P.char '@' - <|> (do x <- U.decode <$> sequence [P.char '%', P.hexDigitChar, P.hexDigitChar] - case x of - [y] -> return y - _ -> fail "Invalid URI escape code" - ) - colon = void (P.char ':') <|> void (P.string "%3A") + uriChar = + P.try (P.satisfy U.isAllowed) + <|> P.char '@' + <|> ( do + x <- U.decode <$> sequence [P.char '%', P.hexDigitChar, P.hexDigitChar] + case x of + [y] -> return y + _ -> fail "Invalid URI escape code" + ) + colon = void (P.char ':') <|> void (P.string "%3A") uriSpace = ' ' <$ (void P.space <|> void (P.string "%20")) -- | Parse a valid otpauth URI and initialize its state. -- -- See -parseSecretURI - :: String - -> Either String SomeSecretState -parseSecretURI s = first P.errorBundlePretty $ +parseSecretURI :: + String -> + Either String SomeSecretState +parseSecretURI s = + first P.errorBundlePretty $ P.parse secretURI "secret URI" s safeElemAt :: Int -> S.Set a -> Maybe a safeElemAt i s | i < S.size s = Just (S.elemAt i s) - | otherwise = Nothing - + | otherwise = Nothing diff --git a/src/Encrypted.hs b/src/Encrypted.hs --- a/src/Encrypted.hs +++ b/src/Encrypted.hs @@ -1,5 +1,5 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE StrictData #-} +{-# LANGUAGE StrictData #-} {-# LANGUAGE TupleSections #-} -- | @@ -20,76 +20,75 @@ -- deserialization into encrypted values. -- -- Might be pulled out to an external package some day. --- - -module Encrypted ( - Enc(..) - , mkEnc - , overEnc - , getEnc - , withEnc - ) where +module Encrypted + ( Enc (..), + mkEnc, + overEnc, + getEnc, + withEnc, + ) +where -import GHC.Generics (Generic) -import qualified Crypto.Gpgme as G -import qualified Data.Binary as B +import qualified Crypto.Gpgme as G +import qualified Data.Binary as B import qualified Data.ByteString.Lazy as BSL +import GHC.Generics (Generic) -- | An @'Enc' a@ abstracts over a encrypted @a@. -- -- Has a useful 'Binary' instance, which allows type-safe deserialization -- into encrypted values. -data Enc a = Enc { encBytes :: G.Encrypted } - deriving Generic +data Enc a = Enc {encBytes :: G.Encrypted} + deriving (Generic) instance B.Binary (Enc a) -- | A variation of 'overEnc' that allows the user to also return a value -- produced from the decrypted value. Re-encrypts the changed value using -- the given GnuPG key. -withEnc - :: B.Binary a - => G.Ctx - -> G.Key - -> Enc a - -> (a -> IO (b, a)) - -> IO (b, Enc a) +withEnc :: + (B.Binary a) => + G.Ctx -> + G.Key -> + Enc a -> + (a -> IO (b, a)) -> + IO (b, Enc a) withEnc c k e f = do - x <- getEnc c e - (o, y) <- f x - e' <- mkEnc c k y - return (o, e') + x <- getEnc c e + (o, y) <- f x + e' <- mkEnc c k y + return (o, e') -- | Modify an encrypted value with a given @a -> IO a@ function, -- re-encrypting it with the given GnuPG key. The decrypted value never -- leaves the closure. -overEnc - :: B.Binary a - => G.Ctx - -> G.Key - -> Enc a - -> (a -> IO a) - -> IO (Enc a) +overEnc :: + (B.Binary a) => + G.Ctx -> + G.Key -> + Enc a -> + (a -> IO a) -> + IO (Enc a) overEnc c k e f = fmap snd . withEnc c k e $ (fmap ((),) . f) -- | Extract a value from an 'Enc', using a compatible key in the GnuPG -- environment. -getEnc - :: B.Binary a - => G.Ctx - -> Enc a - -> IO a +getEnc :: + (B.Binary a) => + G.Ctx -> + Enc a -> + IO a getEnc c (Enc e) = do - Right x <- fmap (B.decode . BSL.fromStrict) <$> G.decrypt c e - return x + Right x <- fmap (B.decode . BSL.fromStrict) <$> G.decrypt c e + return x -- | Wrap a value into an 'Enc', using a given GnuPG key. -mkEnc - :: B.Binary a - => G.Ctx - -> G.Key - -> a - -> IO (Enc a) +mkEnc :: + (B.Binary a) => + G.Ctx -> + G.Key -> + a -> + IO (Enc a) mkEnc c k x = do - Right e' <- G.encrypt c [k] G.NoFlag . BSL.toStrict . B.encode $ x - return (Enc e') + Right e' <- G.encrypt c [k] G.NoFlag . BSL.toStrict . B.encode $ x + return (Enc e')