module Network.HTTP.Wget
( wget
, wget'
, WgetException (..)
) where
import System.Process
import System.Exit
import System.IO
import Numeric (showHex)
import Data.List (intercalate)
import "transformers" Control.Monad.IO.Class
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