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 (hPutStrLn, stderr)
  22 import System.IO.Temp (openBinaryTempFile)
  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
  55 get_page :: Maybe FilePath -> URLString -> IO (Maybe String)
  56 get_page cookie_jar url =
  57   withCurlDo $ do
  58     -- Create a curl instance.
  59     curl <- initialize
  60
  61     -- Perform the request, and get back a CurlResponse object.
  62     -- The cast is needed to specify how we would like our headers
  63     -- and body returned (Strings).
  64     resp <- do_curl_ curl url curl_opts :: IO CurlResponse
  65
  66     -- Pull out the response code as a CurlCode.
  67     let code = respCurlCode resp
  68
  69     case code of
  70       CurlOK -> return $ Just (respBody resp)
  71       error_code -> do
  72         hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
  73         -- If an error occurred, we want to dump as much information as
  74         -- possible. If this becomes a problem, we can use respGetInfo to
  75         -- query the response object for more information
  76         return Nothing
  77   where
  78     get_opts =
  79       case cookie_jar of
  80         Nothing -> []
  81         Just cookies -> [ CurlCookieJar cookies ]
  82
  83     curl_opts = default_curl_opts ++ get_opts
  84
  85
  86 log_in :: FilePath -> String -> String -> IO Bool
  87 log_in cookie_jar username password =
  88   withCurlDo $ do
  89     -- Create a curl instance.
  90     curl <- initialize
  91
  92     -- Perform the request, and get back a CurlResponse object.
  93     -- The cast is needed to specify how we would like our headers
  94     -- and body returned (Strings).
  95     resp <- do_curl_ curl login_url curl_opts :: IO CurlResponse
  96
  97     -- Pull out the response code as a CurlCode.
  98     let code = respCurlCode resp
  99
 100     case code of
 101       CurlOK -> return True
 102       error_code -> do
 103         hPutStrLn stderr ("HTTP Error: " ++ (show error_code))
 104         -- If an error occurred, we want to dump as much information as
 105         -- possible. If this becomes a problem, we can use respGetInfo to
 106         -- query the response object for more information
 107         return False
 108   where
 109     post_submit :: String
 110     post_submit = submit_field ++ "=Log+In"
 111
 112     post_username :: String
 113     post_username = username_field ++ "=" ++ username
 114
 115     post_password :: String
 116     post_password = password_field ++ "=" ++ password
 117
 118     post_data :: [String]
 119     post_data = [post_username, post_password, post_submit]
 120
 121     post_opts :: [CurlOption]
 122     post_opts =
 123       [ CurlCookieSession True,
 124         CurlCookieJar cookie_jar,
 125         CurlPost True,
 126         CurlPostFields post_data ]
 127
 128     curl_opts :: [CurlOption]
 129     curl_opts = default_curl_opts ++ post_opts
 130
 131
 132 -- | Save the image at 'url'. Saves to a temporary file, and
 133 --   returns the path to that file if successful. Otherwise,
 134 --   returns 'Nothing'.
 135 --
 136 --   We need to be able to parse the filename out of the URL
 137 --   so that when we stick our image in the document, the reader
 138 --   knows that type (jpg, png, etc.) it is.
 139 save_image :: URLString -> IO (Maybe FilePath)
 140 save_image url = do
 141   it_exists <- doesFileExist url
 142   if it_exists then do
 143     -- It's local, just use it.
 144     return $ Just url
 145   else do
 146     let fn = filename url
 147     case fn of
 148       Nothing -> return Nothing
 149       Just file -> do
 150         temp_dir <- getTemporaryDirectory
 151         (out_path, out_handle) <- openBinaryTempFile temp_dir file
 152         result <- openURI url
 153         case result of
 154           Left err -> do
 155             hPutStrLn stderr ("HTTP Error: " ++ err)
 156             return Nothing
 157           Right bs -> do
 158             B.hPut out_handle bs
 159             return $ Just out_path