diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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]: +[SemVer]: + +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]: + +## 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,110 @@ +# Redact + +[![Project Status: Active – The project has reached a stable, usable state and is being actively developed.](https://www.repostatus.org/badges/latest/active.svg)](https://www.repostatus.org/#active) +[![GitHub CI](https://github.com/ExtremaIS/redact-haskell/workflows/CI/badge.svg?branch=main)](https://github.com/ExtremaIS/redact-haskell/actions) +[![Hackage](https://img.shields.io/hackage/v/redact.svg)](https://hackage.haskell.org/package/redact) +[![Stackage LTS](https://stackage.org/package/redact/badge/lts)](https://stackage.org/package/redact) +[![Stackage Nightly](https://stackage.org/package/redact/badge/nightly)](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]: + +#### `.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]: +[Cabal]: + +#### Installation From Stackage + +Install PhatSort from [Stackage][] using [Stack][] as follows: + +``` +$ stack install redact +``` + +[Stackage]: +[Stack]: + +### Usage + +See the [`redact` man page](doc/redact.1.md) for usage information. + +## Project + +### Links + +* Hackage: +* Stackage: +* GitHub: +* GitHub Actions CI: + +### 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: + + +Issues may also be submitted via email to . + +### License + +This project is released under the +[MIT License](https://opensource.org/licenses/MIT) as specified in the +[`LICENSE`](LICENSE) file. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/LibOA.hs b/app/LibOA.hs new file mode 100644 --- /dev/null +++ b/app/LibOA.hs @@ -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) diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -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 diff --git a/redact.cabal b/redact.cabal new file mode 100644 --- /dev/null +++ b/redact.cabal @@ -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 + . + +homepage: https://github.com/ExtremaIS/redact-haskell#readme +bug-reports: https://github.com/ExtremaIS/redact-haskell/issues +author: Travis Cardwell +maintainer: Travis Cardwell +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 diff --git a/src/Redact.hs b/src/Redact.hs new file mode 100644 --- /dev/null +++ b/src/Redact.hs @@ -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 diff --git a/src/Redact/Internal.hs b/src/Redact/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Redact/Internal.hs @@ -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 [] = [] diff --git a/src/Redact/Markdown.hs b/src/Redact/Markdown.hs new file mode 100644 --- /dev/null +++ b/src/Redact/Markdown.hs @@ -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) diff --git a/src/Redact/Monad/Handle.hs b/src/Redact/Monad/Handle.hs new file mode 100644 --- /dev/null +++ b/src/Redact/Monad/Handle.hs @@ -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 diff --git a/src/Redact/Monad/Terminal.hs b/src/Redact/Monad/Terminal.hs new file mode 100644 --- /dev/null +++ b/src/Redact/Monad/Terminal.hs @@ -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 "" diff --git a/src/Redact/Types.hs b/src/Redact/Types.hs new file mode 100644 --- /dev/null +++ b/src/Redact/Types.hs @@ -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) diff --git a/test/Redact/Markdown/Mock.hs b/test/Redact/Markdown/Mock.hs new file mode 100644 --- /dev/null +++ b/test/Redact/Markdown/Mock.hs @@ -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 + ] + ] diff --git a/test/Redact/Markdown/Test.hs b/test/Redact/Markdown/Test.hs new file mode 100644 --- /dev/null +++ b/test/Redact/Markdown/Test.hs @@ -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' + ] diff --git a/test/Redact/Monad/Terminal/Mock.hs b/test/Redact/Monad/Terminal/Mock.hs new file mode 100644 --- /dev/null +++ b/test/Redact/Monad/Terminal/Mock.hs @@ -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 + ] + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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 + ] diff --git a/test/TestLib.hs b/test/TestLib.hs new file mode 100644 --- /dev/null +++ b/test/TestLib.hs @@ -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