Wget.hs

{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE CPP #-}
---------------------------------------------------------
-- |
-- Module        : Network.HTTP.Wget
-- Copyright     : Michael Snoyman
-- License       : BSD3
--
-- Maintainer    : Michael Snoyman <michael@snoyman.com>
-- Stability     : Stable
-- Portability   : portable
--
-- Provide a simple HTTP client interface by wrapping the wget command line tool.
--
---------------------------------------------------------
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

-- | Same as 'wget', but easier to access the exception on failure.
wgetSplit :: (Monad m, Failure WgetException m)
          => String -- ^ The URL.
          -> [(String, String)] -- ^ Get parameters.
          -> [(String, String)] -- ^ Post parameters. If empty, this will be a get request.
          -> IO (m String) -- ^ The headers and response body.
wgetSplit url get post = splitException $ wget url get post

-- | Same as wget\', but easier to access the exception on failure.
wgetSplit' :: (Monad m, Failure WgetException m)
           => String -- ^ The URL.
           -> [(String, String)] -- ^ Get parameters.
           -> [(String, String)] -- ^ Post parameters. If empty, this will be a get request.
           -> IO (m ([(String, String)], String)) -- ^ The headers and response body.
wgetSplit' url get post = splitException $ wget' url get post

-- | Get a response from the given URL with the given parameters.
wget :: (MonadIO m, Failure WgetException m)
     => String -- ^ The URL.
     -> [(String, String)] -- ^ Get parameters.
     -> [(String, String)] -- ^ Post parameters. If empty, this will be a get request.
     -> m String -- ^ The response body.
wget url get post = snd `liftM` wget' url get post

-- | Get a response from the given URL with the given parameters, including headers.
wget' :: (MonadIO m, Failure WgetException m)
     => String -- ^ The URL.
     -> [(String, String)] -- ^ Get parameters.
     -> [(String, String)] -- ^ Post parameters. If empty, this will be a get request.
     -> m ([(String, String)], String) -- ^ The headers and response body.
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", "--no-check-certificate"])
        ) { 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, "") -- though this should never happen

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