module Network.HTTP.Wget
( wget
, wget'
, wgetSplit
, wgetSplit'
, WgetException (..)
) where
import System.Process
import System.Exit
import System.IO
import Numeric (showHex)
import Data.List (intercalate)
#if MIN_VERSION_transformers(0,2,0)
import "transformers" Control.Monad.IO.Class
#else
import "transformers" Control.Monad.Trans
#endif
import Control.Failure
import Control.Exception
import Data.Data
import Data.Char (isSpace)
import Control.Arrow (first, second)
import Control.Monad
import Control.Applicative
newtype WgetException = WgetException String
deriving (Show, Typeable)
instance Exception WgetException
newtype SplitHelper x = SplitHelper
{ unSplitHelper :: IO (Either WgetException x)
}
instance Functor SplitHelper where
fmap = liftM
instance Applicative SplitHelper where
pure = return
(<*>) = ap
instance Monad SplitHelper where
return = SplitHelper . return . Right
x >>= f = SplitHelper $ do
x' <- unSplitHelper x
case x' of
Left e -> return $ Left e
Right v -> unSplitHelper $ f v
instance Failure WgetException SplitHelper where
failure = SplitHelper . return . Left
instance MonadIO SplitHelper where
liftIO = SplitHelper . fmap Right
splitException :: (Monad m, Failure WgetException m)
=> SplitHelper x
-> IO (m x)
splitException i = do
x <- unSplitHelper i
case x of
Left e -> return $ failure e
Right v -> return $ return v
wgetSplit :: (Monad m, Failure WgetException m)
=> String
-> [(String, String)]
-> [(String, String)]
-> IO (m String)
wgetSplit url get post = splitException $ wget url get post
wgetSplit' :: (Monad m, Failure WgetException m)
=> String
-> [(String, String)]
-> [(String, String)]
-> IO (m ([(String, String)], String))
wgetSplit' url get post = splitException $ wget' url get post
wget :: (MonadIO m, Failure WgetException m)
=> String
-> [(String, String)]
-> [(String, String)]
-> m String
wget url get post = snd `liftM` wget' url get post
wget' :: (MonadIO m, Failure 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