X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Flwn-epub.git;a=blobdiff_plain;f=src%2FLWN%2FHTTP.hs;h=6216a0f1282e7a7fb1cb674ee557062254328438;hp=1b6bcfd3c966a060ea326a06245f67811f66ba9a;hb=cf0659082f2d0e6afa6b43a6ad55432a00b155e9;hpb=e9151ade502fa997be41b6e37fb9841cacd0f528 diff --git a/src/LWN/HTTP.hs b/src/LWN/HTTP.hs index 1b6bcfd..6216a0f 100644 --- a/src/LWN/HTTP.hs +++ b/src/LWN/HTTP.hs @@ -3,141 +3,103 @@ module LWN.HTTP where -import qualified Data.ByteString as B (hPut) - -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.Curl.Download (openURI) +import Network.HTTP.Types (status200, status302) +import Network.HTTP.Types.Method (methodPost) import System.Directory (doesFileExist, getTemporaryDirectory) -import System.IO (hClose, hPutStrLn, stderr) -import System.IO.Temp (openBinaryTempFile, openTempFile) +import System.IO (hPutStrLn, stderr) +import qualified System.IO.UTF8 as Utf8 (readFile) +import System.IO.Temp (openBinaryTempFile) -import LWN.URI (filename) - -login_url :: URLString -login_url = "https://lwn.net/login" - -username_field :: String -username_field = "Username" - -password_field :: String -password_field = "Password" - -submit_field :: String -submit_field = "submit" +-- 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) +-- | The type of response we get back from http-conduit's httpLbs. +type LBSResponse = Response L.ByteString -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, - - -- Follow redirects. - CurlFollowLocation True, - - -- Give it a little time... - CurlTimeout 45, - - -- For debugging. - CurlVerbose True ] +login_url :: URL +login_url = "https://lwn.net/login" -make_cookie_jar :: IO FilePath -make_cookie_jar = do - temp_dir <- getTemporaryDirectory - let file_name_template = "lwn-epub-cookies.txt" - (out_path, out_handle) <- openTempFile temp_dir file_name_template - hClose out_handle -- We just want to create it for now. - return out_path +username_field :: C.ByteString +username_field = C.pack "Username" -get_page :: Maybe FilePath -> URLString -> IO (Either String String) -get_page cookie_file url = - withCurlDo $ do - -- Create a curl instance. - curl <- initialize +password_field :: C.ByteString +password_field = C.pack "Password" - -- 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 url curl_opts :: IO CurlResponse +submit_field :: C.ByteString +submit_field = C.pack "submit" - -- Pull out the response code as a CurlCode. - let code = respCurlCode resp - return $ - case code of - CurlOK -> Right (respBody resp) - error_code -> Left ("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 - where - get_opts = - case cookie_file of - Nothing -> [] - Just cookies -> [ CurlCookieFile cookies ] +-- | 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 - curl_opts = default_curl_opts ++ get_opts + return $ if (responseStatus resp) == status200 then + Right (responseBody resp) + else + Left resp -- | Log in using curl. Store the resulting session cookies in the --- supplied file.Warning: This returns an error if the function --- fails! -log_in :: FilePath -> String -> String -> IO (Maybe String) -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 - - return $ - case code of - CurlOK -> Nothing - error_code -> Just $ "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 +-- 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' + + resp <- withManager $ httpLbs req + + -- 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 + where - post_submit :: String - post_submit = submit_field ++ "=Log+In" + post_submit :: (C.ByteString, C.ByteString) + post_submit = (submit_field, C.pack "Log+In") - post_username :: String - post_username = username_field ++ "=" ++ username + post_username :: (C.ByteString, C.ByteString) + post_username = (username_field, C.pack username) - post_password :: String - post_password = password_field ++ "=" ++ password + post_password :: (C.ByteString, C.ByteString) + post_password = (password_field, C.pack password) - post_data :: [String] + post_data :: [(C.ByteString, C.ByteString)] post_data = [post_username, post_password, post_submit] - 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 -- | Save the image at 'url'. Saves to a temporary file, and @@ -147,7 +109,7 @@ log_in cookie_jar username password = -- 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 :: URLString -> IO (Maybe FilePath) +save_image :: URL -> IO (Maybe FilePath) save_image url = do it_exists <- doesFileExist url if it_exists then do @@ -160,11 +122,77 @@ save_image url = do Just file -> do temp_dir <- getTemporaryDirectory (out_path, out_handle) <- openBinaryTempFile temp_dir file - result <- openURI url + -- 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 ("HTTP Error: " ++ err) + hPutStrLn stderr $ "Failed to retrieve image. " ++ + "Server response:\n" ++ (show err) return Nothing Right bs -> do - B.hPut out_handle bs + 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 + 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)