gamgee 1.1.0 → 1.2.0

raw patch · 12 files changed

+238/−176 lines, 12 filesdep ~Hclipdep ~polysemyPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: Hclip, polysemy

API changes (from Hackage documentation)

Files

• ChangeLog.md +3/−0
• app/Gamgee/Program/CommandLine.hs +6/−0
• app/Gamgee/Program/Effects.hs +16/−19
• app/Main.hs +24/−10
• gamgee.cabal +132/−106
• src/Gamgee/Effects/Crypto.hs +6/−2
• src/Gamgee/Effects/CryptoRandom.hs +3/−3
• src/Gamgee/Effects/SecretInput.hs +3/−3
• src/Gamgee/Effects/TOTP.hs +16/−8
• src/Gamgee/Operation.hs +21/−8
• test/Gamgee/Test/Effects.hs +5/−15
• test/Gamgee/Test/Operation.hs +3/−2

@@ -5,6 +5,9 @@  ## [Unreleased] +## [1.2.0] - 2019-09-11+- Added `change-password` command+ ## [1.1.0] - 2019-07-25 - Added an info command to get information about Gamgee installation (https://github.com/rkaippully/gamgee/issues/5) - Generate build/configuration files via dhall

@@ -21,6 +21,7 @@              | DeleteToken Token.TokenIdentifier              | ListTokens              | GetOTP Token.TokenIdentifier OutputMode+             | ChangePassword Token.TokenIdentifier              | GetInfo  getCommand :: Parser Command@@ -28,6 +29,7 @@     command "list" (info listTokens $ progDesc "List the names of all known tokens")     <> command "add" (info addToken $ progDesc "Add a new token")     <> command "delete" (info deleteToken $ progDesc "Delete a token")+    <> command "change-password" (info changePassword $ progDesc "Change password of a token")     <> command "info" (info getInfo $ progDesc "Print information about this Gamgee installation")   )   <|> getOTPOperation@@ -76,6 +78,10 @@                   <$> strArgument (help "Get a one-time password" <> metavar "TOKEN-LABEL")                   <*> flag OutputClipboard OutputStdOut                       (long "stdout" <> help "Send the OTP to stdout instead of clipboard")++changePassword :: Parser Command+changePassword = ChangePassword+                 <$> strOption (long "label" <> short 'l' <> help "Label of the token")  getInfo :: Parser Command getInfo = pure GetInfo

@@ -14,7 +14,7 @@ import qualified Data.Text.IO           as TIO import qualified Gamgee.Effects         as Eff import qualified Gamgee.Token           as Token-import           Polysemy               (Lift, Member, Members, Sem)+import           Polysemy               (Embed, Member, Members, Sem) import qualified Polysemy               as P import qualified Polysemy.Error         as P import qualified Polysemy.Output        as P@@ -27,24 +27,21 @@   -- | A version of runM that ignores its result-runM_ :: Monad m => Sem '[Lift m] a -> m ()+runM_ :: Monad m => Sem '[Embed m] a -> m () runM_ = void . P.runM -sendIO :: Member (Lift IO) r => IO a -> Sem r a-sendIO = P.sendM - ---------------------------------------------------------------------------------------------------- -- Interpret Output by writing it to stdout or clipboard ---------------------------------------------------------------------------------------------------- -runOutputStdOut :: Member (Lift IO) r => Sem (P.Output Text : r) a -> Sem r a+runOutputStdOut :: Member (Embed IO) r => Sem (P.Output Text : r) a -> Sem r a runOutputStdOut = P.interpret $ \case-  P.Output s -> sendIO $ putTextLn s+  P.Output s -> P.embed @IO $ putTextLn s -runOutputClipboard :: Member (Lift IO) r => Sem (P.Output Text : r) a -> Sem r a+runOutputClipboard :: Member (Embed IO) r => Sem (P.Output Text : r) a -> Sem r a runOutputClipboard = P.interpret $ \case-  P.Output s -> P.sendM $ Clip.setClipboard $ toString s+  P.Output s -> P.embed $ Clip.setClipboard $ toString s   ----------------------------------------------------------------------------------------------------@@ -69,21 +66,21 @@   toText (ReadError e)  = "Internal Error: Error reading configuration file: " <> show e   toText (WriteError e) = "Internal Error: Error saving configuration file: " <> show e -runErrorStdErr :: Member (Lift IO) r => Sem (P.Error Eff.EffError : P.Error ByteStoreError : r) a -> Sem r (Maybe a)+runErrorStdErr :: Member (Embed IO) r => Sem (P.Error Eff.EffError : P.Error ByteStoreError : r) a -> Sem r (Maybe a) runErrorStdErr = fmap join . runToTextError . runToTextError -runToTextError :: (Member (Lift IO) r, ToText e) => Sem (P.Error e : r) a -> Sem r (Maybe a)+runToTextError :: (Member (Embed IO) r, ToText e) => Sem (P.Error e : r) a -> Sem r (Maybe a) runToTextError a = P.runError a >>= either (printError . toText) (return . Just)   where-    printError :: Member (Lift IO) r => Text -> Sem r (Maybe a)-    printError msg = P.sendM (TIO.hPutStrLn stderr msg) $> Nothing+    printError :: Member (Embed IO) r => Text -> Sem r (Maybe a)+    printError msg = P.embed (TIO.hPutStrLn stderr msg) $> Nothing   ---------------------------------------------------------------------------------------------------- -- Interpret ByteStore using a file ---------------------------------------------------------------------------------------------------- -runByteStoreFile :: ( Members [Lift IO, P.Error e] r+runByteStoreFile :: ( Members [Embed IO, P.Error e] r                     , Exception e1                     , Exception e2)                  => FilePath@@ -93,18 +90,18 @@                  -> Sem r a runByteStoreFile file handleReadError handleWriteError = P.interpret $ \case   Eff.ReadByteStore        -> do-    res <- sendIO $ (Right . Just <$> readFileLBS file) `catch` (return . handleReadError)+    res <- P.embed @IO $ (Right . Just <$> readFileLBS file) `catch` (return . handleReadError)     either P.throw return res   Eff.WriteByteStore bytes -> do-    res <- sendIO $ (writeFileLBS file bytes $> Nothing) `catch` (return . handleWriteError)+    res <- P.embed @IO $ (writeFileLBS file bytes $> Nothing) `catch` (return . handleWriteError)     whenJust res P.throw-    P.sendM $ Files.setFileMode file $ Files.ownerReadMode `Files.unionFileModes` Files.ownerWriteMode+    P.embed $ Files.setFileMode file $ Files.ownerReadMode `Files.unionFileModes` Files.ownerWriteMode -runByteStoreIO :: Members [Lift IO, P.Error ByteStoreError] r+runByteStoreIO :: Members [Embed IO, P.Error ByteStoreError] r                => Sem (Eff.ByteStore : r) a                -> Sem r a runByteStoreIO prog = do-  file <- P.sendM configFilePath+  file <- P.embed configFilePath   runByteStoreFile file handleReadError handleWriteError prog    where

@@ -1,4 +1,4 @@-module Main where+module Main (main) where  import qualified Data.Aeson                 as Aeson import qualified Data.Time.Clock.POSIX      as Clock@@ -8,22 +8,24 @@ import qualified Gamgee.Program.Effects     as Eff import qualified Gamgee.Token               as Token import qualified Options.Applicative        as Options-import           Polysemy                   (Lift, Member, Sem)+import           Polysemy                   (Embed, Member, Sem) import qualified Polysemy                   as P import qualified Polysemy.Error             as P import qualified Polysemy.Input             as P import qualified Polysemy.Output            as P import           Relude + main :: IO () main = do   command <- Options.execParser parserInfo   case command of-    Cmd.AddToken spec -> runAddToken spec-    Cmd.DeleteToken t -> runDeleteToken t-    Cmd.ListTokens    -> runListTokens-    Cmd.GetOTP t mode -> runGetOTP t mode-    Cmd.GetInfo       -> runGetInfo+    Cmd.AddToken spec    -> runAddToken spec+    Cmd.DeleteToken t    -> runDeleteToken t+    Cmd.ListTokens       -> runListTokens+    Cmd.GetOTP t mode    -> runGetOTP t mode+    Cmd.ChangePassword t -> runChangePassword t+    Cmd.GetInfo          -> runGetInfo  parserInfo :: Options.ParserInfo Cmd.Command parserInfo = Options.info (Options.helper@@ -72,7 +74,19 @@     $ Eff.runTOTP     $ Operation.getOTP t now -getConfig :: Member (Lift IO) r => Sem r (Maybe Token.Config)+runChangePassword :: Token.TokenIdentifier -> IO ()+runChangePassword t = Eff.runM_+                      $ Eff.runErrorStdErr+                      $ Eff.runCryptoRandomIO+                      $ Eff.runCrypto+                      $ Eff.runSecretInputIO+                      $ Eff.runByteStoreIO+                      $ Eff.runJSONStore+                      $ Eff.runStateJSON+                      $ Eff.runTOTP+                      $ Operation.changePassword t++getConfig :: Member (Embed IO) r => Sem r (Maybe Token.Config) getConfig = do   res <- fmap (rightToMaybe @Eff.EffError)          $ P.runError@@ -86,7 +100,7 @@ runGetInfo = do   path <- Eff.configFilePath   res <- P.runM-         $ P.runFoldMapOutput (decodeUtf8 . Aeson.encode @Aeson.Value)-         $ P.runConstInput path+         $ P.runOutputMonoid (decodeUtf8 . Aeson.encode @Aeson.Value)+         $ P.runInputConst path          $ Operation.getInfo getConfig   putTextLn $ fst res

@@ -1,119 +1,145 @@ cabal-version: 1.12---- This file has been generated from package.yaml by hpack version 0.31.2.------ see: https://github.com/sol/hpack------ hash: 6ef7fdb4196c49f7636ed723af430ecf585bbd1efa8278400c6d716d7fcc5a7b--name:           gamgee-version:        1.1.0-synopsis:       Tool for generating TOTP MFA tokens.-description:    Tool for generating TOTP MFA tokens. Please see the README on GitHub at <https://github.com/rkaippully/gamgee#readme>-category:       Authentication, Command Line-homepage:       https://github.com/rkaippully/gamgee#readme-bug-reports:    https://github.com/rkaippully/gamgee/issues-author:         Raghu Kaippully-maintainer:     rkaippully@gmail.com-copyright:      2018 Raghu Kaippully-license:        MPL-2.0-license-file:   LICENSE-build-type:     Simple+name: gamgee+version: 1.2.0+license: MPL-2.0+license-file: LICENSE+copyright: 2018 Raghu Kaippully+maintainer: rkaippully@gmail.com+author: Raghu Kaippully+homepage: https://github.com/rkaippully/gamgee#readme+bug-reports: https://github.com/rkaippully/gamgee/issues+synopsis: Tool for generating TOTP MFA tokens.+description:+    Tool for generating TOTP MFA tokens. Please see the README on GitHub at <https://github.com/rkaippully/gamgee#readme>+category: Authentication, Command Line+build-type: Simple extra-source-files:     ChangeLog.md     README.md     test/data/golden/getOTPTest.txt  source-repository head-  type: git-  location: https://github.com/rkaippully/gamgee+    type: git+    location: https://github.com/rkaippully/gamgee  library-  exposed-modules:-      Gamgee.Operation-      Gamgee.Token-      Gamgee.Effects-      Gamgee.Effects.Error-      Gamgee.Effects.Crypto-      Gamgee.Effects.CryptoRandom-      Gamgee.Effects.SecretInput-      Gamgee.Effects.TOTP-      Gamgee.Effects.JSONStore-      Gamgee.Effects.ByteStore-  other-modules:-      Paths_gamgee-  hs-source-dirs:-      src-  default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators-  ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns-  build-depends:-      aeson-    , base >=4.12.0.0 && <4.13-    , base64-bytestring-    , bytestring-    , cryptonite-    , memory-    , polysemy-    , relude-    , safe-exceptions-    , text-    , time-  default-language: Haskell2010+    exposed-modules:+        Gamgee.Operation+        Gamgee.Token+        Gamgee.Effects+        Gamgee.Effects.Error+        Gamgee.Effects.Crypto+        Gamgee.Effects.CryptoRandom+        Gamgee.Effects.SecretInput+        Gamgee.Effects.TOTP+        Gamgee.Effects.JSONStore+        Gamgee.Effects.ByteStore+    hs-source-dirs: src+    other-modules:+        Paths_gamgee+    default-language: Haskell2010+    default-extensions: ApplicativeDo BangPatterns ConstraintKinds+                        DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable+                        DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable+                        DerivingStrategies EmptyCase ExistentialQuantification+                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs+                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase+                        MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude+                        OverloadedStrings PatternSynonyms PolyKinds RankNTypes+                        ScopedTypeVariables StandaloneDeriving TemplateHaskell+                        TupleSections TypeApplications TypeFamilies TypeFamilyDependencies+                        TypeOperators+    ghc-options: -Wall -Wcompat -Wredundant-constraints+                 -Wincomplete-record-updates -Wincomplete-uni-patterns+    build-depends:+        aeson >=1.4.4.0 && <1.5,+        base >=4.12.0.0 && <4.13,+        base64-bytestring >=1.0.0.2 && <1.1,+        bytestring >=0.10.8.2 && <0.11,+        cryptonite ==0.25.*,+        memory >=0.14.18 && <0.15,+        polysemy >=1.0.0.0 && <1.1,+        relude >=0.5.0 && <0.6,+        safe-exceptions >=0.1.7.0 && <0.2,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9  executable gamgee-  main-is: Main.hs-  other-modules:-      Gamgee.Program.CommandLine-      Gamgee.Program.Effects-      Paths_gamgee-  hs-source-dirs:-      app-  default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators-  ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      Hclip-    , aeson-    , base >=4.12.0.0 && <4.13-    , directory-    , filepath-    , gamgee-    , optparse-applicative-    , polysemy-    , relude-    , safe-exceptions-    , text-    , time-    , unix-  default-language: Haskell2010+    main-is: Main.hs+    hs-source-dirs: app+    other-modules:+        Gamgee.Program.CommandLine+        Gamgee.Program.Effects+        Paths_gamgee+    default-language: Haskell2010+    default-extensions: ApplicativeDo BangPatterns ConstraintKinds+                        DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable+                        DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable+                        DerivingStrategies EmptyCase ExistentialQuantification+                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs+                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase+                        MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude+                        OverloadedStrings PatternSynonyms PolyKinds RankNTypes+                        ScopedTypeVariables StandaloneDeriving TemplateHaskell+                        TupleSections TypeApplications TypeFamilies TypeFamilyDependencies+                        TypeOperators+    ghc-options: -Wall -Wcompat -Wredundant-constraints+                 -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded+                 -rtsopts -with-rtsopts=-N+    build-depends:+        Hclip ==3.0.0.4,+        aeson >=1.4.4.0 && <1.5,+        base >=4.12.0.0 && <4.13,+        directory >=1.3.3.0 && <1.4,+        filepath >=1.4.2.1 && <1.5,+        gamgee -any,+        optparse-applicative >=0.14.3.0 && <0.15,+        polysemy >=1.0.0.0 && <1.1,+        relude >=0.5.0 && <0.6,+        safe-exceptions >=0.1.7.0 && <0.2,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9,+        unix >=2.7.2.2 && <2.8  test-suite gamgee-test-  type: exitcode-stdio-1.0-  main-is: Main.hs-  other-modules:-      Gamgee.Test.Effects-      Gamgee.Test.Golden-      Gamgee.Test.Operation-      Gamgee.Test.Property-      Paths_gamgee-  hs-source-dirs:-      test-  default-extensions: ApplicativeDo BangPatterns ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable DerivingStrategies EmptyCase ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PatternSynonyms PolyKinds RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators-  ghc-options: -Wall -Wcompat -Wredundant-constraints -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded -rtsopts -with-rtsopts=-N-  build-depends:-      QuickCheck-    , aeson-    , base >=4.12.0.0 && <4.13-    , bytestring-    , cryptonite-    , filepath-    , gamgee-    , memory-    , polysemy-    , quickcheck-instances-    , relude-    , tasty-    , tasty-golden-    , tasty-quickcheck-    , text-    , time-  default-language: Haskell2010+    type: exitcode-stdio-1.0+    main-is: Main.hs+    hs-source-dirs: test+    other-modules:+        Gamgee.Test.Effects+        Gamgee.Test.Golden+        Gamgee.Test.Operation+        Gamgee.Test.Property+        Paths_gamgee+    default-language: Haskell2010+    default-extensions: ApplicativeDo BangPatterns ConstraintKinds+                        DataKinds DefaultSignatures DeriveAnyClass DeriveFoldable+                        DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable+                        DerivingStrategies EmptyCase ExistentialQuantification+                        FlexibleContexts FlexibleInstances FunctionalDependencies GADTs+                        GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase+                        MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude+                        OverloadedStrings PatternSynonyms PolyKinds RankNTypes+                        ScopedTypeVariables StandaloneDeriving TemplateHaskell+                        TupleSections TypeApplications TypeFamilies TypeFamilyDependencies+                        TypeOperators+    ghc-options: -Wall -Wcompat -Wredundant-constraints+                 -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded+                 -rtsopts -with-rtsopts=-N+    build-depends:+        QuickCheck >=2.13.2 && <2.14,+        aeson >=1.4.4.0 && <1.5,+        base >=4.12.0.0 && <4.13,+        bytestring >=0.10.8.2 && <0.11,+        cryptonite ==0.25.*,+        filepath >=1.4.2.1 && <1.5,+        gamgee -any,+        memory >=0.14.18 && <0.15,+        polysemy >=1.0.0.0 && <1.1,+        quickcheck-instances >=0.3.22 && <0.4,+        relude >=0.5.0 && <0.6,+        tasty >=1.2.3 && <1.3,+        tasty-golden >=2.3.2 && <2.4,+        tasty-quickcheck >=0.10.1 && <0.11,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9

@@ -51,7 +51,9 @@ -- Programs ---------------------------------------------------------------------------------------------------- -encryptSecret :: Members [SI.SecretInput Text, Crypto] r => Token.TokenSpec -> Sem r Token.TokenSpec+encryptSecret :: Members [SI.SecretInput Text, Crypto] r+              => Token.TokenSpec+              -> Sem r Token.TokenSpec encryptSecret spec =   case Token.tokenSecret spec of     -- Secret is already encrypted@@ -69,7 +71,9 @@         secret' <- encrypt secret password         return spec { Token.tokenSecret = secret' } -decryptSecret :: Members [SI.SecretInput Text, Crypto] r => Token.TokenSpec -> Sem r Text+decryptSecret :: Members [SI.SecretInput Text, Crypto] r+              => Token.TokenSpec+              -> Sem r Text decryptSecret spec =   case Token.tokenSecret spec of     Token.TokenSecretPlainText plainSecret  -> return plainSecret

@@ -11,7 +11,7 @@  import qualified Crypto.Random.Types as CRT import qualified Data.ByteArray      as BA-import           Polysemy            (Lift, Member, Sem)+import           Polysemy            (Embed, Member, Sem) import qualified Polysemy            as P import           Relude @@ -32,6 +32,6 @@ -- Interpretations ---------------------------------------------------------------------------------------------------- -runCryptoRandomIO :: Member (Lift IO) r => Sem (CryptoRandom : r) a -> Sem r a+runCryptoRandomIO :: Member (Embed IO) r => Sem (CryptoRandom : r) a -> Sem r a runCryptoRandomIO = P.interpret $ \case-  RandomBytes count -> P.sendM @IO $ CRT.getRandomBytes count+  RandomBytes count -> P.embed @IO $ CRT.getRandomBytes count

@@ -10,7 +10,7 @@     ) where  import           Control.Exception.Safe (bracket_)-import           Polysemy               (Lift, Member, Sem)+import           Polysemy               (Embed, Member, Sem) import qualified Polysemy               as P import           Relude import qualified System.IO              as IO@@ -37,9 +37,9 @@ -- Interpretations ---------------------------------------------------------------------------------------------------- -runSecretInputIO :: (Member (Lift IO) r) => Sem (SecretInput Text : r) a -> Sem r a+runSecretInputIO :: (Member (Embed IO) r) => Sem (SecretInput Text : r) a -> Sem r a runSecretInputIO = P.interpret $ \case-  SecretInput prompt -> P.sendM $ do+  SecretInput prompt -> P.embed $ do     putText prompt     IO.hFlush stdout     i <- withoutEcho getLine

@@ -3,6 +3,7 @@       TOTP (..)        -- * Actions+    , getSecret     , getTOTP        -- * Interpretations@@ -30,7 +31,8 @@ ----------------------------------------------------------------------------------------------------  data TOTP m a where-  GetTOTP :: Token.TokenSpec -> Clock.POSIXTime -> TOTP m Text+  GetSecret :: Token.TokenSpec -> TOTP m Text+  GetTOTP   :: Token.TokenSpec -> Clock.POSIXTime -> TOTP m Text  P.makeSem ''TOTP @@ -41,14 +43,20 @@  runTOTP :: Members [SecretInput Text, Crypto, P.Error Err.EffError] r => Sem (TOTP : r) a -> Sem r a runTOTP = P.interpret $ \case-  GetTOTP spec time -> do-    secret <- Crypto.decryptSecret spec-    case Encoding.convertFromBase Encoding.Base32 (encodeUtf8 secret :: ByteString) of-      Left msg  -> P.throw $ Err.SecretDecryptError $ toText msg-      Right key -> computeTOTP spec key time+  GetSecret spec    -> snd <$> retrieveKeyAndSecret spec+  GetTOTP spec time -> fst <$> retrieveKeyAndSecret spec >>= computeTOTP spec time -computeTOTP :: Member (P.Error Err.EffError) r => Token.TokenSpec -> ByteString -> Clock.POSIXTime -> Sem r Text-computeTOTP spec key time =+retrieveKeyAndSecret :: Members [SecretInput Text, Crypto, P.Error Err.EffError] r+                     => Token.TokenSpec+                     -> Sem r (ByteString, Text)+retrieveKeyAndSecret spec = do+  secret <- Crypto.decryptSecret spec+  case Encoding.convertFromBase Encoding.Base32 (encodeUtf8 secret :: ByteString) of+    Left msg  -> P.throw $ Err.SecretDecryptError $ toText msg+    Right key -> return (key, secret)++computeTOTP :: Member (P.Error Err.EffError) r => Token.TokenSpec -> Clock.POSIXTime -> ByteString -> Sem r Text+computeTOTP spec time key =   case Token.tokenAlgorithm spec of     Token.AlgorithmSHA1   -> makeOTP <$> makeParams HashAlgos.SHA1     Token.AlgorithmSHA256 -> makeOTP <$> makeParams HashAlgos.SHA256

@@ -4,6 +4,7 @@   , listTokens   , getOTP   , getInfo+  , changePassword   ) where  @@ -14,7 +15,7 @@ import qualified Gamgee.Effects        as Eff import qualified Gamgee.Token          as Token import           Paths_gamgee          (version)-import           Polysemy              (Member, Members, Sem)+import           Polysemy              (Members, Sem) import qualified Polysemy.Error        as P import qualified Polysemy.Input        as P import qualified Polysemy.Output       as P@@ -23,9 +24,6 @@ import qualified Relude.Extra.Map      as Map  -getTokens :: Member (P.State Token.Tokens) r => Sem r Token.Tokens-getTokens = P.get- addToken :: Members [ P.State Token.Tokens                     , Eff.Crypto                     , Eff.SecretInput Text@@ -34,7 +32,7 @@          -> Sem r () addToken spec = do   let ident = Token.getIdentifier spec-  tokens <- getTokens+  tokens <- P.get @Token.Tokens   if ident `Map.member` tokens   then P.throw $ Eff.AlreadyExists ident   else do@@ -46,7 +44,7 @@             => Token.TokenIdentifier             -> Sem r () deleteToken ident = do-  tokens <- getTokens+  tokens <- P.get @Token.Tokens   case Map.lookup ident tokens of     Nothing -> P.throw $ Eff.NoSuchToken ident     Just _  -> P.put $ Map.delete ident tokens@@ -55,7 +53,7 @@                       , P.Output Text ] r            => Sem r () listTokens = do-  tokens <- getTokens+  tokens <- P.get @Token.Tokens   mapM_ (P.output . Token.unTokenIdentifier . Token.getIdentifier) tokens  getOTP :: Members [ P.State Token.Tokens@@ -66,7 +64,7 @@        -> Clock.POSIXTime        -> Sem r () getOTP ident time = do-  tokens <- getTokens+  tokens <- P.get @Token.Tokens   case Map.lookup ident tokens of     Nothing   -> P.throw $ Eff.NoSuchToken ident     Just spec -> Eff.getTOTP spec time >>= P.output@@ -88,3 +86,18 @@                           ]   P.output info +changePassword :: Members [ P.State Token.Tokens+                          , Eff.SecretInput Text+                          , Eff.Crypto+                          , Eff.TOTP+                          , P.Error Eff.EffError ] r+               => Token.TokenIdentifier+               -> Sem r ()+changePassword ident = do+  tokens <- P.get @Token.Tokens+  case Map.lookup ident tokens of+    Nothing   -> P.throw $ Eff.NoSuchToken ident+    Just spec -> do+      secret <- Eff.getSecret spec+      spec' <- Eff.encryptSecret spec{ Token.tokenSecret = Token.TokenSecretPlainText secret }+      P.put $ Map.insert ident spec' tokens

@@ -1,6 +1,5 @@ module Gamgee.Test.Effects-  ( runOutputPure-  , runListSecretInput+  ( runListSecretInput   , runCryptoRandom   , runByteStoreST   ) where@@ -11,22 +10,13 @@ import           Data.STRef          (STRef) import qualified Data.STRef          as STRef import qualified Gamgee.Effects      as Eff-import           Polysemy            (Lift, Member, Sem)+import           Polysemy            (Embed, Member, Sem) import qualified Polysemy            as P-import qualified Polysemy.Output     as P import qualified Polysemy.State      as P import           Relude   ------------------------------------------------------------------------------------------------------- Interpret Output by accumulating it in a list-------------------------------------------------------------------------------------------------------runOutputPure :: Sem (P.Output o : r) a -> Sem r ([o], a)-runOutputPure = P.runFoldMapOutput one------------------------------------------------------------------------------------------------------- -- Interpret SecretInput by reading from a list ---------------------------------------------------------------------------------------------------- @@ -56,7 +46,7 @@ -- Interpret ByteStore using the ST monad ---------------------------------------------------------------------------------------------------- -runByteStoreST :: Member (Lift (ST s)) r => STRef s (Maybe LByteString) -> Sem (Eff.ByteStore : r) a -> Sem r a+runByteStoreST :: Member (Embed (ST s)) r => STRef s (Maybe LByteString) -> Sem (Eff.ByteStore : r) a -> Sem r a runByteStoreST ref = P.interpret $ \case-  Eff.ReadByteStore        -> P.sendM $ STRef.readSTRef ref-  Eff.WriteByteStore bytes -> P.sendM $ STRef.writeSTRef ref (Just bytes)+  Eff.ReadByteStore        -> P.embed $ STRef.readSTRef ref+  Eff.WriteByteStore bytes -> P.embed $ STRef.writeSTRef ref (Just bytes)

@@ -18,6 +18,7 @@ import qualified Gamgee.Token          as Token import qualified Polysemy              as P import qualified Polysemy.Error        as P+import qualified Polysemy.Output       as P import           Relude  @@ -59,7 +60,7 @@ listTokens store = fmap fst                    <$> P.runM                        (P.runError-                        $ Eff.runOutputPure+                        $ P.runOutputList                         $ Eff.runByteStoreST store                         $ Eff.runJSONStore                         $ Eff.runStateJSON Operation.listTokens)@@ -75,7 +76,7 @@   fmap fst   <$> P.runM       (P.runError-       $ Eff.runOutputPure+       $ P.runOutputList        $ Eff.runCryptoRandom drg        $ Eff.runCrypto        $ Eff.runListSecretInput input