diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -5,6 +5,13 @@ ## [Unreleased] +## [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 +- Remove polysemy-plugin so that haddock will run :( +- Updated to latest stackage nightly +- Upgraded to latest version of polysemy + ## [1.0.0] - 2019-07-16 - Major reimplementation based on polysemy diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -71,6 +71,14 @@ gamgee delete -l "" ``` +Polysemy stores the tokens in a configuration file under your home +directory. You can find the location of this file (along with some +other details) by running: + +``` +gamgee info +``` + # License Gamgee is distributed under Mozilla Public License 2.0. See the file LICENSE for details. 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 @@ -1,7 +1,3 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -- | Command line argument parsing module Gamgee.Program.CommandLine ( Command (..) @@ -25,12 +21,14 @@ | DeleteToken Token.TokenIdentifier | ListTokens | GetOTP Token.TokenIdentifier OutputMode + | GetInfo getCommand :: Parser Command 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 "info" (info getInfo $ progDesc "Print information about this Gamgee installation") ) <|> getOTPOperation @@ -78,3 +76,6 @@ <$> strArgument (help "Get a one-time password" <> metavar "TOKEN-LABEL") <*> flag OutputClipboard OutputStdOut (long "stdout" <> help "Send the OTP to stdout instead of clipboard") + +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 @@ -1,23 +1,13 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} module Gamgee.Program.Effects ( runM_ - , runGamgeeByteStoreIO + , runByteStoreIO , runOutputStdOut , runOutputClipboard , runErrorStdErr + , configFilePath + , ByteStoreError(..) ) where import Control.Exception.Safe (catch) @@ -40,13 +30,17 @@ runM_ :: Monad m => Sem '[Lift 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 = P.interpret $ \case - P.Output s -> P.sendM $ putTextLn s + P.Output s -> sendIO $ putTextLn s runOutputClipboard :: Member (Lift IO) r => Sem (P.Output Text : r) a -> Sem r a runOutputClipboard = P.interpret $ \case @@ -99,17 +93,17 @@ -> Sem r a runByteStoreFile file handleReadError handleWriteError = P.interpret $ \case Eff.ReadByteStore -> do - res <- P.sendM $ (Right . Just <$> readFileLBS file) `catch` (return . handleReadError) + res <- sendIO $ (Right . Just <$> readFileLBS file) `catch` (return . handleReadError) either P.throw return res Eff.WriteByteStore bytes -> do - res <- P.sendM $ (writeFileLBS file bytes $> Nothing) `catch` (return . handleWriteError) + res <- sendIO $ (writeFileLBS file bytes $> Nothing) `catch` (return . handleWriteError) whenJust res P.throw P.sendM $ Files.setFileMode file $ Files.ownerReadMode `Files.unionFileModes` Files.ownerWriteMode -runGamgeeByteStoreIO :: Members [Lift IO, P.Error ByteStoreError] r - => Sem (Eff.ByteStore : r) a - -> Sem r a -runGamgeeByteStoreIO prog = do +runByteStoreIO :: Members [Lift IO, P.Error ByteStoreError] r + => Sem (Eff.ByteStore : r) a + -> Sem r a +runByteStoreIO prog = do file <- P.sendM configFilePath runByteStoreFile file handleReadError handleWriteError prog diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,13 +1,6 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeOperators #-} - module Main where +import qualified Data.Aeson as Aeson import qualified Data.Time.Clock.POSIX as Clock import qualified Gamgee.Effects as Eff import qualified Gamgee.Operation as Operation @@ -15,6 +8,11 @@ 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 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 () @@ -25,6 +23,7 @@ Cmd.DeleteToken t -> runDeleteToken t Cmd.ListTokens -> runListTokens Cmd.GetOTP t mode -> runGetOTP t mode + Cmd.GetInfo -> runGetInfo parserInfo :: Options.ParserInfo Cmd.Command parserInfo = Options.info (Options.helper @@ -37,16 +36,16 @@ $ Eff.runCryptoRandomIO $ Eff.runCrypto $ Eff.runSecretInputIO - $ Eff.runGamgeeByteStoreIO - $ Eff.runGamgeeJSONStore + $ Eff.runByteStoreIO + $ Eff.runJSONStore $ Eff.runStateJSON $ Operation.addToken spec runDeleteToken :: Token.TokenIdentifier -> IO () runDeleteToken t = Eff.runM_ $ Eff.runErrorStdErr - $ Eff.runGamgeeByteStoreIO - $ Eff.runGamgeeJSONStore + $ Eff.runByteStoreIO + $ Eff.runJSONStore $ Eff.runStateJSON $ Operation.deleteToken t @@ -54,8 +53,8 @@ runListTokens = Eff.runM_ $ Eff.runErrorStdErr $ Eff.runOutputStdOut - $ Eff.runGamgeeByteStoreIO - $ Eff.runGamgeeJSONStore + $ Eff.runByteStoreIO + $ Eff.runJSONStore $ Eff.runStateJSON Operation.listTokens runGetOTP :: Token.TokenIdentifier -> Cmd.OutputMode -> IO () @@ -67,8 +66,27 @@ $ Eff.runCryptoRandomIO $ Eff.runCrypto $ Eff.runSecretInputIO - $ Eff.runGamgeeByteStoreIO - $ Eff.runGamgeeJSONStore + $ Eff.runByteStoreIO + $ Eff.runJSONStore $ Eff.runStateJSON $ Eff.runTOTP $ Operation.getOTP t now + +getConfig :: Member (Lift IO) r => Sem r (Maybe Token.Config) +getConfig = do + res <- fmap (rightToMaybe @Eff.EffError) + $ P.runError + $ fmap (rightToMaybe @Eff.ByteStoreError) + $ P.runError + $ Eff.runByteStoreIO + $ Eff.configStoreToByteStore Eff.jsonDecode + return (join res) + +runGetInfo :: IO () +runGetInfo = do + path <- Eff.configFilePath + res <- P.runM + $ P.runFoldMapOutput (decodeUtf8 . Aeson.encode @Aeson.Value) + $ P.runConstInput path + $ Operation.getInfo getConfig + putTextLn $ fst res diff --git a/gamgee.cabal b/gamgee.cabal --- a/gamgee.cabal +++ b/gamgee.cabal @@ -1,113 +1,119 @@ -cabal-version: >=1.10 -name: gamgee -version: 1.0.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 +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 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 - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall -Wcompat -Wredundant-constraints - -Wincomplete-record-updates -Wincomplete-uni-patterns - -fplugin=Polysemy.Plugin - build-depends: - aeson >=1.4.4.0 && <1.5, - base >=4.12.0.0 && <4.13, - relude >=0.5.0 && <0.6, - base64-bytestring >=1.0.0.2 && <1.1, - bytestring >=0.10.8.2 && <0.11, - cryptonite ==0.25.*, - text >=1.2.3.1 && <1.3, - memory >=0.14.18 && <0.15, - time >=1.8.0.2 && <1.9, - safe-exceptions >=0.1.7.0 && <0.2, - polysemy >=0.5.0.1 && <0.6, - polysemy-plugin >=0.2.1.1 && <0.3 + 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 executable gamgee - main-is: Main.hs - hs-source-dirs: app - other-modules: - Gamgee.Program.CommandLine - Gamgee.Program.Effects - Paths_gamgee - default-language: Haskell2010 - ghc-options: -Wall -Wcompat -Wredundant-constraints - -Wincomplete-record-updates -Wincomplete-uni-patterns -threaded - -rtsopts -with-rtsopts=-N -fplugin=Polysemy.Plugin - build-depends: - gamgee -any, - base >=4.12.0.0 && <4.13, - relude >=0.5.0 && <0.6, - optparse-applicative >=0.14.3.0 && <0.15, - polysemy >=0.5.0.1 && <0.6, - polysemy-plugin >=0.2.1.1 && <0.3, - safe-exceptions >=0.1.7.0 && <0.2, - directory >=1.3.3.0 && <1.4, - filepath >=1.4.2.1 && <1.5, - aeson >=1.4.4.0 && <1.5, - unix >=2.7.2.2 && <2.8, - text >=1.2.3.1 && <1.3, - time >=1.8.0.2 && <1.9, - Hclip >=3.0.0.4 && <3.1 + 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 test-suite gamgee-test - type: exitcode-stdio-1.0 - main-is: Main.hs - hs-source-dirs: test - other-modules: - Gamgee.Test.Property - Gamgee.Test.Effects - Gamgee.Test.Operation - Gamgee.Test.Golden - default-language: Haskell2010 - ghc-options: -Wall -Wcompat -Wredundant-constraints - -Wincomplete-record-updates -Wincomplete-uni-patterns - -fplugin=Polysemy.Plugin - build-depends: - gamgee -any, - base >=4.12.0.0 && <4.13, - relude >=0.5.0 && <0.6, - text >=1.2.3.1 && <1.3, - bytestring >=0.10.8.2 && <0.11, - memory >=0.14.18 && <0.15, - aeson >=1.4.4.0 && <1.5, - tasty >=1.2.3 && <1.3, - tasty-golden >=2.3.2 && <2.4, - tasty-quickcheck >=0.10.1 && <0.11, - QuickCheck >=2.13.1 && <2.14, - quickcheck-instances >=0.3.21 && <0.4, - polysemy >=0.5.0.1 && <0.6, - polysemy-plugin >=0.2.1.1 && <0.3, - filepath >=1.4.2.1 && <1.5, - cryptonite ==0.25.*, - time >=1.8.0.2 && <1.9 + 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 diff --git a/src/Gamgee/Effects.hs b/src/Gamgee/Effects.hs --- a/src/Gamgee/Effects.hs +++ b/src/Gamgee/Effects.hs @@ -1,8 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TypeOperators #-} - module Gamgee.Effects ( module Gamgee.Effects.Crypto , module Gamgee.Effects.CryptoRandom @@ -25,6 +20,7 @@ import Polysemy (Sem) import qualified Polysemy as P import qualified Polysemy.State as P +import Relude ---------------------------------------------------------------------------------------------------- diff --git a/src/Gamgee/Effects/ByteStore.hs b/src/Gamgee/Effects/ByteStore.hs --- a/src/Gamgee/Effects/ByteStore.hs +++ b/src/Gamgee/Effects/ByteStore.hs @@ -1,12 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} - module Gamgee.Effects.ByteStore ( -- * Effect ByteStore (..) 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 @@ -1,14 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - -- | Cryptographic effect for securing tokens module Gamgee.Effects.Crypto ( -- * Effect 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 @@ -1,14 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - module Gamgee.Effects.CryptoRandom ( -- * Effect CryptoRandom(..) @@ -33,7 +22,7 @@ -- | An effect capable of providing random bytes for use with cryptonite data CryptoRandom m a where - -- ^ Generate random bytes + -- | Generate random bytes RandomBytes :: BA.ByteArray b => Int -> CryptoRandom m b P.makeSem ''CryptoRandom @@ -45,4 +34,4 @@ runCryptoRandomIO :: Member (Lift IO) r => Sem (CryptoRandom : r) a -> Sem r a runCryptoRandomIO = P.interpret $ \case - RandomBytes count -> P.sendM $ CRT.getRandomBytes count + RandomBytes count -> P.sendM @IO $ CRT.getRandomBytes count diff --git a/src/Gamgee/Effects/Error.hs b/src/Gamgee/Effects/Error.hs --- a/src/Gamgee/Effects/Error.hs +++ b/src/Gamgee/Effects/Error.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Gamgee.Effects.Error ( EffError(..) ) where diff --git a/src/Gamgee/Effects/JSONStore.hs b/src/Gamgee/Effects/JSONStore.hs --- a/src/Gamgee/Effects/JSONStore.hs +++ b/src/Gamgee/Effects/JSONStore.hs @@ -1,17 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - module Gamgee.Effects.JSONStore ( -- * Effect JSONStore (..) @@ -20,8 +6,9 @@ , jsonEncode , jsonDecode - -- * Interpretation - , runGamgeeJSONStore + -- * Interpretations + , runJSONStore + , configStoreToByteStore ) where import qualified Data.Aeson as Aeson @@ -47,56 +34,44 @@ ---------------------------------------------------------------------------------------------------- --- Gamgee Configuration +-- Interpret JSONStore backed by a ByteStore ---------------------------------------------------------------------------------------------------- -data Config = Config { - configVersion :: Word32 - , configTokens :: Token.Tokens - } - deriving stock (Generic) - deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) - -currentConfigVersion :: Word32 -currentConfigVersion = 1 +-- | Reinterprets a JSONStore as a ByteStore +runJSONStore :: Member (P.Error Err.EffError) r + => Sem (JSONStore Token.Tokens : r) a + -> Sem (BS.ByteStore : r) a +runJSONStore = configStoreToByteStore . tokenStoreToConfigStore -initialConfig :: Config -initialConfig = Config { - configVersion = currentConfigVersion - , configTokens = fromList [] - } +tokenStoreToConfigStore :: Member (P.Error Err.EffError) r + => Sem (JSONStore Token.Tokens : r) a + -> Sem (JSONStore Token.Config : r) a +tokenStoreToConfigStore = + P.reinterpret $ \case + JsonEncode o -> tokensToConfig o >>= jsonEncode + JsonDecode -> jsonDecode >>= configToTokens + where + tokensToConfig :: Token.Tokens -> Sem r Token.Config + tokensToConfig ts = return $ Token.Config { Token.configVersion = Token.currentConfigVersion, Token.configTokens = ts } ----------------------------------------------------------------------------------------------------- --- Interpret JSONStore backed by a ByteStore ----------------------------------------------------------------------------------------------------- + configToTokens :: Member (P.Error Err.EffError) r => Token.Config -> Sem r Token.Tokens + configToTokens cfg = if Token.configVersion cfg == Token.currentConfigVersion + then return (Token.configTokens cfg) + else P.throw $ Err.UnsupportedConfigVersion $ Token.configVersion cfg -runJSONStore :: (o -> Sem (BS.ByteStore : r) Config) -- ^ Function to map object to a JSON serializable value - -> (Config -> Sem (BS.ByteStore : r) o) -- ^ Function to map a JSON value to the object - -> (String -> Sem (BS.ByteStore : r) o) -- ^ Function to handle errors in decoding - -> Sem (JSONStore o : r) a - -> Sem (BS.ByteStore : r) a -runJSONStore convertE convertD handleError = +configStoreToByteStore :: Member (P.Error Err.EffError) r + => Sem (JSONStore Token.Config : r) a + -> Sem (BS.ByteStore : r) a +configStoreToByteStore = P.reinterpret $ \case - JsonEncode o -> do - j <- convertE o - BS.writeByteStore $ Aeson.encode j - JsonDecode -> do + JsonEncode cfg -> BS.writeByteStore $ Aeson.encode cfg + JsonDecode -> do bytes <- BS.readByteStore let - config = maybe (Right initialConfig) Aeson.eitherDecode' bytes - either handleError convertD config + cfg = maybe (Right Token.initialConfig) Aeson.eitherDecode' bytes + either handleDecodeError return cfg -runGamgeeJSONStore :: Member (P.Error Err.EffError) r => Sem (JSONStore Token.Tokens : r) a -> Sem (BS.ByteStore : r) a -runGamgeeJSONStore = runJSONStore tokensToConfig jsonToTokens handleDecodeError where - tokensToConfig :: Token.Tokens -> Sem r Config - tokensToConfig ts = return $ Config { configVersion = currentConfigVersion, configTokens = ts } - - jsonToTokens :: Member (P.Error Err.EffError) r => Config -> Sem r Token.Tokens - jsonToTokens cfg = if configVersion cfg == currentConfigVersion - then return (configTokens cfg) - else P.throw $ Err.UnsupportedConfigVersion $ configVersion cfg - handleDecodeError :: Member (P.Error Err.EffError) r => String -> Sem r a handleDecodeError msg = P.throw $ Err.JSONDecodeError $ toText msg 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 @@ -1,14 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - module Gamgee.Effects.SecretInput ( -- * Effect SecretInput(..) @@ -27,7 +16,6 @@ import qualified System.IO as IO - ---------------------------------------------------------------------------------------------------- -- Effect ---------------------------------------------------------------------------------------------------- @@ -38,7 +26,7 @@ -- appropriately. For example, an IO interpretation may chose not to -- echo the input to the console. data SecretInput i m a where - -- ^ Retrieve a secret input + -- | Retrieve a secret input SecretInput :: Text -- ^ A prompt -> SecretInput i m i 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 @@ -1,14 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} - module Gamgee.Effects.TOTP ( -- * Effects TOTP (..) diff --git a/src/Gamgee/Operation.hs b/src/Gamgee/Operation.hs --- a/src/Gamgee/Operation.hs +++ b/src/Gamgee/Operation.hs @@ -1,26 +1,31 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE NoImplicitPrelude #-} - module Gamgee.Operation ( addToken , deleteToken , listTokens , getOTP + , getInfo ) where +import Data.Aeson ((.=)) +import qualified Data.Aeson as Aeson import qualified Data.Time.Clock.POSIX as Clock +import qualified Data.Version as Version import qualified Gamgee.Effects as Eff import qualified Gamgee.Token as Token -import Polysemy (Members, Sem) +import Paths_gamgee (version) +import Polysemy (Member, Members, Sem) import qualified Polysemy.Error as P +import qualified Polysemy.Input as P import qualified Polysemy.Output as P import qualified Polysemy.State as P 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 @@ -29,7 +34,7 @@ -> Sem r () addToken spec = do let ident = Token.getIdentifier spec - tokens <- P.get + tokens <- getTokens if ident `Map.member` tokens then P.throw $ Eff.AlreadyExists ident else do @@ -41,7 +46,7 @@ => Token.TokenIdentifier -> Sem r () deleteToken ident = do - tokens <- P.get + tokens <- getTokens case Map.lookup ident tokens of Nothing -> P.throw $ Eff.NoSuchToken ident Just _ -> P.put $ Map.delete ident tokens @@ -50,8 +55,8 @@ , P.Output Text ] r => Sem r () listTokens = do - tokens <- P.get - mapM_ (P.output . Token.unTokenIdentifier . Token.getIdentifier) (tokens :: Token.Tokens) + tokens <- getTokens + mapM_ (P.output . Token.unTokenIdentifier . Token.getIdentifier) tokens getOTP :: Members [ P.State Token.Tokens , P.Error Eff.EffError @@ -61,7 +66,25 @@ -> Clock.POSIXTime -> Sem r () getOTP ident time = do - tokens <- P.get + tokens <- getTokens case Map.lookup ident tokens of Nothing -> P.throw $ Eff.NoSuchToken ident Just spec -> Eff.getTOTP spec time >>= P.output + +getInfo :: Members [ P.Input FilePath + , P.Output Aeson.Value ] r + => Sem r (Maybe Token.Config) + -> Sem r () +getInfo cfg = do + path <- P.input @FilePath + + -- Info command should work even if the config file can't be read. So we handle the + -- potential "missing" config here with a `Maybe Config`. + cfgVersion <- maybe Aeson.Null (Aeson.toJSON . Token.configVersion) <$> cfg + + let info = Aeson.object [ "version" .= Version.showVersion version + , "config" .= Aeson.object [ "filepath" .= path + , "version" .= cfgVersion ] + ] + P.output info + diff --git a/src/Gamgee/Token.hs b/src/Gamgee/Token.hs --- a/src/Gamgee/Token.hs +++ b/src/Gamgee/Token.hs @@ -1,11 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - -- | Data structures to define and manipulate tokens module Gamgee.Token ( TokenType (..) @@ -18,7 +10,10 @@ , TokenSpec (..) , TokenIdentifier (..) , Tokens + , Config(..) , getIdentifier + , currentConfigVersion + , initialConfig ) where import qualified Data.Aeson as Aeson @@ -84,19 +79,19 @@ deriving newtype (Eq, Ord, Enum, Num, Real, Integral, Show, Aeson.FromJSON, Aeson.ToJSON) data TokenSpec = TokenSpec { - -- ^ TOTP/HOTP token + -- | TOTP/HOTP token tokenType :: TokenType - -- ^ A short unique label for this token used to identify it + -- | A short unique label for this token used to identify it , tokenLabel :: TokenLabel - -- ^ The secret provided by the issuer to generate tokens + -- | The secret provided by the issuer to generate tokens , tokenSecret :: TokenSecret - -- ^ The name of the issuer + -- | The name of the issuer , tokenIssuer :: TokenIssuer - -- ^ SHA algorithm used to generate tokens + -- | SHA algorithm used to generate tokens , tokenAlgorithm :: TokenAlgorithm - -- ^ Number of digits in the token - 6 or 8 + -- | Number of digits in the token - 6 or 8 , tokenDigits :: TokenDigits - -- ^ Refresh interval of the token - typically 30 sec + -- | Refresh interval of the token - typically 30 sec , tokenPeriod :: TokenPeriod } deriving stock (Generic, Show) @@ -121,3 +116,23 @@ | otherwise -> issuer <> ":" <> label type Tokens = HashMap TokenIdentifier TokenSpec + +---------------------------------------------------------------------------------------------------- +-- Gamgee Configuration +---------------------------------------------------------------------------------------------------- + +data Config = Config { + configVersion :: Word32 + , configTokens :: Tokens + } + deriving stock (Generic) + deriving anyclass (Aeson.FromJSON, Aeson.ToJSON) + +currentConfigVersion :: Word32 +currentConfigVersion = 1 + +initialConfig :: Config +initialConfig = Config { + configVersion = currentConfigVersion + , configTokens = fromList [] + } 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,12 +1,3 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeOperators #-} - module Gamgee.Test.Effects ( runOutputPure , runListSecretInput diff --git a/test/Gamgee/Test/Golden.hs b/test/Gamgee/Test/Golden.hs --- a/test/Gamgee/Test/Golden.hs +++ b/test/Gamgee/Test/Golden.hs @@ -1,7 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} - module Gamgee.Test.Golden ( goldenTests ) where 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 @@ -1,6 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE RankNTypes #-} - module Gamgee.Test.Operation ( OutputMessage , runTest @@ -46,7 +43,7 @@ $ Eff.runCrypto $ Eff.runListSecretInput input $ Eff.runByteStoreST store - $ Eff.runGamgeeJSONStore + $ Eff.runJSONStore $ Eff.runStateJSON $ Operation.addToken spec @@ -54,7 +51,7 @@ deleteToken store t = P.runM $ P.runError $ Eff.runByteStoreST store - $ Eff.runGamgeeJSONStore + $ Eff.runJSONStore $ Eff.runStateJSON $ Operation.deleteToken t @@ -64,7 +61,7 @@ (P.runError $ Eff.runOutputPure $ Eff.runByteStoreST store - $ Eff.runGamgeeJSONStore + $ Eff.runJSONStore $ Eff.runStateJSON Operation.listTokens) getOTP :: CR.DRG gen @@ -83,7 +80,7 @@ $ Eff.runCrypto $ Eff.runListSecretInput input $ Eff.runByteStoreST store - $ Eff.runGamgeeJSONStore + $ Eff.runJSONStore $ Eff.runStateJSON $ Eff.runTOTP $ Operation.getOTP tok time) diff --git a/test/Gamgee/Test/Property.hs b/test/Gamgee/Test/Property.hs --- a/test/Gamgee/Test/Property.hs +++ b/test/Gamgee/Test/Property.hs @@ -1,15 +1,3 @@ -{-# LANGUAGE DeriveAnyClass #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeApplications #-} - {-# OPTIONS_GHC -fno-warn-orphans #-} -- | Property based tests diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} - module Main where import qualified Gamgee.Test.Golden as G