module Network.HTTP.Wget
( wget
, wget'
, WgetException (..)
) where
import System.Process
import System.Exit
import System.IO
import Numeric (showHex)
import Data.List (intercalate)
#if TRANSFORMERS_02
import "transformers" Control.Monad.IO.Class
#else
import "transformers" Control.Monad.Trans
#endif
import Control.Failure
import Control.Exception
import Data.Generics
import Data.Char (isSpace)
import Control.Arrow (first, second)
newtype WgetException = WgetException String
deriving (Show, Typeable)
instance Exception WgetException
wget :: (MonadIO m, MonadFailure WgetException m)
=> String
-> [(String, String)]
-> [(String, String)]
-> m String
wget url get post = snd `fmap` wget' url get post
wget' :: (MonadIO m, MonadFailure WgetException m)
=> String
-> [(String, String)]
-> [(String, String)]
-> m ([(String, String)], String)
wget' url get post = do
let getSepChar :: Char
getSepChar = if '?' `elem` url then '&' else '?'
get' :: String
get' = if null get then "" else getSepChar : urlEncodePairs get
post' :: [String]
post' = if null post
then []
else ["--post-data", urlEncodePairs post]
(Nothing, Just hout, Just herr, phandle) <- liftIO $
createProcess $ (proc "wget"
((url ++ get') : post' ++ ["-O", "-", "--save-headers"])
) { std_out = CreatePipe, std_err = CreatePipe }
exitCode <- liftIO $ waitForProcess phandle
case exitCode of
ExitSuccess -> liftIO $ parseHeaders `fmap` hGetContents hout
_ -> liftIO (hGetContents herr) >>= failure . WgetException
parseHeaders :: String -> ([(String, String)], String)
parseHeaders = first (parseHeaders' . drop 1 . lines) . breakDoubleNewLine
breakDoubleNewLine :: String -> (String, String)
breakDoubleNewLine = first ($ "") . h where
h :: String -> (String -> String, String)
h ('\r':'\n':x) = h $ '\n' : x
h ('\n':'\r':'\n':x) = h $ '\n':'\n':x
h ('\n':'\n':x) = (id, x)
h (c:x) =
let (a, b) = h x
in ((:) c . a, b)
h [] = (id, "")
parseHeaders' :: [String] -> [(String, String)]
parseHeaders' = map helper where
helper = second (dropWhile isSpace . dropColon) . break (== ':')
dropColon (':':x) = x
dropColon x = x
urlEncodePairs :: [(String, String)] -> String
urlEncodePairs = intercalate "&" . map urlEncodePair
urlEncodePair :: (String, String) -> String
urlEncodePair (x, y) = urlEncode x ++ '=' : urlEncode y
urlEncode :: String -> String
urlEncode = concatMap urlEncodeChar
urlEncodeChar :: Char -> String
urlEncodeChar x
| safeChar (fromEnum x) = return x
| otherwise = '%' : showHex (fromEnum x) ""
safeChar :: Int -> Bool
safeChar x
| x >= fromEnum 'a' && x <= fromEnum 'z' = True
| x >= fromEnum 'A' && x <= fromEnum 'Z' = True
| x >= fromEnum '0' && x <= fromEnum '9' = True
| otherwise = False