{-# LANGUAGE CPP, OverloadedStrings #-}
module Network.HTTP.Directory
( httpDirectory,
httpDirectory',
httpRawDirectory,
httpRawDirectory',
httpExists,
httpExists',
httpFileSize,
httpFileSize',
httpLastModified,
httpLastModified',
httpFileSizeTime,
httpFileSizeTime',
httpFileHeaders,
httpFileHeaders',
httpManager,
httpRedirect,
httpRedirect',
httpRedirects,
isHttpUrl,
trailingSlash,
noTrailingSlash,
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 qualified Data.ByteString.Lazy.Char8 as BL
#if MIN_VERSION_base(4,11,0)
import Data.Functor ((<&>))
#endif
import qualified Data.List as L
import Data.Maybe
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,
responseOpenHistory, responseStatus)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Date (httpDateToUTC, parseHTTPDate)
import qualified Network.HTTP.Simple as S
import Network.HTTP.Types (hContentLength, hLocation, hLastModified,
methodHead, statusCode, ResponseHeaders)
import Network.URI (parseURI, URI(..))
import Text.HTML.DOM (parseLBS)
import Text.XML.Cursor
httpDirectory :: Manager -> String -> IO [Text]
httpDirectory :: Manager -> String -> IO [Text]
httpDirectory Manager
mgr String
url = do
[Text]
hrefs <- Manager -> String -> IO [Text]
httpRawDirectory Manager
mgr String
url
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe URI -> [Text] -> [Text]
defaultFilesFilter (String -> Maybe URI
parseURI String
url) [Text]
hrefs
defaultFilesFilter :: Maybe URI -> [Text] -> [Text]
defaultFilesFilter :: Maybe URI -> [Text] -> [Text]
defaultFilesFilter Maybe URI
mUri =
forall a. Eq a => [a] -> [a]
L.nub forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *). Foldable t => t Bool -> Bool
or forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. [a -> b] -> a -> [b]
flist (forall a b. (a -> b) -> [a] -> [b]
map Text -> Text -> Bool
T.isInfixOf [Text
":", Text
"?", Text
"#"] forall a. [a] -> [a] -> [a]
++ [Text -> Bool
nonTrailingSlash] forall a. [a] -> [a] -> [a]
++ [(forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Text
"../", Text
".."])])) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map Text -> Text
removePath
where
flist :: [a->b] -> a -> [b]
flist :: forall a b. [a -> b] -> a -> [b]
flist [a -> b]
fs a
a = forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ a
a) [a -> b]
fs
removePath :: Text -> Text
removePath :: Text -> Text
removePath Text
t =
case Maybe Text
murlPath of
Maybe Text
Nothing -> Text
t
Just Text
path ->
forall a. a -> Maybe a -> a
fromMaybe Text
t forall a b. (a -> b) -> a -> b
$ Text -> Text -> Maybe Text
T.stripPrefix Text
path Text
t
murlPath :: Maybe Text
murlPath :: Maybe Text
murlPath = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (String -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
trailingSlash forall b c a. (b -> c) -> (a -> b) -> a -> c
. URI -> String
uriPath) Maybe URI
mUri
nonTrailingSlash :: Text -> Bool
nonTrailingSlash :: Text -> Bool
nonTrailingSlash Text
"" = Bool
True
nonTrailingSlash Text
"/" = Bool
True
nonTrailingSlash Text
t =
(Text -> Int
T.length Text
t forall a. Ord a => a -> a -> Bool
> Int
1) Bool -> Bool -> Bool
&& (Text
"/" Text -> Text -> Bool
`T.isInfixOf` Text -> Text
T.init Text
t)
httpDirectory' :: String -> IO [Text]
httpDirectory' :: String -> IO [Text]
httpDirectory' String
url = do
[Text]
hrefs <- String -> IO [Text]
httpRawDirectory' String
url
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe URI -> [Text] -> [Text]
defaultFilesFilter (String -> Maybe URI
parseURI String
url) [Text]
hrefs
httpRawDirectoryInternal :: (Request -> IO (Response BL.ByteString)) -> String
-> IO [Text]
httpRawDirectoryInternal :: (Request -> IO (Response ByteString)) -> String -> IO [Text]
httpRawDirectoryInternal Request -> IO (Response ByteString)
httpreq String
url = do
Request
request <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
Response ByteString
response <- Request -> IO (Response ByteString)
httpreq Request
request
forall r. String -> Response r -> IO ()
checkResponse String
url Response ByteString
response
let body :: ByteString
body = forall body. Response body -> body
responseBody Response ByteString
response
doc :: Document
doc = ByteString -> Document
parseLBS ByteString
body
cursor :: Cursor
cursor = Document -> Cursor
fromDocument Document
doc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Name -> Cursor -> [Text]
attribute Name
"href") forall a b. (a -> b) -> a -> b
$ Cursor
cursor forall node a. Cursor node -> (Cursor node -> [a]) -> [a]
$// Name -> Axis
element Name
"a"
httpRawDirectory :: Manager -> String -> IO [Text]
httpRawDirectory :: Manager -> String -> IO [Text]
httpRawDirectory Manager
mgr = (Request -> IO (Response ByteString)) -> String -> IO [Text]
httpRawDirectoryInternal (forall a b c. (a -> b -> c) -> b -> a -> c
flip Request -> Manager -> IO (Response ByteString)
httpLbs Manager
mgr)
httpRawDirectory' :: String -> IO [Text]
httpRawDirectory' :: String -> IO [Text]
httpRawDirectory' = (Request -> IO (Response ByteString)) -> String -> IO [Text]
httpRawDirectoryInternal forall (m :: * -> *).
MonadIO m =>
Request -> m (Response ByteString)
S.httpLBS
httpExists :: Manager -> String -> IO Bool
httpExists :: Manager -> String -> IO Bool
httpExists Manager
mgr String
url = do
Response ()
response <- Manager -> String -> IO (Response ())
httpHead Manager
mgr String
url
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (forall body. Response body -> Status
responseStatus Response ()
response) forall a. Eq a => a -> a -> Bool
== Int
200
httpExists' :: String -> IO Bool
httpExists' :: String -> IO Bool
httpExists' String
url = do
Response ()
response <- String -> IO (Response ())
httpHead' String
url
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode (forall body. Response body -> Status
responseStatus Response ()
response) forall a. Eq a => a -> a -> Bool
== Int
200
httpFileSize :: Manager -> String -> IO (Maybe Integer)
httpFileSize :: Manager -> String -> IO (Maybe Integer)
httpFileSize Manager
mgr String
url =
Manager -> String -> IO ResponseHeaders
httpFileHeaders Manager
mgr String
url forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentLength
httpFileSize' :: String -> IO (Maybe Integer)
httpFileSize' :: String -> IO (Maybe Integer)
httpFileSize' String
url =
String -> IO ResponseHeaders
httpFileHeaders' String
url forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&>
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentLength
httpLastModified :: Manager -> String -> IO (Maybe UTCTime)
httpLastModified :: Manager -> String -> IO (Maybe UTCTime)
httpLastModified Manager
mgr String
url = do
ResponseHeaders
headers <- Manager -> String -> IO ResponseHeaders
httpFileHeaders Manager
mgr String
url
let mdate :: Maybe ByteString
mdate = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLastModified ResponseHeaders
headers
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HTTPDate -> UTCTime
httpDateToUTC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Maybe HTTPDate
parseHTTPDate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mdate)
httpLastModified' :: String -> IO (Maybe UTCTime)
httpLastModified' :: String -> IO (Maybe UTCTime)
httpLastModified' String
url = do
ResponseHeaders
headers <- String -> IO ResponseHeaders
httpFileHeaders' String
url
let mdate :: Maybe ByteString
mdate = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLastModified ResponseHeaders
headers
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ HTTPDate -> UTCTime
httpDateToUTC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Maybe HTTPDate
parseHTTPDate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mdate)
httpFileSizeTime :: Manager -> String -> IO (Maybe Integer, Maybe UTCTime)
httpFileSizeTime :: Manager -> String -> IO (Maybe Integer, Maybe UTCTime)
httpFileSizeTime Manager
mgr String
url = do
ResponseHeaders
headers <- Manager -> String -> IO ResponseHeaders
httpFileHeaders Manager
mgr String
url
let msize :: Maybe Integer
msize = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentLength ResponseHeaders
headers
mdate :: Maybe ByteString
mdate = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLastModified ResponseHeaders
headers
mtime :: Maybe UTCTime
mtime = HTTPDate -> UTCTime
httpDateToUTC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Maybe HTTPDate
parseHTTPDate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mdate)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer
msize, Maybe UTCTime
mtime)
httpFileSizeTime' :: String -> IO (Maybe Integer, Maybe UTCTime)
httpFileSizeTime' :: String -> IO (Maybe Integer, Maybe UTCTime)
httpFileSizeTime' String
url = do
ResponseHeaders
headers <- String -> IO ResponseHeaders
httpFileHeaders' String
url
let msize :: Maybe Integer
msize = forall a. Read a => String -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
B.unpack forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentLength ResponseHeaders
headers
mdate :: Maybe ByteString
mdate = forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLastModified ResponseHeaders
headers
mtime :: Maybe UTCTime
mtime = HTTPDate -> UTCTime
httpDateToUTC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ByteString -> Maybe HTTPDate
parseHTTPDate forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe ByteString
mdate)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Integer
msize, Maybe UTCTime
mtime)
httpFileHeaders :: Manager -> String -> IO ResponseHeaders
Manager
mgr String
url = do
Response ()
response <- Manager -> String -> IO (Response ())
httpHead Manager
mgr String
url
forall r. String -> Response r -> IO ()
checkResponse String
url Response ()
response
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response ()
response
httpFileHeaders' :: String -> IO ResponseHeaders
String
url = do
Response ()
response <- String -> IO (Response ())
httpHead' String
url
forall r. String -> Response r -> IO ()
checkResponse String
url Response ()
response
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall body. Response body -> ResponseHeaders
responseHeaders Response ()
response
checkResponse :: String -> Response r -> IO ()
checkResponse :: forall r. String -> Response r -> IO ()
checkResponse String
url Response r
response =
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Status -> Int
statusCode (forall body. Response body -> Status
responseStatus Response r
response) forall a. Eq a => a -> a -> Bool
/= Int
200) forall a b. (a -> b) -> a -> b
$ do
String -> IO ()
putStrLn String
url
forall a. String -> a
error' forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show forall a b. (a -> b) -> a -> b
$ forall body. Response body -> Status
responseStatus Response r
response
httpManager :: IO Manager
httpManager :: IO Manager
httpManager =
ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
httpRedirects :: Manager -> String -> IO [B.ByteString]
httpRedirects :: Manager -> String -> IO [ByteString]
httpRedirects Manager
mgr String
url = do
Request
request <- String -> IO Request
parseRequestHead String
url
HistoriedResponse BodyReader
respHist <- Request -> Manager -> IO (HistoriedResponse BodyReader)
responseOpenHistory Request
request Manager
mgr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hLocation forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> ResponseHeaders
responseHeaders forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) forall a b. (a -> b) -> a -> b
$ forall body.
HistoriedResponse body -> [(Request, Response ByteString)]
hrRedirects HistoriedResponse BodyReader
respHist
httpRedirect :: Manager -> String -> IO (Maybe B.ByteString)
httpRedirect :: Manager -> String -> IO (Maybe ByteString)
httpRedirect Manager
mgr String
url =
forall a. [a] -> Maybe a
listToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Manager -> String -> IO [ByteString]
httpRedirects Manager
mgr String
url
httpRedirect' :: String -> IO (Maybe B.ByteString)
httpRedirect' :: String -> IO (Maybe ByteString)
httpRedirect' String
url = do
Manager
mgr <- IO Manager
httpManager
forall a. [a] -> Maybe a
listToMaybe forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Manager -> String -> IO [ByteString]
httpRedirects Manager
mgr String
url
parseRequestHead :: String -> IO Request
parseRequestHead :: String -> IO Request
parseRequestHead String
url = do
Request
request <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Request
request {method :: ByteString
method = ByteString
methodHead}
httpHead :: Manager -> String -> IO (Response ())
httpHead :: Manager -> String -> IO (Response ())
httpHead Manager
mgr String
url = do
Request
request <- String -> IO Request
parseRequestHead String
url
Request -> Manager -> IO (Response ())
httpNoBody Request
request Manager
mgr
httpHead' :: String -> IO (Response ())
httpHead' :: String -> IO (Response ())
httpHead' String
url = do
Request
request <- String -> IO Request
parseRequestHead String
url
forall (m :: * -> *). MonadIO m => Request -> m (Response ())
S.httpNoBody Request
request
isHttpUrl :: String -> Bool
isHttpUrl :: String -> Bool
isHttpUrl String
loc = String
"http:" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
loc Bool -> Bool -> Bool
|| String
"https:" forall a. Eq a => [a] -> [a] -> Bool
`L.isPrefixOf` String
loc
trailingSlash :: String -> String
trailingSlash :: String -> String
trailingSlash String
"" = String
""
trailingSlash String
str =
if forall a. [a] -> a
last String
str forall a. Eq a => a -> a -> Bool
== Char
'/' then String
str else String
str forall a. [a] -> [a] -> [a]
++ String
"/"
noTrailingSlash :: Text -> Text
noTrailingSlash :: Text -> Text
noTrailingSlash = (Char -> Bool) -> Text -> Text
T.dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'/')
error' :: String -> a
#if (defined(MIN_VERSION_base) && MIN_VERSION_base(4,9,0))
error' :: forall a. String -> a
error' = forall a. String -> a
errorWithoutStackTrace
#else
error' = error
#endif
infixr 5 +/+
(+/+) :: String -> String -> String
String
"" +/+ :: String -> String -> String
+/+ String
s = String
s
String
s +/+ String
"" = String
s
String
s +/+ String
t | forall a. [a] -> a
last String
s forall a. Eq a => a -> a -> Bool
== Char
'/' = forall a. [a] -> [a]
init String
s String -> String -> String
+/+ String
t
| forall a. [a] -> a
head String
t forall a. Eq a => a -> a -> Bool
== Char
'/' = String
s String -> String -> String
+/+ forall a. [a] -> [a]
tail String
t
String
s +/+ String
t = String
s forall a. [a] -> [a] -> [a]
++ String
"/" forall a. [a] -> [a] -> [a]
++ String
t
#if !MIN_VERSION_base(4,11,0)
infixl 1 <&>
(<&>) :: Functor f => f a -> (a -> b) -> f b
as <&> f = f <$> as
#endif