otp-authenticator 0.1.1.0 → 0.1.2.0
raw patch · 9 files changed
+932/−746 lines, 9 filessetup-changed
Files
- CHANGELOG.md +9/−0
- Setup.hs +1/−0
- app/Main.hs +63/−60
- otp-authenticator.cabal +4/−5
- src/Authenticator/Actions.hs +248/−181
- src/Authenticator/Common.hs +27/−26
- src/Authenticator/Options.hs +247/−171
- src/Authenticator/Vault.hs +286/−255
- src/Encrypted.hs +47/−48
CHANGELOG.md view
@@ -1,3 +1,12 @@+Version 0.1.2.0+================++*January 15, 2024*++<https://github.com/mstksg/uncertain/releases/tag/v0.1.2.0>++* Json output for view command+ Version 0.1.1.0 ================
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
app/Main.hs view
@@ -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 ()
otp-authenticator.cabal view
@@ -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
src/Authenticator/Actions.hs view
@@ -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'+ }
src/Authenticator/Common.hs view
@@ -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 '='
src/Authenticator/Options.hs view
@@ -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
src/Authenticator/Vault.hs view
@@ -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 <https://github.com/google/google-authenticator>.------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 <https://github.com/google/google-authenticator/wiki/Key-Uri-Format>-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
src/Encrypted.hs view
@@ -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')