Permalink
Browse files

Add a type class Postable so that post is extensible.

  • Loading branch information...
1 parent ca7721d commit ee75376586c50b5342a3eb998bb0aad5bcca1784 @haroldl committed Apr 13, 2012
Showing with 81 additions and 9 deletions.
  1. +69 −7 ezhttp/EZHTTP.hs
  2. +10 −0 ezhttp/Main.hs
  3. +2 −2 ezhttp/README.txt
View
@@ -1,7 +1,10 @@
{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
-- | A simple HTTP module for easy scripting or interactive use.
-module EZHTTP (get, post, queryString, InvalidURLException, HttpException) where
+module EZHTTP (get, post, queryString,
+ Postable, contentType, serialize,
+ InvalidURLException, HttpException) where
import Control.Exception (throwIO)
import Control.Exception.Base
@@ -10,6 +13,8 @@ import Data.Typeable
import Network.HTTP
import Network.Stream
import Network.URI
+import Text.JSON
+import Text.XML.Light
-- | Make an HTTP GET request for the URL given and return the body of the response as a String.
--
@@ -32,10 +37,67 @@ get url = executeHttp url request
-- | Make an HTTP GET request for the URL given sending the list of parameters as if submitting an
-- HTML form and return the body of the response as a String.
--
+-- You can post anything that is 'Postable'. Several options are pre-defined and the correct
+-- Content-Type is used automatically.
+--
+-- * Strings (sent as text/plain)
+--
+-- * Form parameters
+--
+-- * JSON (cabal install json, then import Text.JSON)
+--
+-- * XML (cabal install xml, then import Text.XML.Light)
+--
+-- For example:
+--
+-- > -- Post url-encoded form inputs: a=1&b=2
+-- > post url [("a", "1"), ("b", "2")]
+-- >
+-- > -- Post JSON: {"a": 1, "b": 2}
+-- > let json = encJSDict [("a", 1 :: Int), ("b", 2)] in
+-- > post url json
+-- >
+-- > -- Post XML: <doc><a>1</a><b>2</b></doc>
+-- > case parseXMLDoc "<doc><a>1</a><b>2</b></doc>" of
+-- > Just xml -> post url xml
+-- > Nothing -> ...
+--
+-- You can add support for POSTing any other data type by adding an instance
+-- declaration in your code like so:
+--
+-- > instance Postable MyType where
+-- > contentType _ = "some/type"
+-- > serialize value = ...
+--
-- Might throw 'InvalidURLException' or 'HttpException'.
-post :: String -> [(String, String)] -> IO String
+post :: Postable a => String -> a -> IO String
post url params = executeHttp url (\uri -> postReq uri params)
+-- | Class of types that can be sent via HTTP POST.
+class Postable a where
+
+ -- | Give the Content-Type header value for this data type.
+ contentType :: a -> String
+
+ -- | Convert the value to a String to send in the body of a POST request.
+ serialize :: a -> String
+
+instance Postable [Char] where
+ contentType _ = "text/plain"
+ serialize = id
+
+instance Postable [(String, String)] where
+ contentType _ = "application/x-www-form-urlencoded"
+ serialize = queryString
+
+instance Postable JSValue where
+ contentType _ = "application/json"
+ serialize = encode
+
+instance Postable Element where
+ contentType _ = "application/xml"
+ serialize = showElement
+
executeHttp :: String -> (URI -> Request String) -> IO String
executeHttp url request = do uri <- parseURI' url
response <- makeRequest (request uri)
@@ -48,14 +110,14 @@ request uri = Request { rqURI = uri,
rqHeaders = [],
rqBody = "" }
-postReq :: URI -> [(String, String)] -> Request String
+postReq :: Postable a => URI -> a -> Request String
postReq uri params = Request { rqURI = uri,
rqMethod = POST,
rqHeaders = [contentTypeHeader, contentLengthHeader],
- rqBody = qs }
- where contentTypeHeader = Header HdrContentType "application/x-www-form-urlencoded"
- contentLengthHeader = Header HdrContentLength (show $ length $ qs)
- qs = queryString params
+ rqBody = body }
+ where contentTypeHeader = Header HdrContentType (contentType params)
+ contentLengthHeader = Header HdrContentLength (show $ length $ body)
+ body = serialize params
{-|
A helper function to take a set of parameters and urlencode them so that you can add them to the
View
@@ -2,13 +2,23 @@ module Main where
import EZHTTP
import Control.Exception as E
+import Text.JSON
main :: IO ()
main = do html <- get "http://harold.hotelling.net/"
putStrLn $ "Web page has " ++ (show $ length html) ++ " characters."
badRequest `E.catch` handleInvalidURL
putStrLn "Recovered from the bad value safely."
+instance Postable Int where
+ contentType _ = "foo/bar"
+ serialize = show
+
+tryPost :: IO String
+tryPost = let json = encJSDict [("a", 1 :: Int), ("b", 2)] in
+ post url json
+ where url = "http://harold.hotelling.net/"
+
badRequest :: IO ()
badRequest = do html2 <- get "abcdefghijklmnopqrstuvwxyz"
putStrLn html2
View
@@ -1,6 +1,6 @@
-Get the required HTTP library:
+Get the required HTTP libraries:
- cabal install http
+ cabal install http json xml
Build and run the sample code:

0 comments on commit ee75376

Please sign in to comment.