gamgee (empty) → 1.0.0
raw patch · 24 files changed
+1984/−0 lines, 24 filesdep +Hclipdep +QuickCheckdep +aesonsetup-changed
Dependencies added: Hclip, QuickCheck, aeson, base, base64-bytestring, bytestring, cryptonite, directory, filepath, gamgee, memory, optparse-applicative, polysemy, polysemy-plugin, quickcheck-instances, relude, safe-exceptions, tasty, tasty-golden, tasty-quickcheck, text, time, unix
Files
- ChangeLog.md +22/−0
- LICENSE +373/−0
- README.md +79/−0
- Setup.hs +2/−0
- app/Gamgee/Program/CommandLine.hs +80/−0
- app/Gamgee/Program/Effects.hs +130/−0
- app/Main.hs +74/−0
- gamgee.cabal +113/−0
- src/Gamgee/Effects.hs +37/−0
- src/Gamgee/Effects/ByteStore.hs +32/−0
- src/Gamgee/Effects/Crypto.hs +149/−0
- src/Gamgee/Effects/CryptoRandom.hs +48/−0
- src/Gamgee/Effects/Error.hs +23/−0
- src/Gamgee/Effects/JSONStore.hs +102/−0
- src/Gamgee/Effects/SecretInput.hs +65/−0
- src/Gamgee/Effects/TOTP.hs +90/−0
- src/Gamgee/Operation.hs +67/−0
- src/Gamgee/Token.hs +123/−0
- test/Gamgee/Test/Effects.hs +71/−0
- test/Gamgee/Test/Golden.hs +44/−0
- test/Gamgee/Test/Operation.hs +89/−0
- test/Gamgee/Test/Property.hs +156/−0
- test/Main.hs +14/−0
- test/data/golden/getOTPTest.txt +1/−0
+ ChangeLog.md view
@@ -0,0 +1,22 @@+# Changelog+All notable changes to this project will be documented in this file.++The format is based on [Keep a Changelog](http://keepachangelog.com/en/1.0.0/).++## [Unreleased]++## [1.0.0] - 2019-07-16+- Major reimplementation based on polysemy++## [0.2.0] - 2018-06-07++### Added+- Support for secrets in non-canonical format (https://github.com/rkaippully/gamgee/issues/2)++## [0.1.0] - 2018-06-05++### Added+- First version.+- Supports TOTP based tokens+- Secure storage of tokens via AES256 encryption+- Added installation and usage instructions to README
+ LICENSE view
@@ -0,0 +1,373 @@+Mozilla Public License Version 2.0+==================================++1. Definitions+--------------++1.1. "Contributor"+ means each individual or legal entity that creates, contributes to+ the creation of, or owns Covered Software.++1.2. "Contributor Version"+ means the combination of the Contributions of others (if any) used+ by a Contributor and that particular Contributor's Contribution.++1.3. "Contribution"+ means Covered Software of a particular Contributor.++1.4. "Covered Software"+ means Source Code Form to which the initial Contributor has attached+ the notice in Exhibit A, the Executable Form of such Source Code+ Form, and Modifications of such Source Code Form, in each case+ including portions thereof.++1.5. "Incompatible With Secondary Licenses"+ means++ (a) that the initial Contributor has attached the notice described+ in Exhibit B to the Covered Software; or++ (b) that the Covered Software was made available under the terms of+ version 1.1 or earlier of the License, but not also under the+ terms of a Secondary License.++1.6. "Executable Form"+ means any form of the work other than Source Code Form.++1.7. "Larger Work"+ means a work that combines Covered Software with other material, in+ a separate file or files, that is not Covered Software.++1.8. "License"+ means this document.++1.9. "Licensable"+ means having the right to grant, to the maximum extent possible,+ whether at the time of the initial grant or subsequently, any and+ all of the rights conveyed by this License.++1.10. "Modifications"+ means any of the following:++ (a) any file in Source Code Form that results from an addition to,+ deletion from, or modification of the contents of Covered+ Software; or++ (b) any new file in Source Code Form that contains any Covered+ Software.++1.11. "Patent Claims" of a Contributor+ means any patent claim(s), including without limitation, method,+ process, and apparatus claims, in any patent Licensable by such+ Contributor that would be infringed, but for the grant of the+ License, by the making, using, selling, offering for sale, having+ made, import, or transfer of either its Contributions or its+ Contributor Version.++1.12. "Secondary License"+ means either the GNU General Public License, Version 2.0, the GNU+ Lesser General Public License, Version 2.1, the GNU Affero General+ Public License, Version 3.0, or any later versions of those+ licenses.++1.13. "Source Code Form"+ means the form of the work preferred for making modifications.++1.14. "You" (or "Your")+ means an individual or a legal entity exercising rights under this+ License. For legal entities, "You" includes any entity that+ controls, is controlled by, or is under common control with You. For+ purposes of this definition, "control" means (a) the power, direct+ or indirect, to cause the direction or management of such entity,+ whether by contract or otherwise, or (b) ownership of more than+ fifty percent (50%) of the outstanding shares or beneficial+ ownership of such entity.++2. License Grants and Conditions+--------------------------------++2.1. Grants++Each Contributor hereby grants You a world-wide, royalty-free,+non-exclusive license:++(a) under intellectual property rights (other than patent or trademark)+ Licensable by such Contributor to use, reproduce, make available,+ modify, display, perform, distribute, and otherwise exploit its+ Contributions, either on an unmodified basis, with Modifications, or+ as part of a Larger Work; and++(b) under Patent Claims of such Contributor to make, use, sell, offer+ for sale, have made, import, and otherwise transfer either its+ Contributions or its Contributor Version.++2.2. Effective Date++The licenses granted in Section 2.1 with respect to any Contribution+become effective for each Contribution on the date the Contributor first+distributes such Contribution.++2.3. Limitations on Grant Scope++The licenses granted in this Section 2 are the only rights granted under+this License. No additional rights or licenses will be implied from the+distribution or licensing of Covered Software under this License.+Notwithstanding Section 2.1(b) above, no patent license is granted by a+Contributor:++(a) for any code that a Contributor has removed from Covered Software;+ or++(b) for infringements caused by: (i) Your and any other third party's+ modifications of Covered Software, or (ii) the combination of its+ Contributions with other software (except as part of its Contributor+ Version); or++(c) under Patent Claims infringed by Covered Software in the absence of+ its Contributions.++This License does not grant any rights in the trademarks, service marks,+or logos of any Contributor (except as may be necessary to comply with+the notice requirements in Section 3.4).++2.4. Subsequent Licenses++No Contributor makes additional grants as a result of Your choice to+distribute the Covered Software under a subsequent version of this+License (see Section 10.2) or under the terms of a Secondary License (if+permitted under the terms of Section 3.3).++2.5. Representation++Each Contributor represents that the Contributor believes its+Contributions are its original creation(s) or it has sufficient rights+to grant the rights to its Contributions conveyed by this License.++2.6. Fair Use++This License is not intended to limit any rights You have under+applicable copyright doctrines of fair use, fair dealing, or other+equivalents.++2.7. Conditions++Sections 3.1, 3.2, 3.3, and 3.4 are conditions of the licenses granted+in Section 2.1.++3. Responsibilities+-------------------++3.1. Distribution of Source Form++All distribution of Covered Software in Source Code Form, including any+Modifications that You create or to which You contribute, must be under+the terms of this License. You must inform recipients that the Source+Code Form of the Covered Software is governed by the terms of this+License, and how they can obtain a copy of this License. You may not+attempt to alter or restrict the recipients' rights in the Source Code+Form.++3.2. Distribution of Executable Form++If You distribute Covered Software in Executable Form then:++(a) such Covered Software must also be made available in Source Code+ Form, as described in Section 3.1, and You must inform recipients of+ the Executable Form how they can obtain a copy of such Source Code+ Form by reasonable means in a timely manner, at a charge no more+ than the cost of distribution to the recipient; and++(b) You may distribute such Executable Form under the terms of this+ License, or sublicense it under different terms, provided that the+ license for the Executable Form does not attempt to limit or alter+ the recipients' rights in the Source Code Form under this License.++3.3. Distribution of a Larger Work++You may create and distribute a Larger Work under terms of Your choice,+provided that You also comply with the requirements of this License for+the Covered Software. If the Larger Work is a combination of Covered+Software with a work governed by one or more Secondary Licenses, and the+Covered Software is not Incompatible With Secondary Licenses, this+License permits You to additionally distribute such Covered Software+under the terms of such Secondary License(s), so that the recipient of+the Larger Work may, at their option, further distribute the Covered+Software under the terms of either this License or such Secondary+License(s).++3.4. Notices++You may not remove or alter the substance of any license notices+(including copyright notices, patent notices, disclaimers of warranty,+or limitations of liability) contained within the Source Code Form of+the Covered Software, except that You may alter any license notices to+the extent required to remedy known factual inaccuracies.++3.5. Application of Additional Terms++You may choose to offer, and to charge a fee for, warranty, support,+indemnity or liability obligations to one or more recipients of Covered+Software. However, You may do so only on Your own behalf, and not on+behalf of any Contributor. You must make it absolutely clear that any+such warranty, support, indemnity, or liability obligation is offered by+You alone, and You hereby agree to indemnify every Contributor for any+liability incurred by such Contributor as a result of warranty, support,+indemnity or liability terms You offer. You may include additional+disclaimers of warranty and limitations of liability specific to any+jurisdiction.++4. Inability to Comply Due to Statute or Regulation+---------------------------------------------------++If it is impossible for You to comply with any of the terms of this+License with respect to some or all of the Covered Software due to+statute, judicial order, or regulation then You must: (a) comply with+the terms of this License to the maximum extent possible; and (b)+describe the limitations and the code they affect. Such description must+be placed in a text file included with all distributions of the Covered+Software under this License. Except to the extent prohibited by statute+or regulation, such description must be sufficiently detailed for a+recipient of ordinary skill to be able to understand it.++5. Termination+--------------++5.1. The rights granted under this License will terminate automatically+if You fail to comply with any of its terms. However, if You become+compliant, then the rights granted under this License from a particular+Contributor are reinstated (a) provisionally, unless and until such+Contributor explicitly and finally terminates Your grants, and (b) on an+ongoing basis, if such Contributor fails to notify You of the+non-compliance by some reasonable means prior to 60 days after You have+come back into compliance. Moreover, Your grants from a particular+Contributor are reinstated on an ongoing basis if such Contributor+notifies You of the non-compliance by some reasonable means, this is the+first time You have received notice of non-compliance with this License+from such Contributor, and You become compliant prior to 30 days after+Your receipt of the notice.++5.2. If You initiate litigation against any entity by asserting a patent+infringement claim (excluding declaratory judgment actions,+counter-claims, and cross-claims) alleging that a Contributor Version+directly or indirectly infringes any patent, then the rights granted to+You by any and all Contributors for the Covered Software under Section+2.1 of this License shall terminate.++5.3. In the event of termination under Sections 5.1 or 5.2 above, all+end user license agreements (excluding distributors and resellers) which+have been validly granted by You or Your distributors under this License+prior to termination shall survive termination.++************************************************************************+* *+* 6. Disclaimer of Warranty *+* ------------------------- *+* *+* Covered Software is provided under this License on an "as is" *+* basis, without warranty of any kind, either expressed, implied, or *+* statutory, including, without limitation, warranties that the *+* Covered Software is free of defects, merchantable, fit for a *+* particular purpose or non-infringing. The entire risk as to the *+* quality and performance of the Covered Software is with You. *+* Should any Covered Software prove defective in any respect, You *+* (not any Contributor) assume the cost of any necessary servicing, *+* repair, or correction. This disclaimer of warranty constitutes an *+* essential part of this License. No use of any Covered Software is *+* authorized under this License except under this disclaimer. *+* *+************************************************************************++************************************************************************+* *+* 7. Limitation of Liability *+* -------------------------- *+* *+* Under no circumstances and under no legal theory, whether tort *+* (including negligence), contract, or otherwise, shall any *+* Contributor, or anyone who distributes Covered Software as *+* permitted above, be liable to You for any direct, indirect, *+* special, incidental, or consequential damages of any character *+* including, without limitation, damages for lost profits, loss of *+* goodwill, work stoppage, computer failure or malfunction, or any *+* and all other commercial damages or losses, even if such party *+* shall have been informed of the possibility of such damages. This *+* limitation of liability shall not apply to liability for death or *+* personal injury resulting from such party's negligence to the *+* extent applicable law prohibits such limitation. Some *+* jurisdictions do not allow the exclusion or limitation of *+* incidental or consequential damages, so this exclusion and *+* limitation may not apply to You. *+* *+************************************************************************++8. Litigation+-------------++Any litigation relating to this License may be brought only in the+courts of a jurisdiction where the defendant maintains its principal+place of business and such litigation shall be governed by laws of that+jurisdiction, without reference to its conflict-of-law provisions.+Nothing in this Section shall prevent a party's ability to bring+cross-claims or counter-claims.++9. Miscellaneous+----------------++This License represents the complete agreement concerning the subject+matter hereof. If any provision of this License is held to be+unenforceable, such provision shall be reformed only to the extent+necessary to make it enforceable. Any law or regulation which provides+that the language of a contract shall be construed against the drafter+shall not be used to construe this License against a Contributor.++10. Versions of the License+---------------------------++10.1. New Versions++Mozilla Foundation is the license steward. Except as provided in Section+10.3, no one other than the license steward has the right to modify or+publish new versions of this License. Each version will be given a+distinguishing version number.++10.2. Effect of New Versions++You may distribute the Covered Software under the terms of the version+of the License under which You originally received the Covered Software,+or under the terms of any subsequent version published by the license+steward.++10.3. Modified Versions++If you create software not governed by this License, and you want to+create a new license for such software, you may create and use a+modified version of this License if you rename the license and remove+any references to the name of the license steward (except to note that+such modified license differs from this License).++10.4. Distributing Source Code Form that is Incompatible With Secondary+Licenses++If You choose to distribute Source Code Form that is Incompatible With+Secondary Licenses under the terms of this version of the License, the+notice described in Exhibit B of this License must be attached.++Exhibit A - Source Code Form License Notice+-------------------------------------------++ This Source Code Form is subject to the terms of the Mozilla Public+ License, v. 2.0. If a copy of the MPL was not distributed with this+ file, You can obtain one at http://mozilla.org/MPL/2.0/.++If it is not possible or desirable to put the notice in a particular+file, then You may include the notice in a location (such as a LICENSE+file in a relevant directory) where a recipient would be likely to look+for such a notice.++You may add additional accurate notices of copyright ownership.++Exhibit B - "Incompatible With Secondary Licenses" Notice+---------------------------------------------------------++ This Source Code Form is "Incompatible With Secondary Licenses", as+ defined by the Mozilla Public License, v. 2.0.
+ README.md view
@@ -0,0 +1,79 @@+[](https://travis-ci.org/rkaippully/gamgee)+[](https://github.com/rkaippully/gamgee/releases)++# About+Gamgee is your sidekick for managing multi-factor authentication+tokens. It is a command-line tool that can be used as a drop-in+replacement for Google Authenticator app or any other similar app+providing multi-factor authentication using Time-based One-Time+Password (TOTP) algorithm.++Gamgee implements the TOTP algorithm specified in+[RFC6238](https://tools.ietf.org/html/rfc6238)++# Installation+On MacOS, install using homebrew:++```+brew install rkaippully/tools/gamgee+```++See other releases here:+https://github.com/rkaippully/gamgee/releases/latest++# Usage+Gamgee is a replacement for apps like Google Authenticator or Authy+that are used to generate TOTP tokens. Typically, such tools scan a QR+code to create an account. Gamgee cannot scan a QR code (yet), but you+can instead get a secret token from your service and add that to+Gamgee.++1. Go to the multi-factor authentication setup page of your service+ (such as Github, Gmail, etc). You will see a QR code in that page+ and instructions to scan it with an app.+2. Look for a link in the page that gives alternative installation+ instructions. For example, many services include a "Can't scan+ barcode?" or "Enter this text code" link next to the QR code.+ Follow that link.+3. Note down the secret code mentioned in the page. Once you get the+ secret, create a token with this command:++```+gamgee add -l "<token-label>" -s "<secret-code>"+```++`token-label` is a convenient label that you choose for this token.++Now you are ready to generate an OTP with your token:++```+gamgee <token-label>+```++This will generate an OTP and copy it to your clipboard. You can paste+it into your authentication service. Alternatively, you can write the+OTP to standard output with:++```+gamgee <token-label> --stdout+```++You can find a list of all your tokens with:++```+gamgee list+```++You can also remove a token if it is no longer needed. Please remember+that this cannot be undone:++```+gamgee delete -l "<token-label>"+```++# License+Gamgee is distributed under Mozilla Public License 2.0. See the file+LICENSE for details.++This Source Code Form is "Incompatible With Secondary Licenses", as+defined by the Mozilla Public License, v. 2.0.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Gamgee/Program/CommandLine.hs view
@@ -0,0 +1,80 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Command line argument parsing+module Gamgee.Program.CommandLine+ ( Command (..)+ , OutputMode (..)+ , getCommand+ , versionOption+ ) where++import qualified Data.Version as Version+import qualified Gamgee.Token as Token+import Options.Applicative+import Paths_gamgee (version)+import Relude+++data OutputMode = OutputStdOut+ | OutputClipboard+ deriving stock (Eq)++data Command = AddToken Token.TokenSpec+ | DeleteToken Token.TokenIdentifier+ | ListTokens+ | GetOTP Token.TokenIdentifier OutputMode++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")+ )+ <|> getOTPOperation++listTokens :: Parser Command+listTokens = pure ListTokens++addToken :: Parser Command+addToken = AddToken <$> tokenSpec++tokenSpec :: Parser Token.TokenSpec+tokenSpec = Token.TokenSpec+ <$> pure Token.TOTP+ <*> strOption (long "label" <> short 'l'+ <> help "Label of the token")+ <*> (Token.TokenSecretPlainText <$> strOption (long "secret" <> short 's'+ <> help "Secret of the token"))+ <*> strOption (long "issuer" <> short 'i' <> value (Token.TokenIssuer "")+ <> help "Issuer of the token")+ <*> option (eitherReader algoReader) (long "algorithm" <> short 'a' <> value Token.AlgorithmSHA1+ <> help "HMAC algorithm - SHA1 (default), SHA256, or SHA512")+ <*> option (eitherReader digitsReader) (long "digits" <> short 'd' <> value Token.Digits6+ <> help "Number of digits in the OTP - 6 (default) or 8")+ <*> (Token.TokenPeriod <$> option auto (long "period" <> short 'p' <> value 30+ <> help "OTP validity in seconds. Default - 30."))++deleteToken :: Parser Command+deleteToken = DeleteToken <$> strOption (long "label" <> short 'l' <> help "Label of the token")++algoReader :: String -> Either String Token.TokenAlgorithm+algoReader "SHA1" = Right Token.AlgorithmSHA1+algoReader "SHA256" = Right Token.AlgorithmSHA256+algoReader "SHA512" = Right Token.AlgorithmSHA512+algoReader s = Left $ "Invalid algorithm: " ++ s++digitsReader :: String -> Either String Token.TokenDigits+digitsReader "6" = Right Token.Digits6+digitsReader "8" = Right Token.Digits8+digitsReader s = Left $ "Invalid number of digits: " ++ s ++ ". Must be 6 or 8."++versionOption :: Parser (a -> a)+versionOption = infoOption (Version.showVersion version) (long "version" <> help "Show version")++getOTPOperation :: Parser Command+getOTPOperation = GetOTP+ <$> strArgument (help "Get a one-time password" <> metavar "TOKEN-LABEL")+ <*> flag OutputClipboard OutputStdOut+ (long "stdout" <> help "Send the OTP to stdout instead of clipboard")
+ app/Gamgee/Program/Effects.hs view
@@ -0,0 +1,130 @@+{-# 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+ , runOutputStdOut+ , runOutputClipboard+ , runErrorStdErr+ ) where++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 qualified Polysemy as P+import qualified Polysemy.Error as P+import qualified Polysemy.Output as P+import Relude+import qualified System.Directory as Dir+import System.FilePath ((</>))+import qualified System.Hclip as Clip+import qualified System.IO.Error as IO+import qualified System.Posix.Files as Files+++-- | A version of runM that ignores its result+runM_ :: Monad m => Sem '[Lift m] a -> m ()+runM_ = void . P.runM++----------------------------------------------------------------------------------------------------+-- 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++runOutputClipboard :: Member (Lift IO) r => Sem (P.Output Text : r) a -> Sem r a+runOutputClipboard = P.interpret $ \case+ P.Output s -> P.sendM $ Clip.setClipboard $ toString s+++----------------------------------------------------------------------------------------------------+-- Interpret Error by writing it to stderr+----------------------------------------------------------------------------------------------------++instance ToText Eff.EffError where+ toText (Eff.AlreadyExists ident) = "A token named '" <> Token.unTokenIdentifier ident <> "' already exists."+ toText (Eff.NoSuchToken ident) = "No such token: '" <> Token.unTokenIdentifier ident <> "'"+ toText (Eff.CryptoError ce) = show ce+ toText (Eff.CorruptIV _) = "Internal Error: Unable to decode initial vector, your config is probably corrupt"+ toText (Eff.CorruptBase64Encoding msg) = msg+ toText (Eff.SecretDecryptError _) = "Error decrypting token. Did you provide an incorrect password?"+ toText (Eff.InvalidTokenPeriod tp) = "Unsupported token period: " <> show (Token.unTokenPeriod tp)+ toText (Eff.UnsupportedConfigVersion v) = "Internal Error: Unsupported config version: " <> show v+ toText (Eff.JSONDecodeError msg) = "Internal Error: Could not decode Gamgee config file: " <> msg++data ByteStoreError = ReadError IO.IOError+ | WriteError IO.IOError++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 = fmap join . runToTextError . runToTextError++runToTextError :: (Member (Lift 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+++----------------------------------------------------------------------------------------------------+-- Interpret ByteStore using a file+----------------------------------------------------------------------------------------------------++runByteStoreFile :: ( Members [Lift IO, P.Error e] r+ , Exception e1+ , Exception e2)+ => FilePath+ -> (e1 -> Either e (Maybe LByteString)) -- ^ Function to handle read errors+ -> (e2 -> Maybe e) -- ^ Function to handle write errors+ -> Sem (Eff.ByteStore : r) a+ -> Sem r a+runByteStoreFile file handleReadError handleWriteError = P.interpret $ \case+ Eff.ReadByteStore -> do+ res <- P.sendM $ (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)+ 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+ file <- P.sendM configFilePath+ runByteStoreFile file handleReadError handleWriteError prog++ where+ handleReadError :: IO.IOError -> Either ByteStoreError (Maybe LByteString)+ handleReadError e = if IO.isDoesNotExistError e+ then Right Nothing+ else Left $ ReadError e++ handleWriteError :: IO.IOError -> Maybe ByteStoreError+ handleWriteError e = Just $ WriteError e++-- | Path under which tokens are stored - typically ~/.config/gamgee/tokens.json+configFilePath :: IO FilePath+configFilePath = do+ dir <- Dir.getXdgDirectory Dir.XdgConfig "gamgee"+ Dir.createDirectoryIfMissing True dir+ return $ dir </> "tokens.json"
+ app/Main.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeOperators #-}++module Main where++import qualified Data.Time.Clock.POSIX as Clock+import qualified Gamgee.Effects as Eff+import qualified Gamgee.Operation as Operation+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 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++parserInfo :: Options.ParserInfo Cmd.Command+parserInfo = Options.info (Options.helper+ <*> Cmd.versionOption+ <*> Cmd.getCommand) Options.fullDesc++runAddToken :: Token.TokenSpec -> IO ()+runAddToken spec = Eff.runM_+ $ Eff.runErrorStdErr+ $ Eff.runCryptoRandomIO+ $ Eff.runCrypto+ $ Eff.runSecretInputIO+ $ Eff.runGamgeeByteStoreIO+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON+ $ Operation.addToken spec++runDeleteToken :: Token.TokenIdentifier -> IO ()+runDeleteToken t = Eff.runM_+ $ Eff.runErrorStdErr+ $ Eff.runGamgeeByteStoreIO+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON+ $ Operation.deleteToken t++runListTokens :: IO ()+runListTokens = Eff.runM_+ $ Eff.runErrorStdErr+ $ Eff.runOutputStdOut+ $ Eff.runGamgeeByteStoreIO+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON Operation.listTokens++runGetOTP :: Token.TokenIdentifier -> Cmd.OutputMode -> IO ()+runGetOTP t o = do+ now <- Clock.getPOSIXTime+ Eff.runM_+ $ Eff.runErrorStdErr+ $ (if o == Cmd.OutputStdOut then Eff.runOutputStdOut else Eff.runOutputClipboard)+ $ Eff.runCryptoRandomIO+ $ Eff.runCrypto+ $ Eff.runSecretInputIO+ $ Eff.runGamgeeByteStoreIO+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON+ $ Eff.runTOTP+ $ Operation.getOTP t now
+ gamgee.cabal view
@@ -0,0 +1,113 @@+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 <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++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++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++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
+ src/Gamgee/Effects.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TypeOperators #-}++module Gamgee.Effects+ ( module Gamgee.Effects.Crypto+ , module Gamgee.Effects.CryptoRandom+ , module Gamgee.Effects.JSONStore+ , module Gamgee.Effects.ByteStore+ , module Gamgee.Effects.SecretInput+ , module Gamgee.Effects.TOTP+ , module Gamgee.Effects.Error++ , runStateJSON+ ) where++import Gamgee.Effects.ByteStore+import Gamgee.Effects.Crypto+import Gamgee.Effects.CryptoRandom+import Gamgee.Effects.Error+import Gamgee.Effects.JSONStore+import Gamgee.Effects.SecretInput+import Gamgee.Effects.TOTP+import Polysemy (Sem)+import qualified Polysemy as P+import qualified Polysemy.State as P+++----------------------------------------------------------------------------------------------------+-- Reinterpret State backed by a JSON store+----------------------------------------------------------------------------------------------------++runStateJSON :: Sem (P.State o : r) a -> Sem (JSONStore o : r) a+runStateJSON = P.reinterpret $ \case+ P.Get -> jsonDecode+ P.Put s -> jsonEncode s
+ src/Gamgee/Effects/ByteStore.hs view
@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}++module Gamgee.Effects.ByteStore+ ( -- * Effect+ ByteStore (..)++ -- * Actions+ , readByteStore+ , writeByteStore++ ) where++import qualified Polysemy as P+import Relude+++----------------------------------------------------------------------------------------------------+-- A store for saving and reading bytes+----------------------------------------------------------------------------------------------------++data ByteStore m a where+ ReadByteStore :: ByteStore m (Maybe LByteString)+ WriteByteStore :: LByteString -> ByteStore m ()++P.makeSem ''ByteStore
+ src/Gamgee/Effects/Crypto.hs view
@@ -0,0 +1,149 @@+{-# 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+ Crypto(..)++ -- * Programs+ , encryptSecret+ , decryptSecret++ -- * Interpretations+ , runCrypto+ ) where++import Crypto.Cipher.AES (AES256)+import qualified Crypto.Cipher.Types as CT+import qualified Crypto.Error as CE+import qualified Data.ByteArray as BA+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as Text+import qualified Gamgee.Effects.CryptoRandom as CR+import qualified Gamgee.Effects.Error as Err+import qualified Gamgee.Effects.SecretInput as SI+import qualified Gamgee.Token as Token+import Polysemy (Member, Members, Sem)+import qualified Polysemy as P+import qualified Polysemy.Error as P+import Relude+++----------------------------------------------------------------------------------------------------+-- Effect+----------------------------------------------------------------------------------------------------++-- | Effect for encrypting and decrypting secrets+data Crypto m a where+ -- | Encrypts a secret with an optional password+ Encrypt :: Text -- ^ The secret to encrypt+ -> Text -- ^ The password+ -> Crypto m Token.TokenSecret+ -- | Decrypt a secret with an optional password+ Decrypt :: Text -- ^ Base64 encoded IV+ -> Text -- ^ Base64 encoded encrypted secret+ -> Text -- ^ The password for decryption+ -> Crypto m Text -- ^ Decrypted secret++P.makeSem ''Crypto+++----------------------------------------------------------------------------------------------------+-- Programs+----------------------------------------------------------------------------------------------------++encryptSecret :: Members [SI.SecretInput Text, Crypto] r => Token.TokenSpec -> Sem r Token.TokenSpec+encryptSecret spec =+ case Token.tokenSecret spec of+ -- Secret is already encrypted+ Token.TokenSecretAES256 _ _ -> return spec+ Token.TokenSecretPlainText plainSecret -> do+ -- Ask the user for a password+ password <- SI.secretInput "Password to encrypt (leave blank to skip encryption): "++ if Text.null password+ then return spec+ else do+ -- Sometimes the secret may contain extraneous chars - '=', '-', space etc. Clear those.+ let secret = (Text.toUpper . Text.dropWhileEnd (== '=') . Text.replace " " "" . Text.replace "-" "" . Text.strip) plainSecret++ secret' <- encrypt secret password+ return spec { Token.tokenSecret = secret' }++decryptSecret :: Members [SI.SecretInput Text, Crypto] r => Token.TokenSpec -> Sem r Text+decryptSecret spec =+ case Token.tokenSecret spec of+ Token.TokenSecretPlainText plainSecret -> return plainSecret+ Token.TokenSecretAES256 encIV encSecret -> do+ password <- SI.secretInput "Password: "+ decrypt encIV encSecret password+++----------------------------------------------------------------------------------------------------+-- Interpretations+----------------------------------------------------------------------------------------------------++runCrypto :: Members [CR.CryptoRandom, P.Error Err.EffError] r => Sem (Crypto : r) a -> Sem r a+runCrypto = P.interpret $ \case+ Encrypt secret password -> do+ iv <- genRandomIV+ toTokenSecret iv secret password++ Decrypt encIV encSecret password -> fromTokenSecret encIV encSecret password++-- | Generate a random initialization vector+genRandomIV :: Members [P.Error Err.EffError, CR.CryptoRandom] r => Sem r (CT.IV AES256)+genRandomIV = do+ bytes <- CR.randomBytes $ CT.blockSize (error "Internal Error: This shouldn't be evaluated" :: AES256)+ case CT.makeIV (bytes :: ByteString) of+ Just iv -> return iv+ Nothing -> error "Internal Error: Unable to generate random initial vector"++-- | Generate an encrypted TokenSecret from an iv, a secret text and password+toTokenSecret :: Member (P.Error Err.EffError) r+ => CT.IV AES256+ -> Text -- ^ Secret+ -> Text -- ^ Password+ -> Sem r Token.TokenSecret+toTokenSecret iv secret password = do+ cipher <- CE.onCryptoFailure (P.throw . Err.CryptoError) return $ CT.cipherInit (passwordToKey password)+ return Token.TokenSecretAES256 {+ Token.tokenSecretAES256IV = toBase64 $ BA.convert iv+ , Token.tokenSecretAES256Data = toBase64 $ CT.ctrCombine cipher iv (encodeUtf8 secret)+ }++-- | Extract the secret text from a TokenSecret given its password+fromTokenSecret :: Member (P.Error Err.EffError) r+ => Text -- ^ Base64 encoded IV+ -> Text -- ^ Base64 encoded encrypted secret+ -> Text -- ^ The password+ -> Sem r Text -- ^ IV and secret+fromTokenSecret encIV encSecret password = do+ iv <- fromBase64 encIV+ case CT.makeIV iv of+ Nothing -> P.throw $ Err.CorruptIV iv+ Just iv' -> do+ secret <- fromBase64 encSecret+ cipher <- CE.onCryptoFailure (P.throw . Err.CryptoError) return $ CT.cipherInit (passwordToKey password)+ return $ decodeUtf8 $ CT.ctrCombine (cipher :: AES256) iv' secret++passwordToKey :: Text -> ByteString+passwordToKey password = toStrict $ LBS.take 32 $ LBS.cycle $ encodeUtf8 password++toBase64 :: ByteString -> Text+toBase64 = decodeUtf8 . B64.encode++fromBase64 :: Member (P.Error Err.EffError) r+ => Text+ -> Sem r ByteString+fromBase64 = either (P.throw . Err.CorruptBase64Encoding . toText) return . B64.decode . encodeUtf8
+ src/Gamgee/Effects/CryptoRandom.hs view
@@ -0,0 +1,48 @@+{-# 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(..)++ -- * Action+ , randomBytes++ -- * Interpretations+ , runCryptoRandomIO+ ) where++import qualified Crypto.Random.Types as CRT+import qualified Data.ByteArray as BA+import Polysemy (Lift, Member, Sem)+import qualified Polysemy as P+import Relude+++----------------------------------------------------------------------------------------------------+-- Effects+----------------------------------------------------------------------------------------------------++-- | An effect capable of providing random bytes for use with cryptonite+data CryptoRandom m a where+ -- ^ Generate random bytes+ RandomBytes :: BA.ByteArray b => Int -> CryptoRandom m b++P.makeSem ''CryptoRandom+++----------------------------------------------------------------------------------------------------+-- Interpretations+----------------------------------------------------------------------------------------------------++runCryptoRandomIO :: Member (Lift IO) r => Sem (CryptoRandom : r) a -> Sem r a+runCryptoRandomIO = P.interpret $ \case+ RandomBytes count -> P.sendM $ CRT.getRandomBytes count
+ src/Gamgee/Effects/Error.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Gamgee.Effects.Error+ ( EffError(..)+ ) where++import qualified Crypto.Error as CE+import qualified Gamgee.Token as Token+import Relude+++-- | Errors returned by Gamgee effects+data EffError = AlreadyExists Token.TokenIdentifier+ | NoSuchToken Token.TokenIdentifier+ | CryptoError CE.CryptoError+ | CorruptIV ByteString+ | CorruptBase64Encoding Text+ | SecretDecryptError Text+ | InvalidTokenPeriod Token.TokenPeriod+ | UnsupportedConfigVersion Word32+ | JSONDecodeError Text+ deriving stock (Show, Eq)
+ src/Gamgee/Effects/JSONStore.hs view
@@ -0,0 +1,102 @@+{-# 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 (..)++ -- * Actions+ , jsonEncode+ , jsonDecode++ -- * Interpretation+ , runGamgeeJSONStore+ ) where++import qualified Data.Aeson as Aeson+import qualified Gamgee.Effects.ByteStore as BS+import qualified Gamgee.Effects.Error as Err+import qualified Gamgee.Token as Token+import Polysemy (Member, Sem)+import qualified Polysemy as P+import qualified Polysemy.Error as P+import Relude++++----------------------------------------------------------------------------------------------------+-- An abstract JSON store effect that encodes and decodes JSON objects+----------------------------------------------------------------------------------------------------++data JSONStore o m a where+ JsonEncode :: o -> JSONStore o m ()+ JsonDecode :: JSONStore o m o++P.makeSem ''JSONStore+++----------------------------------------------------------------------------------------------------+-- Gamgee Configuration+----------------------------------------------------------------------------------------------------++data Config = Config {+ configVersion :: Word32+ , configTokens :: Token.Tokens+ }+ deriving stock (Generic)+ deriving anyclass (Aeson.FromJSON, Aeson.ToJSON)++currentConfigVersion :: Word32+currentConfigVersion = 1++initialConfig :: Config+initialConfig = Config {+ configVersion = currentConfigVersion+ , configTokens = fromList []+ }+++----------------------------------------------------------------------------------------------------+-- Interpret JSONStore backed by a ByteStore+----------------------------------------------------------------------------------------------------++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 =+ P.reinterpret $ \case+ JsonEncode o -> do+ j <- convertE o+ BS.writeByteStore $ Aeson.encode j+ JsonDecode -> do+ bytes <- BS.readByteStore+ let+ config = maybe (Right initialConfig) Aeson.eitherDecode' bytes+ either handleError convertD config++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
+ src/Gamgee/Effects/SecretInput.hs view
@@ -0,0 +1,65 @@+{-# 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(..)++ -- * Actions+ , secretInput++ -- * Interpretations+ , runSecretInputIO+ ) where++import Control.Exception.Safe (bracket_)+import Polysemy (Lift, Member, Sem)+import qualified Polysemy as P+import Relude+import qualified System.IO as IO++++----------------------------------------------------------------------------------------------------+-- Effect+----------------------------------------------------------------------------------------------------++-- | An effect that provides input to the application. Intended to be+-- used in contexts where the input is a secret such as+-- passwords. Interpretations may chose to "protect" the input+-- 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+ SecretInput :: Text -- ^ A prompt+ -> SecretInput i m i++P.makeSem ''SecretInput+++----------------------------------------------------------------------------------------------------+-- Interpretations+----------------------------------------------------------------------------------------------------++runSecretInputIO :: (Member (Lift IO) r) => Sem (SecretInput Text : r) a -> Sem r a+runSecretInputIO = P.interpret $ \case+ SecretInput prompt -> P.sendM $ do+ putText prompt+ IO.hFlush stdout+ i <- withoutEcho getLine+ IO.putChar '\n'+ return i++ where+ withoutEcho :: IO a -> IO a+ withoutEcho f = do+ old <- IO.hGetEcho stdin+ bracket_ (IO.hSetEcho stdin False) (IO.hSetEcho stdin old) f
+ src/Gamgee/Effects/TOTP.hs view
@@ -0,0 +1,90 @@+{-# 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 (..)++ -- * Actions+ , getTOTP++ -- * Interpretations+ , runTOTP+ ) where++import qualified Crypto.Hash.Algorithms as HashAlgos+import qualified Crypto.OTP as OTP+import qualified Data.ByteArray.Encoding as Encoding+import qualified Data.Time.Clock.POSIX as Clock+import Gamgee.Effects.Crypto (Crypto)+import qualified Gamgee.Effects.Crypto as Crypto+import qualified Gamgee.Effects.Error as Err+import Gamgee.Effects.SecretInput (SecretInput)+import qualified Gamgee.Token as Token+import Polysemy (Member, Members, Sem)+import qualified Polysemy as P+import qualified Polysemy.Error as P+import Relude+import qualified Text.Printf as Printf+++----------------------------------------------------------------------------------------------------+-- Effects+----------------------------------------------------------------------------------------------------++data TOTP m a where+ GetTOTP :: Token.TokenSpec -> Clock.POSIXTime -> TOTP m Text++P.makeSem ''TOTP+++----------------------------------------------------------------------------------------------------+-- Interpret 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 =+ case Token.tokenAlgorithm spec of+ Token.AlgorithmSHA1 -> makeOTP <$> makeParams HashAlgos.SHA1+ Token.AlgorithmSHA256 -> makeOTP <$> makeParams HashAlgos.SHA256+ Token.AlgorithmSHA512 -> makeOTP <$> makeParams HashAlgos.SHA512++ where+ period :: Token.TokenPeriod+ period = Token.tokenPeriod spec++ digits :: OTP.OTPDigits+ digits = case Token.tokenDigits spec of+ Token.Digits6 -> OTP.OTP6+ Token.Digits8 -> OTP.OTP8++ makeParams :: (Member (P.Error Err.EffError) r, HashAlgos.HashAlgorithm h) => h -> Sem r (OTP.TOTPParams h)+ makeParams alg = either (const (P.throw $ Err.InvalidTokenPeriod period))+ return $+ OTP.mkTOTPParams alg 0 (Token.unTokenPeriod period) digits OTP.NoSkew++ makeOTP :: (HashAlgos.HashAlgorithm h) => OTP.TOTPParams h -> Text+ makeOTP p = format $ OTP.totp p key $ floor time++ format :: OTP.OTP -> Text+ format otp =+ let (base, size) = case Token.tokenDigits spec of+ Token.Digits6 -> (1000000, "6")+ Token.Digits8 -> (100000000, "8")+ in fromString $ Printf.printf ("%0" ++ size ++ "d") (otp `mod` base)
+ src/Gamgee/Operation.hs view
@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Gamgee.Operation+ ( addToken+ , deleteToken+ , listTokens+ , getOTP+ ) where+++import qualified Data.Time.Clock.POSIX as Clock+import qualified Gamgee.Effects as Eff+import qualified Gamgee.Token as Token+import Polysemy (Members, Sem)+import qualified Polysemy.Error as P+import qualified Polysemy.Output as P+import qualified Polysemy.State as P+import Relude+import qualified Relude.Extra.Map as Map+++addToken :: Members [ P.State Token.Tokens+ , Eff.Crypto+ , Eff.SecretInput Text+ , P.Error Eff.EffError ] r+ => Token.TokenSpec+ -> Sem r ()+addToken spec = do+ let ident = Token.getIdentifier spec+ tokens <- P.get+ if ident `Map.member` tokens+ then P.throw $ Eff.AlreadyExists ident+ else do+ spec' <- Eff.encryptSecret spec+ P.put $ Map.insert ident spec' tokens++deleteToken :: Members [ P.State Token.Tokens+ , P.Error Eff.EffError ] r+ => Token.TokenIdentifier+ -> Sem r ()+deleteToken ident = do+ tokens <- P.get+ case Map.lookup ident tokens of+ Nothing -> P.throw $ Eff.NoSuchToken ident+ Just _ -> P.put $ Map.delete ident tokens++listTokens :: Members [ P.State Token.Tokens+ , P.Output Text ] r+ => Sem r ()+listTokens = do+ tokens <- P.get+ mapM_ (P.output . Token.unTokenIdentifier . Token.getIdentifier) (tokens :: Token.Tokens)++getOTP :: Members [ P.State Token.Tokens+ , P.Error Eff.EffError+ , P.Output Text+ , Eff.TOTP ] r+ => Token.TokenIdentifier+ -> Clock.POSIXTime+ -> Sem r ()+getOTP ident time = do+ tokens <- P.get+ case Map.lookup ident tokens of+ Nothing -> P.throw $ Eff.NoSuchToken ident+ Just spec -> Eff.getTOTP spec time >>= P.output
+ src/Gamgee/Token.hs view
@@ -0,0 +1,123 @@+{-# 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 (..)+ , TokenLabel (..)+ , TokenSecret (..)+ , TokenIssuer (..)+ , TokenAlgorithm (..)+ , TokenDigits (..)+ , TokenPeriod (..)+ , TokenSpec (..)+ , TokenIdentifier (..)+ , Tokens+ , getIdentifier+ ) where++import qualified Data.Aeson as Aeson+import qualified Data.Text as Text+import Relude+++-- | Type of token TOTP or HOTP (not supported yet)+data TokenType = TOTP+ deriving stock Show++instance Aeson.FromJSON TokenType where+ parseJSON (Aeson.String "totp") = return TOTP+ parseJSON invalid = fail $ "Invalid token type: " ++ show invalid++instance Aeson.ToJSON TokenType where+ toJSON TOTP = Aeson.String "totp"++-- | Label of the token+newtype TokenLabel = TokenLabel {+ unTokenLabel :: Text+ }+ deriving newtype (Show, IsString, Aeson.FromJSON, Aeson.ToJSON)++-- | Secret used to generate OTPs+data TokenSecret = TokenSecretPlainText Text+ | TokenSecretAES256 {+ tokenSecretAES256IV :: Text+ , tokenSecretAES256Data :: Text+ }+ deriving stock (Show, Generic)+ deriving anyclass (Aeson.FromJSON, Aeson.ToJSON)++-- | Optional issuer of this token+newtype TokenIssuer = TokenIssuer {+ unTokenIssuer :: Text+ }+ deriving newtype (Show, IsString, Aeson.FromJSON, Aeson.ToJSON)++data TokenAlgorithm = AlgorithmSHA1+ | AlgorithmSHA256+ | AlgorithmSHA512+ deriving stock (Show, Generic)+ deriving anyclass (Aeson.FromJSON, Aeson.ToJSON)++data TokenDigits = Digits6+ | Digits8+ deriving stock Show++instance Aeson.FromJSON TokenDigits where+ parseJSON (Aeson.Number 6) = return Digits6+ parseJSON (Aeson.Number 8) = return Digits8+ parseJSON invalid = fail $ "Invalid number of digits: " ++ show invalid ++ ". Must be 6 or 8."++instance Aeson.ToJSON TokenDigits where+ toJSON Digits6 = Aeson.Number 6+ toJSON Digits8 = Aeson.Number 8++-- | Refresh interval of the token in seconds+newtype TokenPeriod = TokenPeriod {+ unTokenPeriod :: Word16+ }+ deriving newtype (Eq, Ord, Enum, Num, Real, Integral, Show, Aeson.FromJSON, Aeson.ToJSON)++data TokenSpec = TokenSpec {+ -- ^ TOTP/HOTP token+ tokenType :: TokenType+ -- ^ A short unique label for this token used to identify it+ , tokenLabel :: TokenLabel+ -- ^ The secret provided by the issuer to generate tokens+ , tokenSecret :: TokenSecret+ -- ^ The name of the issuer+ , tokenIssuer :: TokenIssuer+ -- ^ SHA algorithm used to generate tokens+ , tokenAlgorithm :: TokenAlgorithm+ -- ^ Number of digits in the token - 6 or 8+ , tokenDigits :: TokenDigits+ -- ^ Refresh interval of the token - typically 30 sec+ , tokenPeriod :: TokenPeriod+ }+ deriving stock (Generic, Show)+ deriving anyclass (Aeson.FromJSON, Aeson.ToJSON)++-- An identifier for a token. This is derived from the label and issuer+newtype TokenIdentifier = TokenIdentifier {+ unTokenIdentifier :: Text+ }+ deriving newtype (Eq, Show, Hashable, IsString, Semigroup, ToString+ , Aeson.FromJSON, Aeson.ToJSON+ , Aeson.FromJSONKey, Aeson.ToJSONKey)++getIdentifier :: TokenSpec -> TokenIdentifier+getIdentifier spec =+ let+ TokenLabel label = tokenLabel spec+ TokenIssuer issuer = tokenIssuer spec+ in+ TokenIdentifier $ if | Text.null issuer -> label+ | Text.isPrefixOf (issuer <> ":") label -> label+ | otherwise -> issuer <> ":" <> label++type Tokens = HashMap TokenIdentifier TokenSpec
+ test/Gamgee/Test/Effects.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeOperators #-}++module Gamgee.Test.Effects+ ( runOutputPure+ , runListSecretInput+ , runCryptoRandom+ , runByteStoreST+ ) where++import Control.Monad.ST (ST)+import qualified Crypto.Random as CR+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 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+----------------------------------------------------------------------------------------------------++runListSecretInput :: [i] -> Sem (Eff.SecretInput i : r) a -> Sem r a+runListSecretInput is = fmap snd . P.runState is . P.reinterpret+ (\case+ Eff.SecretInput _ -> do+ s <- P.gets uncons+ whenJust s (P.put . snd)+ maybe+ (error "Ran out of input in SecretInput")+ return+ (fst <$> s)+ )+++----------------------------------------------------------------------------------------------------+-- Interpret CryptoRandom with a DRG+----------------------------------------------------------------------------------------------------++runCryptoRandom :: CR.DRG gen => gen -> Sem (Eff.CryptoRandom : r) a -> Sem r a+runCryptoRandom gen = P.interpret $ \case+ Eff.RandomBytes count -> return (fst $ CR.withDRG gen (CRT.getRandomBytes count))+++----------------------------------------------------------------------------------------------------+-- 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 ref = P.interpret $ \case+ Eff.ReadByteStore -> P.sendM $ STRef.readSTRef ref+ Eff.WriteByteStore bytes -> P.sendM $ STRef.writeSTRef ref (Just bytes)
+ test/Gamgee/Test/Golden.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module Gamgee.Test.Golden+ ( goldenTests+ ) where++import qualified Crypto.Random as CR+import qualified Gamgee.Test.Operation as Op+import qualified Gamgee.Token as Token+import Relude+import System.FilePath ((</>))+import qualified Test.Tasty as T+import qualified Test.Tasty.Golden as T+++goldenTests :: T.TestTree+goldenTests = T.testGroup "Golden Tests" [ getOTPTest ]++goldenTest :: Show a => T.TestName -> IO a -> T.TestTree+goldenTest name action = T.goldenVsString name (goldenDir </> name ++ ".txt") (encodeUtf8 @String . show <$> action)+ where+ goldenDir = "test" </> "data" </> "golden"+++----------------------------------------------------------------------------------------------------+-- getOTP tests+----------------------------------------------------------------------------------------------------++getOTPTest :: T.TestTree+getOTPTest = goldenTest "getOTPTest" $ do+ drg <- CR.getSystemDRG+ return $ Op.runTest Nothing $ \cfg -> do+ let spec = Token.TokenSpec {+ Token.tokenType = Token.TOTP+ , Token.tokenLabel = "test"+ , Token.tokenSecret = Token.TokenSecretPlainText "K5RHSRDNJZRSCTDHKM4VSYLN"+ , Token.tokenIssuer = Token.TokenIssuer ""+ , Token.tokenAlgorithm = Token.AlgorithmSHA1+ , Token.tokenDigits = Token.Digits6+ , Token.tokenPeriod = Token.TokenPeriod 30 }+ Right () <- Op.addToken drg cfg ["nicepassword"] spec+ mapM (Op.getOTP drg cfg ["nicepassword"] (Token.getIdentifier spec) . fromInteger) [312 + i*30 | i <- [0..4]]
+ test/Gamgee/Test/Operation.hs view
@@ -0,0 +1,89 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE RankNTypes #-}++module Gamgee.Test.Operation+ ( OutputMessage+ , runTest+ , addToken+ , deleteToken+ , listTokens+ , getOTP+ ) where++import Control.Monad.ST (ST, runST)+import qualified Crypto.Random as CR+import Data.STRef (STRef)+import qualified Data.STRef as STRef+import qualified Data.Time.Clock.POSIX as Clock+import qualified Gamgee.Effects as Eff+import qualified Gamgee.Operation as Operation+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 Relude+++----------------------------------------------------------------------------------------------------+-- All operations supported by gamgee run using STRefs+----------------------------------------------------------------------------------------------------++type TestStore s = STRef s (Maybe LByteString)+type OutputMessage = Text++runTest :: Maybe LByteString -> (forall s. TestStore s -> ST s a) -> a+runTest store action = runST $ STRef.newSTRef store >>= action++addToken :: CR.DRG gen+ => gen+ -> TestStore s+ -> [Text]+ -> Token.TokenSpec+ -> ST s (Either Eff.EffError ())+addToken drg store input spec = P.runM+ $ P.runError+ $ Eff.runCryptoRandom drg+ $ Eff.runCrypto+ $ Eff.runListSecretInput input+ $ Eff.runByteStoreST store+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON+ $ Operation.addToken spec++deleteToken :: TestStore s -> Token.TokenIdentifier -> ST s (Either Eff.EffError ())+deleteToken store t = P.runM+ $ P.runError+ $ Eff.runByteStoreST store+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON+ $ Operation.deleteToken t++listTokens :: TestStore s -> ST s (Either Eff.EffError [OutputMessage])+listTokens store = fmap fst+ <$> P.runM+ (P.runError+ $ Eff.runOutputPure+ $ Eff.runByteStoreST store+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON Operation.listTokens)++getOTP :: CR.DRG gen+ => gen+ -> TestStore s+ -> [Text]+ -> Token.TokenIdentifier+ -> Clock.POSIXTime+ -> ST s (Either Eff.EffError [OutputMessage])+getOTP drg store input tok time =+ fmap fst+ <$> P.runM+ (P.runError+ $ Eff.runOutputPure+ $ Eff.runCryptoRandom drg+ $ Eff.runCrypto+ $ Eff.runListSecretInput input+ $ Eff.runByteStoreST store+ $ Eff.runGamgeeJSONStore+ $ Eff.runStateJSON+ $ Eff.runTOTP+ $ Operation.getOTP tok time)
+ test/Gamgee/Test/Property.hs view
@@ -0,0 +1,156 @@+{-# 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+module Gamgee.Test.Property+ ( propertyTests+ ) where++import Control.Monad.ST (ST)+import qualified Crypto.Random as CR+import qualified Data.ByteArray.Encoding as BE+import qualified Data.ByteString as BS+import qualified Data.Text as Text+import qualified Gamgee.Effects as Eff+import qualified Gamgee.Test.Operation as Op+import qualified Gamgee.Token as Token+import Relude+import qualified Relude.Extra.Map as Map+import Test.QuickCheck (allProperties)+import Test.QuickCheck.Instances ()+import qualified Test.QuickCheck.Monadic as T+import qualified Test.Tasty as T+import qualified Test.Tasty.QuickCheck as T+++deriving newtype instance T.Arbitrary Token.TokenIdentifier+deriving newtype instance T.Arbitrary Token.TokenLabel+deriving newtype instance T.Arbitrary Token.TokenIssuer++instance T.Arbitrary Token.TokenSecret where+ arbitrary = Token.TokenSecretPlainText . decodeUtf8 <$> base32String+ where+ base32String :: T.Gen ByteString+ base32String = BE.convertToBase BE.Base32 <$> T.arbitrary `T.suchThat` (\s -> BS.length s `mod` 10 == 0)++instance T.Arbitrary Token.TokenAlgorithm where+ arbitrary = T.oneof [ pure Token.AlgorithmSHA1+ , pure Token.AlgorithmSHA256+ , pure Token.AlgorithmSHA512+ ]++instance T.Arbitrary Token.TokenDigits where+ arbitrary = T.oneof [ pure Token.Digits6+ , pure Token.Digits8+ ]++instance T.Arbitrary Token.TokenPeriod where+ arbitrary = Token.TokenPeriod <$> T.choose (10, 120)++instance T.Arbitrary Token.TokenSpec where+ arbitrary = Token.TokenSpec+ <$> pure Token.TOTP+ <*> T.arbitrary+ <*> T.arbitrary+ <*> T.arbitrary+ <*> T.arbitrary+ <*> T.arbitrary+ <*> T.arbitrary++-- | Ensures that an effect succeeded, fail the ST monad otherwise+ensureSuccess :: ST s (Either Eff.EffError a) -> ST s a+ensureSuccess action = do+ res <- action+ either (fail . show) return res++withSystemDRG :: (T.Testable a) => (CR.SystemDRG -> T.PropertyM IO a) -> T.Property+withSystemDRG f = T.monadicIO $ do+ drg <- liftIO CR.getSystemDRG+ f drg++prop_addThenRemove :: Token.TokenSpec -> T.Property+prop_addThenRemove spec = withSystemDRG $ \drg -> T.assert (addThenRemove drg == Right [])+ where+ addThenRemove :: CR.SystemDRG -> Either Eff.EffError [Op.OutputMessage]+ addThenRemove drg = Op.runTest Nothing $ \store -> do+ ensureSuccess $ Op.addToken drg store [""] spec+ ensureSuccess $ Op.deleteToken store (Token.getIdentifier spec)+ Op.listTokens store++prop_addThenList :: [Token.TokenSpec] -> T.Property+prop_addThenList specList = withSystemDRG $ \drg -> T.assert (addThenList drg == Right (Token.unTokenIdentifier <$> Map.keys specs))+ where+ specs :: HashMap Token.TokenIdentifier Token.TokenSpec+ specs = fromList $ map (\spec -> (Token.getIdentifier spec, spec)) specList++ addThenList :: CR.SystemDRG -> Either Eff.EffError [Op.OutputMessage]+ addThenList drg = Op.runTest Nothing $ \store -> do+ mapM_ (ensureSuccess . Op.addToken drg store [""]) $ Map.elems specs+ Op.listTokens store++prop_addThenGetOTP :: Token.TokenSpec -> T.Property+prop_addThenGetOTP spec = withSystemDRG $ \drg ->+ forM_ (addThenGetOTP drg) $ \case+ Left err -> fail $ "Expected an OTP but found " <> show err+ Right otp -> case Token.tokenDigits spec of+ Token.Digits6 -> T.assert $ (Text.length <$> otp) == [6]+ Token.Digits8 -> T.assert $ (Text.length <$> otp) == [8]++ where+ ident :: Token.TokenIdentifier+ ident = Token.getIdentifier spec++ addThenGetOTP :: CR.SystemDRG -> [Either Eff.EffError [Op.OutputMessage]]+ addThenGetOTP drg = Op.runTest Nothing $ \store -> do+ ensureSuccess $ Op.addToken drg store [""] spec+ mapM (Op.getOTP drg store [""] ident . fromInteger) [100 + i*30 | i <- [0..4]]++prop_doubleAddFails :: Token.TokenSpec -> T.Property+prop_doubleAddFails spec = withSystemDRG $+ \drg -> T.assert (doubleAdd drg == Left (Eff.AlreadyExists $ Token.getIdentifier spec))++ where+ doubleAdd :: CR.SystemDRG -> Either Eff.EffError ()+ doubleAdd drg = Op.runTest Nothing $ \store -> do+ ensureSuccess $ Op.addToken drg store [""] spec+ Op.addToken drg store [""] spec++prop_doubleDeleteFails :: Token.TokenSpec -> T.Property+prop_doubleDeleteFails spec = withSystemDRG $+ \drg -> T.assert (doubleDelete drg == Left (Eff.NoSuchToken ident))++ where+ ident :: Token.TokenIdentifier+ ident = Token.getIdentifier spec++ doubleDelete :: CR.SystemDRG -> Either Eff.EffError ()+ doubleDelete drg = Op.runTest Nothing $ \store -> do+ ensureSuccess $ Op.addToken drg store [""] spec+ ensureSuccess $ Op.deleteToken store ident+ Op.deleteToken store ident++prop_deleteOnEmptyFails :: Token.TokenIdentifier -> T.Property+prop_deleteOnEmptyFails ident = T.monadicIO $+ T.assert (deleteOnEmpty == Left (Eff.NoSuchToken ident))++ where+ deleteOnEmpty :: Either Eff.EffError ()+ deleteOnEmpty = Op.runTest Nothing $ \store -> Op.deleteToken store ident+++-- Template Haskell hack to make the following $allProperties work+return []++propertyTests :: T.TestTree+propertyTests = T.testProperties "Property Tests" $allProperties
+ test/Main.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Main where++import qualified Gamgee.Test.Golden as G+import qualified Gamgee.Test.Property as P+import Relude+import qualified Test.Tasty as T+++main :: IO ()+main = T.defaultMain $ T.testGroup "All Tests" [ G.goldenTests+ , P.propertyTests ]
+ test/data/golden/getOTPTest.txt view
@@ -0,0 +1,1 @@+[Right ["621420"],Right ["451175"],Right ["884220"],Right ["760248"],Right ["310300"]]