diff --git a/Z/Data/HTTP/Request.hs b/Z/Data/HTTP/Request.hs index f0bbe89..8060f05 100644 --- a/Z/Data/HTTP/Request.hs +++ b/Z/Data/HTTP/Request.hs @@ -5,7 +5,6 @@ import Data.IORef import qualified Data.CaseInsensitive as CI import qualified Z.Data.Builder as B import qualified Z.Data.Parser as P -import qualified Z.Data.Parser as P import qualified Z.Data.Text as T import qualified Z.Data.Vector as V import qualified Z.Data.Vector.Base as V @@ -14,7 +13,7 @@ import Z.Data.ASCII import Z.Data.PrimRef import Z.IO import Z.IO.Network - +import Z.IO.BIO (Source) data HTTPException = BadHeaderLine V.Bytes @@ -54,11 +53,11 @@ instance T.Print Method where data Version = Version {-# UNPACK #-} !Int {-# UNPACK #-} !Int - deriving (Eq, Ord) + deriving (Eq, Ord, Show) instance T.Print Version where toUTF8BuilderP _ (Version maj min) = do - "HTTP" + "HTTP/" B.int maj B.encodePrim DOT B.int min @@ -102,10 +101,10 @@ requestLineParser = do -- version vbs <- P.bytes "HTTP/" - majv <- P.satisfy isDigit + majv <- P.digit P.word8 DOT - minv <- P.satisfy isDigit - let !version = Version (fromIntegral $ majv - DIGIT_0) (fromIntegral $ minv - DIGIT_0) + minv <- P.digit + let !version = Version majv minv -- request line end P.word8 CARRIAGE_RETURN @@ -133,7 +132,7 @@ readRequest remoteAddr secure bi = do host <- readIORef hostRef when (V.null host) $ throwIO NoHostHeader - contentLen <- readPrimIORef contentLenRef + contentLen <- readPrimRef contentLenRef transferEncoding <- readIORef transferEncodingRef keepAlive <- readIORef connectionRef @@ -171,7 +170,7 @@ readRequest remoteAddr secure bi = do when (hdrK == "content-length") $ case P.parse' P.uint hdrV of - Right l -> writePrimIORef contentLenRef l + Right l -> writePrimRef contentLenRef l _ -> throwIO (BadHeaderLine hdr) when (hdrK == "transfer-encoding") $ diff --git a/Z/HTTP/Client.hs b/Z/HTTP/Client.hs new file mode 100644 index 0000000..a9744a3 --- /dev/null +++ b/Z/HTTP/Client.hs @@ -0,0 +1,188 @@ +{-# LANGUAGE StrictData #-} -- Give an error instead of warnings in case + -- user forgets to initialize some fields +{-# LANGUAGE RecordWildCards #-} + +module Z.HTTP.Client where + +import GHC.Word (Word16) +import Data.Foldable (foldr) +import Data.Functor.Identity (Identity) +import Data.Function ((&)) +import Z.IO.Network + ( getAddrInfo + , defaultTCPClientConfig + , initTCPClient + , AddrInfo(addrAddress) + , HostName + , PortNumber(..) + , TCPClientConfig(tcpRemoteAddr) + ) +import Z.IO.Buffered (newBufferedIO, readBuffer, writeBuffer') +import Z.IO (withResource) +import Z.Data.HTTP.Request (Method (..), Version(..)) +import Z.Data.Text (Text) +import Z.Data.Parser (Parser) +import Z.Data.CBytes (fromBytes, buildCBytes, toBytes) +import qualified Z.Data.Parser as P +import qualified Z.Data.ASCII as C +import qualified Z.Data.Vector as V +import qualified Z.Data.Builder as B +import qualified Z.Data.Text as T + +import Z.Data.Vector.FlatMap (FlatMap) +import qualified Z.Data.Vector.FlatMap as FlatMap + +type Path = V.Bytes + +data Request = Request + { reqMethod :: Method + , reqPath :: Path + , reqHost :: V.Bytes + , reqVersion :: Version + , reqHeaders :: [(V.Bytes, V.Bytes)] + } + +data Protocol = HTTP | HTTPS deriving Show + +type Headers = FlatMap V.Bytes V.Bytes + +emptyHeaders :: Headers +emptyHeaders = FlatMap.empty + +data Response = Response + { responseVersion :: Version + , responseCode :: Word16 -- smallest unit that can contain 3 digits int + , responseMessage :: V.Bytes + , responseHeaders :: Headers + } deriving Show + +defaultRequest :: Request +defaultRequest = Request + { reqMethod = GET + , reqPath = "/" + , reqHost = V.empty + , reqVersion = Version 1 1 + , reqHeaders = [] + } + +type Host = (HostName, Maybe PortNumber) + +resolveDNS :: Host -> IO AddrInfo +resolveDNS (hostName, Just portNumber) = head <$> getAddrInfo Nothing hostName (buildCBytes . B.int $ portNumber) +resolveDNS (hostName, Nothing) = head <$> getAddrInfo Nothing hostName "http" + +pattern CRLF :: V.Bytes +pattern CRLF = "\r\n" + +-- build lazily +buildHeaders :: [(V.Bytes, V.Bytes)] -> B.Builder () +buildHeaders = foldr buildHeader "" + where + buildHeader :: (V.Bytes, V.Bytes) -> B.Builder () -> B.Builder () + buildHeader (headerKey, headerVal) b = B.append b $ do + B.bytes headerKey + B.word8 C.COLON + B.bytes headerVal + B.bytes CRLF + +requestToBytes :: Request -> V.Bytes +requestToBytes req = B.build $ do + B.bytes method + B.encodePrim C.SPACE + B.bytes path + B.encodePrim C.SPACE + B.bytes version + B.bytes CRLF + headers + B.bytes CRLF + where + method :: V.Bytes = T.toUTF8Bytes (reqMethod req) + path :: V.Bytes = reqPath req + version :: V.Bytes = T.toUTF8Bytes (reqVersion req) + headers = buildHeaders $ ("Host", reqHost req) : reqHeaders req + +-- TODO: user defined chunksize? +sendRequest :: Request -> IO Response +sendRequest req = do + addr <- resolveDNS (fromBytes $ reqHost req, Nothing) + withResource (initTCPClient defaultTCPClientConfig { tcpRemoteAddr = addrAddress addr }) $ \tcp -> do + (i, o) <- newBufferedIO tcp + writeBuffer' o (requestToBytes req) + buf <- readBuffer i + case P.parse' httpParser buf of + Left _ -> undefined + Right res -> pure res + +httpParser :: Parser Response +httpParser = do + P.bytes "HTTP/" + maj <- P.digit + P.word8 C.DOT + min <- P.digit + P.skipSpaces + httpCode <- P.uint + P.skipSpaces + httpMsg <- P.takeWhile (/= C.CARRIAGE_RETURN) + P.bytes CRLF + !headers <- headersLoop emptyHeaders + return $ Response (Version maj min) httpCode httpMsg headers + + where + headersLoop :: Headers -> Parser Headers + headersLoop acc = do + w <- P.peek + case w of + C.CARRIAGE_RETURN -> do + P.bytes CRLF + return acc + _ -> do + key <- P.takeWhile (/= C.COLON) + P.word8 C.COLON + P.skipSpaces + val <- P.takeWhile (/= C.CARRIAGE_RETURN) + P.bytes CRLF + headersLoop $ FlatMap.insert key val acc + +parseUri :: Parser (Protocol, Host) +parseUri = do + P.bytes "http" + proto <- P.peek + if proto == C.LETTER_S + then P.skipWord8 >> P.bytes "://" >> ((,) HTTPS <$> parseHost) + else P.bytes "://" >> ((,) HTTP <$> parseHost) + +-- This should parse "www.google.com:80" but not "http://www.google.com:80" +parseHost :: Parser Host +parseHost = do + hostName <- P.takeTill (== C.COLON) + w <- P.peek + if w == C.COLON + then P.skipWord8 >> ((,) (fromBytes hostName) <$> (Just . PortNumber <$> P.int)) + else pure (fromBytes hostName, Nothing) + +fromHost :: Text -> Request +fromHost host = let host' = T.toUTF8Bytes host in + case P.parse' parseHost (T.toUTF8Bytes host) of + Left err -> error (show err) + Right (hostName, Nothing) -> defaultRequest { reqHost = toBytes hostName } + Right (hostName, Just port) -> defaultRequest { reqHost = toBytes hostName <> ":" <> T.toUTF8Bytes port } + +fromIpAddr :: Text -> Request +fromIpAddr = undefined + +-- | f :: Request +-- | f = fromHost "www.google.com" +-- | & setPath "/url" +-- | & setHeadears [("X-Powered-By", "Z-HTTP-Client")] + +setMethod :: Method -> Request -> Request +setMethod method req@Request{..} = req { reqMethod = method } + +setPath :: V.Bytes -> Request -> Request +setPath path req@Request{..} = req { reqPath = path } + +setVersion :: Version -> Request -> Request +setVersion version req@Request{..} = req { reqVersion = version } + +setHeadears :: [(V.Bytes, V.Bytes)] -> Request -> Request +setHeadears headers req@Request{..} = req { reqHeaders = headers } diff --git a/z-http.cabal b/z-http.cabal index 41ef6b0..ae50ac5 100644 --- a/z-http.cabal +++ b/z-http.cabal @@ -22,14 +22,15 @@ extra-source-files: CHANGELOG.md library exposed-modules: Z.Data.HTTP.Request Z.HTTP.Server + Z.HTTP.Client -- Modules included in this library but not exported. -- other-modules: build-depends: base >=4.14 , case-insensitive == 1.* - , Z-Data == 0.7.* - , Z-IO == 0.7.* + , Z-Data == 1.0.* + , Z-IO == 1.0.* -- Directories containing source files. hs-source-dirs: .