brok 0.1.7.0 → 0.2.0.0

raw patch · 20 files changed

+179/−97 lines, 20 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• README.md +4/−0
• brok.cabal +3/−1
• src/Brok.hs +15/−12
• src/Brok/IO/CLI.hs +45/−35
• src/Brok/IO/DB.hs +27/−19
• src/Brok/IO/Document.hs +3/−2
• src/Brok/IO/Http.hs +7/−5
• src/Brok/IO/Output.hs +4/−3
• src/Brok/Parser/DB.hs +1/−1
• src/Brok/Parser/Links.hs +1/−1
• src/Brok/Parser/Options.hs +6/−1
• src/Brok/Types/App.hs +9/−0
• src/Brok/Types/Config.hs +10/−2
• src/Brok/Types/Link.hs +3/−2
• src/Brok/Types/Result.hs +4/−2
• src/Brok/Types/URL.hs +7/−0
• template/usage.txt +1/−0
• test/IO/HttpTest.hs +10/−10
• test/OptionsTest.hs +6/−0
• test/Parser/LinksTest.hs +13/−1

@@ -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 

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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

@@ -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)

@@ -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 

@@ -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] 

@@ -0,0 +1,9 @@+module Brok.Types.App+    ( App+    ) where++import ClassyPrelude++import Brok.Types.Config (Config)++type App a = ReaderT Config IO a

@@ -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+    }

@@ -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

@@ -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

@@ -0,0 +1,7 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brok.Types.URL where++import ClassyPrelude++type URL = Text

@@ -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

@@ -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&#64;securesite.com/secret-file.json&quot;"+              result <- testLink "http://user:password&#64;securesite.com/secret-file.json&quot;"               assertEqual                   "Returns a 200"                   (Link "http://user:password&#64;securesite.com/secret-file.json&quot;" InvalidURL)

@@ -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"

@@ -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://<username>.github.io/<repo>/"+                    (assertEqual+                         "Gives back empty list"+                         (Right [])+                         (links "https://<username>.github.io/<repo>/"))               ]         , testCase "nothing" (assertEqual "Gives back empty list" (Right []) (links ""))         ]