From: Michael Orlitzky Date: Thu, 23 Aug 2012 03:13:43 +0000 (-0400) Subject: Merge branch 'master' of michael.orlitzky.com:/var/www/orlitzky.com/michael/public... X-Git-Url: http://gitweb.michael.orlitzky.com/?p=dead%2Flwn-epub.git;a=commitdiff_plain;h=7b567f5bc275be3212d485e2fe537949c921df3d;hp=ac752b19d20e01771664ce50528d7f306bd2de9e Merge branch 'master' of michael.orlitzky.com:/var/www/orlitzky.com/michael/public/git/lwn-epub --- diff --git a/lwn-epub.cabal b/lwn-epub.cabal index 08ee1bf..61b3270 100644 --- a/lwn-epub.cabal +++ b/lwn-epub.cabal @@ -1,11 +1,21 @@ name: lwn-epub -version: 0.0 +version: 0.0.2 cabal-version: >= 1.8 author: Michael Orlitzky maintainer: Michael Orlitzky +license: GPL-3 +license-file: doc/LICENSE +homepage: http://michael.orlitzky.com/code/lwn-epub.php +bug-reports: mailto:michael@orlitzky.com +build-type: Simple +category: Text synopsis: Convert issues of LWN (lwn.net) to EPUB format. -build-type: Simple +description: + A command-line utility that downloads an LWN article (or issue), cleans it + up, and writes it to EPUB with a stylesheet that looks decent on the Kindle. + It can use account credentials to log in and access the current edition. +data-files: makefile doc/README executable lwn-epub build-depends: @@ -14,12 +24,11 @@ executable lwn-epub cmdargs == 0.9.*, ConfigFile == 1.*, containers == 0.*, - curl == 1.*, directory == 1.1.*, - download-curl == 0.1.*, filepath == 1.3.*, HandsomeSoup == 0.3.*, - HUnit == 1.2.*, + http-conduit == 1.6.*, + http-types == 0.7.*, hxt == 9.*, MissingH == 1.1.*, network == 2.3.*, @@ -27,10 +36,12 @@ executable lwn-epub parallel-io == 0.3.*, regex-posix == 0.95.*, temporary == 1.*, - test-framework == 0.6.*, - test-framework-hunit == 0.2.*, time == 1.*, - utf8-string == 0.3.* + utf8-string == 0.3.*, + -- Additional test dependencies. + HUnit == 1.2.*, + test-framework == 0.6.*, + test-framework-hunit == 0.2.* main-is: Main.hs @@ -49,11 +60,52 @@ executable lwn-epub -fwarn-incomplete-record-updates -fwarn-monomorphism-restriction -fwarn-unused-do-bind - -funbox-strict-fields - -fexcess-precision - -fno-spec-constr-count -rtsopts -threaded -O2 -optc-O3 -optc-march=native + + +test-suite testsuite + type: exitcode-stdio-1.0 + hs-source-dirs: src test + main-is: TestSuite.hs + build-depends: + base == 4.5.*, + bytestring == 0.9.*, + cmdargs == 0.9.*, + ConfigFile == 1.*, + containers == 0.*, + directory == 1.1.*, + filepath == 1.3.*, + HandsomeSoup == 0.3.*, + http-conduit == 1.6.*, + http-types == 0.7.*, + hxt == 9.*, + MissingH == 1.1.*, + network == 2.3.*, + pandoc == 1.9.*, + parallel-io == 0.3.*, + regex-posix == 0.95.*, + temporary == 1.*, + time == 1.*, + utf8-string == 0.3.*, + -- Additional test dependencies. + HUnit == 1.2.*, + test-framework == 0.6.*, + test-framework-hunit == 0.2.* + + -- It's not entirely clear to me why I have to reproduce all of this. + ghc-options: + -rtsopts + -threaded + -O2 + -optc-O3 + -optc-march=native + + +source-repository head + type: git + location: http://michael.orlitzky.com/git/lwn-epub.git + branch: master diff --git a/makefile b/makefile index a848bcc..69ab48d 100644 --- a/makefile +++ b/makefile @@ -1,9 +1,10 @@ -.PHONY : test publish_doc doc src_html hlint +.PHONY : test dist # There's onlt one '$' in the awk script, but we have to double-money # it for make. PN = $(shell grep 'name:' *.cabal | awk '{ print $$2 }') BIN = dist/build/$(PN)/$(PN) +TESTSUITE_BIN = dist/build/testsuite/testsuite SRCS = $(shell find src/ -name '*.hs') $(BIN): $(SRCS) @@ -11,6 +12,10 @@ $(BIN): $(SRCS) runghc Setup.hs configure --user --flags=${FLAGS} runghc Setup.hs build +$(TESTSUITE_BIN): src/*.hs test/TestSuite.hs + runghc Setup.hs configure --user --flags=${FLAGS} --enable-tests + runghc Setup.hs build + clean: runghc Setup.hs clean rm -f dist/ @@ -20,15 +25,9 @@ clean: install: $(BIN) runghc Setup.hs install -# Neither 'haddock' nor 'hscolour' seem to work properly. -doc: src_html - runghc Setup.hs hscolour --executables - runghc Setup.hs haddock --internal \ - --executables \ - --hyperlink-source - -dist/build/autogen: $(BIN) - +dist: + runghc Setup.hs configure + runghc Setup.hs sdist -test: dist/build/autogen - runghc -i"src" -i"dist/build/autogen" test/TestSuite.hs +test: $(BIN) $(TESTSUITE_BIN) + runghc Setup.hs test diff --git a/src/CommandLine.hs b/src/CommandLine.hs index 2df29a5..0a31170 100644 --- a/src/CommandLine.hs +++ b/src/CommandLine.hs @@ -80,8 +80,8 @@ is_missing_arg_error s = startswith "Requires at least" s -show_help :: IO (CmdArgs Args) -show_help = withArgs ["--help"] parse_args +show_help :: IO Args +show_help = withArgs ["--help"] apply_args parse_args :: IO (CmdArgs Args) parse_args = do @@ -91,8 +91,9 @@ parse_args = do Right result -> return result Left err -> if (is_missing_arg_error err) then - -- Disregard the error message, show help instead. - show_help + -- Disregard the error message, show help instead. We can't + -- reuse show_help here because of its return type. + withArgs ["--help"] parse_args else do hPutStrLn stderr err exitWith (ExitFailure exit_args_parse_failed) diff --git a/src/Configuration.hs b/src/Configuration.hs index 118f10f..4d56043 100644 --- a/src/Configuration.hs +++ b/src/Configuration.hs @@ -2,15 +2,16 @@ module Configuration ( Cfg(..), + cj_empty, get_cfg, use_account ) where -import Control.Monad (mplus) import Data.ConfigFile import Data.Maybe (isJust) import Data.Monoid (Monoid(..)) +import Network.HTTP.Conduit (CookieJar, createCookieJar, destroyCookieJar) import System.Directory ( doesFileExist, getAppUserDataDirectory @@ -29,27 +30,42 @@ import ExitCodes -- | Contains all of our configurable options. data Cfg = Cfg { article :: String, - cookie_jar :: Maybe FilePath, + cookie_jar :: CookieJar, full_stories :: Bool, output :: FilePath, password :: Maybe String, username :: Maybe String } +-- An empty CookieJar. See cj_append for rationale. +cj_empty :: CookieJar +cj_empty = createCookieJar [] + + +-- Defined for convenience; I would really like to use mappend but GHC +-- bitches about the orphan instance. +cj_append :: CookieJar -> CookieJar -> CookieJar +cj_append cj1 cj2 = + createCookieJar (cookies1 ++ cookies2) + where + -- Decompose the cookie jars into lists. + cookies1 = destroyCookieJar cj1 + cookies2 = destroyCookieJar cj2 + instance Monoid Cfg where - mempty = Cfg { article = "", - cookie_jar = Nothing, + mempty = Cfg { article = mempty, + cookie_jar = cj_empty, full_stories = False, - output = "", + output = mempty, password = Nothing, username = Nothing } mappend c1 c2 = let article' = (if null article1 then article2 else article1) - cookie_jar' = cookie_jar1 `mplus` cookie_jar2 + cookie_jar' = cookie_jar1 `cj_append` cookie_jar2 full_stories' = full_stories1 || full_stories2 output' = (if null output1 then output2 else output1) - password' = password1 `mplus` password2 - username' = username1 `mplus` username2 + password' = password1 `mappend` password2 + username' = username1 `mappend` username2 in Cfg { article = article', cookie_jar = cookie_jar', diff --git a/src/LWN/HTTP.hs b/src/LWN/HTTP.hs index ef4fc5a..6216a0f 100644 --- a/src/LWN/HTTP.hs +++ b/src/LWN/HTTP.hs @@ -4,140 +4,102 @@ module LWN.HTTP where import Control.Concurrent.ParallelIO (parallel) -import qualified Data.ByteString as B (hPut) +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 Network.Curl ( - CurlCode(..), - CurlOption(..), - CurlResponse, - do_curl_, - initialize, - respBody, - respCurlCode, - withCurlDo +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 (hPutStrLn, stderr) import qualified System.IO.UTF8 as Utf8 (readFile) -import System.IO.Temp (openBinaryTempFile, openTempFile) +import System.IO.Temp (openBinaryTempFile) -import qualified Configuration as C (Cfg(..)) +-- 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) -login_url :: URL -login_url = "https://lwn.net/login" - -username_field :: String -username_field = "Username" - -password_field :: String -password_field = "Password" - -submit_field :: String -submit_field = "submit" - - -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, +-- | The type of response we get back from http-conduit's httpLbs. +type LBSResponse = Response L.ByteString - -- Follow redirects. - CurlFollowLocation True, - - -- Give it a little time... - CurlTimeout 45 ] +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 -> URL -> 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. -log_in :: FilePath -> String -> String -> IO (Either String 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 -> 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 +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 @@ -160,13 +122,16 @@ 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 @@ -199,17 +164,14 @@ get_login_cookie cfg | otherwise = do let uname = fromJust $ C.username cfg let pword = fromJust $ C.password cfg - cj <- make_cookie_jar - li_result <- log_in cj uname pword + li_result <- log_in uname pword case li_result of Left err -> do - let msg = "Failed to log in. " ++ err + let msg = "Failed to log in. Server response:\n" ++ (show err) hPutStrLn stderr msg - Right response_body -> do - hPutStrLn stderr response_body - - return $ cfg { C.cookie_jar = Just cj } + return cfg + Right cj -> return $ cfg { C.cookie_jar = cj } -- | Try to parse the given article using HXT. We try a few different @@ -223,12 +185,14 @@ get_article_contents cfg article_name = do contents <- Utf8.readFile my_article return $ Just $ contents False -> do - -- Download the URL and try to parse it. + -- Download the URL. html <- get_page (C.cookie_jar cfg) my_article case html of Left err -> do - let msg = "Failed to retrieve page. " ++ err + let msg = "Failed to retrieve article. " ++ + "Server response:\n" ++ (show err) hPutStrLn stderr msg return Nothing - Right h -> return $ Just h + Right lbs_article -> + return $ Just (toString lbs_article) diff --git a/src/LWN/Page.hs b/src/LWN/Page.hs index cdcd1a6..3d53284 100644 --- a/src/LWN/Page.hs +++ b/src/LWN/Page.hs @@ -302,9 +302,9 @@ fp_parse :: IOSArrow XmlTree XmlTree -> IO (Maybe Page) fp_parse xml = do hl <- parse_headline xml parsed_articles <- fp_parse_articles xml - case parsed_articles of - [] -> return Nothing - x -> return $ Just $ FullPage (fromJust hl) x + return $ case parsed_articles of + [] -> Nothing + x -> Just $ FullPage (fromJust hl) x diff --git a/src/Main.hs b/src/Main.hs index 3ce1eef..1f6d7c5 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -7,8 +7,11 @@ import System.Directory (doesFileExist) import System.IO ( Handle, IOMode (WriteMode), + hPutStrLn, openBinaryFile, - stdout) + stderr, + stdout + ) import CommandLine (show_help) import Configuration (Cfg(..), get_cfg) @@ -40,12 +43,14 @@ main = do cfg <- case aif of False -> get_login_cookie cfg' True -> return cfg' + page <- page_from_url cfg (article cfg) case page of Just p -> do output_handle <- get_output_handle (output cfg) epublish p output_handle Nothing -> do + hPutStrLn stderr "ERROR: could not parse an LWN page from the given URL." _ <- show_help return () diff --git a/test/TestSuite.hs b/test/TestSuite.hs index adbb203..ca6c0e8 100644 --- a/test/TestSuite.hs +++ b/test/TestSuite.hs @@ -1,4 +1,4 @@ -module TestSuite +module Main where import Test.Framework (