+{-# LANGUAGE DoAndIfThenElse #-}
+
module LWN.HTTP
where
-import Network.Curl (
- CurlCode(..),
- CurlOption(..),
- CurlResponse,
- URLString,
- do_curl_,
- initialize,
- respBody,
- respCurlCode,
- withCurlDo
+import Control.Concurrent.ParallelIO (parallel)
+import qualified Data.ByteString.Char8 as C (ByteString, pack)
+import qualified Data.ByteString.Lazy as L (ByteString, hPut)
+import Data.ByteString.Lazy.UTF8 (toString)
+import qualified Data.Map as Map (Map, empty, insert)
+import Data.Maybe (fromJust, isNothing)
+import Data.Time (getCurrentTime)
+import Network.HTTP.Conduit (
+ CookieJar,
+ Response(..),
+ Request(..),
+ httpLbs,
+ insertCookiesIntoRequest,
+ parseUrl,
+ updateCookieJar,
+ urlEncodedBody,
+ withManager
)
+import Network.HTTP.Types (status200, status302)
+import Network.HTTP.Types.Method (methodPost)
+import System.Directory (doesFileExist, getTemporaryDirectory)
import System.IO (hPutStrLn, stderr)
+import qualified System.IO.UTF8 as Utf8 (readFile)
+import System.IO.Temp (openBinaryTempFile)
-login_url :: URLString
-login_url = "https://lwn.net/login"
+-- Also grab the empty cookie jar from Configuration since we'll
+-- use it in a few places.
+import qualified Configuration as C (Cfg(..), cj_empty)
+import LWN.Article (real_article_path)
+import LWN.URI (URL, filename)
-username_field :: String
-username_field = "Username"
+-- | The type of response we get back from http-conduit's httpLbs.
+type LBSResponse = Response L.ByteString
-password_field :: String
-password_field = "Password"
-submit_field :: String
-submit_field = "submit"
+login_url :: URL
+login_url = "https://lwn.net/login"
+
+username_field :: C.ByteString
+username_field = C.pack "Username"
+password_field :: C.ByteString
+password_field = C.pack "Password"
-default_curl_opts :: [CurlOption]
-default_curl_opts =
- [ -- The Global cache is not thread-friendly.
- CurlDNSUseGlobalCache False,
-
- -- And we don't want to use a DNS cache anyway.
- CurlDNSCacheTimeout 0,
+submit_field :: C.ByteString
+submit_field = C.pack "submit"
- -- Give it a little time...
- CurlTimeout 45,
- -- And let us know when things go wrong.
- CurlVerbose True ]
+-- | Get the requested URL as a L.ByteString, or return the response
+-- as an error. Use the given cookie jar for the request.
+get_page :: CookieJar -> URL -> IO (Either LBSResponse L.ByteString)
+get_page cj url = do
+ init_req <- parseUrl url
+ let req' = init_req { checkStatus = \_ _ -> Nothing }
+ now <- getCurrentTime
+ let (req, _) = insertCookiesIntoRequest req' cj now
+ resp <- withManager $ httpLbs req
+ return $ if (responseStatus resp) == status200 then
+ Right (responseBody resp)
+ else
+ Left resp
-get_page :: Maybe FilePath -> URLString -> IO (Maybe String)
-get_page cookie_jar url =
- withCurlDo $ do
- -- Create a curl instance.
- curl <- initialize
+-- | Log in using curl. Store the resulting session cookies in the
+-- supplied file.
+log_in :: String -> String -> IO (Either LBSResponse CookieJar)
+log_in username password = do
+ init_req <- parseUrl login_url
+ let req' = init_req { method = methodPost,
+ checkStatus = \_ _ -> Nothing,
+ redirectCount = 0 }
+ let req = urlEncodedBody post_data req'
- -- Perform the request, and get back a CurlResponse object.
- -- The cast is needed to specify how we would like our headers
- -- and body returned (Strings).
- resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
+ resp <- withManager $ httpLbs req
- -- Pull out the response code as a CurlCode.
- let code = respCurlCode resp
+ -- The login page redirects. If we follow it, we lose our cookies.
+ if (responseStatus resp) == status302 then do
+ now <- getCurrentTime
+ let (cj,_) = updateCookieJar resp req now C.cj_empty
+ return $ Right cj
+ else do
+ return $ Left resp
- case code of
- CurlOK -> return $ Just (respBody resp)
- error_code -> do
- hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
- -- If an error occurred, we want to dump as much information as
- -- possible. If this becomes a problem, we can use respGetInfo to
- -- query the response object for more information
- return Nothing
where
- get_opts =
- case cookie_jar of
- Nothing -> []
- Just cookies -> [ CurlCookieJar cookies ]
-
- curl_opts = default_curl_opts ++ get_opts
-
-
-log_in :: FilePath -> String -> String -> IO Bool
-log_in cookie_jar username password =
- withCurlDo $ do
- -- Create a curl instance.
- curl <- initialize
-
- -- Perform the request, and get back a CurlResponse object.
- -- The cast is needed to specify how we would like our headers
- -- and body returned (Strings).
- resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
-
- -- Pull out the response code as a CurlCode.
- let code = respCurlCode resp
-
- case code of
- CurlOK -> return True
- error_code -> do
- hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
- -- If an error occurred, we want to dump as much information as
- -- possible. If this becomes a problem, we can use respGetInfo to
- -- query the response object for more information
- return False
+ post_submit :: (C.ByteString, C.ByteString)
+ post_submit = (submit_field, C.pack "Log+In")
+
+ post_username :: (C.ByteString, C.ByteString)
+ post_username = (username_field, C.pack username)
+
+ post_password :: (C.ByteString, C.ByteString)
+ post_password = (password_field, C.pack password)
+
+ post_data :: [(C.ByteString, C.ByteString)]
+ post_data = [post_username, post_password, post_submit]
+
+
+
+-- | Save the image at 'url'. Saves to a temporary file, and
+-- returns the path to that file if successful. Otherwise,
+-- returns 'Nothing'.
+--
+-- We need to be able to parse the filename out of the URL
+-- so that when we stick our image in the document, the reader
+-- knows that type (jpg, png, etc.) it is.
+save_image :: URL -> IO (Maybe FilePath)
+save_image url = do
+ it_exists <- doesFileExist url
+ if it_exists then do
+ -- It's local, just use it.
+ return $ Just url
+ else do
+ let fn = filename url
+ case fn of
+ Nothing -> return Nothing
+ Just file -> do
+ temp_dir <- getTemporaryDirectory
+ (out_path, out_handle) <- openBinaryTempFile temp_dir file
+ -- We don't need to be logged in to get the images, so use an
+ -- empty cookie jar.
+ result <- get_page C.cj_empty url
+ case result of
+ Left err -> do
+ hPutStrLn stderr $ "Failed to retrieve image. " ++
+ "Server response:\n" ++ (show err)
+ return Nothing
+ Right bs -> do
+ L.hPut out_handle bs
+ return $ Just out_path
+
+
+
+
+-- | Map absolute image URLs to local system file paths where the
+-- image referenced by the URL is stored.
+type ImageMap = Map.Map URL FilePath
+
+download_image_urls :: [URL] -> IO ImageMap
+download_image_urls image_urls = do
+ files <- parallel $ map save_image image_urls
+ let pairs = zip image_urls files
+ return $ foldl my_insert empty_map pairs
where
- post_submit :: String
- post_submit = submit_field ++ "=Log+In"
-
- post_username :: String
- post_username = username_field ++ "=" ++ username
-
- post_password :: String
- post_password = password_field ++ "=" ++ password
-
- post_data :: [String]
- post_data = [post_username, post_password]
-
- post_opts :: [CurlOption]
- post_opts =
- [ CurlCookieSession True,
- CurlCookieJar cookie_jar,
- CurlPost True,
- CurlPostFields post_data ]
-
- curl_opts :: [CurlOption]
- curl_opts = default_curl_opts ++ post_opts
+ empty_map = Map.empty :: ImageMap
+
+ my_insert :: ImageMap -> (URL, Maybe FilePath) -> ImageMap
+ my_insert dict (_, Nothing) = dict
+ my_insert dict (k, Just v) = Map.insert k v dict
+
+
+
+
+
+get_login_cookie :: C.Cfg -> IO C.Cfg
+get_login_cookie cfg
+ | isNothing (C.username cfg) = return cfg
+ | isNothing (C.password cfg) = return cfg
+ | otherwise = do
+ let uname = fromJust $ C.username cfg
+ let pword = fromJust $ C.password cfg
+ li_result <- log_in uname pword
+
+ case li_result of
+ Left err -> do
+ let msg = "Failed to log in. Server response:\n" ++ (show err)
+ hPutStrLn stderr msg
+ return cfg
+ Right cj -> return $ cfg { C.cookie_jar = cj }
+
+
+-- | Try to parse the given article using HXT. We try a few different
+-- methods; if none of them work, we return 'Nothing'.
+get_article_contents :: C.Cfg -> URL -> IO (Maybe String)
+get_article_contents cfg article_name = do
+ my_article <- real_article_path article_name
+ is_file <- doesFileExist my_article
+ case is_file of
+ True -> do
+ contents <- Utf8.readFile my_article
+ return $ Just $ contents
+ False -> do
+ -- Download the URL.
+ html <- get_page (C.cookie_jar cfg) my_article
+
+ case html of
+ Left err -> do
+ let msg = "Failed to retrieve article. " ++
+ "Server response:\n" ++ (show err)
+ hPutStrLn stderr msg
+ return Nothing
+ Right lbs_article ->
+ return $ Just (toString lbs_article)
projects / dead / lwn-epub.git / blobdiff