diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -104,6 +104,10 @@ If you're using brök as part of a script then you should [redirect `stdout`](#basic-usage). +### Colour Output + +By default the output uses bash colour codes. You can turn this off using the `--no-color` setting. + ### Git Pre-Commit Hook diff --git a/brok.cabal b/brok.cabal --- a/brok.cabal +++ b/brok.cabal @@ -1,6 +1,6 @@ cabal-version: 1.12 name: brok -version: 0.1.7.0 +version: 0.2.0.0 license: BSD3 license-file: LICENSE copyright: 2019 Small Hadron Collider @@ -34,10 +34,12 @@ Brok.Parser.DB Brok.Parser.Links Brok.Parser.Options + Brok.Types.App Brok.Types.Config Brok.Types.Link Brok.Types.Next Brok.Types.Result + Brok.Types.URL hs-source-dirs: src other-modules: Paths_brok diff --git a/src/Brok.hs b/src/Brok.hs --- a/src/Brok.hs +++ b/src/Brok.hs @@ -9,30 +9,32 @@ import ClassyPrelude import Data.FileEmbed (embedFile) +import Data.Text.IO (hPutStrLn) import System.Exit (exitFailure, exitSuccess) -import Brok.IO.CLI (errorMessage, header, replace) +import Brok.IO.CLI (header, replace) import Brok.IO.DB (getCached, setCached) import Brok.IO.Document (readContent) import Brok.IO.Http (check) import Brok.IO.Output (output) import Brok.Options (parse) import Brok.Parser.Links (links) -import qualified Brok.Types.Config as C (Config, cache, files, ignore, interval, onlyFailures) +import Brok.Types.App (App) +import qualified Brok.Types.Config as C (files, ignore, interval, onlyFailures) import Brok.Types.Link (getURL, isSuccess) import Brok.Types.Next (Next (..)) import Brok.Types.Result (cachedLinks, ignoredLinks, justLinks, linkIOMap, parseLinks, pathToResult) -go :: C.Config -> IO () -go config +go :: App () +go = do + config <- ask -- read files - = do content <- traverse (readContent . pathToResult) (C.files config) -- find links in each file let parsed = parseLinks links <$> content -- check cached successes - cached <- getCached (C.cache config) + cached <- getCached let uncached = cachedLinks cached . ignoredLinks (C.ignore config) <$> parsed -- check links in each file header "Checking URLs" @@ -44,11 +46,12 @@ header "Results" anyErrors <- output (C.onlyFailures config) checked -- cache successes - setCached (C.cache config) $ getURL <$> filter isSuccess (concat (justLinks <$> checked)) + setCached $ getURL <$> filter isSuccess (concat (justLinks <$> checked)) -- exit with appropriate status code - if anyErrors - then void exitFailure - else void exitSuccess + lift $ + if anyErrors + then void exitFailure + else void exitSuccess showHelp :: IO () showHelp = putStr $ decodeUtf8 $(embedFile "template/usage.txt") @@ -58,9 +61,9 @@ brok = do config <- parse <$> getArgs case config of - Right (Continue cnf) -> go cnf + Right (Continue cnf) -> runReaderT go cnf Right Help -> showHelp Left _ -> do - errorMessage "Invalid format" + hPutStrLn stderr "Invalid format" showHelp void exitFailure diff --git a/src/Brok/IO/CLI.hs b/src/Brok/IO/CLI.hs --- a/src/Brok/IO/CLI.hs +++ b/src/Brok/IO/CLI.hs @@ -5,67 +5,77 @@ import ClassyPrelude +import Brok.Types.App (App) +import Brok.Types.Config (noColor) import Data.Text.IO (hPutStr, hPutStrLn) import System.Console.ANSI (Color (Blue, Green, Magenta, Red, Yellow), ColorIntensity (Dull), ConsoleLayer (Foreground), SGR (Reset, SetColor), hClearLine, hCursorUpLine, hSetSGR) -message :: Text -> IO () +setSGR :: Handle -> [SGR] -> App () +setSGR hndl settings = do + colourize <- not <$> asks noColor + when colourize $ lift (hSetSGR hndl settings) + +blank :: App () +blank = putStrLn "" + +message :: Text -> App () message msg = do - hSetSGR stdout [SetColor Foreground Dull Blue] - hPutStrLn stdout msg - hSetSGR stdout [Reset] + setSGR stdout [SetColor Foreground Dull Blue] + putStrLn msg + setSGR stdout [Reset] -mehssage :: Text -> IO () +mehssage :: Text -> App () mehssage msg = do - hSetSGR stdout [SetColor Foreground Dull Yellow] - hPutStrLn stdout msg - hSetSGR stdout [Reset] + setSGR stdout [SetColor Foreground Dull Yellow] + putStrLn msg + setSGR stdout [Reset] -header :: Text -> IO () +header :: Text -> App () header msg = do - hSetSGR stdout [SetColor Foreground Dull Magenta] - hPutStrLn stdout $ "*** " ++ msg ++ " ***" - hSetSGR stdout [Reset] + setSGR stdout [SetColor Foreground Dull Magenta] + putStrLn $ "*** " ++ msg ++ " ***" + setSGR stdout [Reset] -successMessage :: Text -> IO () +successMessage :: Text -> App () successMessage msg = do - hSetSGR stdout [SetColor Foreground Dull Green] - hPutStrLn stdout msg - hSetSGR stdout [Reset] + setSGR stdout [SetColor Foreground Dull Green] + putStrLn msg + setSGR stdout [Reset] -errorMessage :: Text -> IO () +errorMessage :: Text -> App () errorMessage msg = do - hSetSGR stderr [SetColor Foreground Dull Red] - hPutStrLn stderr msg - hSetSGR stderr [Reset] + setSGR stderr [SetColor Foreground Dull Red] + lift $ hPutStrLn stderr msg + setSGR stderr [Reset] -errors :: Text -> [Text] -> IO () +errors :: Text -> [Text] -> App () errors _ [] = return () errors msg missing = do errorMessage msg - hPutStrLn stderr "" + lift $ hPutStrLn stderr "" errorMessage (unlines $ ("- " ++) <$> missing) -split :: Handle -> Color -> Text -> Text -> IO () +split :: Handle -> Color -> Text -> Text -> App () split hdl color left right = do - hSetSGR hdl [SetColor Foreground Dull color] - hPutStr hdl left - hSetSGR hdl [Reset] - hPutStr hdl $ ": " ++ right - hPutStrLn hdl "" + setSGR hdl [SetColor Foreground Dull color] + lift $ hPutStr hdl left + setSGR hdl [Reset] + lift $ hPutStr hdl $ ": " ++ right + lift $ hPutStrLn hdl "" -splitErr :: Text -> Text -> IO () +splitErr :: Text -> Text -> App () splitErr = split stderr Red -splitOut :: Text -> Text -> IO () +splitOut :: Text -> Text -> App () splitOut = split stdout Green -splitMeh :: Text -> Text -> IO () +splitMeh :: Text -> Text -> App () splitMeh = split stdout Yellow -replace :: Text -> IO () +replace :: Text -> App () replace msg = do - hCursorUpLine stdout 1 - hClearLine stdout - hPutStrLn stdout msg + lift $ hCursorUpLine stdout 1 + lift $ hClearLine stdout + putStrLn msg diff --git a/src/Brok/IO/DB.hs b/src/Brok/IO/DB.hs --- a/src/Brok/IO/DB.hs +++ b/src/Brok/IO/DB.hs @@ -12,48 +12,56 @@ import Data.Time.Clock.POSIX (getPOSIXTime) import System.Directory (doesFileExist) -import Brok.Parser.DB (db) -import Brok.Types.Link (URL) +import Brok.Parser.DB (db) +import Brok.Types.App (App) +import Brok.Types.Config (cache) +import Brok.Types.URL (URL) path :: String path = ".brokdb" -- time stuff -removeOld :: Integer -> [(URL, Integer)] -> IO [(URL, Integer)] +removeOld :: Integer -> [(URL, Integer)] -> App [(URL, Integer)] removeOld age cached = do - timestamp <- getPOSIXTime + timestamp <- lift getPOSIXTime return $ filter ((\val -> timestamp - val < fromInteger age) . fromInteger . snd) cached -stamp :: URL -> IO (URL, Integer) +stamp :: URL -> App (URL, Integer) stamp lnk = do - timestamp <- round <$> getPOSIXTime + timestamp <- lift $ round <$> getPOSIXTime return (lnk, timestamp) -- write db linkToText :: (URL, Integer) -> Text linkToText (lnk, int) = concat [lnk, " ", tshow int] -write :: [(URL, Integer)] -> IO () +write :: [(URL, Integer)] -> App () write links = writeFile path . encodeUtf8 . unlines $ linkToText <$> links -setCached :: Maybe Integer -> [URL] -> IO () -setCached Nothing _ = return () -setCached (Just age) links = do - current <- load age - stamped <- traverse stamp links - write $ current ++ stamped +setCached :: [URL] -> App () +setCached links = do + mAge <- asks cache + case mAge of + Nothing -> pure () + Just age -> do + current <- load age + stamped <- traverse stamp links + write $ current ++ stamped -- read db -read :: Integer -> FilePath -> IO [(URL, Integer)] +read :: Integer -> FilePath -> App [(URL, Integer)] read age filepath = removeOld age =<< fromRight [] . db . decodeUtf8 <$> readFile filepath -load :: Integer -> IO [(URL, Integer)] +load :: Integer -> App [(URL, Integer)] load age = do - exists <- doesFileExist path + exists <- lift $ doesFileExist path if exists then read age path else return [] -getCached :: Maybe Integer -> IO [URL] -getCached Nothing = return [] -getCached (Just age) = (fst <$>) <$> load age +getCached :: App [URL] +getCached = do + mAge <- asks cache + case mAge of + Nothing -> pure [] + (Just age) -> (fst <$>) <$> load age diff --git a/src/Brok/IO/Document.hs b/src/Brok/IO/Document.hs --- a/src/Brok/IO/Document.hs +++ b/src/Brok/IO/Document.hs @@ -9,13 +9,14 @@ import System.Directory (doesFileExist) +import Brok.Types.App (App) import Brok.Types.Result -readContent :: Result -> IO Result +readContent :: Result -> App Result readContent result = do let path = getPath result let filepath = unpack path - exists <- doesFileExist filepath + exists <- lift $ doesFileExist filepath if exists then setContent result . decodeUtf8 <$> readFile filepath else return $ notFound result diff --git a/src/Brok/IO/Http.hs b/src/Brok/IO/Http.hs --- a/src/Brok/IO/Http.hs +++ b/src/Brok/IO/Http.hs @@ -12,27 +12,29 @@ getResponseStatusCode, httpNoBody, parseRequest, setRequestMethod) import Brok.IO.CLI (replace) +import Brok.Types.App (App) import Brok.Types.Link +import Brok.Types.URL (URL) type StatusCode = Either HttpException Int setHeaders :: Request -> Request setHeaders = addRequestHeader "User-Agent" "smallhadroncollider/brok" -makeRequest :: Integer -> ByteString -> URL -> IO StatusCode +makeRequest :: Integer -> ByteString -> URL -> App StatusCode makeRequest delay method url = - try $ do + lift . try $ do request <- setHeaders . setRequestMethod method <$> parseRequest (unpack url) threadDelay (fromIntegral delay * 1000) -- wait for a little while getResponseStatusCode <$> httpNoBody request -tryWithGet :: Integer -> URL -> StatusCode -> IO StatusCode +tryWithGet :: Integer -> URL -> StatusCode -> App StatusCode tryWithGet delay url (Right code) | code >= 400 = makeRequest delay "GET" url | otherwise = return (Right code) tryWithGet delay url (Left _) = makeRequest delay "GET" url -fetch :: Integer -> URL -> IO StatusCode +fetch :: Integer -> URL -> App StatusCode fetch delay url = replace ("Fetching: " ++ url) >> makeRequest delay "HEAD" url >>= tryWithGet delay url @@ -43,5 +45,5 @@ codeToResponse lnk (Left (HttpExceptionRequest _ _)) = failure lnk codeToResponse lnk (Left (InvalidUrlException _ _)) = invalid lnk -check :: Integer -> Link -> IO Link +check :: Integer -> Link -> App Link check delay lnk = codeToResponse lnk <$> fetch delay (getURL lnk) diff --git a/src/Brok/IO/Output.hs b/src/Brok/IO/Output.hs --- a/src/Brok/IO/Output.hs +++ b/src/Brok/IO/Output.hs @@ -8,11 +8,12 @@ import ClassyPrelude import Brok.IO.CLI +import Brok.Types.App (App) import Brok.Types.Link import Brok.Types.Result -- output -linkOutput :: Link -> IO () +linkOutput :: Link -> App () linkOutput (Link url BareLink) = splitErr "- Failed (unknown)" url linkOutput (Link url Ignored) = mehssage $ "- Ignored: " ++ url linkOutput (Link url Cached) = splitOut "- OK (cached)" url @@ -30,7 +31,7 @@ outputPath :: TFilePath -> Text outputPath path = concat ["\n", "[", path, "]"] -outputMap :: Bool -> Result -> IO Bool +outputMap :: Bool -> Result -> App Bool outputMap _ (Result path NotFound) = do errorMessage $ outputPath path errorMessage " - File not found" @@ -59,7 +60,7 @@ return anyErrs outputMap _ _ = return False -output :: Bool -> [Result] -> IO Bool +output :: Bool -> [Result] -> App Bool output onlyFailures results = do errs <- traverse (outputMap onlyFailures) results let anyErrs = foldl' (||) False errs diff --git a/src/Brok/Parser/DB.hs b/src/Brok/Parser/DB.hs --- a/src/Brok/Parser/DB.hs +++ b/src/Brok/Parser/DB.hs @@ -10,7 +10,7 @@ import Data.Attoparsec.Text import Brok.Parser.Links (url) -import Brok.Types.Link (URL) +import Brok.Types.URL (URL) line :: Parser (URL, Integer) line = (,) <$> (url <* char ' ') <*> (decimal <* endOfLine) diff --git a/src/Brok/Parser/Links.hs b/src/Brok/Parser/Links.hs --- a/src/Brok/Parser/Links.hs +++ b/src/Brok/Parser/Links.hs @@ -12,7 +12,7 @@ import Data.List (nub) import Brok.Parser.Attoparsec -import Brok.Types.Link (URL) +import Brok.Types.URL (URL) type Token = Maybe URL diff --git a/src/Brok/Parser/Options.hs b/src/Brok/Parser/Options.hs --- a/src/Brok/Parser/Options.hs +++ b/src/Brok/Parser/Options.hs @@ -19,11 +19,15 @@ | Interval Integer | Ignore [Text] | Files [Text] + | NoColor | OnlyFailures onlyFailuresP :: Parser Option onlyFailuresP = lexeme $ string "--only-failures" $> OnlyFailures +noColorP :: Parser Option +noColorP = lexeme $ string "--no-color" $> NoColor + noCacheP :: Parser Option noCacheP = lexeme $ string "--no-cache" $> Cache Nothing @@ -49,11 +53,12 @@ convert dc (Ignore i) = dc {ignore = i} convert dc (Interval i) = dc {interval = i} convert dc (Files i) = dc {files = i} + convert dc NoColor = dc {noColor = True} convert dc OnlyFailures = dc {onlyFailures = True} arguments :: Parser Config arguments = do - opts <- many' (noCacheP <|> cacheP <|> intervalP <|> ignoreP <|> onlyFailuresP) + opts <- many' (noCacheP <|> cacheP <|> intervalP <|> ignoreP <|> noColorP <|> onlyFailuresP) fls <- many1 fileP return . optsToConfig $ opts ++ [Files fls] diff --git a/src/Brok/Types/App.hs b/src/Brok/Types/App.hs new file mode 100644 --- /dev/null +++ b/src/Brok/Types/App.hs @@ -0,0 +1,9 @@ +module Brok.Types.App + ( App + ) where + +import ClassyPrelude + +import Brok.Types.Config (Config) + +type App a = ReaderT Config IO a diff --git a/src/Brok/Types/Config.hs b/src/Brok/Types/Config.hs --- a/src/Brok/Types/Config.hs +++ b/src/Brok/Types/Config.hs @@ -4,16 +4,24 @@ import ClassyPrelude -import Brok.Types.Link (URL) +import Brok.Types.URL (URL) data Config = Config { cache :: Maybe Integer , ignore :: [URL] , interval :: Integer , files :: [Text] + , noColor :: Bool , onlyFailures :: Bool } deriving (Show, Eq) defaultConfig :: Config defaultConfig = - Config {cache = Just 84600, ignore = [], interval = 100, files = [], onlyFailures = False} + Config + { cache = Just 84600 + , ignore = [] + , interval = 100 + , files = [] + , noColor = False + , onlyFailures = False + } diff --git a/src/Brok/Types/Link.hs b/src/Brok/Types/Link.hs --- a/src/Brok/Types/Link.hs +++ b/src/Brok/Types/Link.hs @@ -4,7 +4,8 @@ import ClassyPrelude -type URL = Text +import Brok.Types.App (App) +import Brok.Types.URL (URL) data LinkType = BareLink @@ -60,6 +61,6 @@ isSuccess (Link _ (Working _)) = True isSuccess _ = False -lmap :: (Link -> IO Link) -> Link -> IO Link +lmap :: (Link -> App Link) -> Link -> App Link lmap fn (Link url BareLink) = fn (Link url BareLink) lmap _ lnk = return lnk diff --git a/src/Brok/Types/Result.hs b/src/Brok/Types/Result.hs --- a/src/Brok/Types/Result.hs +++ b/src/Brok/Types/Result.hs @@ -4,7 +4,9 @@ import ClassyPrelude +import Brok.Types.App (App) import Brok.Types.Link +import Brok.Types.URL (URL) type TFilePath = Text @@ -54,9 +56,9 @@ ignoredLinks :: [URL] -> Result -> Result ignoredLinks = findLinks ignoredLink -linkIOMap :: (Link -> IO Link) -> Result -> IO Result +linkIOMap :: (Link -> App Link) -> Result -> App Result linkIOMap fn (Result path (Links links)) = Result path . Links <$> traverse (lmap fn) links -linkIOMap _ result = return result +linkIOMap _ result = pure result justLinks :: Result -> [Link] justLinks (Result _ (Links links)) = links diff --git a/src/Brok/Types/URL.hs b/src/Brok/Types/URL.hs new file mode 100644 --- /dev/null +++ b/src/Brok/Types/URL.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module Brok.Types.URL where + +import ClassyPrelude + +type URL = Text diff --git a/template/usage.txt b/template/usage.txt --- a/template/usage.txt +++ b/template/usage.txt @@ -2,6 +2,7 @@ Options: +--no-color Don't use color codes in the output --cache SECONDS The number of seconds to cache successful results for (default: 86400) --interval MILLISECONDS The number of milliseconds between each request (default: 100) --ignore URLS A list of URL prefixes to ignore diff --git a/test/IO/HttpTest.hs b/test/IO/HttpTest.hs --- a/test/IO/HttpTest.hs +++ b/test/IO/HttpTest.hs @@ -7,18 +7,21 @@ import Test.Tasty -import Brok.IO.Http (check) -import Brok.Types.Link (Link (Link), LinkType (..), urlToLink) +import Brok.IO.Http (check) +import Brok.Types.Config (defaultConfig) +import Brok.Types.Link (Link (Link), LinkType (..), urlToLink) import Test.Tasty.HUnit +testLink :: Text -> IO Link +testLink link = runReaderT (check 0 (urlToLink link)) defaultConfig + test_http :: TestTree test_http = testGroup "Brok.IO.Http" [ testCase "Medium (409 with HEAD)" $ do result <- - check 0 $ - urlToLink + testLink "https://medium.freecodecamp.org/understanding-redux-the-worlds-easiest-guide-to-beginning-redux-c695f45546f6" assertEqual "Returns a 200" @@ -28,8 +31,7 @@ result , testCase "TutsPlus (Requires User-Agent Header)" $ do result <- - check 0 $ - urlToLink + testLink "https://code.tutsplus.com/tutorials/stateful-vs-stateless-functional-components-in-react--cms-29541" assertEqual "Returns a 200" @@ -38,15 +40,13 @@ (Working 200)) result , testCase "Non-existent site" $ do - result <- check 0 $ urlToLink "http://askdjfhaksjdhfkajsdfh.com" + result <- testLink "http://askdjfhaksjdhfkajsdfh.com" assertEqual "Returns a 200" (Link "http://askdjfhaksjdhfkajsdfh.com" ConnectionFailure) result , testCase "Invalid URL" $ do - result <- - check 0 $ - urlToLink "http://user:password@securesite.com/secret-file.json"" + result <- testLink "http://user:password@securesite.com/secret-file.json"" assertEqual "Returns a 200" (Link "http://user:password@securesite.com/secret-file.json"" InvalidURL) diff --git a/test/OptionsTest.hs b/test/OptionsTest.hs --- a/test/OptionsTest.hs +++ b/test/OptionsTest.hs @@ -40,6 +40,12 @@ (Right (Continue (defaultConfig {onlyFailures = True, files = ["blah.md"]}))) (parse ["--only-failures", "blah.md"])) , testCase + "single file with no-colors option" + (assertEqual + "gives back files" + (Right (Continue (defaultConfig {noColor = True, files = ["blah.md"]}))) + (parse ["--no-color", "blah.md"])) + , testCase "single file with no-cache option" (assertEqual "gives back files" diff --git a/test/Parser/LinksTest.hs b/test/Parser/LinksTest.hs --- a/test/Parser/LinksTest.hs +++ b/test/Parser/LinksTest.hs @@ -166,13 +166,25 @@ (links tex)) ] , testGroup - "just protocol" + "placeholder URLs" [ testCase "https://" (assertEqual "Gives back empty list" (Right []) (links "https://")) , testCase "http://" (assertEqual "Gives back empty list" (Right []) (links "http://")) + , testCase + "http://*" + (assertEqual "Gives back empty list" (Right []) (links "http://*")) + , testCase + "https://*" + (assertEqual "Gives back empty list" (Right []) (links "https://*")) + , testCase + "https://.github.io//" + (assertEqual + "Gives back empty list" + (Right []) + (links "https://.github.io//")) ] , testCase "nothing" (assertEqual "Gives back empty list" (Right []) (links "")) ]