diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +Version 0.1.0.1 +================ + + + +* Added documentation. +* Minor cleanup in implementation. + Version 0.1.0.0 ================ diff --git a/otp-authenticator.cabal b/otp-authenticator.cabal --- a/otp-authenticator.cabal +++ b/otp-authenticator.cabal @@ -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 + . . - 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 diff --git a/src/Authenticator/Actions.hs b/src/Authenticator/Actions.hs --- a/src/Authenticator/Actions.hs +++ b/src/Authenticator/Actions.hs @@ -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 diff --git a/src/Authenticator/Common.hs b/src/Authenticator/Common.hs --- a/src/Authenticator/Common.hs +++ b/src/Authenticator/Common.hs @@ -1,6 +1,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 diff --git a/src/Authenticator/Options.hs b/src/Authenticator/Options.hs --- a/src/Authenticator/Options.hs +++ b/src/Authenticator/Options.hs @@ -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 diff --git a/src/Authenticator/Vault.hs b/src/Authenticator/Vault.hs --- a/src/Authenticator/Vault.hs +++ b/src/Authenticator/Vault.hs @@ -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 . +-- + + 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 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) diff --git a/src/Encrypted.hs b/src/Encrypted.hs --- a/src/Encrypted.hs +++ b/src/Encrypted.hs @@ -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