gdritter repos shelob / d26eb3c
A simple, hacky HTTP interface Getty Ritter 4 years ago
10 changed file(s) with 281 addition(s) and 0 deletion(s). Collapse all Expand all
1 *~
2 .cabal-sandbox
3 dist-newstyle
4 dist
5 cabal.sandbox.config
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.
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 ()
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
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
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 ""
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 module Network.Vriska.Utils where
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
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