summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorrkaippully <>2019-09-11 08:18:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-09-11 08:18:00 (GMT)
commitd853b8df7c84c1ac25a50957e5d1c2fbf87d9a8d (patch)
tree8f93c77a93aeaa259c2c50eff223eb9f743762c4
parentc5fbe109e897ea6ee9b2996cda5bba2d0de5295b (diff)
version 1.2.0HEAD1.2.0master
-rw-r--r--ChangeLog.md3
-rw-r--r--app/Gamgee/Program/CommandLine.hs6
-rw-r--r--app/Gamgee/Program/Effects.hs35
-rw-r--r--app/Main.hs34
-rw-r--r--gamgee.cabal238
-rw-r--r--src/Gamgee/Effects/Crypto.hs8
-rw-r--r--src/Gamgee/Effects/CryptoRandom.hs6
-rw-r--r--src/Gamgee/Effects/SecretInput.hs6
-rw-r--r--src/Gamgee/Effects/TOTP.hs26
-rw-r--r--src/Gamgee/Operation.hs29
-rw-r--r--test/Gamgee/Test/Effects.hs20
-rw-r--r--test/Gamgee/Test/Operation.hs5
12 files changed, 239 insertions, 177 deletions
diff --git a/ChangeLog.md b/ChangeLog.md
index 52d6f66..100626a 100644
--- a/ChangeLog.md
+++ b/ChangeLog.md
@@ -5,6 +5,9 @@ The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/).
## [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
index a81ea64..b7012ed 100644
--- a/app/Gamgee/Program/CommandLine.hs
+++ b/app/Gamgee/Program/CommandLine.hs
@@ -21,6 +21,7 @@ data Command = AddToken Token.TokenSpec
| DeleteToken Token.TokenIdentifier
| ListTokens
| GetOTP Token.TokenIdentifier OutputMode
+ | ChangePassword Token.TokenIdentifier
| GetInfo
getCommand :: Parser Command
@@ -28,6 +29,7 @@ getCommand = hsubparser (
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
@@ -77,5 +79,9 @@ getOTPOperation = GetOTP
<*> 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
index 9baa2d6..0ecbd3a 100644
--- a/app/Gamgee/Program/Effects.hs
+++ b/app/Gamgee/Program/Effects.hs
@@ -14,7 +14,7 @@ import Control.Exception.Safe (catch)
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 @@ import qualified System.Posix.Files as Files
-- | 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 @@ instance ToText ByteStoreError where
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 @@ runByteStoreFile :: ( Members [Lift IO, P.Error e] r
-> 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
index ca0fa6b..ea20477 100644
--- 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.CommandLine as Cmd
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 @@ runGetOTP t o = do
$ 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 :: IO ()
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
index 07cc2f7..96ee4bb 100644
--- 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 <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
diff --git a/src/Gamgee/Effects/Crypto.hs b/src/Gamgee/Effects/Crypto.hs
index 85ddab8..1527e67 100644
--- a/src/Gamgee/Effects/Crypto.hs
+++ b/src/Gamgee/Effects/Crypto.hs
@@ -51,7 +51,9 @@ P.makeSem ''Crypto
-- 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 @@ encryptSecret spec =
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
index 850f13d..935500f 100644
--- a/src/Gamgee/Effects/CryptoRandom.hs
+++ b/src/Gamgee/Effects/CryptoRandom.hs
@@ -11,7 +11,7 @@ module Gamgee.Effects.CryptoRandom
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 @@ P.makeSem ''CryptoRandom
-- 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
index ea8d01c..11f18ee 100644
--- a/src/Gamgee/Effects/SecretInput.hs
+++ b/src/Gamgee/Effects/SecretInput.hs
@@ -10,7 +10,7 @@ module Gamgee.Effects.SecretInput
) 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 @@ P.makeSem ''SecretInput
-- 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
index 6d15756..4fba180 100644
--- a/src/Gamgee/Effects/TOTP.hs
+++ b/src/Gamgee/Effects/TOTP.hs
@@ -3,6 +3,7 @@ module Gamgee.Effects.TOTP
TOTP (..)
-- * Actions
+ , getSecret
, getTOTP
-- * Interpretations
@@ -30,7 +31,8 @@ import qualified Text.Printf as Printf
----------------------------------------------------------------------------------------------------
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 @@ P.makeSem ''TOTP
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
-
-computeTOTP :: Member (P.Error Err.EffError) r => Token.TokenSpec -> ByteString -> Clock.POSIXTime -> Sem r Text
-computeTOTP spec key time =
+ GetSecret spec -> snd <$> retrieveKeyAndSecret spec
+ GetTOTP spec time -> fst <$> retrieveKeyAndSecret spec >>= computeTOTP spec 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
index 436e2b9..31a0113 100644
--- a/src/Gamgee/Operation.hs
+++ b/src/Gamgee/Operation.hs
@@ -4,6 +4,7 @@ module Gamgee.Operation
, listTokens
, getOTP
, getInfo
+ , changePassword
) where
@@ -14,7 +15,7 @@ import qualified Data.Version as Version
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 Relude
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 @@ addToken :: Members [ P.State Token.Tokens
-> 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 @@ deleteToken :: Members [ P.State Token.Tokens
=> 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 @@ listTokens :: Members [ P.State Token.Tokens
, 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 @@ getOTP :: Members [ P.State Token.Tokens
-> 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 @@ getInfo cfg = do
]
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
index 4bcbe46..90661e9 100644
--- 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 qualified Crypto.Random.Types as CRT
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 @@ runCryptoRandom gen = P.interpret $ \case
-- 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
index 32ae642..e97fa62 100644
--- a/test/Gamgee/Test/Operation.hs
+++ b/test/Gamgee/Test/Operation.hs
@@ -18,6 +18,7 @@ import qualified Gamgee.Test.Effects as Eff
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 :: TestStore s -> ST s (Either Eff.EffError [OutputMessage])
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 @@ getOTP drg store input tok time =
fmap fst
<$> P.runM
(P.runError
- $ Eff.runOutputPure
+ $ P.runOutputList
$ Eff.runCryptoRandom drg
$ Eff.runCrypto
$ Eff.runListSecretInput input