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     -- Give it a little time...
  48     CurlTimeout 45,
  49
  50     -- And let us know when things go wrong.
  51     CurlVerbose True ]
  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 (Maybe String)
  63 get_page cookie_jar 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     case code of
  77       CurlOK -> return $ Just (respBody resp)
  78       error_code -> do
  79         hPutStrLn stderr ("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         return Nothing
  84   where
  85     get_opts =
  86       case cookie_jar of
  87         Nothing -> []
  88         Just cookies -> [ CurlCookieJar cookies ]
  89
  90     curl_opts = default_curl_opts ++ get_opts
  91
  92
  93 log_in :: FilePath -> String -> String -> IO Bool
  94 log_in cookie_jar username password =
  95   withCurlDo $ do
  96     -- Create a curl instance.
  97     curl <- initialize
  98
  99     -- Perform the request, and get back a CurlResponse object.
 100     -- The cast is needed to specify how we would like our headers
 101     -- and body returned (Strings).
 102     resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
 103
 104     -- Pull out the response code as a CurlCode.
 105     let code = respCurlCode resp
 106
 107     case code of
 108       CurlOK -> return True
 109       error_code -> do
 110         hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
 111         -- If an error occurred, we want to dump as much information as
 112         -- possible. If this becomes a problem, we can use respGetInfo to
 113         -- query the response object for more information
 114         return False
 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