diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,6 @@ +Version 0.1.0.0 +================ + + + +* Initial release. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 () diff --git a/otp-authenticator.cabal b/otp-authenticator.cabal new file mode 100644 --- /dev/null +++ b/otp-authenticator.cabal @@ -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 diff --git a/src/Authenticator/Actions.hs b/src/Authenticator/Actions.hs new file mode 100644 --- /dev/null +++ b/src/Authenticator/Actions.hs @@ -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' + } diff --git a/src/Authenticator/Common.hs b/src/Authenticator/Common.hs new file mode 100644 --- /dev/null +++ b/src/Authenticator/Common.hs @@ -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 '=' diff --git a/src/Authenticator/Options.hs b/src/Authenticator/Options.hs new file mode 100644 --- /dev/null +++ b/src/Authenticator/Options.hs @@ -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 diff --git a/src/Authenticator/Vault.hs b/src/Authenticator/Vault.hs new file mode 100644 --- /dev/null +++ b/src/Authenticator/Vault.hs @@ -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) diff --git a/src/Encrypted.hs b/src/Encrypted.hs new file mode 100644 --- /dev/null +++ b/src/Encrypted.hs @@ -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') diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"