{-# LANGUAGE RecordWildCards #-}

module LinkCheck.OptParse
  ( module LinkCheck.OptParse,
    module LinkCheck.OptParse.Types,
  )
where

import Control.Monad.Logger
import Data.Maybe
import LinkCheck.OptParse.Types
import Network.URI
import Options.Applicative
import qualified System.Environment as System
import Text.Read

getSettings :: IO Settings
getSettings :: IO Settings
getSettings = do
  Flags
flags <- IO Flags
getFlags
  Flags -> IO Settings
deriveSettings Flags
flags

deriveSettings :: Flags -> IO Settings
deriveSettings :: Flags -> IO Settings
deriveSettings Flags {Maybe Bool
Maybe Int
Maybe Word
Maybe LogLevel
URI
flagCacheSize :: Flags -> Maybe Word
flagMaxDepth :: Flags -> Maybe Word
flagCheckFragments :: Flags -> Maybe Bool
flagExternal :: Flags -> Maybe Bool
flagFetchers :: Flags -> Maybe Int
flagLogLevel :: Flags -> Maybe LogLevel
flagUri :: Flags -> URI
flagCacheSize :: Maybe Word
flagMaxDepth :: Maybe Word
flagCheckFragments :: Maybe Bool
flagExternal :: Maybe Bool
flagFetchers :: Maybe Int
flagLogLevel :: Maybe LogLevel
flagUri :: URI
..} = do
  let setUri :: URI
setUri = URI
flagUri
      setLogLevel :: LogLevel
setLogLevel = LogLevel -> Maybe LogLevel -> LogLevel
forall a. a -> Maybe a -> a
fromMaybe LogLevel
LevelInfo Maybe LogLevel
flagLogLevel
      setFetchers :: Maybe Int
setFetchers = Maybe Int
flagFetchers
      setExternal :: Bool
setExternal = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
flagExternal
      setCheckFragments :: Bool
setCheckFragments = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False Maybe Bool
flagCheckFragments
      setMaxDepth :: Maybe Word
setMaxDepth = Maybe Word
flagMaxDepth
      setCacheSize :: Maybe Word
setCacheSize = Maybe Word
flagCacheSize
  Settings -> IO Settings
forall (f :: * -> *) a. Applicative f => a -> f a
pure Settings :: URI
-> LogLevel
-> Maybe Int
-> Bool
-> Bool
-> Maybe Word
-> Maybe Word
-> Settings
Settings {Bool
Maybe Int
Maybe Word
URI
LogLevel
setCacheSize :: Maybe Word
setMaxDepth :: Maybe Word
setCheckFragments :: Bool
setExternal :: Bool
setFetchers :: Maybe Int
setLogLevel :: LogLevel
setUri :: URI
setCacheSize :: Maybe Word
setMaxDepth :: Maybe Word
setCheckFragments :: Bool
setExternal :: Bool
setFetchers :: Maybe Int
setLogLevel :: LogLevel
setUri :: URI
..}

getFlags :: IO Flags
getFlags :: IO Flags
getFlags = do
  [String]
args <- IO [String]
System.getArgs
  let result :: ParserResult Flags
result = [String] -> ParserResult Flags
runArgumentsParser [String]
args
  ParserResult Flags -> IO Flags
forall a. ParserResult a -> IO a
handleParseResult ParserResult Flags
result

runArgumentsParser :: [String] -> ParserResult Flags
runArgumentsParser :: [String] -> ParserResult Flags
runArgumentsParser = ParserPrefs -> ParserInfo Flags -> [String] -> ParserResult Flags
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
prefs_ ParserInfo Flags
flagsParser
  where
    prefs_ :: ParserPrefs
prefs_ =
      ParserPrefs
defaultPrefs
        { prefShowHelpOnError :: Bool
prefShowHelpOnError = Bool
True,
          prefShowHelpOnEmpty :: Bool
prefShowHelpOnEmpty = Bool
True
        }

flagsParser :: ParserInfo Flags
flagsParser :: ParserInfo Flags
flagsParser = Parser Flags -> InfoMod Flags -> ParserInfo Flags
forall a. Parser a -> InfoMod a -> ParserInfo a
info (Parser (Flags -> Flags)
forall a. Parser (a -> a)
helper Parser (Flags -> Flags) -> Parser Flags -> Parser Flags
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Flags
parseFlags) InfoMod Flags
forall a. InfoMod a
fullDesc

parseFlags :: Parser Flags
parseFlags :: Parser Flags
parseFlags =
  URI
-> Maybe LogLevel
-> Maybe Int
-> Maybe Bool
-> Maybe Bool
-> Maybe Word
-> Maybe Word
-> Flags
Flags
    (URI
 -> Maybe LogLevel
 -> Maybe Int
 -> Maybe Bool
 -> Maybe Bool
 -> Maybe Word
 -> Maybe Word
 -> Flags)
-> Parser URI
-> Parser
     (Maybe LogLevel
      -> Maybe Int
      -> Maybe Bool
      -> Maybe Bool
      -> Maybe Word
      -> Maybe Word
      -> Flags)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM URI -> Mod ArgumentFields URI -> Parser URI
forall a. ReadM a -> Mod ArgumentFields a -> Parser a
argument
      ((String -> Maybe URI) -> ReadM URI
forall a. (String -> Maybe a) -> ReadM a
maybeReader String -> Maybe URI
parseAbsoluteURI)
      ( [Mod ArgumentFields URI] -> Mod ArgumentFields URI
forall a. Monoid a => [a] -> a
mconcat
          [ String -> Mod ArgumentFields URI
forall (f :: * -> *) a. String -> Mod f a
help String
"The root uri. This must be an absolute URI. For example: https://example.com or http://localhost:8000",
            String -> Mod ArgumentFields URI
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"URI"
          ]
      )
      Parser
  (Maybe LogLevel
   -> Maybe Int
   -> Maybe Bool
   -> Maybe Bool
   -> Maybe Word
   -> Maybe Word
   -> Flags)
-> Parser (Maybe LogLevel)
-> Parser
     (Maybe Int
      -> Maybe Bool -> Maybe Bool -> Maybe Word -> Maybe Word -> Flags)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReadM (Maybe LogLevel)
-> Mod OptionFields (Maybe LogLevel) -> Parser (Maybe LogLevel)
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
        (LogLevel -> Maybe LogLevel
forall a. a -> Maybe a
Just (LogLevel -> Maybe LogLevel)
-> ReadM LogLevel -> ReadM (Maybe LogLevel)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Maybe LogLevel) -> ReadM LogLevel
forall a. (String -> Maybe a) -> ReadM a
maybeReader String -> Maybe LogLevel
parseLogLevel)
        ( [Mod OptionFields (Maybe LogLevel)]
-> Mod OptionFields (Maybe LogLevel)
forall a. Monoid a => [a] -> a
mconcat
            [ String -> Mod OptionFields (Maybe LogLevel)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"log-level",
              String -> Mod OptionFields (Maybe LogLevel)
forall (f :: * -> *) a. String -> Mod f a
help (String -> Mod OptionFields (Maybe LogLevel))
-> String -> Mod OptionFields (Maybe LogLevel)
forall a b. (a -> b) -> a -> b
$ String
"The log level, example values: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall a. Show a => a -> String
show ((LogLevel -> String) -> [LogLevel] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
5 (String -> String) -> (LogLevel -> String) -> LogLevel -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LogLevel -> String
forall a. Show a => a -> String
show) [LogLevel
LevelDebug, LogLevel
LevelInfo, LogLevel
LevelWarn, LogLevel
LevelError]),
              String -> Mod OptionFields (Maybe LogLevel)
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"LOG_LEVEL",
              Maybe LogLevel -> Mod OptionFields (Maybe LogLevel)
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value Maybe LogLevel
forall a. Maybe a
Nothing
            ]
        )
      Parser
  (Maybe Int
   -> Maybe Bool -> Maybe Bool -> Maybe Word -> Maybe Word -> Flags)
-> Parser (Maybe Int)
-> Parser
     (Maybe Bool -> Maybe Bool -> Maybe Word -> Maybe Word -> Flags)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Int -> Parser (Maybe Int)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
        ( ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
            ReadM Int
forall a. Read a => ReadM a
auto
            ( [Mod OptionFields Int] -> Mod OptionFields Int
forall a. Monoid a => [a] -> a
mconcat
                [ String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"fetchers",
                  String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help String
"The number of threads to fetch from. This application is usually not CPU bound so you can comfortably set this higher than the number of cores you have",
                  String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar String
"INT"
                ]
            )
        )
      Parser
  (Maybe Bool -> Maybe Bool -> Maybe Word -> Maybe Word -> Flags)
-> Parser (Maybe Bool)
-> Parser (Maybe Bool -> Maybe Word -> Maybe Word -> Flags)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool -> Parser (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
        ( Mod FlagFields Bool -> Parser Bool
switch
            ( [Mod FlagFields Bool] -> Mod FlagFields Bool
forall a. Monoid a => [a] -> a
mconcat
                [ String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"external",
                  String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Also check external links"
                ]
            )
        )
      Parser (Maybe Bool -> Maybe Word -> Maybe Word -> Flags)
-> Parser (Maybe Bool)
-> Parser (Maybe Word -> Maybe Word -> Flags)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Bool -> Parser (Maybe Bool)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
        ( Mod FlagFields Bool -> Parser Bool
switch
            ( [Mod FlagFields Bool] -> Mod FlagFields Bool
forall a. Monoid a => [a] -> a
mconcat
                [ String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"check-fragments",
                  String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help String
"Also check that the URIs' fragment occurs on the page"
                ]
            )
        )
      Parser (Maybe Word -> Maybe Word -> Flags)
-> Parser (Maybe Word) -> Parser (Maybe Word -> Flags)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word -> Parser (Maybe Word)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
        ( ReadM Word -> Mod OptionFields Word -> Parser Word
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
            ReadM Word
forall a. Read a => ReadM a
auto
            ( [Mod OptionFields Word] -> Mod OptionFields Word
forall a. Monoid a => [a] -> a
mconcat
                [ String -> Mod OptionFields Word
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"max-depth",
                  String -> Mod OptionFields Word
forall (f :: * -> *) a. String -> Mod f a
help String
"Stop looking after reaching this number of links from the root"
                ]
            )
        )
      Parser (Maybe Word -> Flags) -> Parser (Maybe Word) -> Parser Flags
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser Word -> Parser (Maybe Word)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional
        ( ReadM Word -> Mod OptionFields Word -> Parser Word
forall a. ReadM a -> Mod OptionFields a -> Parser a
option
            ReadM Word
forall a. Read a => ReadM a
auto
            ( [Mod OptionFields Word] -> Mod OptionFields Word
forall a. Monoid a => [a] -> a
mconcat
                [ String -> Mod OptionFields Word
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"cache-size",
                  String -> Mod OptionFields Word
forall (f :: * -> *) a. String -> Mod f a
help String
"Cache this many requests' fragments."
                ]
            )
        )

parseLogLevel :: String -> Maybe LogLevel
parseLogLevel :: String -> Maybe LogLevel
parseLogLevel String
s = String -> Maybe LogLevel
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe LogLevel) -> String -> Maybe LogLevel
forall a b. (a -> b) -> a -> b
$ String
"Level" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
s