adblock2privoxy-3.0.0: src/ProgramOptions.hs

{-# LANGUAGE StrictData #-}

module ProgramOptions
  ( Options (..),
    DebugLevel (DebugLevel),
    fillFromLog,
    parseOptions,
    logOptions,
    writeError,
    versionText,
  )
where

import Control.Applicative hiding (many)
import Control.Monad.State
import Data.Version (showVersion)
import Paths_adblock2privoxy (version)
import System.Console.GetOpt
import System.FilePath ((</>))
import Text.ParserCombinators.Parsec hiding (Line, State, (<|>))

newtype DebugLevel = DebugLevel Int deriving (Enum, Eq, Ord, Show)

readDebugLevel :: String -> DebugLevel
readDebugLevel x = fst $ parseDebugLevel (reads x :: [(Int, String)])
  where
    parseDebugLevel :: [(Int, String)] -> (DebugLevel, IO ())
    parseDebugLevel y = case y of
      [(dl, "")] -> (DebugLevel dl, return ())
      _ -> (DebugLevel 0, writeError "Debug level must be an integer.\n")

data Options = Options
  { _showVersion :: Bool,
    _privoxyDir :: FilePath,
    _webDir :: FilePath,
    _taskFile :: FilePath,
    _cssDomain :: String,
    _useHTTP :: Bool,
    _debugLevel :: DebugLevel,
    _forced :: Bool
  }

options :: [OptDescr (Options -> Options)]
options =
  [ Option
      "v"
      ["version"]
      (NoArg (\opts -> opts {_showVersion = True}))
      "Show version number",
    Option
      "p"
      ["privoxyDir"]
      ( ReqArg
          (\f opts -> opts {_privoxyDir = f})
          "PATH"
      )
      "Privoxy config output path",
    Option
      "w"
      ["webDir"]
      ( ReqArg
          (\f opts -> opts {_webDir = f})
          "PATH"
      )
      "Css files output path (optional, privoxyDir is used by default)",
    Option
      "d"
      ["domainCSS"]
      ( ReqArg
          (\d opts -> opts {_cssDomain = d})
          "DOMAIN"
      )
      "Domain of CSS web server (required for Element Hide functionality)",
    Option
      "u"
      ["useHTTP"]
      (NoArg (\opts -> opts {_useHTTP = True}))
      "Use HTTP for CSS web server; the default is HTTPS to avoid mixed content",
    Option
      "g"
      ["debugLevel"]
      ( ReqArg
          (\dL opts -> opts {_debugLevel = readDebugLevel dL})
          "INT"
      )
      "Debug Level. 0: Off; 1: top directory CSS; 2: full directory.",
    Option
      "t"
      ["taskFile"]
      ( ReqArg
          (\f opts -> opts {_taskFile = f})
          "PATH"
      )
      "Path to task file containing urls to process and options. privoxyDir, webDir and domainCSS values are taken from this file if not specified explicitly",
    Option
      "f"
      ["forced"]
      (NoArg (\opts -> opts {_forced = True}))
      "Run even if no sources are expired"
  ]

parseOptions :: [String] -> IO (Options, [String])
parseOptions argv =
  case getOpt Permute options argv of
    (opts, nonOpts, []) ->
      case foldr id emptyOptions opts of
        Options False "" _ "" _ _ _ _ -> writeError "Privoxy dir or task file should be specified.\n"
        opts'@Options {_showVersion = True} -> return (opts', nonOpts)
        opts' -> return (setDefaults opts', nonOpts)
    (_, _, errs) -> writeError $ concat errs
  where
    setDefaults opts@(Options _ privoxyDir@(_ : _) "" _ _ _ _ _) = setDefaults opts {_webDir = privoxyDir}
    setDefaults opts@(Options _ privoxyDir _ "" _ _ _ _) = setDefaults opts {_taskFile = privoxyDir </> "ab2p.task"}
    setDefaults opts = opts

versionText :: String
versionText = "adblock2privoxy version " ++ showVersion version

writeError :: String -> IO a
writeError msg = ioError $ userError $ msg ++ "\n" ++ usageInfo header options
  where
    header =
      versionText
        ++ "\nSee home page for more details and updates: https://github.com/essandess/adblock2privoxy\n"
        ++ "Usage: adblock2privoxy [OPTION...] [URL...]"

logOptions :: Options -> [String]
logOptions options' =
  [ startMark,
    "Privoxy path: " ++ _privoxyDir options',
    "Web path: " ++ _webDir options',
    "CSS web server domain: " ++ _cssDomain options',
    endMark,
    ""
  ]

startMark :: String
startMark = "----- options -----"

endMark :: String
endMark = "------- end ------"

emptyOptions :: Options
emptyOptions = Options False "" "" "" "" False (DebugLevel 0) False

fillFromLog :: Options -> [String] -> Options
fillFromLog existing lns = execState (mapM parseLogOptions lns') existing
  where
    lns' = filter (not . null) $ takeWhile (/= endMark) . dropWhile (/= startMark) $ lns

parseLogOptions :: String -> State Options ()
parseLogOptions text = do
  info <- get
  let ifEmpty getter x =
        let oldValue = getter info
         in if null oldValue then x else oldValue
      privoxyPathParser = (\x -> info {_privoxyDir = ifEmpty _privoxyDir x}) <$> (string "Privoxy path: " *> many1 anyChar)
      webPathParser = (\x -> info {_webDir = ifEmpty _webDir x}) <$> (string "Web path: " *> many1 anyChar)
      cssDomainParser = (\x -> info {_cssDomain = ifEmpty _cssDomain x}) <$> (string "CSS web server domain: " *> many1 anyChar)
      stringParser =
        skipMany (char ' ')
          *> (try privoxyPathParser <|> try webPathParser <|> cssDomainParser)
  case parse stringParser "" text of
    Left _ -> return ()
    Right info' -> put info'