diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,7 +2,13 @@ `http-directory` uses [PVP Versioning](https://pvp.haskell.org). -## 0.1.4 (2019-06-xx) +## 0.1.5 (2019-06-xx) +- also filter "..", "#" and ":" from httpDirectory +- export Manager +- add isHttpUrl +- testsuite added + +## 0.1.4 (2019-06-07) - add httpRawDirectory - httpDirectory now filters out absolutes hrefs and sort links - add httpDirectory' and httpRedirect' variants with own Manager diff --git a/http-directory.cabal b/http-directory.cabal --- a/http-directory.cabal +++ b/http-directory.cabal @@ -1,11 +1,11 @@ cabal-version: 1.18 name: http-directory -version: 0.1.4 +version: 0.1.5 synopsis: http directory listing library description: - Library for listing the files (links) in an http directory. + Library for listing the files (href's) in an http directory. It can also check the size, existence, modtime of files, - and url redirects. + and for url redirects. homepage: https://github.com/juhp/http-directory bug-reports: https://github.com/juhp/http-directory/issues license: MIT @@ -48,3 +48,16 @@ default-language: Haskell2010 default-extensions: OverloadedStrings + +test-suite test + main-is: Spec.hs + type: exitcode-stdio-1.0 + hs-source-dirs: test + + default-language: Haskell2010 + + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + cpp-options: -DDEBUG + build-depends: base >= 4 && < 5 + , hspec >= 1.3 + , http-directory diff --git a/src/Network/HTTP/Directory.hs b/src/Network/HTTP/Directory.hs --- a/src/Network/HTTP/Directory.hs +++ b/src/Network/HTTP/Directory.hs @@ -26,18 +26,21 @@ httpManager, httpRedirect, httpRedirect', - httpRedirects + httpRedirects, + isHttpUrl, + Manager ) where #if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) #else import Control.Applicative ((<$>)) #endif +import Control.Monad (when) import qualified Data.ByteString.Char8 as B -import Data.List (nub) +import qualified Data.List as L import Data.Maybe -import Data.Text (Text, isPrefixOf, pack) +import Data.Text (Text, isPrefixOf, isInfixOf) import Data.Time.Clock (UTCTime) import Network.HTTP.Client (hrRedirects, httpLbs, httpNoBody, Manager, method, @@ -64,9 +67,7 @@ httpDirectory :: Manager -> String -> IO [Text] httpDirectory mgr url = do hrefs <- httpRawDirectory mgr url - return $ nub $ filter (not . or . flist [isHttp, ("/" `isPrefixOf`), (pack "../" ==), ("?" `isPrefixOf`)]) hrefs - where - isHttp loc = "http:" `isPrefixOf` loc || "https:" `isPrefixOf` loc + return $ L.nub $ filter (not . or . flist (map isPrefixOf ["/","?"] ++ [(`elem` ["../", "..", "#"]), (":" `isInfixOf`)])) hrefs -- picked from swish flist :: [a->b] -> a -> [b] @@ -94,15 +95,11 @@ httpRawDirectory mgr url = do request <- parseRequest url response <- httpLbs request mgr - if statusCode (responseStatus response) /= 200 - then do - putStrLn url - error $ show $ responseStatus response - else do - let body = responseBody response - doc = parseLBS body - cursor = fromDocument doc - return $ concatMap (attribute "href") $ cursor $// element "a" + checkResponse url response + let body = responseBody response + doc = parseLBS body + cursor = fromDocument doc + return $ concatMap (attribute "href") $ cursor $// element "a" -- | Test if an file (url) exists -- @@ -118,13 +115,9 @@ httpFileSize :: Manager -> String -> IO (Maybe Integer) httpFileSize mgr url = do response <- httpHead mgr url - if statusCode (responseStatus response) /= 200 - then do - putStrLn url - error $ show $ responseStatus response - else do - let headers = responseHeaders response - return $ read . B.unpack <$> lookup hContentLength headers + checkResponse url response + let headers = responseHeaders response + return $ read . B.unpack <$> lookup hContentLength headers -- | Try to get the modification time (Last-Modified field) of an http file -- @@ -134,14 +127,16 @@ httpLastModified :: Manager -> String -> IO (Maybe UTCTime) httpLastModified mgr url = do response <- httpHead mgr url - if statusCode (responseStatus response) /= 200 - then do + checkResponse url response + let headers = responseHeaders response + mdate = lookup "Last-Modified" headers + return $ httpDateToUTC <$> maybe Nothing parseHTTPDate mdate + +checkResponse :: String -> Response r -> IO () +checkResponse url response = + when (statusCode (responseStatus response) /= 200) $ do putStrLn url error $ show $ responseStatus response - else do - let headers = responseHeaders response - mdate = lookup "Last-Modified" headers - return $ httpDateToUTC <$> maybe Nothing parseHTTPDate mdate -- | alias for 'newManager tlsManagerSettings' -- so one does not need to import http-client etc @@ -172,16 +167,19 @@ mgr <- httpManager listToMaybe <$> httpRedirects mgr url --- parseRequest with HEAD --- --- @since 0.1.3 parseRequestHead :: String -> IO Request parseRequestHead url = do request <- parseRequest url return $ request {method = methodHead} --- @since 0.1.3 httpHead :: Manager -> String -> IO (Response ()) httpHead mgr url = do request <- parseRequestHead url httpNoBody request mgr + +-- | Test if string starts with http[s]: +-- +-- @since 0.1.5 +isHttpUrl :: String -> Bool +isHttpUrl loc = "http:" `L.isPrefixOf` loc || "https:" `L.isPrefixOf` loc + diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,104 @@ +import Data.Maybe +import Test.Hspec +import Network.HTTP.Directory + +main :: IO () +main = hspec $ parallel spec + +spec :: Spec +spec = do + describe "httpDirectory" $ do + it "empty google" $ do + mgr <- httpManager + fs <- httpDirectory mgr "https://google.com/" + fs `shouldBe` [] + + it "empty httpbin" $ do + mgr <- httpManager + fs <- httpDirectory mgr "http://httpbin.org/" + fs `shouldBe` [] + + it "my src hackage" $ do + fs <- httpDirectory' "https://hackage.haskell.org/package/http-directory/src/" + null fs `shouldBe` False + + it "myself hackage" $ do + fs <- httpDirectory' "https://hackage.haskell.org/package/http-directory" + null fs `shouldBe` False + + it "404" $ + httpDirectory' "https://httpbin.org/404" + `shouldThrow` anyException + + describe "httpExists" $ do + it "google" $ do + mgr <- httpManager + exists <- httpExists mgr "https://google.com/" + exists `shouldBe` True + + it "404" $ do + mgr <- httpManager + exists <- httpExists mgr "https://httpbin.org/404" + exists `shouldBe` False + + it "domain" $ do + mgr <- httpManager + httpExists mgr "http://nowhereparticular" + `shouldThrow` anyException + + describe "httpFileSize" $ do + it "httpbin/get" $ do + mgr <- httpManager + msize <- httpFileSize mgr "https://httpbin.org/get" + msize `shouldBe` Nothing + + it "httpbin/0B" $ do + mgr <- httpManager + msize <- httpFileSize mgr "https://httpbin.org/bytes/0" + msize `shouldBe` Just 0 + + it "httpbin/64B" $ do + mgr <- httpManager + msize <- httpFileSize mgr "https://httpbin.org/bytes/64" + msize `shouldBe` Just 64 + + it "cabal" $ do + mgr <- httpManager + msize <- httpFileSize mgr "https://raw.githubusercontent.com/juhp/http-directory/master/http-directory.cabal" + isJust msize `shouldBe` True + + describe "httpLastModified" $ + it "httpbin" $ do + mgr <- httpManager + mtime <- httpLastModified mgr "https://haskell.org/" + isJust mtime `shouldBe` True + + describe "httpRedirect" $ + it "fedora" $ do + mredir <- httpRedirect' "http://dl.fedoraproject.org" + isJust mredir `shouldBe` True + + describe "httpRedirect" $ do + it "fedora" $ do + mredir <- httpRedirect' "http://download.fedoraproject.org" + isJust mredir `shouldBe` True + + it "httpbin" $ do + mredir <- httpRedirect' "http://httpbin.org/relative-redirect/1" + isJust mredir `shouldBe` True + + it "3 redirs" $ do + mgr <- httpManager + redirs <- httpRedirects mgr "http://httpbin.org/relative-redirect/2" + length redirs `shouldBe` 2 + + describe "isHttpUrl" $ do + it "urls" $ + all isHttpUrl + ["http://dl.fedoraproject.org", "https://haskell.org/"] + `shouldBe` True + + it "urls" $ + any isHttpUrl + ["mailto:one@where", "somefile", "an.iso", "package.tgz"] + `shouldBe` False