redact (empty) → 0.4.0.0
raw patch · 18 files changed
+2598/−0 lines, 18 filesdep +HMockdep +ansi-terminaldep +ansi-wl-pprintsetup-changed
Dependencies added: HMock, ansi-terminal, ansi-wl-pprint, base, directory, explainable-predicates, optparse-applicative, redact, tasty, tasty-hunit, text
Files
- CHANGELOG.md +73/−0
- LICENSE +21/−0
- README.md +110/−0
- Setup.hs +2/−0
- app/LibOA.hs +141/−0
- app/Main.hs +414/−0
- redact.cabal +103/−0
- src/Redact.hs +27/−0
- src/Redact/Internal.hs +60/−0
- src/Redact/Markdown.hs +298/−0
- src/Redact/Monad/Handle.hs +180/−0
- src/Redact/Monad/Terminal.hs +170/−0
- src/Redact/Types.hs +52/−0
- test/Redact/Markdown/Mock.hs +398/−0
- test/Redact/Markdown/Test.hs +247/−0
- test/Redact/Monad/Terminal/Mock.hs +224/−0
- test/Spec.hs +24/−0
- test/TestLib.hs +54/−0
+ CHANGELOG.md view
@@ -0,0 +1,73 @@+# `redact-haskell` Changelog++This project follows the [Haskell package versioning policy][PVP], with+versions in `A.B.C.D` format. `A` may be incremented arbitrarily for+non-technical reasons, but [semantic versioning][SemVer] is otherwise+followed, where `A.B` is the major version, `C` is the minor version, and `D`+is the patch version. Initial development uses versions `0.0.0.D`, for which+every version is considered breaking.++[PVP]: <https://pvp.haskell.org/>+[SemVer]: <https://semver.org/>++The format of this changelog is based on [Keep a Changelog][KaC], with the+following conventions:++* Level-two heading `Unreleased` is used to track changes that have not been+ released.+* Other level-two headings specify the release in `A.B.C.D (YYYY-MM-DD)`+ format, with newer versions above older versions.+* Level-three headings are used to categorize changes as follows:+ 1. Breaking+ 2. Non-Breaking+* Changes are listed in arbitrary order and present tense.++[KaC]: <https://keepachangelog.com/en/1.0.0/>++## 0.4.0.0 (2022-03-02)++### Breaking++* Rewrite using a library+* Add `--lenient` flag, with strict behavior by default+* Reset colors on exceptions, including Control+C++### Non-Breaking++* Add tests+* Bump `optparse-applicative` dependency version upper bound++## 0.3.0.0 (2021-06-25)++### Breaking++* Fix `--help` when using `optparse-applicative` `0.16`++### Non-Breaking++* Refactor Nix configuration++## 0.2.0.1 (2021-05-27)++### Non-Breaking++* Fix link in README++## 0.2.0.0 (2021-05-27)++### Breaking++* Add support for `optparse-applicative` `0.16`++### Non-Breaking++* Add `.deb` and `.rpm` packaging+* Add Cabal support to `Makefile`+* Add Cabal tests to GitHub Actions+* Add [stan](https://hackage.haskell.org/package/stan) static analysis++## 0.1.0.0 (2020-11-28)++### Breaking++* Initial public release
+ LICENSE view
@@ -0,0 +1,21 @@+The MIT License++Copyright (c) 2020-2022 Travis Cardwell++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in+all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ README.md view
@@ -0,0 +1,110 @@+# Redact++[](https://www.repostatus.org/#active)+[](https://github.com/ExtremaIS/redact-haskell/actions)+[](https://hackage.haskell.org/package/redact)+[](https://stackage.org/package/redact)+[](https://stackage.org/nightly/package/redact)++* [Overview](#overview)+* [CLI](#cli)+ * [Requirements](#requirements)+ * [Installation](#installation)+ * [`.deb` Package Installation](#deb-package-installation)+ * [`.rpm` Package Installation](#rpm-package-installation)+ * [Installation From Hackage](#installation-from-hackage)+ * [Installation From Stackage](#installation-from-stackage)+ * [Usage](#usage)+* [Project](#project)+ * [Links](#links)+ * [Tags](#tags)+ * [Contribution](#contribution)+ * [License](#license)++## Overview++Redact is a utility for hiding secret text on the terminal.++It is designed to work with Markdown syntax. Inline code (text enclosed in+backticks) and code blocks that are fenced with backticks are hidden. Note+that inline code that spans multiple lines is not supported, and other types+of code blocks are not hidden.++Text is hidden by displaying it using the same color for the foreground and+background. When selecting hidden text, it remains hidden in some terminals+and becomes visible in other terminals.++Be sure to test it in your terminal before relying on it.++## CLI++### Requirements++Redact has only been tested on Linux. Testing on Windows 10 and macOS will+be added in a future release.++### Installation++#### `.deb` Package Installation++Check the [Releases][] page for `.deb` packages.++[Releases]: <https://github.com/ExtremaIS/redact-haskell/releases>++#### `.rpm` Package Installation++Check the [Releases][] page for `.rpm` packages.++#### Installation From Hackage++Install PhatSort from [Hackage][] using [Cabal][] as follows:++```+$ cabal v2-install redact+```++[Hackage]: <https://hackage.haskell.org/package/redact>+[Cabal]: <https://www.haskell.org/cabal/>++#### Installation From Stackage++Install PhatSort from [Stackage][] using [Stack][] as follows:++```+$ stack install redact+```++[Stackage]: <https://www.stackage.org/package/redact>+[Stack]: <https://haskellstack.org/>++### Usage++See the [`redact` man page](doc/redact.1.md) for usage information.++## Project++### Links++* Hackage: <https://hackage.haskell.org/package/redact>+* Stackage: <https://www.stackage.org/package/redact>+* GitHub: <https://github.com/ExtremaIS/redact-haskell>+* GitHub Actions CI: <https://github.com/ExtremaIS/redact-haskell/actions>++### Tags++All releases are tagged in the `main` branch. Release tags are signed using+the+[`security@extrema.is` GPG key](http://keys.gnupg.net/pks/lookup?op=vindex&fingerprint=on&search=0x1D484E4B4705FADF).++### Contribution++Issues and feature requests are tracked on GitHub:+<https://github.com/ExtremaIS/hr-haskell/issues>++Issues may also be submitted via email to <bugs@extrema.is>.++### License++This project is released under the+[MIT License](https://opensource.org/licenses/MIT) as specified in the+[`LICENSE`](LICENSE) file.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/LibOA.hs view
@@ -0,0 +1,141 @@+------------------------------------------------------------------------------+-- |+-- Module : LibOA+-- Description : supplementary functions for optparse-applicative+-- Copyright : Copyright (c) 2019-2022 Travis Cardwell+-- License : MIT+--+-- This is a collection of functions that I often use with+-- @optparse-applicative@. I do not feel that it is worth maintaining yet+-- another helper package on Hackage, so I just copy the code to different+-- projects as required. If the library grows to a substantial size or others+-- with to use it, I will reconsider.+--+-- Revision: 2022-01-02+------------------------------------------------------------------------------++{-# LANGUAGE CPP #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE TupleSections #-}++module LibOA+ ( -- * Options+ -- $Options+ helper+ , versioner+ -- * Utilities+ , commands+ -- * Help+ , (<||>)+ , section+ , table+ , table_+ , vspace+ ) where++-- https://hackage.haskell.org/package/ansi-wl-pprint+import qualified Text.PrettyPrint.ANSI.Leijen as Doc+import Text.PrettyPrint.ANSI.Leijen (Doc)++-- https://hackage.haskell.org/package/base+import Data.List (intersperse, transpose)+import Data.Maybe (fromMaybe)+#if !MIN_VERSION_base (4,11,0)+import Data.Monoid ((<>))+#endif++-- https://hackage.haskell.org/package/optparse-applicative+import qualified Options.Applicative as OA+#if MIN_VERSION_optparse_applicative (0,16,0)+import qualified Options.Applicative.Builder.Internal as OABI+#endif+import qualified Options.Applicative.Common as OAC+import qualified Options.Applicative.Types as OAT++------------------------------------------------------------------------------+-- $Options+--+-- Option descriptions are not capitalized.++-- | A hidden @-h@ / @--help@ option that always fails, showing the help+--+-- This is the same as 'OA.helper' except that it has a different help+-- message.+helper :: OA.Parser (a -> a)+#if MIN_VERSION_optparse_applicative (0,16,0)+helper = OA.option helpReader $ mconcat+ [ OA.short 'h'+ , OA.long "help"+ , OA.value id+ , OA.metavar ""+ , OABI.noGlobal+ , OA.noArgError (OA.ShowHelpText Nothing)+ , OA.help "show this help text"+ , OA.hidden+ ]+ where+ helpReader = do+ potentialCommand <- OAT.readerAsk+ OA.readerAbort $ OA.ShowHelpText (Just potentialCommand)+#else+helper = OA.abortOption OA.ShowHelpText $ mconcat+ [ OA.short 'h'+ , OA.long "help"+ , OA.help "show help and exit"+ , OA.hidden+ ]+#endif++-- | A hidden @--version@ option that always fails, showing the version+versioner+ :: String -- ^ version string+ -> OA.Parser (a -> a)+versioner verStr = OA.infoOption verStr $ mconcat+ [ OA.long "version"+ , OA.help "show version and exit"+ , OA.hidden+ ]++------------------------------------------------------------------------------+-- $Utilities++-- | Get a list of commands for a parser+commands :: OA.Parser a -> [String]+commands =+ let go _ opt = case OAT.optMain opt of+ OAT.CmdReader _ cmds _ -> reverse cmds+ _otherReader -> []+ in concat . OAC.mapParser go++------------------------------------------------------------------------------+-- $Help++-- | Insert a blank line between two documents+(<||>) :: Doc -> Doc -> Doc+d1 <||> d2 = d1 <> Doc.line <> Doc.line <> d2+infixr 5 <||>++-- | Create a section with a title and indented body+section :: String -> Doc -> Doc+section title = (Doc.text title Doc.<$$>) . Doc.indent 2++-- | Create a table, with formatting+table :: Int -> [[(String, Doc -> Doc)]] -> Doc+table sep rows = Doc.vcat $+ map (fromMaybe Doc.empty . foldr go Nothing . zip lengths) rows+ where+ lengths :: [Int]+ lengths = map ((+) sep . maximum . map (length . fst)) $ transpose rows++ go :: (Int, (String, Doc -> Doc)) -> Maybe Doc -> Maybe Doc+ go (len, (s, f)) = Just . \case+ Just doc -> Doc.fill len (f $ Doc.string s) <> doc+ Nothing -> f $ Doc.string s++-- | Create a table, without formatting+table_ :: Int -> [[String]] -> Doc+table_ sep = table sep . (map . map) (, id)++-- | Vertically space documents with blank lines between them+vspace :: [Doc] -> Doc+vspace = mconcat . intersperse (Doc.line <> Doc.line)
+ app/Main.hs view
@@ -0,0 +1,414 @@+------------------------------------------------------------------------------+-- |+-- Module : Main+-- Description : redact: hide secret text on the terminal+-- Copyright : Copyright (c) 2020-2022 Travis Cardwell+-- License : MIT+--+-- See the README for details.+------------------------------------------------------------------------------++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main (main) where++-- https://hackage.haskell.org/package/ansi-terminal+import qualified System.Console.ANSI as Term++-- https://hackage.haskell.org/package/ansi-wl-pprint+import qualified Text.PrettyPrint.ANSI.Leijen as Doc+import Text.PrettyPrint.ANSI.Leijen (Doc)++-- https://hackage.haskell.org/package/base+import Control.Applicative ((<|>), optional)+import Control.Exception (onException)+import Control.Monad (foldM, forM_, when)+import Data.Bifunctor (Bifunctor(bimap))+import Data.Char (isSpace, toLower)+import Data.Functor.Identity (Identity(runIdentity))+import Data.List (dropWhileEnd, intercalate)+import Data.Maybe (fromMaybe, isJust)+import Data.String (fromString)+import System.Environment (lookupEnv)+import System.Exit (ExitCode(ExitFailure), exitSuccess, exitWith)+import System.IO (hPutStrLn, stderr, stdin)++-- https://hackage.haskell.org/package/directory+import qualified System.Directory as Dir++-- https://hackage.haskell.org/package/optparse-applicative+import qualified Options.Applicative as OA++-- (redact)+import qualified Redact as Project+import qualified Redact.Markdown as Redact+import qualified Redact.Monad.Terminal as RedactTerm++-- (redact:executable)+import qualified LibOA++------------------------------------------------------------------------------+-- $Constants++defaultColor :: Term.Color+defaultColor = Term.Red++defaultIntensity :: Term.ColorIntensity+defaultIntensity = Term.Vivid++defaultLenient :: Bool+defaultLenient = False++envColorName, envIntensityName, envLenientName :: String+envColorName = "REDACT_COLOR"+envIntensityName = "REDACT_INTENSITY"+envLenientName = "REDACT_LENIENT"++configFileName :: FilePath+configFileName = "redact.ini"++------------------------------------------------------------------------------+-- $Colors++colorMap :: [(String, Term.Color)]+colorMap =+ [ (toLower <$> show color, color)+ | color <- [minBound ..]+ ]++parseColor+ :: String+ -> Either String Term.Color+parseColor s+ = maybe (Left $ "uknown color: " ++ s) Right+ $ lookup (toLower <$> s) colorMap++------------------------------------------------------------------------------+-- $Intensities++intensityMap :: [(String, Term.ColorIntensity)]+intensityMap =+ [ (toLower <$> show intensity, intensity)+ | intensity <- [minBound ..]+ ]++parseIntensity+ :: String+ -> Either String Term.ColorIntensity+parseIntensity s+ = maybe (Left $ "unknown intensity: " ++ s) Right+ $ lookup (toLower <$> s) intensityMap++------------------------------------------------------------------------------+-- $Lenient++parseLenient+ :: String+ -> Either String Bool+parseLenient s = case toLower <$> s of+ "true" -> Right True+ "false" -> Right False+ _other -> Left $ "lenient setting not true/false: " ++ s++------------------------------------------------------------------------------+-- $Options++-- | Program options+data Options f+ = Options+ { optColor :: !(f Term.Color)+ , optIntensity :: !(f Term.ColorIntensity)+ , optFile :: !(Maybe FilePath)+ , optLenient :: !(f Bool)+ , optColors :: !Bool+ , optTest :: !Bool+ }++getOptions :: IO (Options Identity)+getOptions = do+ opts <-+ maybeLoadEnv getEnvColor optColor+ (\o x -> o { optColor = x }) =<<+ maybeLoadEnv getEnvIntensity optIntensity+ (\o x -> o { optIntensity = x }) =<<+ maybeLoadEnv getEnvLenient optLenient+ (\o x -> o { optLenient = x }) =<<+ parseArgs+ case (optColor opts, optIntensity opts, optLenient opts) of+ (Just color, Just intensity, Just lenient) -> return Options+ { optColor = pure color+ , optIntensity = pure intensity+ , optFile = optFile opts+ , optLenient = pure lenient+ , optColors = optColors opts+ , optTest = optTest opts+ }+ _otherOptions -> do+ configOpts <- loadConfigFile+ return Options+ { optColor = pure . fromMaybe defaultColor $+ optColor opts <|> configColor configOpts+ , optIntensity = pure . fromMaybe defaultIntensity $+ optIntensity opts <|> configIntensity configOpts+ , optFile = optFile opts+ , optLenient = pure . fromMaybe defaultLenient $+ optLenient opts <|> configLenient configOpts+ , optColors = optColors opts+ , optTest = optTest opts+ }+ where+ maybeLoadEnv+ :: IO (Maybe a)+ -> (Options Maybe -> Maybe a)+ -> (Options Maybe -> Maybe a -> Options Maybe)+ -> Options Maybe+ -> IO (Options Maybe)+ maybeLoadEnv getEnv getOpt setOpt opts+ | isJust (getOpt opts) = pure opts+ | otherwise = setOpt opts <$> getEnv++------------------------------------------------------------------------------+-- $Arguments++parseArgs :: IO (Options Maybe)+parseArgs+ = OA.execParser+ . OA.info (LibOA.helper <*> LibOA.versioner version <*> options)+ $ mconcat+ [ OA.fullDesc+ , OA.progDesc "hide secret text on the terminal"+ , OA.failureCode 2+ , OA.footerDoc $ Just footer+ ]+ where+ version :: String+ version = "redact-haskell " ++ Project.version++options :: OA.Parser (Options Maybe)+options = Options+ <$> colorOption+ <*> intensityOption+ <*> fileOption+ <*> lenientOption+ <*> colorsOption+ <*> testOption+ where+ colorOption :: OA.Parser (Maybe Term.Color)+ colorOption = optional . OA.option (OA.eitherReader parseColor) $ mconcat+ [ OA.long "color"+ , OA.short 'c'+ , OA.metavar "COLOR"+ , OA.help "redacted text color"+ ]++ intensityOption :: OA.Parser (Maybe Term.ColorIntensity)+ intensityOption =+ optional . OA.option (OA.eitherReader parseIntensity) $ mconcat+ [ OA.long "intensity"+ , OA.short 'i'+ , OA.metavar "INTENSITY"+ , OA.help "redacted text color intensity"+ ]++ fileOption :: OA.Parser (Maybe FilePath)+ fileOption = optional . OA.strOption $ mconcat+ [ OA.long "file"+ , OA.short 'f'+ , OA.metavar "PATH"+ , OA.help "input file (default: STDIN)"+ ]++ lenientOption :: OA.Parser (Maybe Bool)+ lenientOption = OA.flag Nothing (Just True) $ mconcat+ [ OA.long "lenient"+ , OA.short 'l'+ , OA.help "do not exit on parse errors"+ ]++ colorsOption :: OA.Parser Bool+ colorsOption = OA.switch $ mconcat+ [ OA.long "colors"+ , OA.help "redact test text using all possible colors"+ ]++ testOption :: OA.Parser Bool+ testOption = OA.switch $ mconcat+ [ OA.long "test"+ , OA.help "redact test text using the configured color"+ ]++footer :: Doc+footer = LibOA.vspace+ [ colorsHelp+ , intensitiesHelp+ , lenientHelp+ , settingsHelp+ ]+ where+ colorsHelp :: Doc+ colorsHelp = LibOA.section "COLOR values:" . Doc.text $+ intercalate ", " (fst <$> colorMap)++ intensitiesHelp :: Doc+ intensitiesHelp = LibOA.section "INTENSITY values:" . Doc.text $+ intercalate ", " (fst <$> intensityMap)++ lenientHelp :: Doc+ lenientHelp = LibOA.section "LENIENT values:" $ Doc.text "true, false"++ settingsHelp :: Doc+ settingsHelp = LibOA.section "Settings priority:" . Doc.vcat $+ [ Doc.text "1. command-line options" Doc.<$$> Doc.indent 5+ ( Doc.vcat+ [ Doc.text "--color"+ , Doc.text "--intensity"+ , Doc.text "--lenient"+ ]+ )+ , Doc.text "2. environment variables" Doc.<$$> Doc.indent 5+ ( Doc.vcat+ [ Doc.text $ envColorName ++ "=COLOR"+ , Doc.text $ envIntensityName ++ "=INTENSITY"+ , Doc.text $ envLenientName ++ "=LENIENT"+ ]+ )+ , Doc.text ("3. settings file (" ++ configFileName ++ ")") Doc.<$$>+ Doc.indent 5+ ( Doc.vcat+ [ Doc.text "color=COLOR"+ , Doc.text "intensity=INTENSITY"+ , Doc.text "lenient=LENIENT"+ ]+ )+ , Doc.text "4. defaults" Doc.<$$> Doc.indent 5+ ( LibOA.table_ 2+ [ ["color:", toLower <$> show defaultColor]+ , ["intensity:", toLower <$> show defaultIntensity]+ , ["lenient:", toLower <$> show defaultLenient]+ ]+ )+ ]++------------------------------------------------------------------------------+-- $EnvVars++getEnvColor :: IO (Maybe Term.Color)+getEnvColor = getEnv' envColorName parseColor++getEnvIntensity :: IO (Maybe Term.ColorIntensity)+getEnvIntensity = getEnv' envIntensityName parseIntensity++getEnvLenient :: IO (Maybe Bool)+getEnvLenient = getEnv' envLenientName parseLenient++getEnv'+ :: String+ -> (String -> Either String a)+ -> IO (Maybe a)+getEnv' envName parse = do+ meex <- fmap parse <$> lookupEnv envName+ case meex of+ Nothing -> return Nothing+ Just (Right x) -> return $ Just x+ Just (Left err) -> errorExit $+ "environment variable " ++ envName ++ ": " ++ err++------------------------------------------------------------------------------+-- $ConfigFile++data ConfigFileOptions+ = ConfigFileOptions+ { configColor :: !(Maybe Term.Color)+ , configIntensity :: !(Maybe Term.ColorIntensity)+ , configLenient :: !(Maybe Bool)+ }++loadConfigFile :: IO ConfigFileOptions+loadConfigFile = do+ path <- Dir.getXdgDirectory Dir.XdgConfig configFileName+ exists <- Dir.doesFileExist path+ if exists+ then foldM go defOpts . zip [1..] . map strip . lines =<< readFile path+ else return defOpts+ where+ defOpts :: ConfigFileOptions+ defOpts = ConfigFileOptions+ { configColor = Nothing+ , configIntensity = Nothing+ , configLenient = Nothing+ }++ go :: ConfigFileOptions -> (Int, String) -> IO ConfigFileOptions+ go opts (_, "") = return opts+ go opts (_, '#' : _) = return opts+ go opts (lineNum, line) = case bimap strip strip (break (== '=') line) of+ ("", _) -> errorExit $ "config file: empty key on line " ++ show lineNum+ (key, '=' : value) -> case key of+ "color" -> case parseColor value of+ Right color -> return opts { configColor = Just color }+ Left err -> errorExit $+ "config file: color error on line " ++ show lineNum ++ ": " ++ err+ "intensity" -> case parseIntensity value of+ Right intensity -> return opts { configIntensity = Just intensity }+ Left err -> errorExit $+ "config file: intensity error on line " ++ show lineNum ++ ": " +++ err+ "lenient" -> case parseLenient value of+ Right lenient -> return opts { configLenient = Just lenient }+ Left err -> errorExit $+ "config file: lenient error on line " ++ show lineNum ++ ": " +++ err+ _otherKey -> return opts+ _mistmatch ->+ errorExit $ "config file: unable to parse line " ++ show lineNum++strip :: String -> String+strip = dropWhile isSpace . dropWhileEnd isSpace+{-# INLINE strip #-}++------------------------------------------------------------------------------+-- $Implementation++runTest :: Term.Color -> Term.ColorIntensity -> IO ()+runTest color intensity =+ RedactTerm.putLines (RedactTerm.redactSGRs color intensity)+ [ Redact.NormalLine+ [ Redact.Stet . fromString $+ (toLower <$> show color) ++ " " +++ (toLower <$> show intensity) ++ ": `"+ , Redact.Redact "hidden"+ , Redact.Stet "`"+ ]+ ]++runColors :: IO ()+runColors =+ forM_ [minBound ..] $ \color ->+ forM_ [minBound ..] $ \intensity ->+ runTest color intensity++------------------------------------------------------------------------------+-- $CLI++errorExit :: String -> IO a+errorExit message = do+ hPutStrLn stderr $ "error: " ++ message+ exitWith $ ExitFailure 1++main :: IO ()+main = flip onException RedactTerm.reset $ do+ Options{..} <- getOptions+ let color = runIdentity optColor+ intensity = runIdentity optIntensity+ sgrs = RedactTerm.redactSGRs color intensity+ lenient = runIdentity optLenient+ when optColors $ runColors >> exitSuccess+ when optTest $ runTest color intensity >> exitSuccess+ either (errorExit . show) return =<< case optFile of+ Just path+ | lenient -> Redact.fileToTerminal' sgrs path+ | otherwise -> Redact.fileToTerminal sgrs path+ Nothing+ | lenient -> Right <$> Redact.handleToTerminal' sgrs stdin+ | otherwise -> Redact.handleToTerminal sgrs stdin
+ redact.cabal view
@@ -0,0 +1,103 @@+name: redact+version: 0.4.0.0+category: Utils+synopsis: hide secret text on the terminal+description:+ This package provides a utility for redacting secret text on the terminal.+ Please see the README on GitHub at+ <https://github.com/ExtremaIS/redact-haskell#readme>.++homepage: https://github.com/ExtremaIS/redact-haskell#readme+bug-reports: https://github.com/ExtremaIS/redact-haskell/issues+author: Travis Cardwell <travis.cardwell@extrema.is>+maintainer: Travis Cardwell <travis.cardwell@extrema.is>+copyright: Copyright (c) 2020-2022 Travis Cardwell+license: MIT+license-file: LICENSE++cabal-version: 1.24+build-type: Simple+tested-with:+ GHC ==8.2.2+ || ==8.4.4+ || ==8.6.5+ || ==8.8.4+ || ==8.10.7+ || ==9.0.2+ || ==9.2.1++extra-source-files:+ CHANGELOG.md+ README.md++source-repository head+ type: git+ location: https://github.com/ExtremaIS/redact-haskell.git++flag write-hie+ description: write .hie files+ default: False++library+ hs-source-dirs: src+ exposed-modules:+ Redact+ , Redact.Internal+ , Redact.Markdown+ , Redact.Monad.Handle+ , Redact.Monad.Terminal+ , Redact.Types+ other-modules:+ Paths_redact+ build-depends:+ ansi-terminal >=0.8 && <0.12+ , base >=4.7 && <5+ , text >=1.2.3 && <2.1+ default-language: Haskell2010+ default-extensions:+ OverloadedStrings+ if flag(write-hie)+ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie+ else+ ghc-options: -Wall++executable redact+ hs-source-dirs: app+ main-is: Main.hs+ other-modules:+ LibOA+ build-depends:+ ansi-terminal+ , ansi-wl-pprint >=0.6 && <0.7+ , base+ , directory >=1.3 && <1.4+ , optparse-applicative >=0.14 && <0.18+ , redact+ default-language: Haskell2010+ if flag(write-hie)+ ghc-options: -Wall -fwrite-ide-info -hiedir=.hie+ else+ ghc-options: -Wall++test-suite redact-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ other-modules:+ Redact.Markdown.Test+ build-depends:+ base+ , redact+ , tasty >=1.0 && <1.5+ , tasty-hunit >=0.10 && <0.11+ if impl(ghc >= 8.8.1)+ other-modules:+ Redact.Markdown.Mock+ , Redact.Monad.Terminal.Mock+ , TestLib+ build-depends:+ ansi-terminal+ , explainable-predicates >=0.1.2.1 && <0.2+ , HMock >=0.5.1 && <0.6+ default-language: Haskell2010+ ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N
+ src/Redact.hs view
@@ -0,0 +1,27 @@+------------------------------------------------------------------------------+-- |+-- Module : Redact+-- Description : metadata+-- Copyright : Copyright (c) 2020-2022 Travis Cardwell+-- License : MIT+------------------------------------------------------------------------------++module Redact+ ( -- * Constants+ version+ ) where++-- https://hackage.haskell.org/package/base+import Data.Version (showVersion)++-- (redact:cabal)+import qualified Paths_redact as Project++------------------------------------------------------------------------------+-- $Constants++-- | Redact version string (\"@redact-haskell X.X.X.X@\")+--+-- @since 0.4.0.0+version :: String+version = "redact-haskell " ++ showVersion Project.version
+ src/Redact/Internal.hs view
@@ -0,0 +1,60 @@+------------------------------------------------------------------------------+-- |+-- Module : Redact.Internal+-- Description : internal functions+-- Copyright : Copyright (c) 2020-2022 Travis Cardwell+-- License : MIT+------------------------------------------------------------------------------++{-# LANGUAGE ScopedTypeVariables #-}++module Redact.Internal+ ( -- * Internal+ redact+ , redact'+ ) where++-- https://hackage.haskell.org/package/text+import qualified Data.Text as T+import Data.Text (Text)++-- (redact)+import Redact.Types (Line)++------------------------------------------------------------------------------+-- $Internal++-- | Redact text strictly+redact+ :: forall s+ . (s -> Text -> Either String (Line, s)) -- ^ step function+ -> (s -> Maybe String) -- ^ end function+ -> s -- ^ initial state+ -> Text+ -> Either String [Line]+redact step end initialState = go initialState [] . T.lines+ where+ go :: s -> [Line] -> [Text] -> Either String [Line]+ go state acc (t:ts) = case step state t of+ Right (line, state') -> go state' (line : acc) ts+ Left err -> Left err+ go state acc [] = case end state of+ Nothing -> Right $ reverse acc+ Just err -> Left err++------------------------------------------------------------------------------++-- | Redact text leniently+redact'+ :: forall s+ . (s -> Text -> (Line, s)) -- ^ step function+ -> s -- ^ initial state+ -> Text+ -> [Line]+redact' step initialState = go initialState . T.lines+ where+ go :: s -> [Text] -> [Line]+ go state (t:ts) =+ let (line, state') = step state t+ in line : go state' ts+ go _state [] = []
+ src/Redact/Markdown.hs view
@@ -0,0 +1,298 @@+------------------------------------------------------------------------------+-- |+-- Module : Redact.Markdown+-- Description : Markdown redaction+-- Copyright : Copyright (c) 2020-2022 Travis Cardwell+-- License : MIT+--+-- Markdown inline code (text enclosed in backticks) is redacted. This+-- redacted text may not span multiple lines. Example:+--+-- @The word `hidden` is redacted.@+--+-- Markdown fenced code (text in between lines of three or more backticks is+-- redacted. The number of backticks is not matched. The backticks in the+-- beginning line may optionally be followed by addition text, which is+-- ignored. Example:+--+-- @+-- ```+-- All lines of text between the backticks+-- are hidden.+-- ```+-- @+------------------------------------------------------------------------------++{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE OverloadedStrings #-}++module Redact.Markdown+ ( -- * Types+ Line(..)+ , Part(..)+ , Error(..)+ -- * Pure API+ , redact+ , redact'+ -- * Terminal API+ , textToTerminal+ , textToTerminal'+ , handleToTerminal+ , handleToTerminal'+ , fileToTerminal+ , fileToTerminal'+ -- * Internal+ , redactLine+ , redactLine'+ ) where++-- https://hackage.haskell.org/package/ansi-terminal+import qualified System.Console.ANSI as Term++-- https://hackage.haskell.org/package/base+import Control.Monad (guard)+import Prelude hiding (lines)+import System.IO (Handle)++-- https://hackage.haskell.org/package/text+import qualified Data.Text as T+import Data.Text (Text)++-- (redact)+import qualified Redact.Internal as Internal+import qualified Redact.Monad.Handle as RMH+import Redact.Monad.Handle (MonadHandle)+import qualified Redact.Monad.Terminal as RMT+import Redact.Monad.Terminal (MonadTerminal)+import Redact.Types+ ( Error(IOError, RedactError), Line(NormalLine, RedactLine)+ , Part(Redact, Stet)+ )++------------------------------------------------------------------------------+-- $PureAPI++-- | Redact text strictly+--+-- This function fails if inline or fenced code is not closed.+--+-- @since 0.4.0.0+redact :: Text -> Either String [Line]+redact = Internal.redact strictStep strictEnd initialStrictState++------------------------------------------------------------------------------++-- | Redact text leniently+--+-- This function does not fail if inline or fenced code is not closed.+--+-- @since 0.4.0.0+redact' :: Text -> [Line]+redact' = Internal.redact' lenientStep initialLenientState++------------------------------------------------------------------------------+-- $TerminalAPI++-- | Redact text strictly, putting it to the terminal+--+-- @since 0.4.0.0+textToTerminal+ :: MonadTerminal m+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Text+ -> m (Either Error ())+textToTerminal sgrs+ = either (pure . Left . RedactError) (fmap Right . RMT.putLines sgrs)+ . redact++------------------------------------------------------------------------------++-- | Redact text leniently, putting it to the terminal+--+-- @since 0.4.0.0+textToTerminal'+ :: MonadTerminal m+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Text+ -> m ()+textToTerminal' sgrs = RMT.putLines sgrs . redact'++------------------------------------------------------------------------------++-- | Redact text from a 'Handle' strictly, putting it to the terminal+--+-- @since 0.4.0.0+handleToTerminal+ :: (MonadHandle m, MonadTerminal m)+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Handle+ -> m (Either Error ())+handleToTerminal =+ RMH.handleToTerminal strictStep strictEnd initialStrictState++------------------------------------------------------------------------------++-- | Redact text from a 'Handle' leniently, putting it to the terminal+--+-- @since 0.4.0.0+handleToTerminal'+ :: (MonadHandle m, MonadTerminal m)+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Handle+ -> m ()+handleToTerminal' = RMH.handleToTerminal' lenientStep initialLenientState++------------------------------------------------------------------------------++-- | Redact text from a file strictly, putting it to the terminal+--+-- @since 0.4.0.0+fileToTerminal+ :: (MonadHandle m, MonadTerminal m)+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> FilePath+ -> m (Either Error ())+fileToTerminal = RMH.fileToTerminal strictStep strictEnd initialStrictState++------------------------------------------------------------------------------++-- | Redact text from a file leniently, putting it to the terminal+--+-- @since 0.4.0.0+fileToTerminal'+ :: (MonadHandle m, MonadTerminal m)+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> FilePath+ -> m (Either Error ())+fileToTerminal' = RMH.fileToTerminal' lenientStep initialLenientState++------------------------------------------------------------------------------+-- $Internal++-- | Redact a 'NormalLine' strictly+redactLine :: Text -> Maybe Line+redactLine line = do+ let ts = T.splitOn "`" line+ guard $ length ts `mod` 2 == 1+ pure $ redactLineParts ts++------------------------------------------------------------------------------++-- | Redact a 'NormalLine' leniently+redactLine' :: Text -> Line+redactLine' = redactLineParts . T.splitOn "`"++------------------------------------------------------------------------------++-- | Construct a 'NormalLine' from parts of a line split on @`@+redactLineParts :: [Text] -> Line+redactLineParts = NormalLine . go+ where+ go :: [Text] -> [Part]+ go (tStet:ts)+ | T.null tStet = goR [] ts+ | otherwise = goR [tStet] ts+ go [] = []++ goR :: [Text] -> [Text] -> [Part]+ goR acc (tRedact:ts)+ | T.null tRedact = goS ("`" : acc) ts+ | otherwise+ = Stet (T.concat . reverse $ "`" : acc)+ : Redact tRedact+ : goS [] ts+ goR acc []+ | null acc = []+ | otherwise = [Stet . T.concat $ reverse acc]++ goS :: [Text] -> [Text] -> [Part]+ goS acc (tStet:ts)+ | T.null tStet = goR ("`" : acc) ts+ | otherwise = goR (tStet : "`" : acc) ts+ goS acc []+ | null acc = []+ | otherwise = [Stet . T.concat $ reverse acc]++------------------------------------------------------------------------------++-- | Does a line begin a fenced code block?+--+-- A line that begins a fenced code block beings with three or more backticks.+isFenceBegin :: Text -> Bool+isFenceBegin = (>= 3) . T.length . T.takeWhile (== '`')++------------------------------------------------------------------------------++-- | Does a line end a fence code block?+--+-- A line that ends a fenced code block consists of three or more backticks.+isFenceEnd :: Text -> Bool+isFenceEnd = (&&) <$> (T.null . T.dropWhile (== '`')) <*> ((>= 3) . T.length)++------------------------------------------------------------------------------++-- | State for strict parsing+type StrictState = (Int, Bool) -- (lineNum, isFenced)++------------------------------------------------------------------------------++-- | Initial 'StrictState'+initialStrictState :: StrictState+initialStrictState = (1, False)++------------------------------------------------------------------------------++-- | Parse the next line strictly+strictStep+ :: StrictState+ -> Text+ -> Either String (Line, StrictState)+strictStep (!lineNum, isFenced) t+ | isFenced = if isFenceEnd t+ then Right (NormalLine [Stet t], (lineNum + 1, False))+ else Right (RedactLine t, (lineNum + 1, True))+ | otherwise = if isFenceBegin t+ then Right (NormalLine [Stet t], (lineNum + 1, True))+ else case redactLine t of+ Just line -> Right (line, (lineNum + 1, False))+ Nothing -> Left inlineError+ where+ inlineError :: String+ inlineError = "inline code not terminated (line " ++ show lineNum ++ ")"++------------------------------------------------------------------------------++-- | Process the end of the input strictly+strictEnd :: StrictState -> Maybe String+strictEnd (!lineNum, isFenced)+ | isFenced = Just fencedError+ | otherwise = Nothing+ where+ fencedError :: String+ fencedError = "fenced code not terminated (line " ++ show lineNum ++ ")"++------------------------------------------------------------------------------++-- | State for lenient parsing+type LenientState = Bool -- isFenced++------------------------------------------------------------------------------++-- Initial 'LenientState'+initialLenientState :: LenientState+initialLenientState = False++------------------------------------------------------------------------------++-- | Parse the next line leniently+lenientStep+ :: LenientState+ -> Text+ -> (Line, LenientState)+lenientStep isFenced t+ | isFenced = if isFenceEnd t+ then (NormalLine [Stet t], False)+ else (RedactLine t, True)+ | otherwise = if isFenceBegin t+ then (NormalLine [Stet t], True)+ else (redactLine' t, False)
+ src/Redact/Monad/Handle.hs view
@@ -0,0 +1,180 @@+------------------------------------------------------------------------------+-- |+-- Module : Redact.Monad.Handle+-- Description : handle I/O+-- Copyright : Copyright (c) 2020-2022 Travis Cardwell+-- License : MIT+------------------------------------------------------------------------------++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Redact.Monad.Handle+ ( -- * MonadHandle+ MonadHandle(..)+ -- * Internal+ , handleToTerminal+ , handleToTerminal'+ , fileToTerminal+ , fileToTerminal'+ ) where++-- https://hackage.haskell.org/package/ansi-terminal+import qualified System.Console.ANSI as Term++-- https://hackage.haskell.org/package/base+import Control.Monad (join)+import Data.Bifunctor (first)+import Data.Bool (bool)+import Data.Typeable (Typeable)+import qualified System.IO as IO+import System.IO (Handle, IOMode(ReadMode))+import System.IO.Error (tryIOError)++-- https://hackage.haskell.org/package/text+import Data.Text (Text)+import qualified Data.Text.IO as TIO++-- (redact)+import Redact.Monad.Terminal (MonadTerminal, initialize, putLine)+import Redact.Types (Error(IOError, RedactError), Line)++------------------------------------------------------------------------------+-- $MonadHandle++-- | Handle I/O+--+-- @since 0.4.0.0+class Monad m => MonadHandle m where+ -- | Read a single line from a handle+ hGetLine :: Handle -> m Text++ -- | Check if a handle has more content+ hIsEOF :: Handle -> m Bool++ -- | Open a file and perform an action on its handle+ withFile+ :: Typeable r+ => FilePath+ -> IOMode+ -> (Handle -> m r)+ -> m (Either IOError r)++instance MonadHandle IO where+ hGetLine = TIO.hGetLine+ {-# INLINE hGetLine #-}++ hIsEOF = IO.hIsEOF+ {-# INLINE hIsEOF #-}++ withFile path mode = tryIOError . IO.withFile path mode+ {-# INLINE withFile #-}++------------------------------------------------------------------------------+-- $Internal++-- | Redact text from a 'Handle' strictly, putting it to the terminal+handleToTerminal+ :: forall m s. (MonadHandle m, MonadTerminal m)+ => (s -> Text -> Either String (Line, s)) -- ^ step function+ -> (s -> Maybe String) -- ^ end function+ -> s -- ^ initial state+ -> [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Handle+ -> m (Either Error ())+handleToTerminal step end initialState sgrs handle =+ begin =<< maybeGetLine initialState+ where+ maybeGetLine :: s -> m (Either String (Maybe Line, s))+ maybeGetLine state+ = bool+ (fmap (first Just) . step state <$> hGetLine handle)+ (pure $ Right (Nothing, state))+ =<< hIsEOF handle++ begin :: Either String (Maybe Line, s) -> m (Either Error ())+ begin = \case+ Right (Just line, state) -> do+ initialize sgrs line+ loop line =<< maybeGetLine state+ Right (Nothing, _state) -> pure $ Right ()+ Left err -> pure . Left $ RedactError err++ loop :: Line -> Either String (Maybe Line, s) -> m (Either Error ())+ loop line = \case+ Right (Just nextLine, state) -> do+ putLine sgrs line $ Just nextLine+ loop nextLine =<< maybeGetLine state+ Right (Nothing, state) -> do+ putLine sgrs line Nothing+ case end state of+ Nothing -> pure $ Right ()+ Just err -> pure . Left $ RedactError err+ Left err -> do+ putLine sgrs line Nothing+ pure . Left $ RedactError err++------------------------------------------------------------------------------++-- | Redact text from a 'Handle' leniently, putting it to the terminal+handleToTerminal'+ :: forall m s. (MonadHandle m, MonadTerminal m)+ => (s -> Text -> (Line, s)) -- ^ step function+ -> s -- ^ initial state+ -> [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Handle+ -> m ()+handleToTerminal' step initialState sgrs handle =+ begin =<< maybeGetLine initialState+ where+ maybeGetLine :: s -> m (Maybe Line, s)+ maybeGetLine state+ = bool+ (first Just . step state <$> hGetLine handle)+ (pure (Nothing, state))+ =<< hIsEOF handle++ begin :: (Maybe Line, s) -> m ()+ begin = \case+ (Just line, state) -> do+ initialize sgrs line+ loop line =<< maybeGetLine state+ (Nothing, _state) -> pure ()++ loop :: Line -> (Maybe Line, s) -> m ()+ loop line (mNextLine, state) = do+ putLine sgrs line mNextLine+ case mNextLine of+ Just nextLine -> loop nextLine =<< maybeGetLine state+ Nothing -> pure ()++------------------------------------------------------------------------------++-- | Redact text from a file strictly, putting it to the terminal+fileToTerminal+ :: (MonadHandle m, MonadTerminal m)+ => (s -> Text -> Either String (Line, s)) -- ^ step function+ -> (s -> Maybe String) -- ^ end function+ -> s -- ^ initial state+ -> [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> FilePath+ -> m (Either Error ())+fileToTerminal step end initialState sgrs path+ = fmap (join . first IOError)+ . withFile path ReadMode+ $ handleToTerminal step end initialState sgrs++------------------------------------------------------------------------------++-- | Redact text from a file leniently, putting it to the terminal+fileToTerminal'+ :: (MonadHandle m, MonadTerminal m)+ => (s -> Text -> (Line, s)) -- ^ step function+ -> s -- ^ initial state+ -> [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> FilePath+ -> m (Either Error ())+fileToTerminal' step initialState sgrs path+ = fmap (first IOError)+ . withFile path ReadMode+ $ handleToTerminal' step initialState sgrs
+ src/Redact/Monad/Terminal.hs view
@@ -0,0 +1,170 @@+------------------------------------------------------------------------------+-- |+-- Module : Redact.Monad.Terminal+-- Description : terminal output+-- Copyright : Copyright (c) 2020-2022 Travis Cardwell+-- License : MIT+------------------------------------------------------------------------------++{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Redact.Monad.Terminal+ ( -- * MonadTerminal+ MonadTerminal(..)+ -- * API+ , redactSGRs+ , resetSGRs+ , reset+ , putLines+ -- * Internal+ , initialize+ , putLine+ ) where++-- https://hackage.haskell.org/package/ansi-terminal+import qualified System.Console.ANSI as Term++-- https://hackage.haskell.org/package/base+import Control.Monad (unless, when)+import Data.Maybe (listToMaybe)+import Prelude hiding (lines, putStr, putStrLn)++-- https://hackage.haskell.org/package/text+import Data.Text (Text)+import qualified Data.Text.IO as TIO++-- (redact)+import Redact.Types (Line(NormalLine, RedactLine), Part(Redact, Stet))++------------------------------------------------------------------------------+-- $MonadTerminal++-- | Terminal output+--+-- @since 0.4.0.0+class Monad m => MonadTerminal m where+ -- | Write a string to the terminal+ putStr :: Text -> m ()++ -- | Write a string to the terminal, appending a newline+ putStrLn :: Text -> m ()++ -- | Set Select Graphic Rendition mode+ setSGR :: [Term.SGR] -> m ()++instance MonadTerminal IO where+ putStr = TIO.putStr+ {-# INLINE putStr #-}++ putStrLn = TIO.putStrLn+ {-# INLINE putStrLn #-}++ setSGR = Term.setSGR+ {-# INLINE setSGR #-}++------------------------------------------------------------------------------+-- $API++-- | Construct 'Term.SGR's for redacted text+--+-- @since 0.4.0.0+redactSGRs :: Term.Color -> Term.ColorIntensity -> [Term.SGR]+redactSGRs color intensity =+ [ Term.SetColor Term.Foreground intensity color+ , Term.SetColor Term.Background intensity color+ ]++------------------------------------------------------------------------------++-- | 'Term.SGR's for resetting to normal mode+--+-- @since 0.4.0.0+resetSGRs :: [Term.SGR]+resetSGRs = [Term.Reset]++------------------------------------------------------------------------------++-- | Reset the terminal color mode and go to the next line+--+-- @since 0.4.0.0+reset :: MonadTerminal m => m ()+reset = setSGR resetSGRs >> putStrLn ""++------------------------------------------------------------------------------++-- | Put redacted text to the terminal+--+-- It is assumed that the terminal is set to display normal colors when this+-- function is called. If the first 'Line' is a 'RedactLine', then an extra+-- blank line is first output in order to set the colors. The terminal is set+-- to display normal colors when this function exits.+--+-- @since 0.4.0.0+putLines+ :: forall m. MonadTerminal m+ => [Term.SGR]+ -> [Line]+ -> m ()+putLines sgrs lines = do+ maybe (pure ()) (initialize sgrs) . listToMaybe $ take 1 lines+ mapM_ (uncurry $ putLine sgrs) $+ zip lines ((Just <$> drop 1 lines) ++ [Nothing])++------------------------------------------------------------------------------+-- $Internal++-- | Initialize the terminal colors+--+-- When the first line is a 'RedactLine', an extra blank line is output in+-- order to set the terminal colors.+initialize+ :: MonadTerminal m+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Line -- ^ first line+ -> m ()+initialize sgrs = \case+ NormalLine{} -> pure ()+ RedactLine{} -> setSGR sgrs >> putStrLn ""++------------------------------------------------------------------------------++-- | Put a line of redacted text to the terminal+--+-- The colors for the line is assumed to be already set. Be sure to call+-- 'initialize' before putting the first line.+putLine+ :: forall m. MonadTerminal m+ => [Term.SGR] -- ^ 'Term.SGR's for redacted text+ -> Line -- ^ line to put+ -> Maybe Line -- ^ 'Just' next line or 'Nothing' if end+ -> m ()+putLine sgrs line mNextLine = case line of+ NormalLine parts -> go False parts+ RedactLine t+ | isNextRedact -> putStrLn t+ | otherwise -> putStr t >> setSGR resetSGRs >> putStrLn ""+ where+ isNextRedact :: Bool+ isNextRedact = case mNextLine of+ Just RedactLine{} -> True+ _normalLineOrEnd -> False++ go :: Bool -> [Part] -> m ()+ go isRedact [part] = case part of+ Stet t -> do+ when isRedact $ setSGR resetSGRs+ if isNextRedact+ then putStr t >> setSGR sgrs >> putStrLn ""+ else putStrLn t+ Redact t -> do+ unless isRedact $ setSGR sgrs+ if isNextRedact+ then putStrLn t+ else putStr t >> setSGR resetSGRs >> putStrLn ""+ go isRedact (part:parts) = case (isRedact, part) of+ (False, Stet t) -> putStr t >> go False parts+ (True, Stet t) -> setSGR resetSGRs >> putStr t >> go False parts+ (False, Redact t) -> setSGR sgrs >> putStr t >> go True parts+ (True, Redact t) -> putStr t >> go True parts+ go _isRedact [] = putStrLn ""
+ src/Redact/Types.hs view
@@ -0,0 +1,52 @@+------------------------------------------------------------------------------+-- |+-- Module : Redact.Types+-- Description : types representing redacted text+-- Copyright : Copyright (c) 2020-2022 Travis Cardwell+-- License : MIT+------------------------------------------------------------------------------++module Redact.Types+ ( -- * Line+ Line(..)+ -- * Part+ , Part(..)+ -- * Error+ , Error(..)+ ) where++-- https://hackage.haskell.org/package/text+import Data.Text (Text)++------------------------------------------------------------------------------+-- $Line++-- | Lines of redacted text+--+-- @since 0.4.0.0+data Line+ = NormalLine ![Part] -- ^ normal line of text+ | RedactLine !Text -- ^ fully-redacted line of text+ deriving (Eq, Show)++------------------------------------------------------------------------------+-- $Part++-- | Parts of a normal line+--+-- @since 0.4.0.0+data Part+ = Stet !Text -- ^ text intended to be displayed as-is+ | Redact !Text -- ^ text intended to be made unreadable+ deriving (Eq, Show)++------------------------------------------------------------------------------+-- $Error++-- | Error sum type+--+-- @since 0.4.0.0+data Error+ = IOError !IOError -- ^ I/O error+ | RedactError !String -- ^ redact parsing error+ deriving (Eq, Show)
+ test/Redact/Markdown/Mock.hs view
@@ -0,0 +1,398 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module Redact.Markdown.Mock (tests) where++-- https://hackage.haskell.org/package/base+import System.IO (IOMode(ReadMode), stdin)++-- https://hackage.haskell.org/package/explainable-predicates+import Test.Predicates (anything, eq)++-- https://hackage.haskell.org/package/HMock+import Test.HMock ((|->), (|=>), expect, inSequence, runMockT)++-- https://hackage.haskell.org/package/tasty+import Test.Tasty (TestTree, testGroup)++-- https://hackage.haskell.org/package/tasty-hunit+import Test.Tasty.HUnit ((@=?), testCase)++-- (redact)+import qualified Redact.Markdown as Redact+import Redact.Monad.Handle (MonadHandle)+import Redact.Monad.Terminal (resetSGRs)++-- (redact:test)+import TestLib++------------------------------------------------------------------------------++testTextToTerminalStrictEmpty :: TestTree+testTextToTerminalStrictEmpty = testCase "empty" . runMockT $+ assertSuccess =<< Redact.textToTerminal redactSGRs ""++------------------------------------------------------------------------------++testTextToTerminalStrictOK :: TestTree+testTextToTerminalStrictOK = testCase "OK" . runMockT $ do+ inSequence+ [ expect $ PutStr "one`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "`" |-> ()+ , expect $ PutStr "```" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStrLn "```" |-> ()+ ]+ assertSuccess =<< Redact.textToTerminal redactSGRs+ "one`two`\n```\nthree\n```\n"++------------------------------------------------------------------------------++testTextToTerminalStrictErrorInline :: TestTree+testTextToTerminalStrictErrorInline = testCase "error_inline" $ do+ Left err <- runMockT $+ Redact.textToTerminal redactSGRs "one\ntwo`three\nfour`five`six\n"+ err @=? Redact.RedactError "inline code not terminated (line 2)"++------------------------------------------------------------------------------++testTextToTerminalStrictErrorFenced :: TestTree+testTextToTerminalStrictErrorFenced = testCase "error_fenced" $ do+ Left err <- runMockT $+ Redact.textToTerminal redactSGRs "one\n```\ntwo\n"+ err @=? Redact.RedactError "fenced code not terminated (line 4)"++------------------------------------------------------------------------------++testTextToTerminalLenientEmpty :: TestTree+testTextToTerminalLenientEmpty = testCase "empty" . runMockT $+ Redact.textToTerminal' redactSGRs ""++------------------------------------------------------------------------------++testTextToTerminalLenientOK :: TestTree+testTextToTerminalLenientOK = testCase "OK" . runMockT $ do+ inSequence+ [ expect $ PutStr "one`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "`" |-> ()+ , expect $ PutStr "```" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStrLn "```" |-> ()+ ]+ Redact.textToTerminal' redactSGRs "one`two`\n```\nthree\n```\n"++------------------------------------------------------------------------------++testTextToTerminalLenientErrorInline :: TestTree+testTextToTerminalLenientErrorInline = testCase "error_inline" . runMockT $ do+ inSequence+ [ expect $ PutStrLn "one" |-> ()+ , expect $ PutStr "two`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "four`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "five" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "`six" |-> ()+ ]+ Redact.textToTerminal' redactSGRs "one\ntwo`three\nfour`five`six\n"++------------------------------------------------------------------------------++testTextToTerminalLenientErrorFenced :: TestTree+testTextToTerminalLenientErrorFenced = testCase "error_fenced" . runMockT $ do+ inSequence+ [ expect $ PutStrLn "one" |-> ()+ , expect $ PutStr "```" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ Redact.textToTerminal' redactSGRs "one\n```\ntwo\n"++------------------------------------------------------------------------------++testHandleToTerminalStrictNone :: TestTree+testHandleToTerminalStrictNone = testCase "none" . runMockT $ do+ expect $ HIsEOF stdin |-> True+ assertSuccess =<< Redact.handleToTerminal redactSGRs stdin++------------------------------------------------------------------------------++testHandleToTerminalStrictOK :: TestTree+testHandleToTerminalStrictOK = testCase "OK" . runMockT $ do+ inSequence+ [ expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "one`two`"+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "```"+ , expect $ PutStr "one`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "`" |-> ()+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "three"+ , expect $ PutStr "```" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "```"+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ HIsEOF stdin |-> True+ , expect $ PutStrLn "```" |-> ()+ ]+ assertSuccess =<< Redact.handleToTerminal redactSGRs stdin++------------------------------------------------------------------------------++testHandleToTerminalStrictErrorInline :: TestTree+testHandleToTerminalStrictErrorInline = testCase "error_inline" $ do+ Left err <- runMockT $ do+ inSequence+ [ expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "one"+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "two`three"+ , expect $ PutStrLn "one"+ ]+ Redact.handleToTerminal redactSGRs stdin+ err @=? Redact.RedactError "inline code not terminated (line 2)"++------------------------------------------------------------------------------++testHandleToTerminalStrictErrorFenced :: TestTree+testHandleToTerminalStrictErrorFenced = testCase "error_fenced" $ do+ Left err <- runMockT $ do+ inSequence+ [ expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "one"+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "```"+ , expect $ PutStrLn "one" |-> ()+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "two"+ , expect $ PutStr "```" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ HIsEOF stdin |-> True+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ Redact.handleToTerminal redactSGRs stdin+ err @=? Redact.RedactError "fenced code not terminated (line 4)"++------------------------------------------------------------------------------++testHandleToTerminalLenientNone :: TestTree+testHandleToTerminalLenientNone = testCase "none" . runMockT $ do+ expect $ HIsEOF stdin |-> True+ Redact.handleToTerminal' redactSGRs stdin++------------------------------------------------------------------------------++testHandleToTerminalLenientOK :: TestTree+testHandleToTerminalLenientOK = testCase "OK" . runMockT $ do+ inSequence+ [ expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "one`two`"+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "```"+ , expect $ PutStr "one`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "`" |-> ()+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "three"+ , expect $ PutStr "```" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "```"+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ HIsEOF stdin |-> True+ , expect $ PutStrLn "```" |-> ()+ ]+ Redact.handleToTerminal' redactSGRs stdin++------------------------------------------------------------------------------++testHandleToTerminalLenientErrorInline :: TestTree+testHandleToTerminalLenientErrorInline =+ testCase "error_inline" . runMockT $ do+ inSequence+ [ expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "one"+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "two`three"+ , expect $ PutStrLn "one"+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "four`five`six"+ , expect $ PutStr "two`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ HIsEOF stdin |-> True+ , expect $ PutStr "four`" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "five" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "`six" |-> ()+ ]+ Redact.handleToTerminal' redactSGRs stdin++------------------------------------------------------------------------------++testHandleToTerminalLenientErrorFenced :: TestTree+testHandleToTerminalLenientErrorFenced =+ testCase "error_fenced" . runMockT $ do+ inSequence+ [ expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "one"+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "```"+ , expect $ PutStrLn "one" |-> ()+ , expect $ HIsEOF stdin |-> False+ , expect $ HGetLine stdin |-> "two"+ , expect $ PutStr "```" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ HIsEOF stdin |-> True+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ Redact.handleToTerminal' redactSGRs stdin++------------------------------------------------------------------------------++testFileToTerminalStrictOK :: TestTree+testFileToTerminalStrictOK = testCase "OK" . runMockT $ do+ expect $+ ( WithFile_ (eq "test.md") (eq ReadMode) anything+ :: Matcher MonadHandle "withFile" IO+ (Either IOError (Either Redact.Error ()))+ )+ |=> \(WithFile _path _mode _action) -> pure . Right $ Right ()+ assertSuccess =<< Redact.fileToTerminal redactSGRs "test.md"++------------------------------------------------------------------------------++testFileToTerminalStrictRedactError :: TestTree+testFileToTerminalStrictRedactError = testCase "error_redact" $ do+ let err = Redact.RedactError "inline code not terminated (line 42)"+ Left err' <- runMockT $ do+ expect $+ ( WithFile_ (eq "test.md") (eq ReadMode) anything+ :: Matcher MonadHandle "withFile" IO+ (Either IOError (Either Redact.Error ()))+ )+ |=> \(WithFile _path _mode _action) -> pure . Right $ Left err+ Redact.fileToTerminal redactSGRs "test.md"+ err' @=? err++------------------------------------------------------------------------------++testFileToTerminalStrictIOError :: TestTree+testFileToTerminalStrictIOError = testCase "error_io" $ do+ let err = userError "nope"+ Left err' <- runMockT $ do+ expect $+ ( WithFile_ (eq "test.md") (eq ReadMode) anything+ :: Matcher MonadHandle "withFile" IO+ (Either IOError (Either Redact.Error ()))+ )+ |=> \(WithFile _path _mode _action) -> pure $ Left err+ Redact.fileToTerminal redactSGRs "test.md"+ err' @=? Redact.IOError err++------------------------------------------------------------------------------++testFileToTerminalLenientOK :: TestTree+testFileToTerminalLenientOK = testCase "OK" . runMockT $ do+ expect $+ ( WithFile_ (eq "test.md") (eq ReadMode) anything+ :: Matcher MonadHandle "withFile" IO (Either IOError ())+ )+ |=> \(WithFile _path _mode _action) -> pure $ Right ()+ assertSuccess =<< Redact.fileToTerminal' redactSGRs "test.md"++------------------------------------------------------------------------------++testFileToTerminalLenientIOError :: TestTree+testFileToTerminalLenientIOError = testCase "error_io" $ do+ let err = userError "nope"+ Left err' <- runMockT $ do+ expect $+ ( WithFile_ (eq "test.md") (eq ReadMode) anything+ :: Matcher MonadHandle "withFile" IO (Either IOError ())+ )+ |=> \(WithFile _path _mode _action) -> pure $ Left err+ Redact.fileToTerminal' redactSGRs "test.md"+ err' @=? Redact.IOError err++------------------------------------------------------------------------------++tests :: TestTree+tests = testGroup "Redact.Markdown:Mock"+ [ testGroup "textToTerminal"+ [ testTextToTerminalStrictEmpty+ , testTextToTerminalStrictOK+ , testTextToTerminalStrictErrorInline+ , testTextToTerminalStrictErrorFenced+ ]+ , testGroup "textToTerminal'"+ [ testTextToTerminalLenientEmpty+ , testTextToTerminalLenientOK+ , testTextToTerminalLenientErrorInline+ , testTextToTerminalLenientErrorFenced+ ]+ , testGroup "handleToTerminal"+ [ testHandleToTerminalStrictNone+ , testHandleToTerminalStrictOK+ , testHandleToTerminalStrictErrorInline+ , testHandleToTerminalStrictErrorFenced+ ]+ , testGroup "handleToTerminal'"+ [ testHandleToTerminalLenientNone+ , testHandleToTerminalLenientOK+ , testHandleToTerminalLenientErrorInline+ , testHandleToTerminalLenientErrorFenced+ ]+ , testGroup "fileToTerminal"+ [ testFileToTerminalStrictOK+ , testFileToTerminalStrictRedactError+ , testFileToTerminalStrictIOError+ ]+ , testGroup "fileToTerminal'"+ [ testFileToTerminalLenientOK+ , testFileToTerminalLenientIOError+ ]+ ]
+ test/Redact/Markdown/Test.hs view
@@ -0,0 +1,247 @@+{-# LANGUAGE OverloadedStrings #-}++module Redact.Markdown.Test (tests) where++-- https://hackage.haskell.org/package/tasty+import Test.Tasty (TestTree, testGroup)++-- https://hackage.haskell.org/package/tasty-hunit+import Test.Tasty.HUnit ((@=?), testCase)++-- (redact)+import Redact.Markdown+ ( Line(NormalLine, RedactLine), Part(Redact, Stet), redact, redact'+ , redactLine, redactLine'+ )++------------------------------------------------------------------------------++testRedactLine :: TestTree+testRedactLine = testGroup "redactLine"+ [ testCase "empty" $ Just (NormalLine []) @=? redactLine ""+ , testCase "TT" $ Just (NormalLine [Stet "``"]) @=? redactLine "``"+ , testCase "T" $ Nothing @=? redactLine "`"+ , testCase "TTT" $ Nothing @=? redactLine "```"+ , testCase "a" $ Just (NormalLine [Stet "a"]) @=? redactLine "a"+ , testCase "TaT" $+ Just (NormalLine [Stet "`", Redact "a", Stet "`"]) @=?+ redactLine "`a`"+ , testCase "TTa" $ Just (NormalLine [Stet "``a"]) @=? redactLine "``a"+ , testCase "aTT" $ Just (NormalLine [Stet "a``"]) @=? redactLine "a``"+ , testCase "aT" $ Nothing @=? redactLine "a`"+ , testCase "Ta" $ Nothing @=? redactLine "`a"+ , testCase "TTaT" $ Nothing @=? redactLine "``a`"+ , testCase "TaTT" $ Nothing @=? redactLine "`a``"+ , testCase "TaTb" $+ Just (NormalLine [Stet "`", Redact "a", Stet "`b"]) @=?+ redactLine "`a`b"+ , testCase "aTbT" $+ Just (NormalLine [Stet "a`", Redact "b", Stet "`"]) @=?+ redactLine "a`b`"+ , testCase "aTTb" $ Just (NormalLine [Stet "a``b"]) @=? redactLine "a``b"+ , testCase "TaTbT" $ Nothing @=? redactLine "`a`b`"+ , testCase "aTbTc" $+ Just (NormalLine [Stet "a`", Redact "b", Stet "`c"]) @=?+ redactLine "a`b`c"+ , testCase "TaTbTcT" $+ Just+ ( NormalLine+ [Stet "`", Redact "a", Stet "`b`", Redact "c", Stet "`"]+ ) @=?+ redactLine "`a`b`c`"+ , testCase "TaTTbTc" $+ Just+ ( NormalLine+ [Stet "`", Redact "a", Stet "``", Redact "b", Stet "`c"]+ ) @=?+ redactLine "`a``b`c"+ , testCase "TaTTbTTcT" $+ Just+ ( NormalLine+ [ Stet "`", Redact "a", Stet "``", Redact "b", Stet "``"+ , Redact "c" , Stet "`"+ ]+ ) @=? redactLine "`a``b``c`"+ , testCase "TaTbTcTd" $+ Just+ ( NormalLine+ [Stet "`", Redact "a", Stet "`b`", Redact "c", Stet "`d"]+ ) @=?+ redactLine "`a`b`c`d"+ , testCase "aTbTTcTd" $+ Just+ ( NormalLine+ [Stet "a`", Redact "b", Stet "``", Redact "c", Stet "`d"]+ ) @=?+ redactLine "a`b``c`d"+ , testCase "aTbTcTcT" $+ Just+ ( NormalLine+ [Stet "a`", Redact "b", Stet "`c`", Redact "d", Stet "`"]+ ) @=?+ redactLine "a`b`c`d`"+ ]++------------------------------------------------------------------------------++testRedactLine' :: TestTree+testRedactLine' = testGroup "redactLine'"+ [ testCase "empty" $ NormalLine [] @=? redactLine' ""+ , testCase "TT" $ NormalLine [Stet "``"] @=? redactLine' "``"+ , testCase "T" $ NormalLine [Stet "`"] @=? redactLine' "`"+ , testCase "TTT" $ NormalLine [Stet "```"] @=? redactLine' "```"+ , testCase "a" $ NormalLine [Stet "a"] @=? redactLine' "a"+ , testCase "TaT" $+ NormalLine [Stet "`", Redact "a", Stet "`"] @=? redactLine' "`a`"+ , testCase "TTa" $ NormalLine [Stet "``a"] @=? redactLine' "``a"+ , testCase "aTT" $ NormalLine [Stet "a``"] @=? redactLine' "a``"+ , testCase "aT" $ NormalLine [Stet "a`"] @=? redactLine' "a`"+ , testCase "Ta" $ NormalLine [Stet "`", Redact "a"] @=? redactLine' "`a"+ , testCase "TTaT" $ NormalLine [Stet "``a`"] @=? redactLine' "``a`"+ , testCase "TaTT" $+ NormalLine [Stet "`", Redact "a", Stet "``"] @=? redactLine' "`a``"+ , testCase "TaTb" $+ NormalLine [Stet "`", Redact "a", Stet "`b"] @=? redactLine' "`a`b"+ , testCase "aTbT" $+ NormalLine [Stet "a`", Redact "b", Stet "`"] @=? redactLine' "a`b`"+ , testCase "aTTb" $ NormalLine [Stet "a``b"] @=? redactLine' "a``b"+ , testCase "TaTbT" $+ NormalLine [Stet "`", Redact "a", Stet "`b`"] @=? redactLine' "`a`b`"+ , testCase "aTbTc" $+ NormalLine [Stet "a`", Redact "b", Stet "`c"] @=? redactLine' "a`b`c"+ , testCase "TaTbTcT" $+ NormalLine [Stet "`", Redact "a", Stet "`b`", Redact "c", Stet "`"]+ @=? redactLine' "`a`b`c`"+ , testCase "TaTTbTc" $+ NormalLine [Stet "`", Redact "a", Stet "``", Redact "b", Stet "`c"]+ @=? redactLine' "`a``b`c"+ , testCase "TaTTbTTcT" $+ NormalLine+ [ Stet "`", Redact "a", Stet "``", Redact "b", Stet "``"+ , Redact "c", Stet "`"+ ]+ @=? redactLine' "`a``b``c`"+ , testCase "TaTbTcTd" $+ NormalLine [Stet "`", Redact "a", Stet "`b`", Redact "c", Stet "`d"]+ @=? redactLine' "`a`b`c`d"+ , testCase "aTbTTcTd" $+ NormalLine [Stet "a`", Redact "b", Stet "``", Redact "c", Stet "`d"]+ @=? redactLine' "a`b``c`d"+ , testCase "aTbTcTcT" $+ NormalLine [Stet "a`", Redact "b", Stet "`c`", Redact "d", Stet "`"]+ @=? redactLine' "a`b`c`d`"+ ]++------------------------------------------------------------------------------++testRedact :: TestTree+testRedact = testGroup "redact"+ [ testCase "empty" $ Right [] @=? redact ""+ , testCase "newline" $ Right [NormalLine []] @=? redact "\n"+ , testCase "newlines" $+ Right [NormalLine [], NormalLine []] @=? redact "\n\n"+ , testCase "inline_single" $+ Right [NormalLine [Stet "a`", Redact "b", Stet "`c"]] @=?+ redact "a`b`c\n"+ , testCase "inline_multiple" $+ Right+ [ NormalLine [Stet "a`", Redact "b", Stet "`c"]+ , NormalLine+ [Stet "`", Redact "d", Stet "`e`", Redact "f", Stet "`"]+ ] @=? redact "a`b`c\n`d`e`f`\n"+ , testCase "inline_invalid" $+ Left "inline code not terminated (line 2)" @=? redact "a`b`c\nd`e\n\n"+ , testCase "fenced_three" $+ Right+ [ NormalLine [Stet "```"]+ , RedactLine "a`b`c"+ , NormalLine [Stet "```"]+ ] @=? redact "```\na`b`c\n```\n"+ , testCase "fenced_extra" $+ Right+ [ NormalLine [Stet "`````"]+ , RedactLine "a`b`c"+ , NormalLine [Stet "```````"]+ ] @=? redact "`````\na`b`c\n```````\n"+ , testCase "fenced_multiple" $+ Right+ [ NormalLine [Stet "a"]+ , NormalLine [Stet "```"]+ , RedactLine "b"+ , RedactLine "c"+ , NormalLine [Stet "```"]+ , NormalLine [Stet "```"]+ , RedactLine "d"+ , NormalLine [Stet "```"]+ ] @=? redact "a\n```\nb\nc\n```\n```\nd\n```\n"+ , testCase "fenced_language" $+ Right+ [ NormalLine [Stet "a"]+ , NormalLine [Stet "```haskell"]+ , RedactLine "--"+ , NormalLine [Stet "```"]+ ] @=? redact "a\n```haskell\n--\n```\n"+ , testCase "fenced_invalid" $+ Left "fenced code not terminated (line 4)" @=? redact "a\n```\nb\n"+ ]++------------------------------------------------------------------------------++testRedact' :: TestTree+testRedact' = testGroup "redact'"+ [ testCase "empty" $ [] @=? redact' ""+ , testCase "newline" $ [NormalLine []] @=? redact' "\n"+ , testCase "newlines" $ [NormalLine [], NormalLine []] @=? redact' "\n\n"+ , testCase "inline_single" $+ [NormalLine [Stet "a`", Redact "b", Stet "`c"]] @=? redact' "a`b`c\n"+ , testCase "inline_multiple" $+ [ NormalLine [Stet "a`", Redact "b", Stet "`c"]+ , NormalLine [Stet "`", Redact "d", Stet "`e`", Redact "f", Stet "`"]+ ] @=? redact' "a`b`c\n`d`e`f`\n"+ , testCase "inline_invalid" $+ [ NormalLine [Stet "a`", Redact "b", Stet "`c"]+ , NormalLine [Stet "d`", Redact "e"]+ , NormalLine []+ ] @=? redact' "a`b`c\nd`e\n\n"+ , testCase "fenced_three" $+ [ NormalLine [Stet "```"]+ , RedactLine "a`b`c"+ , NormalLine [Stet "```"]+ ] @=? redact' "```\na`b`c\n```\n"+ , testCase "fenced_extra" $+ [ NormalLine [Stet "`````"]+ , RedactLine "a`b`c"+ , NormalLine [Stet "```````"]+ ] @=? redact' "`````\na`b`c\n```````\n"+ , testCase "fenced_multiple" $+ [ NormalLine [Stet "a"]+ , NormalLine [Stet "```"]+ , RedactLine "b"+ , RedactLine "c"+ , NormalLine [Stet "```"]+ , NormalLine [Stet "```"]+ , RedactLine "d"+ , NormalLine [Stet "```"]+ ] @=? redact' "a\n```\nb\nc\n```\n```\nd\n```\n"+ , testCase "fenced_language" $+ [ NormalLine [Stet "a"]+ , NormalLine [Stet "```haskell"]+ , RedactLine "--"+ , NormalLine [Stet "```"]+ ] @=? redact' "a\n```haskell\n--\n```\n"+ , testCase "fenced_invalid" $+ [ NormalLine [Stet "a"]+ , NormalLine [Stet "```"]+ , RedactLine "b"+ ] @=? redact' "a\n```\nb\n"+ ]++------------------------------------------------------------------------------++tests :: TestTree+tests = testGroup "Redact.Markdown"+ [ testRedactLine+ , testRedactLine'+ , testRedact+ , testRedact'+ ]
+ test/Redact/Monad/Terminal/Mock.hs view
@@ -0,0 +1,224 @@+{-# LANGUAGE OverloadedStrings #-}++module Redact.Monad.Terminal.Mock (tests) where++-- https://hackage.haskell.org/package/HMock+import Test.HMock ((|->), expect, inSequence, runMockT)++-- https://hackage.haskell.org/package/tasty+import Test.Tasty (TestTree, testGroup)++-- https://hackage.haskell.org/package/tasty-hunit+import Test.Tasty.HUnit (testCase)++-- (redact)+import qualified Redact.Monad.Terminal as RMT+import Redact.Monad.Terminal (resetSGRs)+import Redact.Types (Line(NormalLine, RedactLine), Part(Redact, Stet))++-- (redact:test)+import TestLib++------------------------------------------------------------------------------++testReset :: TestTree+testReset = testCase "reset" . runMockT $ do+ inSequence+ [ expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ RMT.reset++------------------------------------------------------------------------------++testPutLinesNone :: TestTree+testPutLinesNone = testCase "none" . runMockT $ RMT.putLines redactSGRs []++------------------------------------------------------------------------------++testPutLinesNormalEmpty :: TestTree+testPutLinesNormalEmpty = testCase "normal_empty" . runMockT $ do+ expect $ PutStrLn "" |-> ()+ RMT.putLines redactSGRs [NormalLine []]++------------------------------------------------------------------------------++testPutLinesNormalStet :: TestTree+testPutLinesNormalStet = testCase "normal_stet" . runMockT $ do+ inSequence+ [ expect $ PutStrLn "one" |-> ()+ , expect $ PutStrLn "two" |-> ()+ ]+ RMT.putLines redactSGRs+ [ NormalLine [Stet "one"]+ , NormalLine [Stet "two"]+ ]++------------------------------------------------------------------------------++testPutLinesNormalRedact :: TestTree+testPutLinesNormalRedact = testCase "normal_redact" . runMockT $ do+ inSequence+ [ expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "one" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ RMT.putLines redactSGRs+ [ NormalLine [Redact "one"]+ , NormalLine [Redact "two"]+ ]++------------------------------------------------------------------------------++testPutLinesNormalMixed :: TestTree+testPutLinesNormalMixed = testCase "normal_mixed" . runMockT $ do+ inSequence+ [ expect $ PutStrLn "one" |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "four" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "five" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStr "six" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "seven" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ RMT.putLines redactSGRs+ [ NormalLine [Stet "one"]+ , NormalLine []+ , NormalLine [Stet "two", Redact "three"]+ , NormalLine [Redact "four"]+ , NormalLine []+ , NormalLine [Redact "five", Stet "six", Redact "seven"]+ ]++------------------------------------------------------------------------------++testPutLinesRedactStet :: TestTree+testPutLinesRedactStet = testCase "redact_stet" . runMockT $ do+ inSequence+ [ expect $ PutStr "one" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStrLn "three" |-> ()+ ]+ RMT.putLines redactSGRs+ [ NormalLine [Stet "one"]+ , RedactLine "two"+ , NormalLine [Stet "three"]+ ]++------------------------------------------------------------------------------++testPutLinesRedactRedact :: TestTree+testPutLinesRedactRedact = testCase "redact_redact" . runMockT $ do+ inSequence+ [ expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "one" |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ RMT.putLines redactSGRs+ [ NormalLine [Redact "one"]+ , RedactLine "two"+ , NormalLine [Redact "three"]+ ]++------------------------------------------------------------------------------++testPutLinesRedactMultiple :: TestTree+testPutLinesRedactMultiple = testCase "redact_multiple" . runMockT $ do+ inSequence+ [ expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "one" |-> ()+ , expect $ PutStrLn "two" |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "three" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStrLn "four" |-> ()+ ]+ RMT.putLines redactSGRs+ [ NormalLine [Redact "one"]+ , RedactLine "two"+ , RedactLine ""+ , RedactLine "three"+ , NormalLine [Stet "four"]+ ]++------------------------------------------------------------------------------++testPutLinesRedactBegin :: TestTree+testPutLinesRedactBegin = testCase "redact_begin" . runMockT $ do+ inSequence+ [ expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "one" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStrLn "two" |-> ()+ ]+ RMT.putLines redactSGRs+ [ RedactLine "one"+ , NormalLine [Stet "two"]+ ]++------------------------------------------------------------------------------++testPutLinesRedactEnd :: TestTree+testPutLinesRedactEnd = testCase "redact_end" . runMockT $ do+ inSequence+ [ expect $ PutStr "one" |-> ()+ , expect $ SetSGR redactSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ , expect $ PutStr "two" |-> ()+ , expect $ SetSGR resetSGRs |-> ()+ , expect $ PutStrLn "" |-> ()+ ]+ RMT.putLines redactSGRs+ [ NormalLine [Stet "one"]+ , RedactLine "two"+ ]++------------------------------------------------------------------------------++tests :: TestTree+tests = testGroup "Redact.Monad.Terminal:Mock"+ [ testReset+ , testGroup "putLines"+ [ testPutLinesNone+ , testPutLinesNormalEmpty+ , testPutLinesNormalStet+ , testPutLinesNormalRedact+ , testPutLinesNormalMixed+ , testPutLinesRedactStet+ , testPutLinesRedactRedact+ , testPutLinesRedactMultiple+ , testPutLinesRedactBegin+ , testPutLinesRedactEnd+ ]+ ]
+ test/Spec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}++module Main (main) where++-- https://hackage.haskell.org/package/tasty+import Test.Tasty (defaultMain, testGroup)++-- (redact:test)+import qualified Redact.Markdown.Test+#if __GLASGOW_HASKELL__ >= 808+import qualified Redact.Markdown.Mock+import qualified Redact.Monad.Terminal.Mock+#endif++------------------------------------------------------------------------------++main :: IO ()+main = defaultMain $ testGroup "test"+ [ Redact.Markdown.Test.tests+#if __GLASGOW_HASKELL__ >= 808+ , Redact.Markdown.Mock.tests+ , Redact.Monad.Terminal.Mock.tests+#endif+ ]
+ test/TestLib.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}++{-# OPTIONS_GHC -fno-warn-orphans #-}++module TestLib where++-- https://hackage.haskell.org/package/ansi-terminal+import qualified System.Console.ANSI as Term++-- https://hackage.haskell.org/package/base+import Control.Monad.IO.Class (MonadIO(liftIO))+import GHC.Stack (HasCallStack)++-- https://hackage.haskell.org/package/HMock+import Test.HMock (makeMockable)++-- https://hackage.haskell.org/package/tasty-hunit+import qualified Test.Tasty.HUnit as HUnit++-- (redact)+import Redact.Monad.Handle (MonadHandle)+import qualified Redact.Monad.Terminal as RMT+import Redact.Monad.Terminal (MonadTerminal)++------------------------------------------------------------------------------++makeMockable [t|MonadHandle|]++makeMockable [t|MonadTerminal|]++------------------------------------------------------------------------------++redactSGRs :: [Term.SGR]+redactSGRs = RMT.redactSGRs Term.Red Term.Vivid++------------------------------------------------------------------------------++assertSuccess+ :: (HasCallStack, MonadIO m, Show e)+ => Either e ()+ -> m ()+assertSuccess = \case+ Right () -> pure ()+ Left err ->+ liftIO . HUnit.assertFailure $ "unexpected error: " ++ show err