src/Main.hs

   1 {-# LANGUAGE DoAndIfThenElse #-}
   2 module Main
   3 where
   4
   5 import Data.List (isPrefixOf)
   6 import Data.Maybe (fromJust)
   7 import Prelude hiding (readFile)
   8 import System.Directory (doesFileExist)
   9 import System.IO (
  10   Handle,
  11   IOMode (WriteMode),
  12   hPutStrLn,
  13   openBinaryFile,
  14   stderr,
  15   stdout
  16   )
  17 import System.IO.UTF8 (readFile)
  18 import Test.HUnit (Assertion, assertEqual)
  19 import Test.Framework (Test, testGroup)
  20 import Test.Framework.Providers.HUnit (testCase)
  21 import Text.Regex.Posix ((=~))
  22 import Text.XML.HXT.Core (
  23   IOStateArrow,
  24   SysConfigList,
  25   XmlTree,
  26   no,
  27   readString,
  28   withParseHTML,
  29   withValidate,
  30   withWarnings,
  31   yes
  32   )
  33 import CommandLine (show_help)
  34 import Configuration (Cfg(..), get_cfg, use_account)
  35 import LWN.HTTP (get_page, log_in, make_cookie_jar)
  36 import LWN.Page (epublish, parse)
  37 import LWN.URI (
  38   add_trailing_slash,
  39   is_lwn_url,
  40   try_make_absolute_url,
  41   make_https)
  42
  43
  44
  45 my_read_opts :: SysConfigList
  46 my_read_opts = [ withValidate  no,
  47                  withParseHTML yes,
  48                  withWarnings no ]
  49
  50 -- | My version of HandsomeSoup's parseHTML.
  51 my_read :: String -> IOStateArrow s b XmlTree
  52 my_read = readString my_read_opts
  53
  54
  55 -- | Try to parse the given article using HXT. We try a few different
  56 --   methods; if none of them work, we return 'Nothing'.
  57 get_xml_from_article :: Cfg -> IO (Maybe (IOStateArrow s b XmlTree))
  58 get_xml_from_article cfg = do
  59   my_article <- real_article_path (article cfg)
  60   is_file <- doesFileExist my_article
  61   case is_file of
  62     True -> do
  63       contents <- readFile my_article
  64       return $ Just $ my_read contents
  65     False -> do
  66       -- Download the URL and try to parse it.
  67       if use_account cfg then do
  68         -- use_account would be false if these fromJusts would fail.
  69         cj <- make_cookie_jar
  70         li_result <- log_in cj
  71                       (fromJust $ username cfg)
  72                       (fromJust $ password cfg)
  73
  74         case li_result of
  75           Left err -> do
  76             let msg = "Failed to log in. " ++ err
  77             hPutStrLn stderr msg
  78           Right response_body -> do
  79             hPutStrLn stderr response_body
  80
  81         html <- get_page (Just cj) my_article
  82
  83         case html of
  84           Left err -> do
  85             let msg = "Failed to retrieve page. " ++ err
  86             hPutStrLn stderr msg
  87             return Nothing
  88           Right h -> return $ Just $ my_read h
  89       else do
  90         html <- get_page Nothing my_article
  91         case html of
  92           Left err -> do
  93             let msg = "Failed to retrieve page. " ++ err
  94             hPutStrLn stderr msg
  95             return Nothing
  96           Right h -> return $ Just $ my_read h
  97
  98 -- | If we're given an empty path, return a handle to
  99 --   'stdout'. Otherwise, open the given file and return a read/write
 100 --   handle to that.
 101 get_output_handle :: FilePath -> IO Handle
 102 get_output_handle path =
 103   if (null path) then
 104     return stdout
 105   else
 106     openBinaryFile path WriteMode
 107
 108
 109
 110 -- | Convert the given article to either a URL or a filesystem
 111 --   path. If the given article exists on the filesystem, we assume
 112 --   it's a file. Otherwise, we check to see if it's a URL. Failing
 113 --   that, we try to construct a URL from what we're given and do our
 114 --   best.
 115 real_article_path :: String -> IO String
 116 real_article_path path = do
 117   is_file <- doesFileExist path
 118   return $ if is_file then path else add_trailing_slash check_cases
 119   where
 120     abs_current = try_make_absolute_url ("/" ++ path)
 121     abs_article = try_make_absolute_url ("Articles/" ++ path)
 122
 123     check_cases :: String
 124     check_cases
 125       | is_lwn_url path = make_https path
 126       | isPrefixOf "current" path = abs_current
 127       | path =~ "^[0-9]+$" = abs_article
 128       | otherwise = path -- Give up
 129
 130 main :: IO ()
 131 main = do
 132   cfg <- get_cfg
 133   output_handle <- get_output_handle (output cfg)
 134   maybe_html <- get_xml_from_article cfg
 135
 136   case maybe_html of
 137     Just html -> do
 138       result <- parse html
 139       case result of
 140         Just stuff  -> epublish stuff output_handle
 141         Nothing     -> do
 142          _ <- show_help
 143          return ()
 144
 145     Nothing -> do
 146       _ <- show_help
 147       return ()
 148
 149
 150 test_current_article_path :: Assertion
 151 test_current_article_path = do
 152   let expected = "https://lwn.net/current/"
 153   actual <- real_article_path "current"
 154   assertEqual "Current article path constructed" expected actual
 155
 156 test_current_bigpage_article_path :: Assertion
 157 test_current_bigpage_article_path = do
 158   let expected = "https://lwn.net/current/bigpage"
 159   actual <- real_article_path "current/bigpage"
 160   assertEqual "Current bigpage article path constructed" expected actual
 161
 162 test_numbered_article_path :: Assertion
 163 test_numbered_article_path = do
 164   let expected = "https://lwn.net/Articles/69/"
 165   actual <- real_article_path "69" -- I'm twelve
 166   assertEqual "Numbered article path constructed" expected actual
 167
 168
 169 test_full_article_path :: Assertion
 170 test_full_article_path = do
 171   let expected = "https://lwn.net/Articles/502979/"
 172   actual <- real_article_path "https://lwn.net/Articles/502979/"
 173   assertEqual "Full article path left alone" expected actual
 174
 175 test_non_https_article_path :: Assertion
 176 test_non_https_article_path = do
 177   let expected = "https://lwn.net/Articles/502979/"
 178   actual <- real_article_path "http://lwn.net/Articles/502979/"
 179   assertEqual "Non-https URL made https" expected actual
 180
 181 main_tests :: Test
 182 main_tests =
 183   testGroup "Main Tests" [
 184     testCase "Current article path constructed" test_current_article_path,
 185     testCase
 186       "Current bigpage article path constructed"
 187       test_current_bigpage_article_path,
 188     testCase "Numbered article path constructed" test_numbered_article_path,
 189     testCase "Full article path left alone" test_full_article_path,
 190     testCase "Non-https URL made https" test_non_https_article_path ]