gdritter repos shelob / 7f4a83f
Update examples + fix HEAD reqs Getty Ritter 6 years ago
8 changed file(s) with 81 addition(s) and 29 deletion(s). Collapse all Expand all
77 main :: IO ()
88 main = do
99 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"]
1513 pPrint r0
14
15 r1 <- HTTP.makeRequest conn $
16 HTTP.get "/index.html" [HTTP.Header "Host" "gdritter.com"]
1617 pPrint r1
18
19 r2 <- HTTP.makeRequest conn $
20 HTTP.get "/matzo/matzo.html" [HTTP.Header "Host" "gdritter.com"]
1721 pPrint r2
22
23 HTTP.connClose conn
1824 return ()
2323 build-depends: base >=4.7 && <4.10
2424 , bytestring
2525 , network
26 , deepseq
2627 default-language: Haskell2010
2728 default-extensions: OverloadedStrings,
2829 ScopedTypeVariables
3434 MConnect -> "CONNECT"
3535 MPatch -> "PATCH"
3636 MOther bs -> bs
37
3837 pHeader :: Header -> B.Builder
38 pHeader (HContentLength v) =
39 B.byteString "Content-Length: " <>
40 B.intDec v <> crlf
3941 pHeader (Header k v) =
4042 B.byteString k <> B.char7 ':' <> B.char7 ' ' <>
4143 B.byteString v <> crlf
1616 )
1717 | otherwise = error "???"
1818
19 readResponse :: Connection -> IO (Either HTTPError Response)
20 readResponse conn = do
19 readResponse :: Connection -> Request -> IO (Either HTTPError Response)
20 readResponse conn req = do
2121 ln <- connReadLine conn
2222 case BS.split 32 ln of
2323 (_version:code:_reason) -> do
2424 let c = pCode code
2525 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)))
2831 _ -> return (Left HTTPError)
2932
3033 readHeaders :: Connection -> IO [Header]
3740 let (key:vals) = BS.split 58 ln'
3841 let val = BS.intercalate ":" vals
3942 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
4148
4249 readBody :: Connection -> [Header] -> IO BS.ByteString
4350 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 ]
4852 of
49 [ len ] -> connRead conn len
53 [ len ] -> do
54 print len
55 connRead conn len
5056 _ -> return ""
1 {-# LANGUAGE BangPatterns #-}
2
13 module Network.Shelob.Types where
24
35 import qualified Control.Exception as Ex
6 import Control.DeepSeq (NFData(..))
47 import qualified Data.ByteString as BS
58 import qualified Data.ByteString.Lazy as LBS
69 import Data.Typeable (Typeable)
1518 | MOptions
1619 | MConnect
1720 | MPatch
18 | MOther BS.ByteString
21 | MOther !BS.ByteString
1922 deriving (Eq, Show)
2023
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
2236
2337 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
2842 } 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
2947
3048 type ResponseCode = (Int, Int, Int)
3149
3250 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)
3654 } deriving (Eq, Show)
55
56 instance NFData Response where
57 rnf (Response h c b) = rnf h `seq` rnf c `seq` rnf b
58
3759
3860 -- | This "Connection" abstraction allows us to build on top of
3961 -- arbitrary other connection packages for our HTTP
4466 , connClose :: IO ()
4567 }
4668
47 data HTTPError = HTTPError deriving (Typeable, Show)
69
70 data HTTPError
71 = HTTPError deriving (Typeable, Show)
4872
4973 instance Ex.Exception HTTPError where
5074 toException = undefined
5555 makeRequest :: Connection -> Request -> IO (Either HTTPError Response)
5656 makeRequest conn req = do
5757 let pReq = pRequest req
58 print pReq
5859 connWrite conn pReq
59 readResponse conn
60 readResponse conn req
2323 default-language: Haskell2010
2424 default-extensions: OverloadedStrings,
2525 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
3434 liftIO m = ConnM (\ _ -> m)
3535
3636 -- * HTTPPayload
37 -- | Types that implement
37
38 -- | Types that implement 'HTTPPayload' can be transparently used as
39 -- the body of an HTTP request.
3840 class HTTPPayload t where
3941 toPayload :: t -> BS.ByteString
4042
4446 instance HTTPPayload T.Text where
4547 toPayload = T.encodeUtf8
4648
49 -- | The 'JSONPayload' type is used so that we can interpret the
50 -- payload of a response
4751 newtype JSONPayload t = JSONPayload { fromJSONPayload :: t }
4852
4953 instance Aeson.FromJSON t => Aeson.FromJSON (JSONPayload t) where
7781 fromResponse = onSuccess (go . responseBody)
7882 where go Nothing = Ex.throw HTTPError
7983 go (Just x)
80 | Just rs <- Aeson.decode x = JSONPayload x
84 | Just rs <- Aeson.decodeStrict x = JSONPayload rs
8185 | otherwise = Ex.throw HTTPError
8286
8387 withConn :: Connection -> ConnM a -> IO a