module Twitch.Main where
import Control.Applicative
import Data.Monoid
import Options.Applicative
( Parser
, helper
, execParser
, value
, short
, progDesc
, option
, metavar
, long
, info
, help
, header
, fullDesc
, auto
, eitherReader
, switch
, flag
, ParserInfo
)
import Data.Default ( Default(..) )
import qualified System.FSNotify as FS
import Twitch.Path ( findAllDirs )
import qualified Twitch.InternalRule as IR
import System.IO
( IOMode(AppendMode)
, Handle
, hPrint
, openFile
, hClose
)
import Data.Foldable ( for_ )
import Twitch.Run ( runWithConfig )
import Twitch.Internal ( Dep )
import System.Directory ( getCurrentDirectory )
import Data.Maybe ( fromMaybe )
import System.FilePath
( FilePath
, (</>)
, isRelative
, isValid
)
import Control.Monad ( liftM )
import Prelude hiding (log, FilePath)
concatMapM :: Monad m => (a -> m [b]) -> [a] -> m [b]
concatMapM f = liftM concat . mapM f
data LoggerType
= LogToStdout
| LogToFile
| NoLogger
deriving (Eq, Show, Read, Ord)
toLogger :: FilePath
-> LoggerType
-> IO (IR.Issue -> IO (), Maybe Handle)
toLogger filePath lt = case lt of
LogToStdout -> return (print, Nothing)
LogToFile -> do
handle <- openFile filePath AppendMode
return (hPrint handle, Just handle)
NoLogger -> return (const $ return (), Nothing)
data Options = Options
{ log :: LoggerType
, logFile :: Maybe FilePath
, root :: Maybe FilePath
, recurseThroughDirectories :: Bool
, debounce :: DebounceType
, debounceAmount :: Double
, pollInterval :: Int
, usePolling :: Bool
}
data DebounceType
= DebounceDefault
| Debounce
| NoDebounce
deriving (Eq, Show, Read, Ord)
instance Default Options where
def = Options
{ log = NoLogger
, logFile = Nothing
, root = Nothing
, recurseThroughDirectories = True
, debounce = DebounceDefault
, debounceAmount = 0
, pollInterval = 10^(6 :: Int)
, usePolling = False
}
dropDoubleQuotes :: String -> String
dropDoubleQuotes [] = []
dropDoubleQuotes (x : xs)
| x == '\"' = xs
| otherwise = x : xs
stripDoubleQuotes :: String -> String
stripDoubleQuotes = dropDoubleQuotes . reverse . dropDoubleQuotes . reverse
readFilePath :: String -> Either String FilePath
readFilePath xs =
let filePath = stripDoubleQuotes xs
in if isValid filePath then
Right filePath
else
Left $ "invalid filePath " ++ xs
pOptions :: Parser Options
pOptions
= Options
<$> option auto
( long "log"
<> short 'l'
<> metavar "LOG_TYPE"
<> help "Type of logger. Valid options are LogToStdout | LogToFile | NoLogger"
<> value (log def)
)
<*> option (Just <$> eitherReader readFilePath)
( long "log-file"
<> short 'f'
<> metavar "LOG_FILE"
<> help "Log file"
<> value (logFile def)
)
<*> option (Just <$> eitherReader readFilePath)
( long "root"
<> short 'r'
<> metavar "ROOT"
<> help "Root directory to watch"
<> value (root def)
)
<*> flag True False
( long "no-recurse"
<> short 'n'
<> help "flag to turn off recursing"
)
<*> option auto
( long "debounce"
<> short 'b'
<> metavar "DEBOUNCE"
<> help "Type of debouncing. Valid choices are DebounceDefault | Debounce | NoDebounce"
<> value (debounce def)
)
<*> option auto
( long "debounce-amount"
<> short 'a'
<> metavar "DEBOUNCE_AMOUNT"
<> help "Target for the greeting"
<> value (debounceAmount def)
)
<*> option auto
( long "poll-interval"
<> short 'i'
<> metavar "POLL_INTERVAL"
<> help "Poll interval if polling is used"
<> value (pollInterval def)
)
<*> switch
( long "should-poll"
<> short 'p'
<> help "Whether to use polling or not. Off by default"
)
toDB :: Real a => a -> DebounceType -> FS.Debounce
toDB amount dbtype = case dbtype of
DebounceDefault -> FS.DebounceDefault
Debounce -> FS.Debounce $ fromRational $ toRational amount
NoDebounce -> FS.NoDebounce
makeAbsolute :: FilePath -> FilePath -> FilePath
makeAbsolute currentDir path =
if isRelative path then
currentDir </> path
else
path
optionsToConfig :: Options -> IO (FilePath, IR.Config, Maybe Handle)
optionsToConfig Options {..} = do
currentDir <- getCurrentDirectory
let root' = makeAbsolute currentDir $ fromMaybe currentDir root
(logger, mhandle) <- toLogger (fromMaybe "log.txt" logFile) log
dirsToWatch <- if recurseThroughDirectories then
(root' :) <$> findAllDirs root'
else
return [root']
let watchConfig = FS.WatchConfig
{ FS.confDebounce = toDB debounceAmount debounce
, FS.confPollInterval = pollInterval
, FS.confUsePolling = usePolling
}
let config = IR.Config
{ logger = logger
, dirs = dirsToWatch
, watchConfig = watchConfig
}
return (root', config, mhandle)
opts :: ParserInfo Options
opts = info (helper <*> pOptions)
( fullDesc
<> progDesc "twitch"
<> header "a file watcher"
)
defaultMain :: Dep -> IO ()
defaultMain dep = do
options <- execParser opts
defaultMainWithOptions options dep
defaultMainWithOptions :: Options -> Dep -> IO ()
defaultMainWithOptions options dep = do
(root, config, mhandle) <- optionsToConfig options
manager <- runWithConfig root config dep
putStrLn "Type anything to quit"
_ <- getLine
for_ mhandle hClose
FS.stopManager manager