Commit d26eb3c1faecbb08d236497826acddf732f99508 - shelob

+5

-0

.gitignore less more

	1	*~
	2	.cabal-sandbox
	3	dist-newstyle
	4	dist
	5	cabal.sandbox.config

+12

-0

LICENSE less more

	1	Copyright (c) 2017, Getty Ritter
	2	All rights reserved.
	3
	4	Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:
	5
	6	1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.
	7
	8	2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.
	9
	10	3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.
	11
	12	THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+13

-0

example/Main.hs less more

	1	module Main where
	2
	3	import qualified Network.Vriska as HTTP
	4	import qualified Network.Vriska.Types as HTTP
	5	import Text.Show.Pretty
	6
	7	main :: IO ()
	8	main = do
	9	let req = HTTP.request HTTP.MGet "/index.html" [HTTP.Header "Host" "gdritter.com"]
	10	conn <- HTTP.httpConnection "gdritter.com"
	11	rs <- HTTP.makeRequest conn req
	12	pPrint rs
	13	return ()

+22

-0

src/Network/Vriska/Connection.hs less more

	1	{-# LANGUAGE RecordWildCards #-}
	2	module Network.Vriska.Connection where
	3
	4	import qualified Data.ByteString as BS
	5	import qualified Data.ByteString.Lazy as LBS
	6	import qualified GHC.IO.Handle as H
	7
	8	import Network.Vriska.Types
	9
	10	handleToConnection :: H.Handle -> Connection
	11	handleToConnection h = Connection { .. }
	12	where connRead n = BS.hGet h n
	13	connReadLine = BS.hGetLine h
	14	connWrite bs = LBS.hPut h bs
	15	connClose = H.hClose h
	16
	17	connReadContents :: Connection -> IO BS.ByteString
	18	connReadContents conn = do
	19	buf <- connRead conn 1024
	20	if buf == ""
	21	then connClose conn >> return buf
	22	else BS.append buf `fmap` connReadContents conn

+40

-0

src/Network/Vriska/Request.hs less more

	1	{-# LANGUAGE RecordWildCards #-}
	2	module Network.Vriska.Request where
	3
	4	import Data.Monoid ((<>))
	5	import qualified Data.ByteString.Lazy as B
	6	import qualified Data.ByteString.Builder as B
	7	import qualified Data.Foldable as F
	8
	9	import Network.Vriska.Types
	10
	11	crlf :: B.Builder
	12	crlf = B.char7 '\13' <> B.char7 '\10'
	13
	14	pRequest :: Request -> B.ByteString
	15	pRequest Request { .. } = B.toLazyByteString body
	16	where body = pMethod requestMethod <> B.char7 ' ' <>
	17	B.byteString requestPath <>
	18	B.byteString " HTTP/1.1" <>
	19	crlf <>
	20	F.foldMap pHeader requestHeaders <>
	21	crlf <>
	22	B.byteString requestBody
	23
	24	pMethod :: Method -> B.Builder
	25	pMethod m = B.byteString $ case m of
	26	MGet -> "GET"
	27	MHead -> "HEAD"
	28	MPost -> "POST"
	29	MPut -> "PUT"
	30	MDelete -> "DELETE"
	31	MTrace -> "TRACE"
	32	MOptions -> "OPTIONS"
	33	MConnect -> "CONNECT"
	34	MPatch -> "PATCH"
	35	MOther bs -> bs
	36
	37	pHeader :: Header -> B.Builder
	38	pHeader (Header k v) =
	39	B.byteString k <> B.char7 ':' <> B.char7 ' ' <>
	40	B.byteString v <> crlf

+50

-0

src/Network/Vriska/Response.hs less more

	1	module Network.Vriska.Response where
	2
	3	import qualified Data.ByteString as BS
	4	import qualified Data.ByteString.Char8 as BS8
	5
	6	import Network.Vriska.Types
	7
	8	pCode :: BS.ByteString -> (Int, Int, Int)
	9	pCode ln
	10	\| Just (a, as) <- BS.uncons ln
	11	, Just (b, bs) <- BS.uncons as
	12	, Just (c, "") <- BS.uncons bs
	13	= ( fromIntegral (a - 48)
	14	, fromIntegral (b - 48)
	15	, fromIntegral (c - 48)
	16	)
	17	\| otherwise = error "???"
	18
	19	readResponse :: Connection -> IO (Either HTTPError Response)
	20	readResponse conn = do
	21	ln <- connReadLine conn
	22	case BS.split 32 ln of
	23	(_version:code:_reason) -> do
	24	let c = pCode code
	25	headers <- readHeaders conn
	26	body <- readBody conn headers
	27	return (Right (Response headers c (Just body)))
	28	_ -> return (Left HTTPError)
	29
	30	readHeaders :: Connection -> IO [Header]
	31	readHeaders conn = do
	32	ln <- connReadLine conn
	33	let Just (ln', 13) = BS.unsnoc ln
	34	if BS.null ln'
	35	then return []
	36	else do
	37	let (key:vals) = BS.split 58 ln'
	38	let val = BS.intercalate ":" vals
	39	rs <- readHeaders conn
	40	return (Header key (BS.tail val) : rs)
	41
	42	readBody :: Connection -> [Header] -> IO BS.ByteString
	43	readBody conn hs
	44	= case [ read (BS8.unpack value)
	45	\| Header name value <- hs
	46	, name == "Content-Length"
	47	]
	48	of
	49	[ len ] -> connRead conn len
	50	_ -> return ""

+67

-0

src/Network/Vriska/Types.hs less more

	1	{-# LANGUAGE FlexibleInstances #-}
	2	module Network.Vriska.Types where
	3
	4	import qualified Control.Exception as Ex
	5	import qualified Data.ByteString as BS
	6	import qualified Data.ByteString.Lazy as LBS
	7	import Data.Typeable (Typeable)
	8
	9	data Method
	10	= MGet
	11	\| MHead
	12	\| MPost
	13	\| MPut
	14	\| MDelete
	15	\| MTrace
	16	\| MOptions
	17	\| MConnect
	18	\| MPatch
	19	\| MOther BS.ByteString
	20	deriving (Eq, Show)
	21
	22	data Header = Header BS.ByteString BS.ByteString deriving (Eq, Show)
	23
	24	data Request = Request
	25	{ requestMethod :: Method
	26	, requestPath :: BS.ByteString
	27	, requestHeaders :: [Header]
	28	, requestBody :: BS.ByteString
	29	} deriving (Eq, Show)
	30
	31	type ResponseCode = (Int, Int, Int)
	32
	33	data Response = Response
	34	{ responseHeaders :: [Header]
	35	, responseCode :: ResponseCode
	36	, responseBody :: Maybe BS.ByteString
	37	} deriving (Eq, Show)
	38
	39	-- \| This "Connection" abstraction allows us to build on top of
	40	-- arbitrary other connection packages for our HTTP
	41	data Connection = Connection
	42	{ connRead :: Int -> IO BS.ByteString
	43	, connReadLine :: IO BS.ByteString
	44	, connWrite :: LBS.ByteString -> IO ()
	45	, connClose :: IO ()
	46	}
	47
	48	data HTTPError = HTTPError deriving (Typeable, Show)
	49
	50	instance Ex.Exception HTTPError where
	51	toException = undefined
	52	fromException = undefined
	53
	54	class HTTPResult t where
	55	fromResponse :: Either HTTPError Response -> t
	56
	57	instance HTTPResult r => HTTPResult (Either HTTPError r) where
	58	fromResponse (Left err) = Left err
	59	fromResponse (Right v) = Right (fromResponse (Right v))
	60
	61	instance HTTPResult r => HTTPResult (Maybe r) where
	62	fromResponse (Left _) = Nothing
	63	fromResponse (Right v) = Just (fromResponse (Right v))
	64
	65	instance HTTPResult Response where
	66	fromResponse (Left err) = Ex.throw err
	67	fromResponse (Right v) = v

+1

-0

src/Network/Vriska/Utils.hs less more

1

module Network.Vriska.Utils where

+35

-0

src/Network/Vriska.hs less more

	1	module Network.Vriska where
	2
	3	import qualified Data.ByteString as BS
	4	import qualified Network.Socket as Sock
	5	import qualified System.IO as H
	6
	7	import Network.Vriska.Connection
	8	import Network.Vriska.Request
	9	import Network.Vriska.Response
	10	import Network.Vriska.Types
	11
	12	request :: Method -> BS.ByteString -> [Header] -> Request
	13	request m p hs = Request m p (hs' ++ hs) ""
	14	where hs' = [ Header "Content-Length" "0"
	15	, Header "User-Agent" "haskell/vriska"
	16	]
	17
	18	httpConnection :: String -> IO Connection
	19	httpConnection host = do
	20	addrInfo <- Sock.getAddrInfo Nothing (Just host) (Just "http")
	21	case addrInfo of
	22	[] -> error ("unable to look up " ++ host)
	23	info:_ -> do
	24	s <- Sock.socket (Sock.addrFamily info)
	25	(Sock.addrSocketType info)
	26	(Sock.addrProtocol info)
	27	Sock.connect s (Sock.addrAddress info)
	28	h <- Sock.socketToHandle s H.ReadWriteMode
	29	return $ handleToConnection h
	30
	31	makeRequest :: Connection -> Request -> IO (Either HTTPError Response)
	32	makeRequest conn req = do
	33	let pReq = pRequest req
	34	connWrite conn pReq
	35	readResponse conn

+36

-0

vriska.cabal less more

	1	name: vriska
	2	version: 0.1.0.0
	3	-- synopsis:
	4	-- description:
	5	license: BSD3
	6	license-file: LICENSE
	7	author: Getty Ritter <getty.ritter@gmail.com>
	8	maintainer: Getty Ritter <getty.ritter@gmail.com>
	9	copyright: ©2017 Getty Ritter
	10	-- category:
	11	build-type: Simple
	12	cabal-version: >= 1.14
	13
	14	library
	15	exposed-modules: Network.Vriska
	16	, Network.Vriska.Connection
	17	, Network.Vriska.Types
	18	, Network.Vriska.Request
	19	, Network.Vriska.Response
	20	, Network.Vriska.Utils
	21	hs-source-dirs: src
	22	ghc-options: -Wall
	23	build-depends: base >=4.7 && <4.10
	24	, bytestring
	25	, network
	26	default-language: Haskell2010
	27	default-extensions: OverloadedStrings,
	28	ScopedTypeVariables
	29
	30	executable example
	31	hs-source-dirs: example
	32	main-is: Main.hs
	33	ghc-options: -Wall
	34	build-depends: base, vriska, pretty-show
	35	default-language: Haskell2010
	36	default-extensions: OverloadedStrings