src/LWN/HTTP.hs

   1 {-# LANGUAGE DoAndIfThenElse #-}
   2
   3 module LWN.HTTP
   4 where
   5
   6 import qualified Data.ByteString as B (hPut)
   7
   8 import Network.Curl (
   9   CurlCode(..),
  10   CurlOption(..),
  11   CurlResponse,
  12   URLString,
  13   do_curl_,
  14   initialize,
  15   respBody,
  16   respCurlCode,
  17   withCurlDo
  18   )
  19 import Network.Curl.Download (openURI)
  20 import System.Directory (doesFileExist, getTemporaryDirectory)
  21 import System.IO (hClose, hPutStrLn, stderr)
  22 import System.IO.Temp (openBinaryTempFile, openTempFile)
  23
  24 import LWN.URI (filename)
  25
  26 login_url :: URLString
  27 login_url = "https://lwn.net/login"
  28
  29 username_field :: String
  30 username_field = "Username"
  31
  32 password_field :: String
  33 password_field = "Password"
  34
  35 submit_field :: String
  36 submit_field = "submit"
  37
  38
  39 default_curl_opts :: [CurlOption]
  40 default_curl_opts =
  41   [ -- The Global cache is not thread-friendly.
  42     CurlDNSUseGlobalCache False,
  43
  44     -- And we don't want to use a DNS cache anyway.
  45     CurlDNSCacheTimeout 0,
  46
  47     -- Follow redirects.
  48     CurlFollowLocation True,
  49
  50     -- Give it a little time...
  51     CurlTimeout 45 ]
  52
  53
  54 make_cookie_jar :: IO FilePath
  55 make_cookie_jar = do
  56   temp_dir <- getTemporaryDirectory
  57   let file_name_template = "lwn-epub-cookies.txt"
  58   (out_path, out_handle) <- openTempFile temp_dir file_name_template
  59   hClose out_handle -- We just want to create it for now.
  60   return out_path
  61
  62 get_page :: Maybe FilePath -> URLString -> IO (Either String String)
  63 get_page cookie_file url =
  64   withCurlDo $ do
  65     -- Create a curl instance.
  66     curl <- initialize
  67
  68     -- Perform the request, and get back a CurlResponse object.
  69     -- The cast is needed to specify how we would like our headers
  70     -- and body returned (Strings).
  71     resp <- do_curl_ curl url curl_opts :: IO CurlResponse
  72
  73     -- Pull out the response code as a CurlCode.
  74     let code = respCurlCode resp
  75
  76     return $
  77       case code of
  78         CurlOK -> Right (respBody resp)
  79         error_code -> Left ("HTTP Error: " ++ (show error_code))
  80         -- If an error occurred, we want to dump as much information as
  81         -- possible. If this becomes a problem, we can use respGetInfo to
  82         -- query the response object for more information
  83   where
  84     get_opts =
  85       case cookie_file of
  86         Nothing -> []
  87         Just cookies -> [ CurlCookieFile cookies ]
  88
  89     curl_opts = default_curl_opts ++ get_opts
  90
  91
  92 -- | Log in using curl. Store the resulting session cookies in the
  93 --   supplied file.
  94 log_in :: FilePath -> String -> String -> IO (Either String String)
  95 log_in cookie_jar username password =
  96   withCurlDo $ do
  97     -- Create a curl instance.
  98     curl <- initialize
  99
 100     -- Perform the request, and get back a CurlResponse object.
 101     -- The cast is needed to specify how we would like our headers
 102     -- and body returned (Strings).
 103     resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
 104
 105     -- Pull out the response code as a CurlCode.
 106     let code = respCurlCode resp
 107
 108     return $
 109       case code of
 110         CurlOK -> Right (respBody resp)
 111         error_code -> Left $ "HTTP Error: " ++ (show error_code)
 112         -- If an error occurred, we want to dump as much information as
 113         -- possible. If this becomes a problem, we can use respGetInfo to
 114         -- query the response object for more information
 115   where
 116     post_submit :: String
 117     post_submit = submit_field ++ "=Log+In"
 118
 119     post_username :: String
 120     post_username = username_field ++ "=" ++ username
 121
 122     post_password :: String
 123     post_password = password_field ++ "=" ++ password
 124
 125     post_data :: [String]
 126     post_data = [post_username, post_password, post_submit]
 127
 128     post_opts :: [CurlOption]
 129     post_opts =
 130       [ CurlCookieSession True,
 131         CurlCookieJar cookie_jar,
 132         CurlPost True,
 133         CurlPostFields post_data ]
 134
 135     curl_opts :: [CurlOption]
 136     curl_opts = default_curl_opts ++ post_opts
 137
 138
 139 -- | Save the image at 'url'. Saves to a temporary file, and
 140 --   returns the path to that file if successful. Otherwise,
 141 --   returns 'Nothing'.
 142 --
 143 --   We need to be able to parse the filename out of the URL
 144 --   so that when we stick our image in the document, the reader
 145 --   knows that type (jpg, png, etc.) it is.
 146 save_image :: URLString -> IO (Maybe FilePath)
 147 save_image url = do
 148   it_exists <- doesFileExist url
 149   if it_exists then do
 150     -- It's local, just use it.
 151     return $ Just url
 152   else do
 153     let fn = filename url
 154     case fn of
 155       Nothing -> return Nothing
 156       Just file -> do
 157         temp_dir <- getTemporaryDirectory
 158         (out_path, out_handle) <- openBinaryTempFile temp_dir file
 159         result <- openURI url
 160         case result of
 161           Left err -> do
 162             hPutStrLn stderr ("HTTP Error: " ++ err)
 163             return Nothing
 164           Right bs -> do
 165             B.hPut out_handle bs
 166             return $ Just out_path