module Util.Fetch
( readContentsURL
, readUserContentsURL
, postContentsURL
, URLString
, User(..)
) where
import Network.Browser
import Network.HTTP
import Network.URI
type URLString = String
data User
= User { userName :: String
, userPass :: String
}
readContentsURL :: URLString -> IO String
readContentsURL u = do
req <-
case parseURI u of
Nothing -> fail ("ill-formed URL: " ++ u)
Just ur -> return (defaultGETRequest ur)
let nullHandler _ = return ()
(_u, resp) <- browse $ setOutHandler nullHandler >> request req
case rspCode resp of
(2,_,_) -> return (rspBody resp)
_ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp))
readUserContentsURL :: User -> URLString -> IO String
readUserContentsURL usr us = do
req <-
case parseURI us of
Nothing -> fail ("ill-formed URL: " ++ us)
Just ur -> return (defaultGETRequest ur)
let nullHandler _ = return ()
(u, resp) <- browse $ do
setOutHandler nullHandler
setAllowBasicAuth True
setAuthorityGen (\ _ _ -> return (Just (userName usr,userPass usr)))
request req
case rspCode resp of
(2,_,_) -> return (rspBody resp)
_ -> fail ("Failed reading URL " ++ show u ++ " code: " ++ show (rspCode resp))
postContentsURL :: URLString -> [(String,String)] -> String -> IO String
postContentsURL u hdrs body = do
let hs =
case parseHeaders $ map (\ (x,y) -> x++": " ++ y) hdrs of
Left{} -> []
Right xs -> xs
req0 <-
case parseURI u of
Nothing -> fail ("ill-formed URL: " ++ u)
Just ur -> return (defaultGETRequest ur)
let req = req0{rqMethod=POST
,rqBody=body
,rqHeaders=hs
}
let nullHandler _ = return ()
(_,rsp) <- browse $ setOutHandler nullHandler >> request req
case rspCode rsp of
(2,_,_) -> return (rspBody rsp)
x -> fail ("POST failed - code: " ++ show x ++ ", URL: " ++ u)