packages feed

brok (empty) → 0.1.2.0

raw patch · 24 files changed

+1274/−0 lines, 24 filesdep +ansi-terminaldep +attoparsecdep +base

Dependencies added: ansi-terminal, attoparsec, base, brok, classy-prelude, directory, file-embed, http-client, http-conduit, tasty, tasty-discover, tasty-expected-failure, tasty-hunit, text, time

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Small Hadron Collider / Mark Wales (c) 2019++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Small Hadron Collider / Mark Wales nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,76 @@+# brök++Find broken links in text documents++![Demo](https://files.smallhadroncollider.com/brok-0.1.gif)++Similar idea to [awesome_bot](https://github.com/dkhamsing/awesome_bot), but with different output options.++Currently only supports `http://` and `https://` prefixed URLs++## Install++[Binaries for Mac and Linux are available](https://github.com/smallhadroncollider/brok/releases). Add the binary to a directory in your path (such as `/usr/local/bin`).++### Building++**Requirements**: [Stack](https://docs.haskellstack.org/en/stable/README/)++The following command will build brök and then install it in `~/.local/bin`:++```bash+stack build && stack install+```++## Usage++### Basic Usage++Check all links in a single text file:++```bash+brok test.md+```++Or in multiple files:++```bash+brok test.md links.tex+```++If you're using this as part of a test suite, you probably only need the errors:++```+brok text.md links.tex > /dev/null+```++### Options++#### Cache++By default brök will cache successes for a day. It will always recheck errors.++If you want to adjust the cache length, you can enter the number of seconds after which the cache invalidates:++```bash+# cache for a week+brok --cache 604800 test.md links.tex+```++#### Ignore URLs++You can tell brök to ignore URLs with specified prefixes:++```bash+# ignore facebook and amazon URLS+brok --ignore "http://facebook.com" "http://amazon.com" test.md links.tex+```++#### Interval++By default brök waits for 100ms between URL checks. You can change the delay:++```bash+# wait for 1 second between checks+brok --interval 1000 test.md links.tex+```
+ app/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import Brok          (brok)+import ClassyPrelude (IO)++main :: IO ()+main = brok
+ brok.cabal view
@@ -0,0 +1,92 @@+cabal-version: 1.12+name: brok+version: 0.1.2.0+license: BSD3+license-file: LICENSE+copyright: 2019 Small Hadron Collider+maintainer: mark@smallhadroncollider.com+author: Small Hadron Collider+homepage: https://github.com/smallhadroncollider/brok#readme+bug-reports: https://github.com/smallhadroncollider/brok/issues+synopsis: Finds broken links in text files+description:+    Please see the README on GitHub at <https://github.com/smallhadroncollider/brok#readme>+category: Command Line Tools+build-type: Simple+extra-source-files:+    README.md++source-repository head+    type: git+    location: https://github.com/smallhadroncollider/brok++library+    exposed-modules:+        Brok+        Brok.IO.CLI+        Brok.IO.DB+        Brok.IO.Document+        Brok.IO.Http+        Brok.IO.Output+        Brok.Options+        Brok.Parser.Attoparsec+        Brok.Parser.DB+        Brok.Parser.Links+        Brok.Parser.Options+        Brok.Types.Config+        Brok.Types.Link+        Brok.Types.Next+        Brok.Types.Result+    hs-source-dirs: src+    other-modules:+        Paths_brok+    default-language: Haskell2010+    default-extensions: OverloadedStrings NoImplicitPrelude+    build-depends:+        ansi-terminal >=0.8.2 && <0.9,+        attoparsec >=0.13.2.2 && <0.14,+        base >=4.7 && <5,+        classy-prelude >=1.5.0 && <1.6,+        directory >=1.3.3.0 && <1.4,+        file-embed >=0.0.11 && <0.1,+        http-client >=0.5.14 && <0.6,+        http-conduit >=2.3.5 && <2.4,+        text >=1.2.3.1 && <1.3,+        time >=1.8.0.2 && <1.9++executable brok+    main-is: Main.hs+    hs-source-dirs: app+    other-modules:+        Paths_brok+    default-language: Haskell2010+    default-extensions: OverloadedStrings NoImplicitPrelude+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base >=4.7 && <5,+        brok -any,+        classy-prelude >=1.5.0 && <1.6,+        file-embed >=0.0.11 && <0.1++test-suite brok-test+    type: exitcode-stdio-1.0+    main-is: Spec.hs+    hs-source-dirs: test+    other-modules:+        IO.HttpTest+        OptionsTest+        Parser.DBTest+        Parser.LinksTest+        Paths_brok+    default-language: Haskell2010+    default-extensions: OverloadedStrings NoImplicitPrelude+    ghc-options: -threaded -rtsopts -with-rtsopts=-N+    build-depends:+        base >=4.7 && <5,+        brok -any,+        classy-prelude >=1.5.0 && <1.6,+        file-embed >=0.0.11 && <0.1,+        tasty ==1.2.*,+        tasty-discover >=4.2.1 && <4.3,+        tasty-expected-failure >=0.11.1.1 && <0.12,+        tasty-hunit >=0.10.0.1 && <0.11
+ src/Brok.hs view
@@ -0,0 +1,66 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Brok+    ( brok+    ) where++import ClassyPrelude++import Data.FileEmbed (embedFile)+import System.Exit    (exitFailure, exitSuccess)++import           Brok.IO.CLI       (errorMessage, 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)+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+    -- read files+ = do+    content <- sequence (readContent . pathToResult <$> C.files config)+    -- find links in each file+    let parsed = parseLinks links <$> content+    -- check cached successes+    cached <- getCached (C.cache config)+    let uncached = cachedLinks cached . ignoredLinks (C.ignore config) <$> parsed+    -- check links in each file+    header "Checking URLs"+    putStrLn ""+    checked <- sequence (linkIOMap (check (C.interval config)) <$> uncached)+    replace "Fetching complete"+    -- display results+    putStrLn ""+    header "Results"+    anyErrors <- sequence $ output <$> checked+    -- cache successes+    setCached (C.cache config) $ getURL <$> filter isSuccess (concat (justLinks <$> checked))+    -- exit with appropriate status code+    if foldl' (||) False anyErrors+        then void exitFailure+        else void exitSuccess++showHelp :: IO ()+showHelp = putStr $ decodeUtf8 $(embedFile "template/usage.txt")++-- entry point+brok :: IO ()+brok = do+    config <- parse <$> getArgs+    case config of+        Right (Continue cnf) -> go cnf+        Right Help -> showHelp+        Left _ -> do+            errorMessage "Invalid format"+            showHelp+            void exitFailure
+ src/Brok/IO/CLI.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.IO.CLI where++import ClassyPrelude++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 ()+message msg = do+    hSetSGR stdout [SetColor Foreground Dull Blue]+    hPutStrLn stdout msg+    hSetSGR stdout [Reset]++mehssage :: Text -> IO ()+mehssage msg = do+    hSetSGR stdout [SetColor Foreground Dull Yellow]+    hPutStrLn stdout msg+    hSetSGR stdout [Reset]++header :: Text -> IO ()+header msg = do+    hSetSGR stdout [SetColor Foreground Dull Magenta]+    hPutStrLn stdout $ "*** " ++ msg ++ " ***"+    hSetSGR stdout [Reset]++errorMessage :: Text -> IO ()+errorMessage msg = do+    hSetSGR stderr [SetColor Foreground Dull Red]+    hPutStrLn stderr msg+    hSetSGR stderr [Reset]++errors :: Text -> [Text] -> IO ()+errors _ [] = return ()+errors msg missing = do+    errorMessage msg+    hPutStrLn stderr ""+    errorMessage (unlines $ ("- " ++) <$> missing)++split :: Handle -> Color -> Text -> Text -> IO ()+split hdl color left right = do+    hSetSGR hdl [SetColor Foreground Dull color]+    hPutStr hdl left+    hSetSGR hdl [Reset]+    hPutStr hdl $ ": " ++ right+    hPutStrLn hdl ""++splitErr :: Text -> Text -> IO ()+splitErr = split stderr Red++splitOut :: Text -> Text -> IO ()+splitOut = split stdout Green++splitMeh :: Text -> Text -> IO ()+splitMeh = split stdout Yellow++replace :: Text -> IO ()+replace msg = do+    hCursorUpLine stdout 1+    hClearLine stdout+    hPutStrLn stdout msg
+ src/Brok/IO/DB.hs view
@@ -0,0 +1,57 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.IO.DB+    ( getCached+    , setCached+    ) where++import ClassyPrelude++import Data.Either           (fromRight)+import Data.Time.Clock.POSIX (getPOSIXTime)+import System.Directory      (doesFileExist)++import Brok.Parser.DB  (db)+import Brok.Types.Link (URL)++path :: String+path = ".brokdb"++-- time stuff+removeOld :: Integer -> [(URL, Integer)] -> IO [(URL, Integer)]+removeOld age cached = do+    timestamp <- getPOSIXTime+    return $ filter ((\val -> timestamp - val < fromInteger age) . fromInteger . snd) cached++stamp :: URL -> IO (URL, Integer)+stamp lnk = do+    timestamp <- round <$> getPOSIXTime+    return (lnk, timestamp)++-- write db+linkToText :: (URL, Integer) -> Text+linkToText (lnk, int) = concat [lnk, " ", tshow int]++write :: [(URL, Integer)] -> IO ()+write links = writeFile path . encodeUtf8 . unlines $ linkToText <$> links++setCached :: Integer -> [URL] -> IO ()+setCached age links = do+    current <- load age+    stamped <- sequence (stamp <$> links)+    write $ current ++ stamped++-- read db+read :: Integer -> FilePath -> IO [(URL, Integer)]+read age filepath = removeOld age =<< fromRight [] . db . decodeUtf8 <$> readFile filepath++load :: Integer -> IO [(URL, Integer)]+load age = do+    exists <- doesFileExist path+    if exists+        then read age path+        else return []++getCached :: Integer -> IO [URL]+getCached age = (fst <$>) <$> load age
+ src/Brok/IO/Document.hs view
@@ -0,0 +1,21 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brok.IO.Document+    ( TFilePath+    , readContent+    ) where++import ClassyPrelude++import System.Directory (doesFileExist)++import Brok.Types.Result++readContent :: Result -> IO Result+readContent result = do+    let path = getPath result+    let filepath = unpack path+    exists <- doesFileExist filepath+    if exists+        then setContent result . decodeUtf8 <$> readFile filepath+        else return $ notFound result
+ src/Brok/IO/Http.hs view
@@ -0,0 +1,47 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.IO.Http+    ( check+    ) where++import ClassyPrelude++import Control.Concurrent  (threadDelay)+import Network.HTTP.Simple (HttpException, HttpException (..), Request, addRequestHeader,+                            getResponseStatusCode, httpNoBody, parseRequest, setRequestMethod)++import Brok.IO.CLI     (replace)+import Brok.Types.Link++type StatusCode = Either HttpException Int++setHeaders :: Request -> Request+setHeaders = addRequestHeader "User-Agent" "smallhadroncollider/brok"++makeRequest :: Integer -> ByteString -> URL -> IO StatusCode+makeRequest delay method url =+    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 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 delay url =+    replace ("Fetching: " ++ url) >> makeRequest delay "HEAD" url >>= tryWithGet delay url++codeToResponse :: Link -> StatusCode -> Link+codeToResponse lnk (Right code)+    | code >= 200 && code < 300 = working lnk code+    | otherwise = broken lnk code+codeToResponse lnk (Left (HttpExceptionRequest _ _)) = failure lnk+codeToResponse lnk (Left (InvalidUrlException _ _)) = invalid lnk++check :: Integer -> Link -> IO Link+check delay lnk = codeToResponse lnk <$> fetch delay (getURL lnk)
+ src/Brok/IO/Output.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.IO.Output+    ( output+    ) where++import ClassyPrelude++import Brok.IO.CLI+import Brok.Types.Link+import Brok.Types.Result++-- output+linkOutput :: Link -> IO ()+linkOutput (Link url BareLink)          = splitErr "- Failed (unknown)" url+linkOutput (Link url Ignored)           = mehssage $ "- Ignored: " ++ url+linkOutput (Link url Cached)            = splitOut "- OK (cached)" url+linkOutput (Link url (Working code))    = splitOut ("- OK (" ++ tshow code ++ ")") url+linkOutput (Link url (Broken code))     = splitErr ("- Failed (" ++ tshow code ++ ")") url+linkOutput (Link url ConnectionFailure) = splitErr "- Could not connect" url+linkOutput (Link url InvalidURL)        = splitErr "- Invalid URL" url++statusError :: Link -> Bool+statusError (Link _ (Working _)) = False+statusError (Link _ Cached)      = False+statusError (Link _ Ignored)     = False+statusError _                    = True++countErrors :: [Link] -> Int+countErrors statuses = length $ filter statusError statuses++outputPath :: TFilePath -> Text+outputPath path = concat ["\n", "[", path, "]"]++output :: Result -> IO Bool+output (Result path NotFound) = do+    errorMessage $ outputPath path+    errorMessage "  - File not found"+    return True+output (Result path (ParseError err)) = do+    errorMessage $ outputPath path+    errorMessage "  - Parse error:"+    errorMessage err+    return True+output (Result path (Links links)) = do+    let errs = countErrors links /= 0+    if errs+        then errorMessage $ outputPath path+        else message $ outputPath path+    if not (null links)+        then sequence_ $ linkOutput <$> links+        else putStrLn "- No links found in file"+    return errs+output _ = return False
+ src/Brok/Options.hs view
@@ -0,0 +1,11 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brok.Options where++import ClassyPrelude++import Brok.Parser.Options (options)+import Brok.Types.Next     (Next)++parse :: [Text] -> Either Text Next+parse = options
+ src/Brok/Parser/Attoparsec.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.Parser.Attoparsec where++import ClassyPrelude++import Data.Attoparsec.Text++lexeme :: Parser a -> Parser a+lexeme p = many' space *> p <* many' space++tchar :: Char -> Parser Text+tchar ch = singleton <$> char ch++chopt :: Char -> Parser Text+chopt ch = option "" (tchar ch)++concat3 :: (Monoid a) => a -> a -> a -> a+concat3 t1 t2 t3 = concat [t1, t2, t3]++concat4 :: (Monoid a) => a -> a -> a -> a -> a+concat4 t1 t2 t3 t4 = concat [t1, t2, t3, t4]++surround :: Char -> Char -> Parser Text -> Parser Text+surround open close parser = concat3 <$> tchar open <*> parser <*> tchar close
+ src/Brok/Parser/DB.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.Parser.DB+    ( db+    ) where++import ClassyPrelude++import Data.Attoparsec.Text++import Brok.Parser.Links (url)+import Brok.Types.Link++line :: Parser (URL, Integer)+line = do+    lnk <- url+    _ <- char ' '+    int <- many1 digit+    _ <- char '\n'+    case readMay int :: Maybe Integer of+        Just i  -> return (lnk, i)+        Nothing -> fail "Unable to parse timestamp"++entries :: Parser [(URL, Integer)]+entries = many1 line++-- run parser+db :: Text -> Either Text [(URL, Integer)]+db "" = Right []+db content =+    case parseOnly entries content of+        Right c -> Right c+        Left e  -> Left $ tshow e
+ src/Brok/Parser/Links.hs view
@@ -0,0 +1,45 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.Parser.Links+    ( links+    , url+    ) where++import ClassyPrelude++import Data.Attoparsec.Text+import Data.List            (nub)++import Brok.Parser.Attoparsec+import Brok.Types.Link        (URL)++type Token = Maybe URL++-- parentheses+parens :: Parser Text -> Parser Text+parens parser = surround '(' ')' parser <|> surround '[' ']' parser++-- urls+urlChar :: Parser Char+urlChar = digit <|> letter <|> choice (char <$> "-._~:/?#%@!$&*+,;=")++urlChars :: Parser Text+urlChars = concat <$> many1 (parens urlChars <|> (pack <$> many1 urlChar))++url :: Parser Text+url = concat4 <$> string "http" <*> chopt 's' <*> string "://" <*> urlChars++noise :: Parser Token+noise = anyChar >> return Nothing++urls :: Parser [URL]+urls = nub . catMaybes <$> many1 ((Just <$> url) <|> noise)++-- run parser+links :: Text -> Either Text [URL]+links "" = Right []+links content =+    case parseOnly urls content of+        Right c -> Right c+        Left e  -> Left $ tshow e
+ src/Brok/Parser/Options.hs view
@@ -0,0 +1,69 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Brok.Parser.Options+    ( options+    ) where++import ClassyPrelude++import Data.Attoparsec.Text++import Brok.Parser.Attoparsec+import Brok.Parser.Links      (url)+import Brok.Types.Config+import Brok.Types.Next        (Next (..))++data Option+    = Cache Integer+    | Interval Integer+    | Ignore [Text]+    | Files [Text]++readInt :: String -> String -> Parser Integer+readInt arg value =+    maybe (fail $ "Unable to parse " ++ arg ++ " value") return (readMay value :: Maybe Integer)++cacheP :: Parser Option+cacheP = lexeme $ Cache <$> (string "--cache" *> char '\n' *> many1 digit >>= readInt "cache")++intervalP :: Parser Option+intervalP =+    lexeme $ Interval <$> (string "--interval" *> char '\n' *> many1 digit >>= readInt "interval")++urlP :: Parser Text+urlP = lexeme url++ignoreP :: Parser Option+ignoreP = lexeme $ Ignore <$> (string "--ignore" *> char '\n' *> many1 urlP)++fileP :: Parser Text+fileP = lexeme $ pack <$> many1 (notChar '\n')++optsToConfig :: [Option] -> Config+optsToConfig = foldl' convert defaultConfig+  where+    convert dc (Cache i)    = dc {cache = i}+    convert dc (Ignore i)   = dc {ignore = i}+    convert dc (Interval i) = dc {interval = i}+    convert dc (Files i)    = dc {files = i}++arguments :: Parser Config+arguments = do+    opts <- many' (cacheP <|> intervalP <|> ignoreP)+    fls <- many1 fileP+    return . optsToConfig $ opts ++ [Files fls]++helpP :: Parser Next+helpP = lexeme $ (string "--help" <|> string "-h") $> Help++next :: Parser Next+next = helpP <|> (Continue <$> arguments)++-- run parser+options :: [Text] -> Either Text Next+options [] = Left "No files provided"+options content =+    case parseOnly next (unlines content) of+        Right c -> Right c+        Left e  -> Left $ tshow e
+ src/Brok/Types/Config.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brok.Types.Config where++import ClassyPrelude++import Brok.Types.Link (URL)++data Config = Config+    { cache    :: Integer+    , ignore   :: [URL]+    , interval :: Integer+    , files    :: [Text]+    } deriving (Show, Eq)++defaultConfig :: Config+defaultConfig = Config {cache = 84600, ignore = [], interval = 100, files = []}
+ src/Brok/Types/Link.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brok.Types.Link where++import ClassyPrelude++type URL = Text++data LinkType+    = BareLink+    | Cached+    | Ignored+    | Working Int+    | Broken Int+    | InvalidURL+    | ConnectionFailure+    deriving (Show, Eq)++data Link =+    Link URL+         LinkType+    deriving (Show, Eq)++urlToLink :: URL -> Link+urlToLink url = Link url BareLink++getURL :: Link -> URL+getURL (Link url _) = url++working :: Link -> Int -> Link+working (Link url BareLink) code = Link url (Working code)+working lnk _                    = lnk++broken :: Link -> Int -> Link+broken (Link url BareLink) code = Link url (Broken code)+broken lnk _                    = lnk++failure :: Link -> Link+failure (Link url BareLink) = Link url ConnectionFailure+failure lnk                 = lnk++invalid :: Link -> Link+invalid (Link url BareLink) = Link url InvalidURL+invalid lnk                 = lnk++findLink :: LinkType -> (URL -> URL -> Bool) -> [URL] -> Link -> Link+findLink lType fn urls (Link url BareLink) =+    case find (fn url) urls of+        Just _  -> Link url lType+        Nothing -> Link url BareLink+findLink _ _ _ lnk = lnk++cachedLink :: [URL] -> Link -> Link+cachedLink = findLink Cached (==)++ignoredLink :: [URL] -> Link -> Link+ignoredLink = findLink Ignored (flip isPrefixOf)++isSuccess :: Link -> Bool+isSuccess (Link _ (Working _)) = True+isSuccess _                    = False++lmap :: (Link -> IO Link) -> Link -> IO Link+lmap fn (Link url BareLink) = fn (Link url BareLink)+lmap _ lnk                  = return lnk
+ src/Brok/Types/Next.hs view
@@ -0,0 +1,12 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brok.Types.Next where++import ClassyPrelude++import Brok.Types.Config (Config)++data Next+    = Continue Config+    | Help+    deriving (Show, Eq)
+ src/Brok/Types/Result.hs view
@@ -0,0 +1,63 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Brok.Types.Result where++import ClassyPrelude++import Brok.Types.Link++type TFilePath = Text++type Error = Text++data ResultType+    = BareResult+    | Content Text+    | NotFound+    | ParseError Error+    | Links [Link]+    deriving (Show, Eq)++data Result =+    Result TFilePath+           ResultType+    deriving (Show, Eq)++pathToResult :: TFilePath -> Result+pathToResult path = Result path BareResult++getPath :: Result -> TFilePath+getPath (Result path _) = path++notFound :: Result -> Result+notFound (Result path BareResult) = Result path NotFound+notFound result                   = result++setContent :: Result -> Text -> Result+setContent (Result path BareResult) text = Result path (Content text)+setContent result _                      = result++parseLinks :: (Text -> Either Text [URL]) -> Result -> Result+parseLinks fn (Result path (Content text)) =+    case fn text of+        Left err    -> Result path (ParseError err)+        Right links -> Result path (Links $ urlToLink <$> links)+parseLinks _ result = result++findLinks :: ([URL] -> Link -> Link) -> [URL] -> Result -> Result+findLinks fn urls (Result path (Links links)) = Result path (Links $ fn urls <$> links)+findLinks _ _ result                          = result++cachedLinks :: [URL] -> Result -> Result+cachedLinks = findLinks cachedLink++ignoredLinks :: [URL] -> Result -> Result+ignoredLinks = findLinks ignoredLink++linkIOMap :: (Link -> IO Link) -> Result -> IO Result+linkIOMap fn (Result path (Links links)) = Result path . Links <$> sequence (lmap fn <$> links)+linkIOMap _ result                       = return result++justLinks :: Result -> [Link]+justLinks (Result _ (Links links)) = links+justLinks _                        = []
+ test/IO/HttpTest.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module IO.HttpTest where++import ClassyPrelude++import Test.Tasty++import Brok.IO.Http     (check)+import Brok.Types.Link  (Link (Link), LinkType (..), urlToLink)+import Test.Tasty.HUnit++test_http :: TestTree+test_http =+    testGroup+        "Brok.IO.Http"+        [ testCase "Medium (409 with HEAD)" $ do+              result <-+                  check 0 $+                  urlToLink+                      "https://medium.freecodecamp.org/understanding-redux-the-worlds-easiest-guide-to-beginning-redux-c695f45546f6"+              assertEqual+                  "Returns a 200"+                  (Link+                       "https://medium.freecodecamp.org/understanding-redux-the-worlds-easiest-guide-to-beginning-redux-c695f45546f6"+                       (Working 200))+                  result+        , testCase "TutsPlus (Requires User-Agent Header)" $ do+              result <-+                  check 0 $+                  urlToLink+                      "https://code.tutsplus.com/tutorials/stateful-vs-stateless-functional-components-in-react--cms-29541"+              assertEqual+                  "Returns a 200"+                  (Link+                       "https://code.tutsplus.com/tutorials/stateful-vs-stateless-functional-components-in-react--cms-29541"+                       (Working 200))+                  result+        , testCase "Random blog (404 on a HEAD request)" $ do+              result <-+                  check 0 $+                  urlToLink+                      "https://blog.infinitenegativeutility.com/2017/12/some-notes-about-how-i-write-haskell"+              assertEqual+                  "Returns a 200"+                  (Link+                       "https://blog.infinitenegativeutility.com/2017/12/some-notes-about-how-i-write-haskell"+                       (Working 200))+                  result+        , testCase "Non-existant site" $ do+              result <- check 0 $ urlToLink "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;"+              assertEqual+                  "Returns a 200"+                  (Link "http://user:password&#64;securesite.com/secret-file.json&quot;" InvalidURL)+                  result+        ]
+ test/OptionsTest.hs view
@@ -0,0 +1,150 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module OptionsTest where++import ClassyPrelude++import Test.Tasty+import Test.Tasty.HUnit++import Brok.Options      (parse)+import Brok.Types.Config+import Brok.Types.Next   (Next (..))++test_options :: TestTree+test_options =+    testGroup+        "Brok.Options"+        [ testGroup+              "Help"+              [ testCase "--help" (assertEqual "return Help" (Right Help) (parse ["--help"]))+              , testCase "-h" (assertEqual "return Help" (Right Help) (parse ["-h"]))+              ]+        , testCase+              "single file"+              (assertEqual+                   "gives back file"+                   (Right (Continue (defaultConfig {files = ["blah.md"]})))+                   (parse ["blah.md"]))+        , testCase+              "multiple files"+              (assertEqual+                   "gives back files"+                   (Right (Continue (defaultConfig {files = ["blah.md", "tests/spoon.md"]})))+                   (parse ["blah.md", "tests/spoon.md"]))+        , testCase+              "single file with cache option"+              (assertEqual+                   "gives back files"+                   (Right (Continue (defaultConfig {cache = 172800, files = ["blah.md"]})))+                   (parse ["--cache", "172800", "blah.md"]))+        , testCase+              "multiple files with cache option"+              (assertEqual+                   "gives back files"+                   (Right+                        (Continue+                             (defaultConfig {cache = 172800, files = ["blah.md", "tests/spoon.md"]})))+                   (parse ["--cache", "172800", "blah.md", "tests/spoon.md"]))+        , testCase+              "multiple files with interval option"+              (assertEqual+                   "gives back files"+                   (Right+                        (Continue+                             (defaultConfig {interval = 200, files = ["blah.md", "tests/spoon.md"]})))+                   (parse ["--interval", "200", "blah.md", "tests/spoon.md"]))+        , testCase+              "multiple files with ignore option"+              (assertEqual+                   "gives back files"+                   (Right+                        (Continue+                             (defaultConfig+                              { ignore = ["http://www.google.com", "http://facebook.com"]+                              , files = ["blah.md", "tests/spoon.md"]+                              })))+                   (parse+                        [ "--ignore"+                        , "http://www.google.com"+                        , "http://facebook.com"+                        , "blah.md"+                        , "tests/spoon.md"+                        ]))+        , testCase+              "multiple files with all options #1"+              (assertEqual+                   "gives back files"+                   (Right+                        (Continue+                             (defaultConfig+                              { cache = 172800+                              , interval = 400+                              , ignore = ["http://www.google.com", "http://facebook.com"]+                              , files = ["blah.md", "tests/spoon.md"]+                              })))+                   (parse+                        [ "--cache"+                        , "172800"+                        , "--interval"+                        , "400"+                        , "--ignore"+                        , "http://www.google.com"+                        , "http://facebook.com"+                        , "blah.md"+                        , "tests/spoon.md"+                        ]))+        , testCase+              "multiple files with all options #2"+              (assertEqual+                   "gives back files"+                   (Right+                        (Continue+                             (defaultConfig+                              { cache = 172800+                              , interval = 400+                              , ignore = ["http://www.google.com", "http://facebook.com"]+                              , files = ["blah.md", "tests/spoon.md"]+                              })))+                   (parse+                        [ "--interval"+                        , "400"+                        , "--cache"+                        , "172800"+                        , "--ignore"+                        , "http://www.google.com"+                        , "http://facebook.com"+                        , "blah.md"+                        , "tests/spoon.md"+                        ]))+        , testCase+              "multiple files with all options #3"+              (assertEqual+                   "gives back files"+                   (Right+                        (Continue+                             (defaultConfig+                              { cache = 172800+                              , interval = 400+                              , ignore = ["http://www.google.com", "http://facebook.com"]+                              , files = ["blah.md", "tests/spoon.md"]+                              })))+                   (parse+                        [ "--ignore"+                        , "http://www.google.com"+                        , "http://facebook.com"+                        , "--interval"+                        , "400"+                        , "--cache"+                        , "172800"+                        , "blah.md"+                        , "tests/spoon.md"+                        ]))+        , testCase+              "files with space"+              (assertEqual+                   "gives back files"+                   (Right (Continue (defaultConfig {files = ["blah.md", "tests/spoon book.md"]})))+                   (parse ["blah.md", "tests/spoon book.md"]))+        ]
+ test/Parser/DBTest.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Parser.DBTest where++import ClassyPrelude++import Test.Tasty+import Test.Tasty.HUnit++import Data.Either    (fromRight, isLeft)+import Data.FileEmbed (embedFile)++import Brok.Parser.DB (db)++content :: Text+content = decodeUtf8 $(embedFile "test/data/.brokdb")++invalid :: Text+invalid = decodeUtf8 $(embedFile "test/data/.brokdb-invalid")++big :: Text+big = decodeUtf8 $(embedFile "test/data/.brokdb-big")++test_db :: TestTree+test_db =+    testGroup+        "Brok.Parser.DB"+        [ testCase+              "parses .brokdb"+              (assertEqual+                   "Gives back URLs with timestamp"+                   (Right+                        [ ( "https://developer.mozilla.org/en-US/docs/Web/API/Window/getComputedStyle"+                          , 1547542131)+                        , ( "https://www.amazon.co.uk/Code-Language-Computer-Hardware-Software/dp/0735611319"+                          , 1546959165)+                        , ("https://rosettacode.org/wiki/FizzBuzz", 1546440765)+                        , ( "https://medium.com/dailyjs/the-why-behind-the-wat-an-explanation-of-javascripts-weird-type-system-83b92879a8db"+                          , 1546008765)+                        ])+                   (db content))+        , testCase+              "big file"+              (assertEqual+                   "Gives back final url"+                   (Just+                        "https://developmentarc.gitbooks.io/react-indepth/content/life_cycle/the_life_cycle_recap.html")+                   (fst <$> (lastMay . fromRight [] $ db big)))+        , testCase "invalid .brokdb" (assertEqual "Parse error" True (isLeft $ db invalid))+        , testCase "parses empty" (assertEqual "Gives back empty array" (Right []) (db ""))+        ]
+ test/Parser/LinksTest.hs view
@@ -0,0 +1,147 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}++module Parser.LinksTest where++import ClassyPrelude++import Test.Tasty+import Test.Tasty.ExpectedFailure (expectFail)+import Test.Tasty.HUnit++import Data.FileEmbed (embedFile)++import Brok.Parser.Links (links)++markdown :: Text+markdown = decodeUtf8 $(embedFile "test/data/links.md")++complex :: Text+complex = decodeUtf8 $(embedFile "test/data/complex.md")++tex :: Text+tex = decodeUtf8 $(embedFile "test/data/links.tex")++test_parser :: TestTree+test_parser =+    testGroup+        "Brok.Parser.Links"+        [ testGroup+              "single links"+              [ testCase+                    "just http link"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com"])+                         (links "http://google.com"))+              , testCase+                    "just https link"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["https://google.com"])+                         (links "https://google.com"))+              , testCase+                    "http link with surrounding text"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com"])+                         (links "A link to Google http://google.com - doesn't it look nice"))+              , testCase+                    "https link with surrounding text"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["https://google.com"])+                         (links "A link to Google https://google.com - doesn't it look nice"))+              , testCase+                    "markdown"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com"])+                         (links "[A link](http://google.com)"))+              , testCase+                    "link with brackets"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com?q=(fish)"])+                         (links "[A link](http://google.com?q=(fish))"))+              , testCase+                    "link with square brackets surrounding"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com?q=(fish)"])+                         (links "[http://google.com?q=(fish)]"))+              , testCase+                    "link with square brackets"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com?q=fish"])+                         (links "[http://google.com?q=fish]"))+              , expectFail $+                -- using surround with the same character on each side causing issues? +                testCase+                    "link with single quotes"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com?q='fish'"])+                         (links "http://google.com?q='fish'"))+              , testCase+                    "link with single quotes surrounding"+                    (assertEqual+                         "Gives back google.com"+                         (Right ["http://google.com?q=fish"])+                         (links "'http://google.com?q=fish'"))+              ]+        , testGroup+              "multiple links"+              [ testCase+                    "links with surrounding text"+                    (assertEqual+                         "Gives back two URLs"+                         (Right ["https://google.com", "http://spoons.com"])+                         (links+                              "A link to Google https://google.com - doesn't it look like http://spoons.com"))+              , testCase+                    "basic markdown"+                    (assertEqual+                         "Gives back list of URLS"+                         (Right+                              [ "https://google.com"+                              , "http://amazon.com"+                              , "https://www.facebook.com"+                              , "http://www.apple.com"+                              ])+                         (links markdown))+              , testCase+                    "complex markdown"+                    (assertEqual+                         "Gives back list of URLS"+                         (Right+                              [ "https://developer.mozilla.org/en-US/docs/Web/API/Window"+                              , "https://developer.mozilla.org/en-US/docs/Web/API/Window/getComputedStyle"+                              , "https://developer.mozilla.org/en-US/docs/Web/API/Element/getBoundingClientRect"+                              , "https://developer.mozilla.org/en-US/docs/Learn/HTML/Howto/Use_data_attributes"+                              ])+                         (links complex))+              , testCase+                    "tex"+                    (assertEqual+                         "Gives back list of URLs"+                         (Right+                              [ "https://eloquentjavascript.net/01_values.html"+                              , "http://exploringjs.com/impatient-js/ch_variables-assignment.html"+                              , "https://developers.google.com/web/updates/2015/01/ES6-Template-Strings#string_substitution"+                              , "https://medium.com/dailyjs/the-why-behind-the-wat-an-explanation-of-javascripts-weird-type-system-83b92879a8db"+                              , "https://developer.mozilla.org/en-US/docs/Learn/JavaScript/Building_blocks/conditionals"+                              , "https://developer.mozilla.org/en-US/docs/Web/JavaScript/Guide/Loops_and_iteration"+                              , "https://eloquentjavascript.net/02_program_structure.html"+                              , "http://exploringjs.com/impatient-js/ch_control-flow.html"+                              , "https://rosettacode.org/wiki/FizzBuzz"+                              , "https://www.youtube.com/watch?v=QPZ0pIK_wsc"+                              , "https://www.amazon.co.uk/Code-Language-Computer-Hardware-Software/dp/0735611319"+                              , "https://en.wikipedia.org/wiki/Turing_completeness"+                              ])+                         (links tex))+              ]+        , testCase "nothing" (assertEqual "Gives back empty list" (Right []) (links ""))+        ]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF tasty-discover #-}