redact-0.4.0.0: app/Main.hs
------------------------------------------------------------------------------
-- |
-- 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