From 8202cb1437ece6be41677c0bbdae4713041199ac Mon Sep 17 00:00:00 2001 From: Michael Orlitzky Date: Fri, 29 Jun 2012 01:30:29 -0400 Subject: [PATCH] Final cleanups to get the download working. Fix current/bigpage URL handling. Add a test for current/bigpage URLs. --- src/LWN/HTTP.hs | 14 ++++------ src/LWN/Page.hs | 5 ++-- src/LWN/URI.hs | 7 ++--- src/Main.hs | 71 ++++++++++++++++++++++--------------------------- 4 files changed, 44 insertions(+), 53 deletions(-) diff --git a/src/LWN/HTTP.hs b/src/LWN/HTTP.hs index 1b6bcfd..71058dc 100644 --- a/src/LWN/HTTP.hs +++ b/src/LWN/HTTP.hs @@ -48,10 +48,7 @@ default_curl_opts = CurlFollowLocation True, -- Give it a little time... - CurlTimeout 45, - - -- For debugging. - CurlVerbose True ] + CurlTimeout 45 ] make_cookie_jar :: IO FilePath @@ -93,9 +90,8 @@ get_page cookie_file url = -- | 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) +-- supplied file. +log_in :: FilePath -> String -> String -> IO (Either String String) log_in cookie_jar username password = withCurlDo $ do -- Create a curl instance. @@ -111,8 +107,8 @@ log_in cookie_jar username password = return $ case code of - CurlOK -> Nothing - error_code -> Just $ "HTTP Error: " ++ (show error_code) + 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 diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs index 7419402..bdfe8ca 100644 --- a/src/LWN/Page.hs +++ b/src/LWN/Page.hs @@ -5,7 +5,7 @@ where import qualified Data.Map as Map import Data.Time (getCurrentTime) -import System.IO (Handle) +import System.IO (Handle, hClose, hFlush) import qualified Data.ByteString.Lazy as B (ByteString, hPut) import Data.String.Utils (split, strip) import Data.Maybe (catMaybes, fromJust, isNothing) @@ -393,7 +393,8 @@ epublish obj handle = do epmd <- metadata obj epub <- xhtml_to_epub epmd xhtml B.hPut handle epub - + hFlush handle + hClose handle xhtml_to_epub :: String -> String -> IO B.ByteString xhtml_to_epub epmd = diff --git a/src/LWN/URI.hs b/src/LWN/URI.hs index 3a21413..d9076c4 100644 --- a/src/LWN/URI.hs +++ b/src/LWN/URI.hs @@ -54,15 +54,16 @@ make_https url = parse_result = parseURIReference url - add_trailing_slash :: URL -> URL add_trailing_slash url = case parse_result of Nothing -> url -- Shrug? Just uri -> let old_path = uriPath uri in - if isSuffixOf "/" old_path then - url -- It already had a trailing slash + if (isSuffixOf "/" old_path) || (isSuffixOf "bigpage" old_path) then + -- It already had a trailing slash, or it's a 'bigpage' URL. + -- Trailing slashes after 'bigpage' don't work. + url else show $ uri { uriPath = old_path ++ "/" } where diff --git a/src/Main.hs b/src/Main.hs index 2700038..74971fd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -2,9 +2,8 @@ module Main where -import Control.Concurrent (threadDelay) -import Control.Monad (when) -import Data.Maybe (fromJust, isJust) +import Data.List (isPrefixOf) +import Data.Maybe (fromJust) import Prelude hiding (readFile) import System.Directory (doesFileExist) import System.IO ( @@ -35,8 +34,12 @@ import CommandLine (show_help) import Configuration (Cfg(..), get_cfg, use_account) import LWN.HTTP (get_page, log_in, make_cookie_jar) import LWN.Page (epublish, parse) -import LWN.URI (add_trailing_slash, is_lwn_url, make_absolute_url, make_https) -import Misc (contains) +import LWN.URI ( + add_trailing_slash, + is_lwn_url, + try_make_absolute_url, + make_https) + my_read_opts :: SysConfigList @@ -49,14 +52,6 @@ my_read :: String -> IOStateArrow s b XmlTree my_read = readString my_read_opts --- |A wrapper around threadDelay which takes seconds instead of --- microseconds as its argument. -thread_sleep :: Int -> IO () -thread_sleep seconds = do - let microseconds = seconds * (10 ^ (6 :: Int)) - threadDelay microseconds - - -- | Try to parse the given article using HXT. We try a few different -- methods; if none of them work, we return 'Nothing'. get_xml_from_article :: Cfg -> IO (Maybe (IOStateArrow s b XmlTree)) @@ -76,13 +71,12 @@ get_xml_from_article cfg = do (fromJust $ username cfg) (fromJust $ password cfg) - -- Without this, the cookie file is empty during - -- get_page. Whaaat? - thread_sleep 1 - - when (isJust li_result) $ do - let msg = "Failed to log in. " ++ (fromJust li_result) - hPutStrLn stderr msg + case li_result of + Left err -> do + let msg = "Failed to log in. " ++ err + hPutStrLn stderr msg + Right response_body -> do + hPutStrLn stderr response_body html <- get_page (Just cj) my_article @@ -119,34 +113,24 @@ get_output_handle path = -- that, we try to construct a URL from what we're given and do our -- best. real_article_path :: String -> IO String -real_article_path s = do - is_file <- doesFileExist s - return $ if is_file then s else add_trailing_slash check_cases +real_article_path path = do + is_file <- doesFileExist path + return $ if is_file then path else add_trailing_slash check_cases where - abs_current = - case make_absolute_url "current" of - Nothing -> s - Just ac -> ac - abs_article = - case make_absolute_url ("Articles/" ++ s) of - Nothing -> s - Just as -> as + abs_current = try_make_absolute_url ("/" ++ path) + abs_article = try_make_absolute_url ("Articles/" ++ path) check_cases :: String check_cases - | is_lwn_url s = make_https s - | s `contains` "current" = abs_current - | s =~ "^[0-9]+$" = abs_article - | otherwise = s -- Give up + | is_lwn_url path = make_https path + | isPrefixOf "current" path = abs_current + | path =~ "^[0-9]+$" = abs_article + | otherwise = path -- Give up main :: IO () main = do cfg <- get_cfg output_handle <- get_output_handle (output cfg) - - when (use_account cfg) $ do - putStrLn "Using account." - maybe_html <- get_xml_from_article cfg case maybe_html of @@ -169,6 +153,12 @@ test_current_article_path = do actual <- real_article_path "current" assertEqual "Current article path constructed" expected actual +test_current_bigpage_article_path :: Assertion +test_current_bigpage_article_path = do + let expected = "https://lwn.net/current/bigpage" + actual <- real_article_path "current/bigpage" + assertEqual "Current bigpage article path constructed" expected actual + test_numbered_article_path :: Assertion test_numbered_article_path = do let expected = "https://lwn.net/Articles/69/" @@ -192,6 +182,9 @@ main_tests :: Test main_tests = testGroup "Main Tests" [ testCase "Current article path constructed" test_current_article_path, + testCase + "Current bigpage article path constructed" + test_current_bigpage_article_path, testCase "Numbered article path constructed" test_numbered_article_path, testCase "Full article path left alone" test_full_article_path, testCase "Non-https URL made https" test_non_https_article_path ] -- 2.43.2