otp-authenticator 0.1.0.1 → 0.1.1.0

raw patch · 8 files changed

+307/−232 lines, 8 filesdep +base-compatdep +megaparsecdep +vinyldep −bifunctorsdep −one-time-passworddep −singletonsdep ~basedep ~yamlPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: base-compat, megaparsec, vinyl

Dependencies removed: bifunctors, one-time-password, singletons, trifecta, type-combinators, witherable

Dependency ranges changed: base, yaml

API changes (from Hackage documentation)

Files

• CHANGELOG.md +8/−0
• app/Main.hs +12/−16
• otp-authenticator.cabal +89/−83
• src/Authenticator/Actions.hs +21/−20
• src/Authenticator/Common.hs +2/−1
• src/Authenticator/Options.hs +11/−10
• src/Authenticator/Vault.hs +164/−100
• test/Spec.hs +0/−2

@@ -1,3 +1,11 @@+Version 0.1.1.0+================++<https://github.com/mstksg/uncertain/releases/tag/v0.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 ================ 

@@ -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."

@@ -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-                     <https://github.com/google/google-authenticator google authenticator app>.-                     .-                     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+                <https://github.com/google/google-authenticator google authenticator app>.+                .+                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

@@ -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

@@ -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

@@ -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) 

@@ -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+

@@ -1,2 +0,0 @@-main :: IO ()-main = putStrLn "Test suite not yet implemented"