Commit 7f4a83fc2d3c5dfd15c7a305679abf31fc8a697e - shelob

+11

-5

shelob/example/Main.hs less more

7	7	main :: IO ()
8	8	main = do
9	9	conn <- HTTP.httpConnection "gdritter.com"
10		(r0,r1,r2) <- HTTP.connect conn $ do
11		h <- HTTP.head "/index.html" [HTTP.Header "Host" "gdritter.com"]
12		a <- HTTP.get "/index.html" [HTTP.Header "Host" "gdritter.com"]
13		b <- HTTP.get "/matzo/matzo.html" [HTTP.Header "Host" "gdritter.com"]
14		return (h, a, b)
	10
	11	r0 <- HTTP.makeRequest conn $
	12	HTTP.head "/index.html" [HTTP.Header "Host" "gdritter.com"]
15	13	pPrint r0
	14
	15	r1 <- HTTP.makeRequest conn $
	16	HTTP.get "/index.html" [HTTP.Header "Host" "gdritter.com"]
16	17	pPrint r1
	18
	19	r2 <- HTTP.makeRequest conn $
	20	HTTP.get "/matzo/matzo.html" [HTTP.Header "Host" "gdritter.com"]
17	21	pPrint r2
	22
	23	HTTP.connClose conn
18	24	return ()

+1

-0

shelob/shelob.cabal less more

23	23	build-depends: base >=4.7 && <4.10
24	24	, bytestring
25	25	, network
	26	, deepseq
26	27	default-language: Haskell2010
27	28	default-extensions: OverloadedStrings,
28	29	ScopedTypeVariables

+3

-1

shelob/src/Network/Shelob/Request.hs less more

34	34	MConnect -> "CONNECT"
35	35	MPatch -> "PATCH"
36	36	MOther bs -> bs
37
38	37	pHeader :: Header -> B.Builder
	38	pHeader (HContentLength v) =
	39	B.byteString "Content-Length: " <>
	40	B.intDec v <> crlf
39	41	pHeader (Header k v) =
40	42	B.byteString k <> B.char7 ':' <> B.char7 ' ' <>
41	43	B.byteString v <> crlf

+16

-10

shelob/src/Network/Shelob/Response.hs less more

16	16	)
17	17	\| otherwise = error "???"
18	18
19		readResponse :: Connection -> IO (Either HTTPError Response)
20		readResponse conn = do
	19	readResponse :: Connection -> Request -> IO (Either HTTPError Response)
	20	readResponse conn req = do
21	21	ln <- connReadLine conn
22	22	case BS.split 32 ln of
23	23	(_version:code:_reason) -> do
24	24	let c = pCode code
25	25	headers <- readHeaders conn
26		body <- readBody conn headers
27		return (Right (Response headers c (Just body)))
	26	case requestMethod req of
	27	MHead -> return (Right (Response headers c Nothing))
	28	_ -> do
	29	body <- readBody conn headers
	30	return (Right (Response headers c (Just body)))
28	31	_ -> return (Left HTTPError)
29	32
30	33	readHeaders :: Connection -> IO [Header]

37	40	let (key:vals) = BS.split 58 ln'
38	41	let val = BS.intercalate ":" vals
39	42	rs <- readHeaders conn
40		return (Header key (BS.tail val) : rs)
	43	return (toHeader key (BS.tail val) : rs)
	44
	45	toHeader :: BS.ByteString -> BS.ByteString -> Header
	46	toHeader "Content-Length" v = HContentLength (read (BS8.unpack v))
	47	toHeader k v = Header k v
41	48
42	49	readBody :: Connection -> [Header] -> IO BS.ByteString
43	50	readBody conn hs
44		= case [ read (BS8.unpack value)
45		\| Header name value <- hs
46		, name == "Content-Length"
47		]
	51	= case [ ln \| HContentLength ln <- hs ]
48	52	of
49		[ len ] -> ~~connRead conn len~~
	53	[ len ] -> do
	54	print len
	55	connRead conn len
50	56	_ -> return ""

+34

-10

shelob/src/Network/Shelob/Types.hs less more

	1	{-# LANGUAGE BangPatterns #-}
	2
1	3	module Network.Shelob.Types where
2	4
3	5	import qualified Control.Exception as Ex
	6	import Control.DeepSeq (NFData(..))
4	7	import qualified Data.ByteString as BS
5	8	import qualified Data.ByteString.Lazy as LBS
6	9	import Data.Typeable (Typeable)

15	18	\| MOptions
16	19	\| MConnect
17	20	\| MPatch
18		\| MOther BS.ByteString
	21	\| MOther !BS.ByteString
19	22	deriving (Eq, Show)
20	23
21		data Header = Header BS.ByteString BS.ByteString deriving (Eq, Show)
	24	instance NFData Method where
	25	rnf _ = ()
	26
	27	data Header
	28	= HContentLength !Int
	29	\| Header !BS.ByteString !BS.ByteString
	30	deriving (Eq, Show)
	31
	32	instance NFData Header where
	33	rnf (HContentLength v) = rnf v
	34	rnf (Header k v) = rnf k `seq` rnf v
	35
22	36
23	37	data Request = Request
24		{ requestMethod :: Method
25		, requestPath :: BS.ByteString
26		, requestHeaders :: [Header]
27		, requestBody :: BS.ByteString
	38	{ requestMethod :: !Method
	39	, requestPath :: !BS.ByteString
	40	, requestHeaders :: ![Header]
	41	, requestBody :: !BS.ByteString
28	42	} deriving (Eq, Show)
	43
	44	instance NFData Request where
	45	rnf (Request m p h b) = rnf m `seq` rnf p `seq` rnf h `seq` rnf b
	46
29	47
30	48	type ResponseCode = (Int, Int, Int)
31	49
32	50	data Response = Response
33		{ responseHeaders :: [Header]
34		, responseCode :: ResponseCode
35		~~, responseBody :: Maybe BS.ByteString~~
	51	{ responseHeaders :: ![Header]
	52	, responseCode :: !ResponseCode
	53	, responseBody :: !(Maybe BS.ByteString)
36	54	} deriving (Eq, Show)
	55
	56	instance NFData Response where
	57	rnf (Response h c b) = rnf h `seq` rnf c `seq` rnf b
	58
37	59
38	60	-- \| This "Connection" abstraction allows us to build on top of
39	61	-- arbitrary other connection packages for our HTTP

44	66	, connClose :: IO ()
45	67	}
46	68
47		data HTTPError = HTTPError deriving (Typeable, Show)
	69
	70	data HTTPError
	71	= HTTPError deriving (Typeable, Show)
48	72
49	73	instance Ex.Exception HTTPError where
50	74	toException = undefined

+2

-1

shelob/src/Network/Shelob.hs less more

55	55	makeRequest :: Connection -> Request -> IO (Either HTTPError Response)
56	56	makeRequest conn req = do
57	57	let pReq = pRequest req
	58	print pReq
58	59	connWrite conn pReq
59		readResponse conn
	60	readResponse conn req

+8

-0

shelob-client/shelob-client.cabal less more

23	23	default-language: Haskell2010
24	24	default-extensions: OverloadedStrings,
25	25	ScopedTypeVariables
	26
	27	executable example
	28	hs-source-dirs: example
	29	main-is: Main.hs
	30	ghc-options: -Wall
	31	build-depends: base, shelob, shelob-client, pretty-show
	32	default-language: Haskell2010
	33	default-extensions: OverloadedStrings

+6

-2

shelob-client/src/Network/Shelob/Client.hs less more

34	34	liftIO m = ConnM (\ _ -> m)
35	35
36	36	-- * HTTPPayload
37		-- \| Types that implement
	37
	38	-- \| Types that implement 'HTTPPayload' can be transparently used as
	39	-- the body of an HTTP request.
38	40	class HTTPPayload t where
39	41	toPayload :: t -> BS.ByteString
40	42

44	46	instance HTTPPayload T.Text where
45	47	toPayload = T.encodeUtf8
46	48
	49	-- \| The 'JSONPayload' type is used so that we can interpret the
	50	-- payload of a response
47	51	newtype JSONPayload t = JSONPayload { fromJSONPayload :: t }
48	52
49	53	instance Aeson.FromJSON t => Aeson.FromJSON (JSONPayload t) where

77	81	fromResponse = onSuccess (go . responseBody)
78	82	where go Nothing = Ex.throw HTTPError
79	83	go (Just x)
80		\| Just rs <- Aeson.decode ~~x = JSONPayload x~~
	84	\| Just rs <- Aeson.decodeStrict x = JSONPayload rs
81	85	\| otherwise = Ex.throw HTTPError
82	86
83	87	withConn :: Connection -> ConnM a -> IO a