Skip to content

Commit db37c69

Browse files
winterland1989winterland1989
committed
start rolling
0 parents  commit db37c69

File tree

6 files changed

+325
-0
lines changed

6 files changed

+325
-0
lines changed

‎CHANGELOG.md

+5
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
# Revision history for z-uri
2+
3+
## 0.1.0.0 -- YYYY-mm-dd
4+
5+
* First version. Released on an unsuspecting world.

‎LICENSE

+20
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
Copyright (c) 2021 Dong
2+
3+
Permission is hereby granted, free of charge, to any person obtaining
4+
a copy of this software and associated documentation files (the
5+
"Software"), to deal in the Software without restriction, including
6+
without limitation the rights to use, copy, modify, merge, publish,
7+
distribute, sublicense, and/or sell copies of the Software, and to
8+
permit persons to whom the Software is furnished to do so, subject to
9+
the following conditions:
10+
11+
The above copyright notice and this permission notice shall be included
12+
in all copies or substantial portions of the Software.
13+
14+
THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15+
EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16+
MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
17+
IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
18+
CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
19+
TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
20+
SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

‎Z/Data/HTTP/Request.hs

+189
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,189 @@
1+
module Z.Data.HTTP.Request where
2+
3+
import Control.Monad
4+
import Data.IORef
5+
import qualified Data.CaseInsensitive as CI
6+
import qualified Z.Data.Builder as B
7+
import qualified Z.Data.Parser as P
8+
import qualified Z.Data.Parser as P
9+
import qualified Z.Data.Text as T
10+
import qualified Z.Data.Vector as V
11+
import qualified Z.Data.Vector.Base as V
12+
import qualified Z.Data.Vector.Search as V
13+
import Z.Data.ASCII
14+
import Z.Data.PrimRef
15+
import Z.IO
16+
import Z.IO.Network
17+
18+
19+
data HTTPException
20+
= BadHeaderLine V.Bytes
21+
| EmptyOrBadContentLength
22+
| NoHostHeader
23+
| ClientExpectedShutDown
24+
deriving Show
25+
26+
instance Exception HTTPException
27+
28+
-- | HTTP standard method (as defined by RFC 2616, and PATCH which is defined
29+
-- by RFC 5789).
30+
data Method
31+
= GET
32+
| POST
33+
| HEAD
34+
| PUT
35+
| DELETE
36+
| TRACE
37+
| CONNECT
38+
| OPTIONS
39+
| PATCH
40+
| CUSTOM_METHOD V.Bytes
41+
deriving (Eq, Ord)
42+
43+
instance T.Print Method where
44+
toUTF8BuilderP _ GET = "GET"
45+
toUTF8BuilderP _ POST = "POST"
46+
toUTF8BuilderP _ HEAD = "HEAD"
47+
toUTF8BuilderP _ PUT = "PUT"
48+
toUTF8BuilderP _ DELETE = "DELETE"
49+
toUTF8BuilderP _ TRACE = "TRACE"
50+
toUTF8BuilderP _ CONNECT = "CONNECT"
51+
toUTF8BuilderP _ OPTIONS = "OPTIONS"
52+
toUTF8BuilderP _ PATCH = "PATCH"
53+
toUTF8BuilderP _ (CUSTOM_METHOD bs) = B.bytes bs
54+
55+
56+
data Version = Version {-# UNPACK #-} !Int {-# UNPACK #-} !Int
57+
deriving (Eq, Ord)
58+
59+
instance T.Print Version where
60+
toUTF8BuilderP _ (Version maj min) = do
61+
"HTTP"
62+
B.int maj
63+
B.encodePrim DOT
64+
B.int min
65+
66+
data Request = Request
67+
{ requestHost :: V.Bytes
68+
, requestSecure :: Bool
69+
, requestRemote :: SocketAddr
70+
71+
, requestMethod :: !Method
72+
, requestVersion :: !Version
73+
, requestPathRaw :: !V.Bytes
74+
, requestPathQuery :: ([V.Bytes], V.Vector (V.Bytes, V.Bytes))
75+
76+
, requestHeaders :: V.Vector (V.Bytes, V.Bytes)
77+
78+
, requestBody :: Either V.Bytes (Source V.Bytes)
79+
}
80+
81+
82+
requestLineParser :: P.Parser (Method, V.Bytes, Version)
83+
requestLineParser = do
84+
-- method
85+
mbs <- P.takeWhile1 (/= SPACE)
86+
let !method = case mbs of
87+
"GET" -> GET
88+
"POST" -> POST
89+
"HEAD" -> HEAD
90+
"PUT" -> PUT
91+
"DELETE" -> DELETE
92+
"TRACE" -> TRACE
93+
"CONNECT" -> CONNECT
94+
"OPTIONS" -> OPTIONS
95+
"PATCH" -> PATCH
96+
_ -> CUSTOM_METHOD mbs
97+
P.skipWord8
98+
99+
-- path
100+
!rawpath <- P.takeWhile1 (/= SPACE)
101+
P.skipWord8
102+
103+
-- version
104+
vbs <- P.bytes "HTTP/"
105+
majv <- P.satisfy isDigit
106+
P.word8 DOT
107+
minv <- P.satisfy isDigit
108+
let !version = Version (fromIntegral $ majv - DIGIT_0) (fromIntegral $ minv - DIGIT_0)
109+
110+
-- request line end
111+
P.word8 CARRIAGE_RETURN
112+
P.word8 NEWLINE
113+
114+
pure (method, rawpath, version)
115+
116+
readRequest :: HasCallStack
117+
=> SocketAddr
118+
-> Bool
119+
-> BufferedInput
120+
-> IO (Bool, Request) -- ^ (keep-alive, request)
121+
readRequest remoteAddr secure bi = do
122+
-- some special headers
123+
contentLenRef <- newCounter 0
124+
transferEncodingRef <- newIORef V.empty
125+
hostRef <- newIORef V.empty
126+
connectionRef <- newIORef False
127+
128+
(method, rawpath, version) <- readParser requestLineParser bi
129+
printStdLn (method, rawpath, version)
130+
131+
headers <- readHeaderLines contentLenRef transferEncodingRef hostRef connectionRef
132+
133+
host <- readIORef hostRef
134+
when (V.null host) $ throwIO NoHostHeader
135+
136+
contentLen <- readPrimIORef contentLenRef
137+
transferEncoding <- readIORef transferEncodingRef
138+
keepAlive <- readIORef connectionRef
139+
140+
body <-
141+
if CI.foldCase transferEncoding == "chunked"
142+
then sourceChunkedEncoding bi
143+
else if contentLen > 0
144+
then Left <$> readExactly contentLen bi
145+
else if contentLen == 0
146+
then return (Left V.empty)
147+
else throwIO EmptyOrBadContentLength
148+
149+
pure (keepAlive, Request host secure remoteAddr method version
150+
rawpath (parsePathQuery rawpath) headers body)
151+
152+
where
153+
parsePathQuery x = undefined
154+
sourceChunkedEncoding bi = pure $ Right undefined
155+
156+
readHeaderLines contentLenRef transferEncodingRef hostRef connectionRef =
157+
let loop !i acc = do
158+
mhdr <- readLine bi
159+
case mhdr of
160+
Just hdr@(V.PrimVector arr s l) ->
161+
if l == 0
162+
then return $! V.packRN i acc
163+
else do
164+
let (!n, _) = V.findByte COLON hdr
165+
if n == l
166+
then throwIO (BadHeaderLine hdr)
167+
else do
168+
let !hdrK = CI.foldCase (V.PrimVector arr s n)
169+
!hdrV = V.PrimVector arr (s+n+1) (l-n-1)
170+
171+
172+
when (hdrK == "content-length") $
173+
case P.parse' P.uint hdrV of
174+
Right l -> writePrimIORef contentLenRef l
175+
_ -> throwIO (BadHeaderLine hdr)
176+
177+
when (hdrK == "transfer-encoding") $
178+
writeIORef transferEncodingRef hdrV
179+
180+
when (hdrK == "host") $
181+
writeIORef hostRef hdrV
182+
183+
when (hdrK == "connection") $
184+
writeIORef connectionRef $! (hdrV == "keep-alive")
185+
186+
loop (i+1) ((hdrK, hdrV) : acc)
187+
_ -> throwIO ClientExpectedShutDown
188+
in loop 0 []
189+

‎Z/HTTP/Server.hs

+25
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,25 @@
1+
module Z.HTTP.Server where
2+
3+
import Z.Data.HTTP.Request
4+
import Z.IO.Network
5+
import Z.IO
6+
7+
type ServerLoop = (UVStream -> IO ()) -> IO ()
8+
data HTTPServerConfig = HTTPServerConfig
9+
{ httpSendBufSiz :: Int
10+
, httpRecvBufSiz :: Int
11+
}
12+
13+
defaultHTTPServerConfig :: HTTPServerConfig
14+
defaultHTTPServerConfig = HTTPServerConfig defaultChunkSize defaultChunkSize
15+
16+
runHTTPServer' :: ServerLoop
17+
-> HTTPServerConfig
18+
-> (Request -> IO ())
19+
-> IO ()
20+
runHTTPServer' loop conf@HTTPServerConfig{..} worker = loop $ \ uvs -> do
21+
remoteAddr <- getTCPPeerName uvs
22+
bi <- newBufferedInput' httpSendBufSiz uvs
23+
bo <- newBufferedOutput' httpSendBufSiz uvs
24+
req <- readRequest remoteAddr False bi
25+
return ()

‎test/MyLibTest.hs

+4
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,4 @@
1+
module Main (main) where
2+
3+
main :: IO ()
4+
main = putStrLn "Test suite not yet implemented."

‎z-http.cabal

+82
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,82 @@
1+
cabal-version: 2.4
2+
name: z-http
3+
version: 0.1.0.0
4+
synopsis:
5+
6+
-- A longer description of the package.
7+
-- description:
8+
homepage:
9+
10+
-- A URL where users can report bugs.
11+
-- bug-reports:
12+
license: MIT
13+
license-file: LICENSE
14+
author: Dong
15+
maintainer: [email protected]
16+
17+
-- A copyright notice.
18+
-- copyright:
19+
category: Network
20+
extra-source-files: CHANGELOG.md
21+
22+
library
23+
exposed-modules: Z.Data.HTTP.Request
24+
Z.HTTP.Server
25+
26+
-- Modules included in this library but not exported.
27+
-- other-modules:
28+
29+
build-depends: base >=4.14
30+
, case-insensitive == 1.*
31+
, Z-Data == 0.7.*
32+
, Z-IO == 0.7.*
33+
34+
-- Directories containing source files.
35+
hs-source-dirs: .
36+
default-language: Haskell2010
37+
default-extensions:
38+
BangPatterns
39+
BinaryLiterals
40+
CApiFFI
41+
CPP
42+
ConstraintKinds
43+
DataKinds
44+
DefaultSignatures
45+
DeriveAnyClass
46+
DeriveGeneric
47+
DerivingStrategies
48+
ExistentialQuantification
49+
FlexibleContexts
50+
FlexibleInstances
51+
GeneralizedNewtypeDeriving
52+
KindSignatures
53+
MagicHash
54+
MultiParamTypeClasses
55+
MultiWayIf
56+
OverloadedStrings
57+
PartialTypeSignatures
58+
PatternSynonyms
59+
PolyKinds
60+
QuantifiedConstraints
61+
QuasiQuotes
62+
RankNTypes
63+
RecordWildCards
64+
ScopedTypeVariables
65+
StandaloneDeriving
66+
TemplateHaskell
67+
TupleSections
68+
TypeApplications
69+
TypeFamilies
70+
TypeFamilyDependencies
71+
TypeOperators
72+
UnboxedTuples
73+
UnliftedFFITypes
74+
ViewPatterns
75+
76+
77+
test-suite z-http-test
78+
default-language: Haskell2010
79+
type: exitcode-stdio-1.0
80+
hs-source-dirs: test
81+
main-is: MyLibTest.hs
82+
build-depends: base ^>=4.14.1.0

0 commit comments

Comments
 (0)