diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +Version 0.1.1.0 +================ + + + +* Major cleanup of dependencies and underlying implementation +* Fix bug based on dependencies that caused codes to generate improperly. + Version 0.1.0.1 ================ diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,6 +1,5 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} @@ -32,13 +31,11 @@ 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' - + k <- for fingerprint $ \fing -> G.getKey ctx fing G.NoSecret >>= \case + Nothing -> do + printf "No key found for fingerprint %s!\n" (T.decodeUtf8 fing) + exitFailure + Just k' -> return k' (e, mkNewVault) <- ((,False) <$> B.decodeFile @(Enc Vault) vault) `catch` \e -> if isDoesNotExistError e @@ -61,14 +58,13 @@ 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 + forM vtmsg $ \(s, vt) -> case k of + Nothing -> do + putStrLn "Generating a counter-based (HOTP) key requires a fingerprint." + exitFailure + Just k' -> do + putStrLn s + mkEnc ctx k' vt Edit n -> case k of Nothing -> do putStrLn "Editing keys requires a fingerprint." diff --git a/otp-authenticator.cabal b/otp-authenticator.cabal --- a/otp-authenticator.cabal +++ b/otp-authenticator.cabal @@ -1,88 +1,94 @@ -name: otp-authenticator -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 - . - . - 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 -tested-with: GHC == 8.0.2 - , GHC == 8.2.1 - -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 +cabal-version: 1.12 -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 +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 2c3280bb44648673b1ae4f40b7244c3dc6da72f3f2b5bf1304c964e277af6e61 -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 +name: otp-authenticator +version: 0.1.1.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 + . + . + 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. +category: CLI, Security +homepage: https://github.com/mstksg/otp-authenticator#readme +bug-reports: https://github.com/mstksg/otp-authenticator/issues +author: Justin Le +maintainer: justin@jle.im +copyright: (c) Justin Le 2017 +license: BSD3 +license-file: LICENSE +tested-with: GHC >= 8.2 && < 8.8 +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md source-repository head - type: git + type: git location: https://github.com/mstksg/otp-authenticator + +library + exposed-modules: + Authenticator.Vault + Encrypted + Authenticator.Common + Authenticator.Actions + Authenticator.Options + other-modules: + Paths_otp_authenticator + hs-source-dirs: + src + ghc-options: -Wall -Werror=incomplete-patterns -Wredundant-constraints -Wcompat + build-depends: + aeson + , base >=4.10 && <5 + , base-compat >=0.10 + , binary + , bytestring + , containers + , cryptonite + , dependent-sum + , filepath + , h-gpgme + , haskeline + , megaparsec >=7.0 + , microlens + , optparse-applicative + , sandi + , text + , time + , transformers + , unix + , uri-encode + , vinyl >=0.10 + , yaml >=0.8.31 + default-language: Haskell2010 + +executable otp-auth + main-is: Main.hs + other-modules: + Paths_otp_authenticator + hs-source-dirs: + app + ghc-options: -Wall -Werror=incomplete-patterns -Wredundant-constraints -Wcompat -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.10 && <5 + , binary + , bytestring + , h-gpgme + , otp-authenticator + , text + , yaml >=0.8.31 + default-language: Haskell2010 diff --git a/src/Authenticator/Actions.hs b/src/Authenticator/Actions.hs --- a/src/Authenticator/Actions.hs +++ b/src/Authenticator/Actions.hs @@ -1,7 +1,7 @@ +{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} -- | @@ -42,16 +42,15 @@ import Data.Functor import Data.Maybe import Data.Monoid -import Data.Singletons import Data.String -import Data.Type.Conjunction -import Data.Witherable +import GHC.Generics import Lens.Micro import Options.Applicative import Prelude hiding (filter) import System.Exit import Text.Printf import Text.Read (readMaybe) +import qualified Crypto.OTP as OTP import qualified Data.Text as T import qualified System.Console.Haskeline as L @@ -62,7 +61,7 @@ -> Vault -> IO () viewVault l filts vt = do - (n,found) <- runWriterT . flip execStateT 1 $ vaultSecrets (\(sc :: Secret m) ms -> do + (n,found) <- runWriterT . (`execStateT` 1) $ (`vaultSecrets` vt) $ \m sc ms -> do i <- state $ \x -> (x :: Int, x + 1) fmap (fromMaybe ms) . runMaybeT $ do case filts of @@ -73,14 +72,13 @@ lift . lift $ tell (Any True) liftIO $ if l then printf "(%d) %s\n" i (describeSecret sc) $> ms - else case sing @_ @m of + else case m of SHOTP -> ms <$ printf "(%d) %s: [ counter-based, use gen ]\n" i (describeSecret sc) STOTP -> do p <- totp sc printf "(%d) %s: %s\n" i (describeSecret sc) p return ms - ) 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 @@ -100,6 +98,7 @@ fromMaybe "" <$> if echoPass then L.getInputLine "URI Secret?: " else L.getPassword (Just '*') "URI Secret?: " + putStrLn "parsing" case parseSecretURI q of Left err -> do putStrLn "Parse error:" @@ -120,13 +119,13 @@ -> IO (Maybe (String, Vault)) genSecret n vt = do res <- runMaybeT . runWriterT . forOf (_Vault . ix (n - 1)) vt $ \case - s :=> sc :&: ms -> + 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' + return $ s :=> sc :*: ms' STOTP -> do liftIO $ do p <- totp sc @@ -146,12 +145,12 @@ -> IO Vault editSecret n vt = do (vt', found) <- runWriterT . forOf (_Vault . ix (n - 1)) vt $ \case - (s :=> sc :&: ms) -> do + (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 + return $ s :=> sc' :*: ms case getFirst found of Nothing -> do printf "No item with ID %d found.\n" n @@ -167,7 +166,7 @@ -> IO Vault deleteSecret n vt = do (vt', found) <- runWriterT . flip evalStateT 1 . forOf (_Vault . wither) vt $ \case - ds@(_ :=> sc :&: _) -> do + ds@(_ :=> sc :*: _) -> do i <- state $ \x -> (x :: Int, x + 1) if n == i then do @@ -184,6 +183,8 @@ printf "No item with ID %d found.\n" n exitFailure return vt' + where + wither f = fmap catMaybes . traverse f mkSecret :: Bool -> IO SomeSecretState mkSecret echoPass = L.runInputT hlSettings $ do @@ -197,7 +198,8 @@ 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' + s :: Maybe (Secret m) + s = Sec (T.pack a) (T.pack <$> i') HASHA1 (OTPDigits OTP.OTP6) <$> k' case toLower <$> m of Just 'c' -> do n <- mfilter (not . null) <$> L.getInputLine "Initial counter? [0]: " @@ -210,13 +212,12 @@ 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 + Just s' -> return $ SHOTP :=> s' :*: HOTPState n' + _ -> case s of + Nothing -> liftIO $ do + printf "Invalid secret key: %s\n" k + exitFailure + Just s' -> return $ STOTP :=> (s' :*: TOTPState) mkSecretFrom :: Secret m -> IO (Secret m) mkSecretFrom sc = L.runInputT hlSettings $ do diff --git a/src/Authenticator/Common.hs b/src/Authenticator/Common.hs --- a/src/Authenticator/Common.hs +++ b/src/Authenticator/Common.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} @@ -21,7 +22,7 @@ import Control.Monad.IO.Class import Data.Char -import Data.Semigroup +import Prelude.Compat import qualified Codec.Binary.Base32 as B32 import qualified Data.ByteString as BS import qualified Data.Text as T diff --git a/src/Authenticator/Options.hs b/src/Authenticator/Options.hs --- a/src/Authenticator/Options.hs +++ b/src/Authenticator/Options.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TupleSections #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Authenticator.Options @@ -38,7 +38,6 @@ 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 @@ -72,7 +71,9 @@ deriving (Generic) confJsonOpts :: J.Options -confJsonOpts = J.defaultOptions { J.fieldLabelModifier = J.camelTo2 '-' . drop 1 } +confJsonOpts = J.defaultOptions + { J.fieldLabelModifier = J.camelTo2 '-' . drop 1 + } instance J.FromJSON Config where parseJSON = J.genericParseJSON confJsonOpts instance J.ToJSON Config where @@ -140,9 +141,9 @@ <> short 'l' <> help "Only list accounts; do not generate any keys." ) - <*> (Left <$> (argument auto ( metavar "ID" + <*> (Left <$> argument auto ( metavar "ID" <> help "Specific ID number of account" - )) + ) <|> Right <$> ((,) <$> optional (option str ( long "account" <> short 'a' <> metavar "NAME" @@ -186,14 +187,14 @@ return $ homeDirectory ue ".otp-auth.yaml" (Conf{..}, mkNewConf) <- do - (c0, mkNew) <- ((, False) . Y.decodeEither <$> BS.readFile oConfig') `catch` \e -> + (c0, mkNew) <- fmap (,False) (Y.decodeFileEither @Config oConfig') `catch` \e -> if isDoesNotExistError e then return (Right (Conf Nothing Nothing), True) else throwIO e case c0 of Left e -> do putStrLn "Could not parse configuration file. Ignoring." - putStrLn e + putStrLn . Y.prettyPrintParseException $ e return (Conf Nothing Nothing, False) Right c1 -> return (c1, mkNew) diff --git a/src/Authenticator/Vault.hs b/src/Authenticator/Vault.hs --- a/src/Authenticator/Vault.hs +++ b/src/Authenticator/Vault.hs @@ -1,22 +1,19 @@ -{-# 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 #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeInType #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE ViewPatterns #-} -- | -- Module : Authenticator.Vault @@ -35,12 +32,10 @@ module Authenticator.Vault ( - Mode(..) - , Sing(SHOTP, STOTP) - , SMode, HOTPSym0, TOTPSym0 + Mode(..), SMode(..), withSMode, fromSMode , HashAlgo(..) , parseAlgo - , Secret(..) + , Secret(..), OTPDigits(..), pattern OTPDigitsInt , ModeState(..) , SomeSecretState , Vault(..) @@ -58,35 +53,38 @@ import Authenticator.Common import Control.Applicative -import Control.Monad +import Control.Monad hiding (fail) import Crypto.Hash.Algorithms +import Data.Bifunctor import Data.Bitraversable import Data.Char import Data.Dependent.Sum +import Data.Function +import Data.GADT.Show import Data.Kind import Data.Maybe -import Data.Semigroup -import Data.Singletons -import Data.Singletons.TH -import Data.Time.Clock -import Data.Type.Combinator -import Data.Type.Conjunction +import Data.Ord +import Data.Some +import Data.Time.Clock.POSIX +import Data.Vinyl +import Data.Void import Data.Word -import GHC.Generics (Generic) +import GHC.Generics +import Prelude.Compat import Text.Printf import Text.Read (readMaybe) -import Type.Class.Higher -import Type.Class.Witness import qualified Codec.Binary.Base32 as B32 +import qualified Crypto.OTP as OTP import qualified Data.Aeson as J import qualified Data.Binary as B import qualified Data.ByteString as BS import qualified Data.Map as M -import qualified Data.OTP as OTP +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Encoding as T import qualified Network.URI.Encode as U -import qualified Text.Trifecta as P +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as P -- | OTP generation mode data Mode @@ -96,13 +94,36 @@ | TOTP deriving (Generic, Show) -genSingletons [''Mode] +-- | Singleton for 'Mode' +data SMode :: Mode -> Type where + SHOTP :: SMode 'HOTP + STOTP :: SMode 'TOTP +deriving instance Show (SMode m) + +instance GShow SMode where + gshowsPrec = showsPrec + instance B.Binary Mode instance J.ToJSON Mode where toJSON HOTP = J.toJSON @T.Text "hotp" toJSON TOTP = J.toJSON @T.Text "totp" +-- | Reify a 'Mode' to its singleton +withSMode + :: Mode + -> (forall m. SMode m -> r) + -> r +withSMode = \case + HOTP -> ($ SHOTP) + TOTP -> ($ STOTP) + +-- | Reflect a 'SMode' to its value. +fromSMode :: SMode m -> Mode +fromSMode = \case + SHOTP -> HOTP + STOTP -> TOTP + -- | A data family consisting of the state required by each mode. data family ModeState :: Mode -> Type @@ -117,16 +138,16 @@ 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 + 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 :: SMode m -> DictOnly B.Binary (ModeState m) modeStateBinary = \case - SHOTP -> Wit1 - STOTP -> Wit1 + SHOTP -> DictOnly + STOTP -> DictOnly -- | Which OTP-approved hash algorithm to use? data HashAlgo = HASHA1 | HASHA256 | HASHA512 @@ -139,27 +160,58 @@ 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) +hashAlgo :: HashAlgo -> Some (Dict HashAlgorithm) +hashAlgo HASHA1 = Some $ Dict SHA1 +hashAlgo HASHA256 = Some $ Dict SHA256 +hashAlgo HASHA512 = Some $ Dict SHA512 -- | Parse a hash algorithm string into the appropriate 'HashAlgo'. parseAlgo :: String -> Maybe HashAlgo parseAlgo = (`lookup` algos) . map toLower . unwords . words where - algos = [("sha1", HASHA1) + algos = [("sha1" , HASHA1 ) ,("sha256", HASHA256) ,("sha512", HASHA512) ] +-- | Newtype wrapper to provide 'Eq', 'Ord', 'B.Binary', and 'J.ToJSON' +-- instances. You can convert to and from this and the 'Int' +-- representation using 'OTPDigitsInt' +newtype OTPDigits = OTPDigits { otpDigits :: OTP.OTPDigits } + deriving Show + +instance Eq OTPDigits where + (==) = (==) `on` show + +instance Ord OTPDigits where + compare = comparing show + +otpDigitsSet :: S.Set OTPDigits +otpDigitsSet = S.fromList $ + OTPDigits <$> [OTP.OTP4, OTP.OTP5, OTP.OTP6, OTP.OTP7, OTP.OTP8, OTP.OTP9] + +pattern OTPDigitsInt :: OTPDigits -> Int +pattern OTPDigitsInt o <- ((`safeElemAt` otpDigitsSet) . subtract 4->Just o) + where + OTPDigitsInt o = S.findIndex o otpDigitsSet + 4 + +instance B.Binary OTPDigits where + get = do + OTPDigitsInt o <- B.get + pure o + put = B.put . OTPDigitsInt + +instance J.ToJSON OTPDigits where + toEncoding = J.toEncoding . OTPDigitsInt + toJSON = J.toJSON . OTPDigitsInt + -- | A standards-compliant secret key type. Well, almost. It doesn't -- include configuration for the time period if it's time-based. data Secret :: Mode -> Type where Sec :: { secAccount :: T.Text , secIssuer :: Maybe T.Text , secAlgo :: HashAlgo - , secDigits :: Word + , secDigits :: OTPDigits , secKey :: BS.ByteString } -> Secret m @@ -167,14 +219,14 @@ instance B.Binary (Secret m) instance J.ToJSON (Secret m) where - toEncoding (Sec{..}) = J.pairs + 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 $ + toJSON Sec{..} = J.object $ [ "account" J..= secAccount , "algorithm" J..= secAlgo , "digits" J..= secDigits @@ -201,36 +253,38 @@ instance B.Binary SomeSecretState where get = do m <- B.get - withSomeSing m $ \s -> modeStateBinary s // do - sc <- B.get - ms <- B.get - return $ s :=> sc :&: ms + withSMode m $ \s -> case modeStateBinary s of + DictOnly -> 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 + s :=> sc :*: ms -> case modeStateBinary s of + DictOnly -> do + B.put $ fromSMode s + B.put sc + B.put ms instance J.ToJSON SomeSecretState where - toEncoding (s :=> sc :&: ms) = J.pairs - ( "type" J..= fromSing s + toEncoding (s :=> sc :*: ms) = J.pairs + ( "type" J..= fromSMode s <> "secret" J..= sc <> (case s of SHOTP -> "state" J..= ms STOTP -> mempty ) ) - toJSON (s :=> sc :&: ms) = J.object $ - [ "type" J..= fromSing s + toJSON (s :=> sc :*: ms) = J.object $ + [ "type" J..= fromSMode s , "secret" J..= sc ] ++ case s of SHOTP -> ["state" J..= ms] STOTP -> [] -- | A 'Secret' coupled with its 'ModeState', existentially quantified over -- its 'Mode'. -type SomeSecretState = DSum SMode (Secret :&: ModeState) +type SomeSecretState = DSum SMode (Secret :*: ModeState) -- | A list of secrets and their states, of various modes. -data Vault = Vault { vaultList :: [SomeSecretState] } +newtype Vault = Vault { vaultList :: [SomeSecretState] } deriving Generic instance B.Binary Vault @@ -243,23 +297,29 @@ 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 + fmt = "%0" ++ show (OTPDigitsInt secDigits) ++ "d" + p = withSome (hashAlgo secAlgo) $ \case + Dict a -> OTP.hotp a (otpDigits secDigits) secKey i -- | (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 +totp_ :: Secret 'TOTP -> POSIXTime -> T.Text +totp_ Sec{..} t = withSome (hashAlgo secAlgo) $ \case + Dict a -> + let Right tparam = + OTP.mkTOTPParams a 0 30 (otpDigits secDigits) OTP.TwoSteps + in formatKey 3 . T.pack $ + printf fmt $ + OTP.totp tparam secKey (round t) where - fmt = "%0" ++ show secDigits ++ "d" + fmt = "%0" ++ show (OTPDigitsInt 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 +totp s = totp_ s <$> getPOSIXTime -- | 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 +otp :: SMode m -> Secret m -> ModeState m -> IO (T.Text, ModeState m) +otp = \case SHOTP -> curry $ return . uncurry hotp STOTP -> curry $ bitraverse totp return @@ -271,19 +331,17 @@ -- library to update the 'ModeState' in IO. someSecret :: Functor f - => (forall m. SingI m => Secret m -> ModeState m -> f (ModeState m)) + => (forall m. SMode m -> Secret m -> ModeState m -> f (ModeState m)) -> 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) + s :=> (sc :*: ms) -> (s :=>) . (sc :*:) <$> f s sc ms -- | A RankN traversal over all of the 'Secret's and 'ModeState's in -- a 'Vault'. vaultSecrets :: Applicative f - => (forall m. SingI m => Secret m -> ModeState m -> f (ModeState m)) + => (forall m. SMode m -> Secret m -> ModeState m -> f (ModeState m)) -> Vault -> f Vault vaultSecrets f = (_Vault . traverse) (someSecret f) @@ -297,23 +355,26 @@ -> f Vault _Vault f s = Vault <$> f (vaultList s) +type Parser = P.Parsec Void String + -- | A parser for a otpauth URI. -secretURI :: P.Parser SomeSecretState +secretURI :: Parser SomeSecretState secretURI = do _ <- P.string "otpauth://" m <- otpMode _ <- P.char '/' (a,i) <- otpLabel - ps <- M.fromList <$> param `P.sepBy` P.char '&' + ps <- M.fromList <$> P.try param `P.sepBy` P.char '&' sec <- case M.lookup "secret" ps of Nothing -> fail "Required parameter 'secret' not present" Just s -> case decodePad s of Just s' -> return s' Nothing -> fail $ "Not a valid base-32 string: " ++ T.unpack s - let dig = fromMaybe 6 $ do - d <- M.lookup "digits" ps - readMaybe @Word $ T.unpack d + let dig = fromMaybe (OTPDigits OTP.OTP6) $ do + d <- M.lookup "digits" ps + OTPDigitsInt o <- readMaybe $ T.unpack d + pure o i' = i <|> M.lookup "issuer" ps alg = fromMaybe HASHA1 $ do al <- M.lookup "algorithm" ps @@ -321,46 +382,44 @@ secr :: forall m. Secret m secr = Sec a i' alg dig sec - withSomeSing m $ \case + withSMode m $ \case SHOTP -> case M.lookup "counter" ps of Nothing -> fail "Paramater 'counter' required for hotp mode" Just (T.unpack->c) -> case readMaybe c of Nothing -> fail $ "Could not parse 'counter' parameter: " ++ c - Just c' -> return $ SHOTP :=> secr :&: HOTPState c' - STOTP -> return $ STOTP :=> secr :&: TOTPState + Just c' -> return $ SHOTP :=> secr :*: HOTPState c' + STOTP -> return $ STOTP :=> secr :*: TOTPState where - otpMode :: P.Parser Mode + otpMode :: 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 :: 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 '?' + x <- P.some (P.try (mfilter (/= ':') uriChar)) + rest <- Just <$> ( colon + *> P.manyTill (P.try uriChar <|> uriSpace) (P.char '?') ) <|> Nothing <$ P.char '?' return $ case rest of Nothing -> (T.pack . U.decode $ x, Nothing) Just y -> (T.pack . U.decode $ y, Just . T.pack . U.decode $ x) - param :: P.Parser (T.Text, T.Text) + param :: Parser (T.Text, T.Text) param = do k <- T.map toLower . T.pack <$> P.some (P.try uriChar) _ <- P.char '=' v <- T.pack <$> P.some (P.try uriChar) return (k, v) - uriChar = P.satisfy U.isAllowed + uriChar = P.try (P.satisfy U.isAllowed) <|> P.char '@' - <|> (do x <- U.decode <$> sequence [P.char '%', P.hexDigit, P.hexDigit] + <|> (do x <- U.decode <$> sequence [P.char '%', P.hexDigitChar, P.hexDigitChar] case x of [y] -> return y _ -> fail "Invalid URI escape code" ) - colon = void (P.char ':') <|> void (P.string "%3A") - uriSpace = void P.space <|> void (P.string "%20") + 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. -- @@ -368,6 +427,11 @@ parseSecretURI :: String -> Either String SomeSecretState -parseSecretURI s = case P.parseString secretURI mempty s of - P.Success r -> Right r - P.Failure e -> Left (show e) +parseSecretURI s = first P.errorBundlePretty $ + P.parse secretURI "secret URI" s + +safeElemAt :: Int -> S.Set a -> Maybe a +safeElemAt i s + | i < S.size s = Just (S.elemAt i s) + | otherwise = Nothing + diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"