X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Flwn-epub.git;a=blobdiff_plain;f=src%2FMain.hs;h=74971fdb05529f7feefad0bc9486e19d38f2e727;hp=924b9a558dd59df682d9cbdb3713fceaad0b27f1;hb=96249c993a34237c6e6df772eb36858e70ce9b34;hpb=b18c060e5cb708901eb29f1f27b25c467875a143 diff --git a/src/Main.hs b/src/Main.hs index 924b9a5..74971fd 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,13 +1,17 @@ -{-# LANGUAGE ScopedTypeVariables, RecordWildCards #-} +{-# LANGUAGE DoAndIfThenElse #-} module Main where +import Data.List (isPrefixOf) +import Data.Maybe (fromJust) import Prelude hiding (readFile) import System.Directory (doesFileExist) import System.IO ( Handle, IOMode (WriteMode), + hPutStrLn, openBinaryFile, + stderr, stdout ) import System.IO.UTF8 (readFile) @@ -15,13 +19,27 @@ import Test.HUnit (Assertion, assertEqual) import Test.Framework (Test, testGroup) import Test.Framework.Providers.HUnit (testCase) import Text.Regex.Posix ((=~)) -import Text.XML.HXT.Core - +import Text.XML.HXT.Core ( + IOStateArrow, + SysConfigList, + XmlTree, + no, + readString, + withParseHTML, + withValidate, + withWarnings, + yes + ) import CommandLine (show_help) -import Configuration (Cfg(..), get_cfg) -import LWN.Page -import LWN.URI (is_lwn_url, make_absolute_url, make_https) -import Misc (contains) +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, + try_make_absolute_url, + make_https) + my_read_opts :: SysConfigList @@ -33,19 +51,49 @@ my_read_opts = [ withValidate no, my_read :: String -> IOStateArrow s b XmlTree my_read = readString my_read_opts + -- | 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 :: String -> IO (Maybe (IOStateArrow s b XmlTree)) -get_xml_from_article s = do - article <- real_article_path s - is_file <- doesFileExist article +get_xml_from_article :: Cfg -> IO (Maybe (IOStateArrow s b XmlTree)) +get_xml_from_article cfg = do + my_article <- real_article_path (article cfg) + is_file <- doesFileExist my_article case is_file of True -> do - contents <- readFile article + contents <- readFile my_article return $ Just $ my_read contents False -> do -- Download the URL and try to parse it. - return Nothing + if use_account cfg then do + -- use_account would be false if these fromJusts would fail. + cj <- make_cookie_jar + li_result <- log_in cj + (fromJust $ username cfg) + (fromJust $ password cfg) + + 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 + + case html of + Left err -> do + let msg = "Failed to retrieve page. " ++ err + hPutStrLn stderr msg + return Nothing + Right h -> return $ Just $ my_read h + else do + html <- get_page Nothing my_article + case html of + Left err -> do + let msg = "Failed to retrieve page. " ++ err + hPutStrLn stderr msg + return Nothing + Right h -> return $ Just $ my_read h -- | If we're given an empty path, return a handle to -- 'stdout'. Otherwise, open the given file and return a read/write @@ -65,34 +113,27 @@ 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 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 - maybe_html <- get_xml_from_article article + cfg <- get_cfg + output_handle <- get_output_handle (output cfg) + maybe_html <- get_xml_from_article cfg case maybe_html of - Just html -> do result <- parse html case result of @@ -106,16 +147,21 @@ main = do return () - test_current_article_path :: Assertion test_current_article_path = do - let expected = "https://lwn.net/current" + let expected = "https://lwn.net/current/" 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" + let expected = "https://lwn.net/Articles/69/" actual <- real_article_path "69" -- I'm twelve assertEqual "Numbered article path constructed" expected actual @@ -136,7 +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 ] - \ No newline at end of file