summaryrefslogtreecommitdiff
path: root/mini-http/Network/HTTP/Server/Mini
diff options
context:
space:
mode:
Diffstat (limited to 'mini-http/Network/HTTP/Server/Mini')
-rw-r--r--mini-http/Network/HTTP/Server/Mini/Parser.hs162
-rw-r--r--mini-http/Network/HTTP/Server/Mini/Printer.hs39
-rw-r--r--mini-http/Network/HTTP/Server/Mini/Types.hs69
-rw-r--r--mini-http/Network/HTTP/Server/Mini/URI.hs44
-rw-r--r--mini-http/Network/HTTP/Server/Mini/Util.hs9
5 files changed, 0 insertions, 323 deletions
diff --git a/mini-http/Network/HTTP/Server/Mini/Parser.hs b/mini-http/Network/HTTP/Server/Mini/Parser.hs
deleted file mode 100644
index 1e968cb..0000000
--- a/mini-http/Network/HTTP/Server/Mini/Parser.hs
+++ /dev/null
@@ -1,162 +0,0 @@
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeApplications #-}
-module Network.HTTP.Server.Mini.Parser where
-
-import Control.Monad (guard)
-import Control.Monad.Trans.Maybe
-import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-import Data.ByteString.Short (ShortByteString)
-import Data.ByteString.Short qualified as SBS
-import Data.Char
-import Data.Word
-import FlatParse.Basic qualified as P
-
-import Network.HTTP.Server.Mini.Types
-import Network.HTTP.Server.Mini.URI
-import Network.HTTP.Server.Mini.Util
-
-
-readRequest :: Monad m => Int -> (Int -> m ByteString) -> m (Maybe Request)
-readRequest maxsize recv = runMaybeT $ do
- bs <- MaybeT $ readUntilTerminator maxsize recv []
- hoistMaybe (parseRequest bs)
-
-parseRequest :: ByteString -> Maybe Request
-parseRequest bs =
- case P.runParser pRequest bs of
- P.OK req rest | BS.null rest -> Just req
- _ -> Nothing
-
-pRequest :: P.Parser e Request
-pRequest = do
- (method, uri) <- pFirstLine
- headers <- P.many pHeader
- let (path, query) = parseURI uri
- return Request { reqMethod = method
- , reqURI = uri
- , reqHeaders = headers
- , reqPath = path
- , reqQuery = query }
-
-pFirstLine :: P.Parser e (ShortByteString, ByteString)
-pFirstLine = do
- method <- pTakeUntil (ord8 ' ')
- guard (BS.length method <= 32) -- will put it in an SBS later
- P.word8 32
- uri <- pTakeUntil (ord8 ' ')
- P.word8 32
- $(P.bytes (map (fromIntegral @Int @Word . ord) "HTTP/1."))
- version <- P.anyWord8
- guard (version == ord8 '0' || version == ord8 '1')
- pNewline
- return (SBS.pack (map toAsciiUpperCase (BS.unpack method)), uri)
-
-pHeader :: P.Parser e (Header, ByteString)
-pHeader = do
- key <- pTakeUntil (ord8 ':')
- guard (BS.length key <= 128) -- will put it in an SBS later
- P.word8 (ord8 ':')
- P.skipMany (P.satisfy isLinearSpace)
- value <- pValue []
- return (SBS.pack (map toAsciiLowerCase (BS.unpack key)), value)
- where
- pValue revlines = do
- line <- trimCR <$> pTakeUntil 10
- P.word8 10
- P.withOption (P.lookahead (P.skipSatisfyAscii isLinearSpace))
- (\_ -> pValue (line : revlines))
- (return (BS.concat (reverse (line : revlines))))
-
- trimCR bs
- | len >= 1, bs `BS.index` (len - 1) == 13 = BS.take (len - 1) bs
- | otherwise = bs
- where len = BS.length bs
-
-isLinearSpace :: Char -> Bool
-isLinearSpace c = c == ' ' || c == '\t'
-
-pTakeUntil :: Word8 -> P.Parser e ByteString
-pTakeUntil term = do
- midx <- P.lookahead (BS.elemIndex term <$> P.takeRest)
- case midx of
- Just idx -> P.take idx
- Nothing -> P.failed
-
-pNewline :: P.Parser e ()
-pNewline = P.withAnyWord8 $ \case
- 10 -> return ()
- 13 -> P.word8 10
- _ -> P.failed
-
-readUntilTerminator :: Monad m => Int -> (Int -> m ByteString) -> [ByteString] -> m (Maybe ByteString)
-readUntilTerminator 0 _ _ = return Nothing
-readUntilTerminator maxsize recv toprevprefix = do
- text <- recv maxsize
- if BS.length text == 0
- then return Nothing
- else goFind toprevprefix text
- where
- goFind revprefix text =
- case findTerminator text of
- NoTerm -> readUntilTerminator (maxsize - BS.length text) recv (text : revprefix)
- IncompleteTerm haveCR
- | maxsize == BS.length text -> return Nothing
- | otherwise -> do
- text2 <- recv (maxsize - BS.length text)
- text2' <- case BS.length text2 of
- 1 -> (text2 <>) <$> recv (maxsize - BS.length text - 1) -- premature concat but rare
- _ -> return text2 -- also for length 0 (i.e. EOF)!
- -- now text2' has length at least 2 if available before EOF
- case (haveCR, BS.length text2') of
- (_, 0) -> return Nothing
- (False, _) | text2' `BS.index` 0 == 10 -> return (Just (BS.concat (reverse (text : revprefix))))
- (False, n) | n >= 2, text2' `BS.index` 0 == 13, text2' `BS.index` 1 == 10 ->
- return (Just (BS.concat (reverse (text : revprefix))))
- (True, _) | text2' `BS.index` 0 == 10 -> return (Just (BS.init (BS.concat (reverse (text : revprefix)))))
- (_, 1) -> return Nothing -- second recv returned EOF and no terminator found before that
- _ -> goFind (text : revprefix) text2'
- FoundTerm i -> return (Just (BS.concat (reverse (BS.take i text : revprefix))))
-
-data FoundTerminator
- = NoTerm
- | IncompleteTerm {-# UNPACK #-} !Bool
- -- ^ Bool indicates "have CR".
- -- If False, then LF at end of segment, requires LF or CRLF at start of next.
- -- If True, then LF CR at end of segment, requires LF at start of next.
- | FoundTerm Int -- ^ Index right after the first [CR]LF sequence in the terminator
- deriving (Show)
-
-findTerminator :: ByteString -> FoundTerminator
-findTerminator bs =
- -- We're looking for [CR] LF [CR] LF. Look for the first LF, and see if it's
- -- followed by CRLF or LF.
- go (BS.elemIndices 10 bs)
- where
- len = BS.length bs
-
- go [] = NoTerm
- go (i:is)
- | i == len - 1 = IncompleteTerm False
- | i == len - 2 =
- case bs `BS.index` (i+1) of
- 10 -> FoundTerm (i+1)
- 13 -> IncompleteTerm True
- _ -> NoTerm
- -- now certainly two bytes after this LF
- | otherwise =
- case bs `BS.index` (i+1) of
- 10 -> FoundTerm (i+1)
- -- [i+2] is read twice if this check fails, but LF CR (!=LF) will be very rare so it's fine
- 13 | bs `BS.index` (i+2) == 10 -> FoundTerm (i+1)
- _ -> go is
-
-toAsciiUpperCase :: Word8 -> Word8
-toAsciiUpperCase c
- | ord8 'a' <= c, c <= ord8 'z' = c - 32
- | otherwise = c
-
-toAsciiLowerCase :: Word8 -> Word8
-toAsciiLowerCase c
- | ord8 'A' <= c, c <= ord8 'Z' = c + 32
- | otherwise = c
diff --git a/mini-http/Network/HTTP/Server/Mini/Printer.hs b/mini-http/Network/HTTP/Server/Mini/Printer.hs
deleted file mode 100644
index ab6c1f6..0000000
--- a/mini-http/Network/HTTP/Server/Mini/Printer.hs
+++ /dev/null
@@ -1,39 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Network.HTTP.Server.Mini.Printer where
-
-import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-import Data.ByteString.Lazy qualified as BSL
-import Data.ByteString.Builder qualified as BSB
-import Network.Socket
-import Network.Socket.ByteString
-
-import Network.HTTP.Server.Mini.Types
-
-
-sendResponse :: Socket -> Response -> IO ()
-sendResponse conn (Response status hdrs (BodyLBS body)) =
- sendResponseChunks conn status hdrs body
-sendResponse conn (Response status hdrs (BodyFile path)) =
- -- lazy IO is fine here because the whole thing is traversed before the end of this function in sendMany
- sendResponseChunks conn status hdrs =<< BSL.readFile path
-
-sendResponseChunks :: Socket -> Status -> [(Header, ByteString)] -> BSL.ByteString -> IO ()
-sendResponseChunks conn (Status code reason) hdrs body =
- sendMany conn $
- BSL.toStrict (BSB.toLazyByteString
- (BSB.shortByteString "HTTP/1.1 "
- <> BSB.intDec code
- <> BSB.char8 ' '
- <> BSB.shortByteString reason
- <> BSB.shortByteString "\r\n"
- <> foldMap (\(key, val) ->
- BSB.shortByteString key <> BSB.shortByteString ": "
- <> BSB.byteString (wrapHdrVal val) <> BSB.shortByteString "\r\n")
- hdrs
- <> BSB.shortByteString "Content-Length: " <> BSB.int64Dec (BSL.length body)
- <> BSB.shortByteString "\r\nConnection: close\r\n\r\n"))
- : BSL.toChunks body
-
-wrapHdrVal :: ByteString -> ByteString
-wrapHdrVal bs = BS.intercalate (BS.singleton 32) (BS.split 10 bs)
diff --git a/mini-http/Network/HTTP/Server/Mini/Types.hs b/mini-http/Network/HTTP/Server/Mini/Types.hs
deleted file mode 100644
index c764182..0000000
--- a/mini-http/Network/HTTP/Server/Mini/Types.hs
+++ /dev/null
@@ -1,69 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-module Network.HTTP.Server.Mini.Types where
-
-import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-import Data.ByteString.Lazy (LazyByteString)
-import Data.ByteString.Builder (Builder)
-import Data.ByteString.Builder qualified as BSB
-import Data.ByteString.Short (ShortByteString)
-
-
-data Settings = Settings
- { setPort :: !Int
- , setListenQueue :: !Int
- , setMaxParallelRequests :: !Int
- , setMaxRequestSize :: !Int
- }
- deriving (Show)
-
-defaultSettings :: Settings
-defaultSettings = Settings
- { setPort = 80
- , setListenQueue = 32
- , setMaxParallelRequests = 4
- , setMaxRequestSize = 8192
- }
-
-type Header = ShortByteString
-
-data Request = Request
- { reqMethod :: !ShortByteString -- | All-uppercase
- , reqURI :: !ByteString
- , reqHeaders :: ![(Header, ByteString)] -- | Header name in all-lowercase
- , reqPath :: [ByteString] -- | Lazy field
- , reqQuery :: [(ByteString, ByteString)] -- | Lazy field
- }
- deriving (Show)
-
-data Status = Status !Int !ShortByteString
- deriving (Show)
-
-data Response = Response
- { resStatus :: !Status
- , resHeaders :: ![(Header, ByteString)]
- , resBody :: !ResponseBody }
- deriving (Show)
-
-data ResponseBody
- = BodyLBS !LazyByteString
- | BodyFile !FilePath
- deriving (Show)
-
-status200 :: Status
-status200 = Status 200 "OK"
-
-status404 :: Status
-status404 = Status 404 "Not Found"
-
-responseLBS :: Status -> [(Header, ByteString)] -> LazyByteString -> Response
-responseLBS status hdrs = Response status hdrs . BodyLBS
-
-responseBS :: Status -> [(Header, ByteString)] -> ByteString -> Response
-responseBS status hdrs = responseLBS status hdrs . BS.fromStrict
-
-responseBuilder :: Status -> [(Header, ByteString)] -> Builder -> Response
-responseBuilder status hdrs = responseLBS status hdrs . BSB.toLazyByteString
-
-responseFile :: Status -> [(Header, ByteString)] -> FilePath -> Response
-responseFile status hdrs = Response status hdrs . BodyFile
diff --git a/mini-http/Network/HTTP/Server/Mini/URI.hs b/mini-http/Network/HTTP/Server/Mini/URI.hs
deleted file mode 100644
index 13d7c35..0000000
--- a/mini-http/Network/HTTP/Server/Mini/URI.hs
+++ /dev/null
@@ -1,44 +0,0 @@
-{-# LANGUAGE ViewPatterns #-}
-module Network.HTTP.Server.Mini.URI where
-
-import Data.ByteString (ByteString)
-import Data.ByteString qualified as BS
-
-import Network.HTTP.Server.Mini.Util
-
-
--- | (path components, query string)
---
--- TODO: percent-decode
-parseURI :: ByteString -> ([ByteString], [(ByteString, ByteString)])
-parseURI = \bs ->
- case BS.uncons bs of
- Just ((== ord8 '/') -> True, bs1) -> goPath id bs1
- _ -> ([], [])
- where
- goPath f bs
- | BS.null bs = (f [], [])
- | otherwise =
- let (comp, bs1) = BS.span (\c -> c /= ord8 '/' && c /= ord8 '?') bs
- in case BS.uncons bs1 of
- Just ((== ord8 '/') -> True, bs2) ->
- goPath (f . (comp:)) bs2
- Just ((== ord8 '?') -> True, bs2) ->
- (f [comp], goQuery bs2)
- _ -> (f [comp], [])
-
- goQuery bs
- | BS.null bs = []
- | Just ((== ord8 '&') -> True, bs1) <- BS.uncons bs = goQuery bs1
- | otherwise =
- let (key, bs1) = BS.span (\c -> c /= ord8 '=' && c /= ord8 '&') bs
- in case BS.uncons bs1 of
- Just ((== ord8 '=') -> True, bs2) ->
- let (val, bs3) = BS.span (\c -> c /= ord8 '&') bs2
- in case BS.uncons bs3 of
- Just (_, bs4) -> (key, val) : goQuery bs4
- Nothing -> [(key, val)]
- Just ((== ord8 '&') -> True, bs2) ->
- (key, BS.empty) : goQuery bs2
- _ ->
- [(key, BS.empty)]
diff --git a/mini-http/Network/HTTP/Server/Mini/Util.hs b/mini-http/Network/HTTP/Server/Mini/Util.hs
deleted file mode 100644
index c29a8e6..0000000
--- a/mini-http/Network/HTTP/Server/Mini/Util.hs
+++ /dev/null
@@ -1,9 +0,0 @@
-module Network.HTTP.Server.Mini.Util where
-
-import Data.Char
-import Data.Word
-
-
-{-# INLINE ord8 #-}
-ord8 :: Char -> Word8
-ord8 = fromIntegral . ord
generated by cgit v1.3.1 (git 2.54.0) at 2026-05-26 22:40:14 +0200