otp-authenticator (empty) → 0.1.0.0
raw patch · 12 files changed
+1088/−0 lines, 12 filesdep +aesondep +basedep +bifunctorssetup-changed
Dependencies added: aeson, base, bifunctors, binary, bytestring, containers, cryptonite, dependent-sum, filepath, h-gpgme, haskeline, microlens, one-time-password, optparse-applicative, otp-authenticator, sandi, singletons, text, time, transformers, trifecta, type-combinators, unix, uri-encode, witherable, yaml
Files
- CHANGELOG.md +6/−0
- LICENSE +30/−0
- README.md +48/−0
- Setup.hs +2/−0
- app/Main.hs +91/−0
- otp-authenticator.cabal +88/−0
- src/Authenticator/Actions.hs +200/−0
- src/Authenticator/Common.hs +31/−0
- src/Authenticator/Options.hs +209/−0
- src/Authenticator/Vault.hs +319/−0
- src/Encrypted.hs +62/−0
- test/Spec.hs +2/−0
+ CHANGELOG.md view
@@ -0,0 +1,6 @@+Version 0.1.0.0+================++<https://github.com/mstksg/uncertain/releases/tag/v0.1.0.0>++* Initial release.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Justin Le (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Justin Le nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,48 @@+# otp-authenticator++Simple tool for keeping track of your one-time pad two-factor authentication+keys; basically a command-line version of the canonical [Google Authenticator+App][gauth].++[gauth]: https://github.com/google/google-authenticator++The library uses GnuPG (through *h-gpgme*) to safely encrypt your secret keys.+The first time you use it, it asks for a fingerprint to use for encryption.+Currently *GnuPG 1.x* has some issues with *h-gpgme* when asking for keys, so+*GPG 2.x* is recommended. Keys are stored, encrypted, at `~/.otp-auth.vault`+by default.++Instructions are available through `--help`, but the basics are:++```bash+# interactively add a new key+otp-auth add++# interactively add a new key by entering the secret key uri+# (following the otpauth protocol)+otp-auth add --uri++# view all time-based codes and cached counter-based codes+otp-auth view++# list accounts, do not display codes+otp-auth view --list++# generate a new counter-based code+otp-auth gen ID++# edit the metadata and delete codes+otp-auth edit ID+otp-auth delete ID++# dump all stored data as json (and as yaml)+otp-auth dump+otp-auth dump --yaml+```++You can edit configuration at `~/.otp-auth.yaml`, the basic schema is:++```yaml+fingerprint: ABCDEF12+vault: /home/robert/.otp-auth.vault+```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# 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+++main :: IO ()+main = G.withCtx "~/.gnupg" "C" G.OpenPGP $ \ctx -> do+ (cmd, echoPass, vault, fingerprint) <- getOptions++ k <- for fingerprint $ \fing -> do+ 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 ->+ if isDoesNotExistError e+ then case (,) <$> k <*> fingerprint of+ Nothing -> do+ putStrLn "No vault found; please try again with a fingerprint to create new vault."+ exitFailure+ Just (k', fing) -> do+ printf "No vault found; generating new vault with fingerprint %s ...\n" $+ T.decodeUtf8 fing+ (,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) -> do+ 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+ 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+ return Nothing++ case e' of+ Just changed -> B.encodeFile vault changed+ Nothing | mkNewVault -> B.encodeFile vault e+ | otherwise -> return ()
+ otp-authenticator.cabal view
@@ -0,0 +1,88 @@+name: otp-authenticator+version: 0.1.0.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+ version of the canonical [Google Authenticator+ App][gauth].+ .+ [gauth]: https://github.com/google/google-authenticator+ .+ The library uses GnuPG (through *h-gpgme*) to safely+ encrypt your secret keys. The first time you use it, it+ asks for a fingerprint to use for encryption. Currently+ *GnuPG 1.x* has some issues with *h-gpgme* when asking+ for keys, so *GPG 2.x* is recommended. Keys are stored,+ encrypted, at `~/.otp-auth.vault` by default.+homepage: https://github.com/mstksg/otp-authenticator+license: BSD3+license-file: LICENSE+author: Justin Le+maintainer: justin@jle.im+copyright: (c) Justin Le 2017+category: CLI, Security+build-type: Simple+extra-source-files: README.md, CHANGELOG.md+cabal-version: >=1.10++library+ hs-source-dirs: src+ exposed-modules: Authenticator.Vault+ Encrypted+ Authenticator.Common+ Authenticator.Actions+ Authenticator.Options+ build-depends: base >= 4.9 && < 5+ , aeson+ , sandi+ , haskeline+ , bifunctors+ , binary+ , bytestring+ , containers+ , cryptonite+ , dependent-sum+ , filepath+ , h-gpgme+ , microlens+ , one-time-password+ , optparse-applicative+ , singletons+ , text+ , time+ , transformers+ , trifecta+ , type-combinators+ , unix+ , uri-encode+ , witherable+ , yaml+ default-language: Haskell2010+ ghc-options: -Wall++executable otp-auth+ hs-source-dirs: app+ main-is: Main.hs+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall+ build-depends: base+ , aeson+ , binary+ , bytestring+ , h-gpgme+ , otp-authenticator+ , text+ , yaml+ default-language: Haskell2010++test-suite otp-authenticator-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , otp-authenticator+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010++source-repository head+ type: git+ location: https://github.com/mstksg/otp-authenticator
+ src/Authenticator/Actions.hs view
@@ -0,0 +1,200 @@+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeOperators #-}++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 Data.Char+import Data.Dependent.Sum+import Data.Foldable+import Data.Functor+import Data.Maybe+import Data.Monoid+import Data.Singletons+import Data.String+import Data.Type.Conjunction+import Data.Witherable+import Lens.Micro+import Options.Applicative+import Prelude hiding (filter)+import System.Exit+import Text.Printf+import Text.Read (readMaybe)+import qualified Data.Text as T+import qualified System.Console.Haskeline as L++viewVault+ :: Bool+ -> Either Int (Maybe T.Text, Maybe T.Text)+ -> Vault+ -> IO ()+viewVault l filts vt = do+ (n,found) <- runWriterT . flip execStateT 1 $ vaultSecrets (\(sc :: Secret m) 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 sing @_ @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+ ) vt+ 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!"++addSecret :: Bool -> Bool -> Vault -> IO Vault+addSecret echoPass u vt = do+ -- 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?: "+ case parseSecretURI q of+ Left err -> do+ putStrLn "Parse error:"+ putStrLn err+ exitFailure+ Right d ->+ return d+ else mkSecret echoPass+ putStrLn "Added succesfully!"+ return $+ vt & _Vault %~ (++ [dsc])++genSecret :: 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++editSecret :: 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+ Just desc -> do+ printf "%s edited successfuly!\n" desc+ return vt'++deleteSecret :: 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'++mkSecret :: Bool -> IO (DSum Sing (Secret :&: ModeState))+mkSecret echoPass = L.runInputT hlSettings $ do+ 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 = Sec (T.pack a) (T.pack <$> i') HASHA1 6 <$> 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'+ _ -> do+ 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'+ }
+ src/Authenticator/Common.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Authenticator.Common (+ hlSettings+ , decodePad+ ) where++import Control.Monad.IO.Class+import Data.Char+import Data.Semigroup+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 System.Console.Haskeline as L++hlSettings :: forall m. MonadIO m => L.Settings m+hlSettings = (L.defaultSettings @m) { L.complete = L.noCompletion + , L.autoAddHistory = False+ }++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+ where+ p = fromIntegral $ ord '='
+ src/Authenticator/Options.hs view
@@ -0,0 +1,209 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TupleSections #-}++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.Aeson.Types 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+++data DumpType = DTYaml | DTJSON++data Cmd = Add Bool+ | View 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 Config = Conf { cFingerprint :: Maybe T.Text+ , cVault :: Maybe FilePath+ }+ deriving (Generic)++confJsonOpts :: J.Options+confJsonOpts = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '-' . drop 1 }+instance J.FromJSON Config where+ parseJSON = J.genericParseJSON confJsonOpts+instance J.ToJSON Config where+ 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")+ )+ )+ where+ 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."+ )+ <*> (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"+ )++-- | 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"+ )++ oConfig' <- case oConfig of+ Just fp -> return fp+ Nothing -> do+ ue <- getUserEntryForID =<< getEffectiveUserID+ return $ homeDirectory ue </> ".otp-auth.yaml"++ (Conf{..}, mkNewConf) <- do+ (c0, mkNew) <- ((, False) . Y.decodeEither <$> BS.readFile 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 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+ 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)+ Nothing -> L.runInputT hlSettings $ fmap T.pack <$> L.getInputLine "Fingerprint? "+ Y.encodeFile oConfig' $ Conf fing (Just vault)+ return fing+ else+ return cFingerprint++ let fingerprint = oFingerprint <|> (T.encodeUtf8 <$> cFingerprint')++ return (oCmd, oEchoPass, vault, fingerprint)++-- | is str from optparse-applicative 0.14 and above+str :: IsString s => ReadM s+str = fromString <$> O.str
+ src/Authenticator/Vault.hs view
@@ -0,0 +1,319 @@+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeInType #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}++module Authenticator.Vault (+ Mode(..)+ , Sing(SHOTP, STOTP)+ , SMode, HOTPSym0, TOTPSym0+ , HashAlgo(..)+ , parseAlgo+ , Secret(..)+ , ModeState(..)+ , Vault(..)+ , _Vault+ , hotp+ , totp+ , totp_+ , otp+ , someotp+ , someSecret+ , vaultSecrets+ , describeSecret+ , secretURI+ , parseSecretURI+ ) where++import Authenticator.Common+import Control.Applicative+import Control.Monad+import Crypto.Hash.Algorithms+import Data.Bitraversable+import Data.Char+import Data.Dependent.Sum+import Data.Kind+import Data.Maybe+import Data.Semigroup+import Data.Singletons+import Data.Singletons.TH+import Data.Time.Clock+import Data.Type.Combinator+import Data.Type.Conjunction+import Data.Word+import GHC.Generics (Generic)+import Text.Printf+import Text.Read (readMaybe)+import Type.Class.Higher+import Type.Class.Witness+import qualified Codec.Binary.Base32 as B32+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.OTP as OTP+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Network.URI.Encode as U+import qualified Text.Trifecta as P++$(singletons [d|+ data Mode = HOTP | TOTP+ deriving (Generic, Show)+ |])++instance B.Binary Mode+instance J.ToJSON Mode where+ toJSON HOTP = J.toJSON @T.Text "hotp"+ toJSON TOTP = J.toJSON @T.Text "totp"++data family ModeState :: Mode -> Type+data instance ModeState 'HOTP =+ HOTPState { hotpCounter :: Word64+ }+ deriving (Generic, Show)+data instance ModeState 'TOTP = TOTPState+ 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 ]++instance J.ToJSON (ModeState 'TOTP)++modeStateBinary :: Sing m -> Wit1 B.Binary (ModeState m)+modeStateBinary = \case+ SHOTP -> Wit1+ STOTP -> Wit1++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"++hashAlgo :: HashAlgo -> SomeC HashAlgorithm I+hashAlgo HASHA1 = SomeC (I SHA1 )+hashAlgo HASHA256 = SomeC (I SHA256)+hashAlgo HASHA512 = SomeC (I SHA512)++parseAlgo :: String -> Maybe HashAlgo+parseAlgo = (`lookup` algos) . map toLower . unwords . words+ where+ algos = [("sha1", HASHA1)+ ,("sha256", HASHA256)+ ,("sha512", HASHA512)+ ]++-- TODO: add period?+data Secret :: Mode -> Type where+ Sec :: { secAccount :: T.Text+ , secIssuer :: Maybe T.Text+ , secAlgo :: HashAlgo+ , secDigits :: Word+ , 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++formatKey :: Int -> T.Text -> T.Text+formatKey c = T.unwords+ . T.chunksOf c+ . T.map toLower+ . T.filter isAlphaNum++describeSecret :: Secret m -> T.Text+describeSecret s = secAccount s <> case secIssuer s of+ Nothing -> ""+ Just i -> " / " <> i++instance B.Binary (DSum Sing (Secret :&: ModeState)) where+ get = do+ m <- B.get+ withSomeSing m $ \s -> modeStateBinary s // do+ sc <- B.get+ ms <- B.get+ return $ s :=> sc :&: ms+ put = \case+ s :=> sc :&: ms -> modeStateBinary s // do+ B.put $ fromSing s+ B.put sc+ B.put ms++instance J.ToJSON (DSum Sing (Secret :&: ModeState)) where+ toEncoding (s :=> sc :&: ms) = J.pairs+ ( "type" J..= fromSing s+ <> "secret" J..= sc+ <> (case s of SHOTP -> "state" J..= ms+ STOTP -> mempty+ )+ )+ toJSON (s :=> sc :&: ms) = J.object $+ [ "type" J..= fromSing s+ , "secret" J..= sc+ ] ++ case s of SHOTP -> ["state" J..= ms]+ STOTP -> []++data Vault = Vault { vaultList :: [DSum Sing (Secret :&: ModeState)] }+ 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]++hotp :: Secret 'HOTP -> ModeState 'HOTP -> (T.Text, ModeState 'HOTP)+hotp Sec{..} (HOTPState i) =+ (formatKey 3 . T.pack $ printf fmt p, HOTPState (i + 1))+ where+ fmt = "%0" ++ show secDigits ++ "d"+ p = hashAlgo secAlgo >>~ \(I a) -> OTP.hotp a secKey i secDigits++totp_ :: Secret 'TOTP -> UTCTime -> T.Text+totp_ Sec{..} t = hashAlgo secAlgo >>~ \(I a) -> formatKey 3 . T.pack $+ printf fmt $ OTP.totp a secKey (30 `addUTCTime` t) 30 secDigits+ where+ fmt = "%0" ++ show secDigits ++ "d"++totp :: Secret 'TOTP -> IO T.Text+totp s = totp_ s <$> getCurrentTime++otp :: forall m. SingI m => Secret m -> ModeState m -> IO (T.Text, ModeState m)+otp = case sing @_ @m of+ SHOTP -> curry $ return . uncurry hotp+ STOTP -> curry $ bitraverse totp return++someotp :: DSum Sing (Secret :&: ModeState) -> IO (T.Text, DSum Sing (Secret :&: ModeState))+someotp = getComp . someSecret (\s -> Comp . otp s)++someSecret+ :: Functor f+ => (forall m. SingI m => Secret m -> ModeState m -> f (ModeState m))+ -> DSum Sing (Secret :&: ModeState)+ -> f (DSum Sing (Secret :&: ModeState))+someSecret f = \case+ s :=> (sc :&: ms) -> withSingI s $ ((s :=>) . (sc :&:)) <$> f sc ms++deriving instance (Functor f, Functor g) => Functor (f :.: g)++vaultSecrets+ :: Applicative f+ => (forall m. SingI m => Secret m -> ModeState m -> f (ModeState m))+ -> Vault+ -> f Vault+vaultSecrets f = (_Vault . traverse) (someSecret f)++_Vault+ :: Functor f+ => ([DSum Sing (Secret :&: ModeState)] -> f [DSum Sing (Secret :&: ModeState)])+ -> Vault+ -> f Vault+_Vault f s = Vault <$> f (vaultList s)++secretURI :: P.Parser (DSum Sing (Secret :&: ModeState))+secretURI = do+ _ <- P.string "otpauth://"+ m <- otpMode+ _ <- P.char '/'+ (a,i) <- otpLabel+ ps <- M.fromList <$> 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 6 $ do+ d <- M.lookup "digits" ps+ readMaybe @Word $ T.unpack d+ 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++ withSomeSing 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 :: P.Parser Mode+ otpMode = HOTP <$ P.string "hotp"+ <|> HOTP <$ P.string "HOTP"+ <|> TOTP <$ P.string "totp"+ <|> TOTP <$ P.string "TOTP"+ otpLabel :: P.Parser (T.Text, Maybe T.Text)+ otpLabel = do+ x <- P.some (P.try (mfilter (/= ':') uriChar))+ rest <- Just <$> (colon+ *> P.many (P.try uriSpace)+ *> P.some (P.try uriChar)+ <* 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)+ param :: P.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.satisfy U.isAllowed+ <|> P.char '@'+ <|> (do x <- U.decode <$> sequence [P.char '%', P.hexDigit, P.hexDigit]+ 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")++parseSecretURI+ :: String+ -> Either String (DSum Sing (Secret :&: ModeState))+parseSecretURI s = case P.parseString secretURI mempty s of+ P.Success r -> Right r+ P.Failure e -> Left (show e)
+ src/Encrypted.hs view
@@ -0,0 +1,62 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE StrictData #-}+{-# LANGUAGE TupleSections #-}++module Encrypted (+ Enc(..)+ , withEnc+ , overEnc+ , getEnc+ , mkEnc+ ) where++import GHC.Generics (Generic)+import qualified Crypto.Gpgme as G+import qualified Data.Binary as B+import qualified Data.ByteString.Lazy as BSL++data Enc a = Enc { encBytes :: G.Encrypted }+ deriving Generic++instance B.Binary (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')++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)++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++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')
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"