diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -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 diff --git a/app/Gamgee/Program/CommandLine.hs b/app/Gamgee/Program/CommandLine.hs --- a/app/Gamgee/Program/CommandLine.hs +++ b/app/Gamgee/Program/CommandLine.hs @@ -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 diff --git a/app/Gamgee/Program/Effects.hs b/app/Gamgee/Program/Effects.hs --- a/app/Gamgee/Program/Effects.hs +++ b/app/Gamgee/Program/Effects.hs @@ -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 diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -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 diff --git a/gamgee.cabal b/gamgee.cabal --- a/gamgee.cabal +++ b/gamgee.cabal @@ -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 -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 +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 diff --git a/src/Gamgee/Effects/Crypto.hs b/src/Gamgee/Effects/Crypto.hs --- a/src/Gamgee/Effects/Crypto.hs +++ b/src/Gamgee/Effects/Crypto.hs @@ -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 diff --git a/src/Gamgee/Effects/CryptoRandom.hs b/src/Gamgee/Effects/CryptoRandom.hs --- a/src/Gamgee/Effects/CryptoRandom.hs +++ b/src/Gamgee/Effects/CryptoRandom.hs @@ -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 diff --git a/src/Gamgee/Effects/SecretInput.hs b/src/Gamgee/Effects/SecretInput.hs --- a/src/Gamgee/Effects/SecretInput.hs +++ b/src/Gamgee/Effects/SecretInput.hs @@ -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 diff --git a/src/Gamgee/Effects/TOTP.hs b/src/Gamgee/Effects/TOTP.hs --- a/src/Gamgee/Effects/TOTP.hs +++ b/src/Gamgee/Effects/TOTP.hs @@ -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 diff --git a/src/Gamgee/Operation.hs b/src/Gamgee/Operation.hs --- a/src/Gamgee/Operation.hs +++ b/src/Gamgee/Operation.hs @@ -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 diff --git a/test/Gamgee/Test/Effects.hs b/test/Gamgee/Test/Effects.hs --- a/test/Gamgee/Test/Effects.hs +++ b/test/Gamgee/Test/Effects.hs @@ -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) diff --git a/test/Gamgee/Test/Operation.hs b/test/Gamgee/Test/Operation.hs --- a/test/Gamgee/Test/Operation.hs +++ b/test/Gamgee/Test/Operation.hs @@ -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