diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,11 @@ `http-directory` uses [PVP Versioning](https://pvp.haskell.org). +## 0.1.6 (2020-01-24) +- filter relative/paths and relative?queries +- add `url file` +- add trailingSlash for url and noTrailingSlash for filename + ## 0.1.5 (2019-06-xx) - also filter "..", "#" and ":" from httpDirectory - export Manager diff --git a/example/Makefile b/example/Makefile new file mode 100644 --- /dev/null +++ b/example/Makefile @@ -0,0 +1,7 @@ +all: latest-ghc list-page + +latest-ghc: latest-ghc.hs + ghc latest-ghc + +list-page: list-page.hs + ghc list-page diff --git a/example/latest-ghc.hs b/example/latest-ghc.hs new file mode 100644 --- /dev/null +++ b/example/latest-ghc.hs @@ -0,0 +1,11 @@ +import Network.HTTP.Directory +import qualified Data.Text as T +import Data.Char + +main :: IO () +main = do + mgr <- httpManager + let url = "https://downloads.haskell.org/~ghc/" + dirs <- httpDirectory mgr url + let vs = filter (isDigit . T.head) dirs + putStrLn $ "Latest ghc: " <> url <> T.unpack (last vs) diff --git a/example/list-page.hs b/example/list-page.hs new file mode 100644 --- /dev/null +++ b/example/list-page.hs @@ -0,0 +1,10 @@ +import Network.HTTP.Directory +import qualified Data.Text.IO as T +import System.Environment + +main :: IO () +main = do + [url] <- getArgs + mgr <- httpManager + dirs <- httpDirectory mgr url + mapM_ T.putStrLn dirs diff --git a/http-directory.cabal b/http-directory.cabal --- a/http-directory.cabal +++ b/http-directory.cabal @@ -1,6 +1,6 @@ cabal-version: 1.18 name: http-directory -version: 0.1.5 +version: 0.1.6 synopsis: http directory listing library description: Library for listing the files (href's) in an http directory. @@ -17,8 +17,11 @@ build-type: Simple extra-doc-files: README.md , CHANGELOG.md -tested-with: GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, GHC == 8.0.2, - GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 + , example/Makefile + , example/latest-ghc.hs + , example/list-page.hs +tested-with: GHC == 7.4.2, GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.3, + GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, GHC == 8.6.5 source-repository head type: git @@ -27,15 +30,15 @@ library hs-source-dirs: src exposed-modules: Network.HTTP.Directory - build-depends: base < 5, bytestring, html-conduit, http-client, http-client-tls, - http-date, + http-date >= 0.0.7, http-types, + network-uri, text, time, xml-conduit @@ -61,3 +64,4 @@ build-depends: base >= 4 && < 5 , hspec >= 1.3 , http-directory + , text 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 @@ -9,10 +9,12 @@ main = do mgr <- httpManager - files <- httpDirectory mgr "https://example.com/some/dir/" + let url = "https://example.com/some/dir/" + files <- httpDirectory mgr url mapM_ T.putStrLn files - httpFileSize mgr (head files) >>= print - httpLastModified mgr (head files) >>= print + let file = url T.unpack (head files) + httpFileSize mgr file >>= print + httpLastModified mgr file >>= print @ -} @@ -28,7 +30,10 @@ httpRedirect', httpRedirects, isHttpUrl, - Manager + trailingSlash, + noTrailingSlash, + Manager, + () ) where #if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,8,0)) @@ -40,22 +45,26 @@ import qualified Data.ByteString.Char8 as B import qualified Data.List as L import Data.Maybe -import Data.Text (Text, isPrefixOf, isInfixOf) +import Data.Text (Text) +import qualified Data.Text as T import Data.Time.Clock (UTCTime) import Network.HTTP.Client (hrRedirects, httpLbs, httpNoBody, Manager, method, - newManager, parseRequest, - Request, Response, responseBody, responseHeaders, + newManager, parseRequest, Request, + Response, responseBody, responseHeaders, responseOpenHistory, responseStatus) import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Date (httpDateToUTC, parseHTTPDate) import Network.HTTP.Types (hContentLength, hLocation, methodHead, statusCode) +import Network.URI (parseURI, URI(..)) import Text.HTML.DOM (parseLBS) import Text.XML.Cursor --- | List the file links (hrefs) in an http directory +-- | List the files (hrefs) in an http directory -- +-- It filters out absolute urls & paths, queries, '..', and '#' links. +-- -- Raises an error if the http request fails. -- -- Note if the directory (webpage) url is redirected to a different path @@ -63,16 +72,31 @@ -- the actual final url prefix for relative links -- (files). -- --- (Filters "non-files/subdirs" @since 0.1.4 (before that was just httpRawDirectory) +-- (before 0.1.4 it was just httpRawDirectory) httpDirectory :: Manager -> String -> IO [Text] httpDirectory mgr url = do hrefs <- httpRawDirectory mgr url - return $ L.nub $ filter (not . or . flist (map isPrefixOf ["/","?"] ++ [(`elem` ["../", "..", "#"]), (":" `isInfixOf`)])) hrefs + return $ defaultFilesFilter uri hrefs + where + uri = parseURI url --- picked from swish -flist :: [a->b] -> a -> [b] -flist fs a = map ($ a) fs +defaultFilesFilter :: Maybe URI -> [Text] -> [Text] +defaultFilesFilter mUri = + L.nub . filter (not . or . flist (map T.isInfixOf [":", "?", "/"] ++ [(`elem` ["../", "..", "#"])])) . map removePath + where + -- picked from swish + flist :: [a->b] -> a -> [b] + flist fs a = map ($ a) fs + removePath :: Text -> Text + removePath t = + case mpath of + Nothing -> t + Just path -> + fromMaybe t $ T.stripPrefix (T.pack path) t + + mpath = uriPath <$> mUri + -- | Like httpDirectory but uses own Manager -- -- @since 0.1.4 @@ -130,13 +154,14 @@ checkResponse url response let headers = responseHeaders response mdate = lookup "Last-Modified" headers - return $ httpDateToUTC <$> maybe Nothing parseHTTPDate mdate + return $ httpDateToUTC <$> (parseHTTPDate =<< mdate) +-- conflicts with Request checkResponse :: String -> Response r -> IO () checkResponse url response = when (statusCode (responseStatus response) /= 200) $ do putStrLn url - error $ show $ responseStatus response + error' $ show $ responseStatus response -- | alias for 'newManager tlsManagerSettings' -- so one does not need to import http-client etc @@ -183,3 +208,47 @@ isHttpUrl :: String -> Bool isHttpUrl loc = "http:" `L.isPrefixOf` loc || "https:" `L.isPrefixOf` loc +-- | This eats extra slashes. +-- +-- @"dir//" "/subdir/" = "dir/subdir/"@ +-- +-- @since 0.1.6 +infixr 5 +() :: String -> String -> String +"" s = s +s "" = s +s t | last s == '/' = init s t + | head t == '/' = s tail t +s t = s ++ "/" ++ t + +-- | Make sure an url ends with "/" +-- +-- @ +-- trailingSlash "url" == "url/" +-- trailingSlash "url/" == "url/" +-- @ +-- +-- @since 0.1.6 +trailingSlash :: String -> String +trailingSlash "" = "" +trailingSlash str = + if last str == '/' then str else str ++ "/" + +-- | Remove all trailing slashes from filename or url +-- +-- @ +-- noTrailingSlash "dir/" == "dir" +-- noTrailingSlash "dir//" == "dir" +-- @ +-- +-- @since 0.1.6 +noTrailingSlash :: Text -> Text +noTrailingSlash = T.dropWhileEnd (== '/') + +-- from simple-cmd +error' :: String -> a +#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,9,0)) +error' = errorWithoutStackTrace +#else +error' = error +#endif diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,4 +1,5 @@ import Data.Maybe +import Data.Text (pack) import Test.Hspec import Network.HTTP.Directory @@ -50,7 +51,7 @@ it "httpbin/get" $ do mgr <- httpManager msize <- httpFileSize mgr "https://httpbin.org/get" - msize `shouldBe` Nothing + isJust msize `shouldBe` True it "httpbin/0B" $ do mgr <- httpManager @@ -93,12 +94,35 @@ length redirs `shouldBe` 2 describe "isHttpUrl" $ do - it "urls" $ + it "http" $ all isHttpUrl ["http://dl.fedoraproject.org", "https://haskell.org/"] `shouldBe` True - it "urls" $ + it "non-http" $ any isHttpUrl ["mailto:one@where", "somefile", "an.iso", "package.tgz"] `shouldBe` False + + describe "" $ do + it "url + dir" $ + "http://example.com//" "dir/" `shouldBe` "http://example.com/dir/" + + it "dir + dir" $ + "abc" "def" `shouldBe` "abc/def" + + it "dir + dir" $ + "abc/" "/def" `shouldBe` "abc/def" + + describe "trailing slash" $ do + it "add" $ + trailingSlash "http://example.com/dir" `shouldBe` "http://example.com/dir/" + + it "idempotent" $ + trailingSlash "http://example.com/" `shouldBe` "http://example.com/" + + it "remove" $ + noTrailingSlash (pack "abc/") `shouldBe` pack "abc" + + it "remove all" $ + noTrailingSlash (pack "abc/def//") `shouldBe` pack "abc/def"