otp-authenticator 0.1.0.0 → 0.1.0.1

raw patch · 7 files changed

+199/−39 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• otp-authenticator.cabal +8/−8
• src/Authenticator/Actions.hs +42/−7
• src/Authenticator/Common.hs +15/−0
• src/Authenticator/Options.hs +15/−0
• src/Authenticator/Vault.hs +76/−22
• src/Encrypted.hs +35/−2

@@ -1,3 +1,11 @@+Version 0.1.0.1+================++<https://github.com/mstksg/uncertain/releases/tag/v0.1.0.1>++*   Added documentation.+*   Minor cleanup in implementation.+ Version 0.1.0.0 ================ 

@@ -1,18 +1,16 @@ name:                otp-authenticator-version:             0.1.0.0+version:             0.1.0.1 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+                     version of the canonical+                     <https://github.com/google/google-authenticator google authenticator app>.                      .-                     The library uses GnuPG (through *h-gpgme*) to safely+                     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,+                     /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@@ -24,6 +22,8 @@ build-type:          Simple extra-source-files:  README.md, CHANGELOG.md cabal-version:       >=1.10+tested-with:         GHC == 8.0.2+                   , GHC == 8.2.1  library   hs-source-dirs:      src

@@ -4,6 +4,22 @@ {-# LANGUAGE TypeApplications    #-} {-# LANGUAGE TypeOperators       #-} +-- |+-- Module      : Authenticator.Actions+-- Description : Simple CLI actions for 'Vault's.+-- Copyright   : (c) Justin Le 2017+-- License     : MIT+-- Maintainer  : justin@jle.im+-- Stability   : unstable+-- Portability : portable+--+-- Basic actions to manipulate 'Vault's.  The @otp-auth@ executable is+-- a thin wrapper over these actions.+--+-- See 'Cmd'.+--++ module Authenticator.Actions (     viewVault   , addSecret@@ -39,9 +55,10 @@ import qualified Data.Text                  as T import qualified System.Console.Haskeline   as L +-- | View secrets, generating codes for time-based keys. viewVault-    :: Bool-    -> Either Int (Maybe T.Text, Maybe T.Text)+    :: 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@@ -69,7 +86,12 @@       Left i   -> printf "ID %d not found!\n" i *> exitFailure       Right _  -> putStrLn "No matches found!" -addSecret :: Bool -> Bool -> Vault -> IO Vault+-- | Add a secret, interactively.+addSecret+    :: Bool         -- ^ Echo back password entry+    -> Bool         -- ^ If 'True', add via otpauth protocol URI+    -> Vault+    -> IO Vault addSecret echoPass u vt = do     -- TODO: verify b32?     dsc <- if u@@ -90,7 +112,12 @@     return $       vt & _Vault %~ (++ [dsc]) -genSecret :: Int -> Vault -> IO (Maybe (String, Vault))+-- | 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 n vt = do     res <- runMaybeT . runWriterT . forOf (_Vault . ix (n - 1)) vt $ \case       s :=> sc :&: ms -> @@ -112,7 +139,11 @@           printf "No item with ID %d found.\n" n           exitFailure -editSecret :: Int -> Vault -> IO Vault+-- | 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@@ -129,7 +160,11 @@         printf "%s edited successfuly!\n" desc         return vt' -deleteSecret :: Int -> Vault -> IO Vault+-- | 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@@ -150,7 +185,7 @@       exitFailure     return vt' -mkSecret :: Bool -> IO (DSum Sing (Secret :&: ModeState))+mkSecret :: Bool -> IO SomeSecretState mkSecret echoPass = L.runInputT hlSettings $ do     a <- (mfilter (not . null) <$> L.getInputLine "Account?: ") >>= \case       Nothing -> liftIO $ putStrLn "Account required" >> exitFailure

@@ -1,6 +1,19 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications    #-} +-- |+-- Module      : Authenticator.Common+-- Description : Utilty functions+-- Copyright   : (c) Justin Le 2017+-- License     : MIT+-- Maintainer  : justin@jle.im+-- Stability   : unstable+-- Portability : portable+--+-- Common utility functions and values used throughout the library.+--++ module Authenticator.Common (     hlSettings   , decodePad@@ -15,11 +28,13 @@ import qualified Data.Text.Encoding       as T 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                                     } +-- | Pad and decode a base32-encoded value from its 'Text' prepresentation. decodePad :: T.Text -> Maybe BS.ByteString decodePad = either (const Nothing) Just           . B32.decode

@@ -3,6 +3,19 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections   #-} +-- |+-- Module      : Authenticator.Options+-- Description : Options for the @otp-auth@ executable+-- Copyright   : (c) Justin Le 2017+-- License     : MIT+-- Maintainer  : justin@jle.im+-- Stability   : unstable+-- Portability : portable+--+-- Load options for the @otp-auth@ executable.+--++ module Authenticator.Options (     Cmd(..)   , DumpType(..)@@ -34,8 +47,10 @@ import qualified System.Console.Haskeline   as L  +-- | 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

@@ -18,6 +18,22 @@ {-# LANGUAGE ViewPatterns         #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +-- |+-- Module      : Authenticator.Vault+-- Description : Secrets and storage for OTP keys.+-- Copyright   : (c) Justin Le 2017+-- License     : MIT+-- Maintainer  : justin@jle.im+-- Stability   : unstable+-- Portability : portable+--+-- Types for storing, serializing, accessing OTP keys.  Gratuitous+-- type-level programming here for no reason because I have issues.+--+-- Based off of <https://github.com/google/google-authenticator>.+--++ module Authenticator.Vault (     Mode(..)   , Sing(SHOTP, STOTP)@@ -26,13 +42,13 @@   , parseAlgo   , Secret(..)   , ModeState(..)+  , SomeSecretState   , Vault(..)   , _Vault   , hotp   , totp   , totp_   , otp-  , someotp   , someSecret   , vaultSecrets   , describeSecret@@ -72,21 +88,29 @@ import qualified Network.URI.Encode     as U import qualified Text.Trifecta          as P -$(singletons [d|-  data Mode = HOTP | TOTP-    deriving (Generic, Show)-  |])+-- | OTP generation mode+data Mode+    -- | Counter-based+    = HOTP+    -- | Time-based+    | TOTP+  deriving (Generic, Show) +genSingletons [''Mode]+ instance B.Binary Mode instance J.ToJSON Mode where     toJSON HOTP = J.toJSON @T.Text "hotp"     toJSON TOTP = J.toJSON @T.Text "totp" +-- | A data family consisting of the state required by each mode. data family ModeState :: Mode -> Type-data instance ModeState 'HOTP =-    HOTPState { hotpCounter :: Word64-              }++-- | For 'HOTP' (counter-based) mode, the state is the current counter.+data instance ModeState 'HOTP = HOTPState { hotpCounter :: Word64 }   deriving (Generic, Show)++-- | For 'TOTP' (time-based) mode, there is no state. data instance ModeState 'TOTP = TOTPState   deriving (Generic, Show) @@ -104,6 +128,7 @@     SHOTP -> Wit1     STOTP -> Wit1 +-- | Which OTP-approved hash algorithm to use? data HashAlgo = HASHA1 | HASHA256 | HASHA512   deriving (Generic, Show) @@ -113,11 +138,13 @@     toJSON HASHA256 = J.toJSON @T.Text "sha256"     toJSON HASHA512 = J.toJSON @T.Text "sha512" +-- | Generate the /cryptonite/ 'HashAlgorithm' instance. hashAlgo :: HashAlgo -> SomeC HashAlgorithm I hashAlgo HASHA1   = SomeC (I SHA1  ) hashAlgo HASHA256 = SomeC (I SHA256) hashAlgo HASHA512 = SomeC (I SHA512) +-- | Parse a hash algorithm string into the appropriate 'HashAlgo'. parseAlgo :: String -> Maybe HashAlgo parseAlgo = (`lookup` algos) . map toLower . unwords . words   where@@ -126,7 +153,8 @@             ,("sha512", HASHA512)             ] --- TODO: add period?+-- | 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@@ -153,18 +181,24 @@         , "key"       J..= formatKey 4 (T.decodeUtf8 (B32.encode secKey))         ] ++ maybe [] ((:[]) . ("issuer" J..=)) secIssuer -formatKey :: Int -> T.Text -> T.Text+formatKey+    :: Int      -- ^ chunk size+    -> T.Text+    -> T.Text formatKey c = T.unwords           . T.chunksOf c           . T.map toLower           . T.filter isAlphaNum -describeSecret :: Secret m -> T.Text+-- | 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 -instance B.Binary (DSum Sing (Secret :&: ModeState)) where+instance B.Binary SomeSecretState where     get = do       m <- B.get       withSomeSing m $ \s -> modeStateBinary s // do@@ -177,7 +211,7 @@         B.put sc         B.put ms -instance J.ToJSON (DSum Sing (Secret :&: ModeState)) where+instance J.ToJSON SomeSecretState where     toEncoding (s :=> sc :&: ms) = J.pairs         ( "type"   J..= fromSing s        <> "secret" J..= sc@@ -191,7 +225,12 @@         ] ++ case s of SHOTP -> ["state" J..= ms]                        STOTP -> [] -data Vault = Vault { vaultList :: [DSum Sing (Secret :&: ModeState)] }+-- | 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.+data Vault = Vault { vaultList :: [SomeSecretState] }   deriving Generic  instance B.Binary Vault@@ -199,6 +238,7 @@     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))@@ -206,33 +246,41 @@     fmt = "%0" ++ show secDigits ++ "d"     p = hashAlgo secAlgo >>~ \(I a) -> OTP.hotp a secKey i secDigits +-- | (Purely) generate a TOTP (time-based) code, for a given time. 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" +-- | Generate a TOTP (time-based) code in IO for the current time. totp :: Secret 'TOTP -> IO T.Text totp s = totp_ s <$> getCurrentTime +-- | Abstract over both 'hotp' and 'totp'. 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)-+-- | Some sort of RankN lens and traversal over a 'SomeSecret'.  Allows you+-- to traverse (effectfully map) over the 'ModeState' in+-- a 'SomeSecretState', with access to the 'Secret' as well.+--+-- 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. SingI m => Secret m -> ModeState m -> f (ModeState m))-    -> DSum Sing (Secret :&: ModeState)-    -> f (DSum Sing (Secret :&: ModeState))+    -> SomeSecretState+    -> f SomeSecretState someSecret f = \case     s :=> (sc :&: ms) -> withSingI s $ ((s :=>) . (sc :&:)) <$> f sc ms  deriving instance (Functor f, Functor g) => Functor (f :.: g) +-- | A RankN traversal over all of the 'Secret's and 'ModeState's in+-- a 'Vault'. vaultSecrets     :: Applicative f     => (forall m. SingI m => Secret m -> ModeState m -> f (ModeState m))@@ -240,14 +288,17 @@     -> 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-    => ([DSum Sing (Secret :&: ModeState)] -> f [DSum Sing (Secret :&: ModeState)])+    => ([SomeSecretState] -> f [SomeSecretState])     -> Vault     -> f Vault _Vault f s = Vault <$> f (vaultList s) -secretURI :: P.Parser (DSum Sing (Secret :&: ModeState))+-- | A parser for a otpauth URI.+secretURI :: P.Parser SomeSecretState secretURI = do     _ <- P.string "otpauth://"     m <- otpMode@@ -311,9 +362,12 @@     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 (DSum Sing (Secret :&: ModeState))+    -> Either String SomeSecretState parseSecretURI s = case P.parseString secretURI mempty s of     P.Success r -> Right r     P.Failure e -> Left (show e)

@@ -2,12 +2,32 @@ {-# LANGUAGE StrictData    #-} {-# LANGUAGE TupleSections #-} +-- |+-- Module      : Encrypted+-- Description : Abstracting over an encrypted value with gpgme and gnupg+-- Copyright   : (c) Justin Le 2017+-- License     : MIT+-- Maintainer  : justin@jle.im+-- Stability   : unstable+-- Portability : portable+--+-- Basically provides @'Enc' a@, which abstracts over an encrypted @a@.+-- Can only be read by invoking GnuPG in 'IO', where the user needs to+-- provide their key to decrypt.+--+-- One main advantage is that an @'Enc' a@ can be seriealized and+-- deserialized using its 'Binary' instance, providing type-safe+-- deserialization into encrypted values.+--+-- Might be pulled out to an external package some day.+--+ module Encrypted (     Enc(..)-  , withEnc+  , mkEnc   , overEnc   , getEnc-  , mkEnc+  , withEnc   ) where  import           GHC.Generics         (Generic)@@ -15,11 +35,18 @@ import qualified Data.Binary          as B import qualified Data.ByteString.Lazy as BSL +-- | 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  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@@ -33,6 +60,9 @@     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@@ -42,6 +72,8 @@     -> 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@@ -51,6 +83,7 @@     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