From 30d4ca02ea147089af994ea7d5f7941a4bbe94a7 Mon Sep 17 00:00:00 2001 From: Tom Smeding Date: Fri, 8 May 2026 18:26:10 +0100 Subject: Rename mini-http to mini-http-server And move Parser to Internal.Parser for test suite --- mini-http-server/Main.hs | 12 ++ mini-http-server/Network/HTTP/Server/Mini.hs | 76 ++++++++++ .../Network/HTTP/Server/Mini/Internal/Parser.hs | 162 +++++++++++++++++++++ .../Network/HTTP/Server/Mini/Printer.hs | 39 +++++ mini-http-server/Network/HTTP/Server/Mini/Types.hs | 69 +++++++++ mini-http-server/Network/HTTP/Server/Mini/URI.hs | 44 ++++++ mini-http-server/Network/HTTP/Server/Mini/Util.hs | 9 ++ mini-http/Main.hs | 12 -- mini-http/Network/HTTP/Server/Mini.hs | 76 ---------- mini-http/Network/HTTP/Server/Mini/Parser.hs | 162 --------------------- mini-http/Network/HTTP/Server/Mini/Printer.hs | 39 ----- mini-http/Network/HTTP/Server/Mini/Types.hs | 69 --------- mini-http/Network/HTTP/Server/Mini/URI.hs | 44 ------ mini-http/Network/HTTP/Server/Mini/Util.hs | 9 -- tirclogv.cabal | 5 +- 15 files changed, 414 insertions(+), 413 deletions(-) create mode 100644 mini-http-server/Main.hs create mode 100644 mini-http-server/Network/HTTP/Server/Mini.hs create mode 100644 mini-http-server/Network/HTTP/Server/Mini/Internal/Parser.hs create mode 100644 mini-http-server/Network/HTTP/Server/Mini/Printer.hs create mode 100644 mini-http-server/Network/HTTP/Server/Mini/Types.hs create mode 100644 mini-http-server/Network/HTTP/Server/Mini/URI.hs create mode 100644 mini-http-server/Network/HTTP/Server/Mini/Util.hs delete mode 100644 mini-http/Main.hs delete mode 100644 mini-http/Network/HTTP/Server/Mini.hs delete mode 100644 mini-http/Network/HTTP/Server/Mini/Parser.hs delete mode 100644 mini-http/Network/HTTP/Server/Mini/Printer.hs delete mode 100644 mini-http/Network/HTTP/Server/Mini/Types.hs delete mode 100644 mini-http/Network/HTTP/Server/Mini/URI.hs delete mode 100644 mini-http/Network/HTTP/Server/Mini/Util.hs diff --git a/mini-http-server/Main.hs b/mini-http-server/Main.hs new file mode 100644 index 0000000..08e66c1 --- /dev/null +++ b/mini-http-server/Main.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE OverloadedStrings #-} +module Main where + +import Data.ByteString.Char8 qualified as BS8 + +import Network.HTTP.Server.Mini + + +main :: IO () +main = + run defaultSettings { setPort = 8000 } $ \req -> + return (responseBS status200 [("Content-Type", "text/plain")] (BS8.pack (show req))) diff --git a/mini-http-server/Network/HTTP/Server/Mini.hs b/mini-http-server/Network/HTTP/Server/Mini.hs new file mode 100644 index 0000000..266e958 --- /dev/null +++ b/mini-http-server/Network/HTTP/Server/Mini.hs @@ -0,0 +1,76 @@ +{-# LANGUAGE TypeApplications #-} +module Network.HTTP.Server.Mini ( + run, + module Network.HTTP.Server.Mini.Types, +) where + +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception +import Control.Monad +import Data.List.NonEmpty qualified as NE +import Network.Socket +import Network.Socket.ByteString + +import Network.HTTP.Server.Mini.Internal.Parser +import Network.HTTP.Server.Mini.Printer +import Network.HTTP.Server.Mini.Types + + +-- | The request handler will run in a forkIO thread. +run :: Settings -> (Request -> IO Response) -> IO () +run settings handler = do + let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] + , addrSocketType = Stream } + addrs <- getAddrInfo @NE.NonEmpty (Just hints) Nothing (Just (show (setPort settings))) + + semaphore <- newTVarIO (setMaxParallelRequests settings) + finishVar <- newEmptyMVar + + threads <- forM addrs $ \addr -> + forkIO $ + bracket + (openSocket addr) + (\sock -> close sock `finally` putMVar finishVar ()) + (\sock -> do + setSocketOption sock ReusePort 1 + bind sock (addrAddress addr) + listen sock (setListenQueue settings) + acceptLoop sock semaphore) + + takeMVar finishVar + forM_ threads killThread + where + -- Put the forever _outside_ the mask_ to unmask briefly between iterations + -- (when it's safe because we have nothing ongoing). + acceptLoop sock semaphore = forever $ mask_ $ do + -- Because we're masked, if atomically exits with an async exception, it + -- was while blocking so the transaction failed, so nothing happened, so + -- no cleanup necessary. + atomically $ do + n <- readTVar semaphore + when (n == 0) retry + writeTVar semaphore $! n - 1 + let increment = atomically (modifyTVar' semaphore (+1)) + + (conn, _peer) <- accept sock `onException` increment + let cleanup = close conn `finally` increment + + onException + (do allowInterrupt -- we're masked but we just blocked (in `accept` in FFI), so let exceptions through + -- Now either the forkIO succeeds (and the responsibility for + -- closing and incrementing is passed to the thread) or it fails + -- (and we retain both responsibilities). + void $ forkIO $ + handleConnection settings conn handler `finally` cleanup) + cleanup + +-- | Will not close the connection, instead will just return, expecting the +-- caller to close the connection then. +handleConnection :: Settings -> Socket -> (Request -> IO Response) -> IO () +handleConnection settings conn handler = + readRequest (setMaxRequestSize settings) (recv conn) >>= \case + Nothing -> return () + Just req -> do + resp <- handler req + sendResponse conn resp diff --git a/mini-http-server/Network/HTTP/Server/Mini/Internal/Parser.hs b/mini-http-server/Network/HTTP/Server/Mini/Internal/Parser.hs new file mode 100644 index 0000000..6278326 --- /dev/null +++ b/mini-http-server/Network/HTTP/Server/Mini/Internal/Parser.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeApplications #-} +module Network.HTTP.Server.Mini.Internal.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-server/Network/HTTP/Server/Mini/Printer.hs b/mini-http-server/Network/HTTP/Server/Mini/Printer.hs new file mode 100644 index 0000000..ab6c1f6 --- /dev/null +++ b/mini-http-server/Network/HTTP/Server/Mini/Printer.hs @@ -0,0 +1,39 @@ +{-# 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-server/Network/HTTP/Server/Mini/Types.hs b/mini-http-server/Network/HTTP/Server/Mini/Types.hs new file mode 100644 index 0000000..d657a13 --- /dev/null +++ b/mini-http-server/Network/HTTP/Server/Mini/Types.hs @@ -0,0 +1,69 @@ +{-# 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, Eq) + +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-server/Network/HTTP/Server/Mini/URI.hs b/mini-http-server/Network/HTTP/Server/Mini/URI.hs new file mode 100644 index 0000000..13d7c35 --- /dev/null +++ b/mini-http-server/Network/HTTP/Server/Mini/URI.hs @@ -0,0 +1,44 @@ +{-# 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-server/Network/HTTP/Server/Mini/Util.hs b/mini-http-server/Network/HTTP/Server/Mini/Util.hs new file mode 100644 index 0000000..c29a8e6 --- /dev/null +++ b/mini-http-server/Network/HTTP/Server/Mini/Util.hs @@ -0,0 +1,9 @@ +module Network.HTTP.Server.Mini.Util where + +import Data.Char +import Data.Word + + +{-# INLINE ord8 #-} +ord8 :: Char -> Word8 +ord8 = fromIntegral . ord diff --git a/mini-http/Main.hs b/mini-http/Main.hs deleted file mode 100644 index 08e66c1..0000000 --- a/mini-http/Main.hs +++ /dev/null @@ -1,12 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -module Main where - -import Data.ByteString.Char8 qualified as BS8 - -import Network.HTTP.Server.Mini - - -main :: IO () -main = - run defaultSettings { setPort = 8000 } $ \req -> - return (responseBS status200 [("Content-Type", "text/plain")] (BS8.pack (show req))) diff --git a/mini-http/Network/HTTP/Server/Mini.hs b/mini-http/Network/HTTP/Server/Mini.hs deleted file mode 100644 index 3c5c3f6..0000000 --- a/mini-http/Network/HTTP/Server/Mini.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# LANGUAGE TypeApplications #-} -module Network.HTTP.Server.Mini ( - run, - module Network.HTTP.Server.Mini.Types, -) where - -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception -import Control.Monad -import Data.List.NonEmpty qualified as NE -import Network.Socket -import Network.Socket.ByteString - -import Network.HTTP.Server.Mini.Parser -import Network.HTTP.Server.Mini.Printer -import Network.HTTP.Server.Mini.Types - - --- | The request handler will run in a forkIO thread. -run :: Settings -> (Request -> IO Response) -> IO () -run settings handler = do - let hints = defaultHints { addrFlags = [AI_NUMERICHOST, AI_NUMERICSERV, AI_PASSIVE] - , addrSocketType = Stream } - addrs <- getAddrInfo @NE.NonEmpty (Just hints) Nothing (Just (show (setPort settings))) - - semaphore <- newTVarIO (setMaxParallelRequests settings) - finishVar <- newEmptyMVar - - threads <- forM addrs $ \addr -> - forkIO $ - bracket - (openSocket addr) - (\sock -> close sock `finally` putMVar finishVar ()) - (\sock -> do - setSocketOption sock ReusePort 1 - bind sock (addrAddress addr) - listen sock (setListenQueue settings) - acceptLoop sock semaphore) - - takeMVar finishVar - forM_ threads killThread - where - -- Put the forever _outside_ the mask_ to unmask briefly between iterations - -- (when it's safe because we have nothing ongoing). - acceptLoop sock semaphore = forever $ mask_ $ do - -- Because we're masked, if atomically exits with an async exception, it - -- was while blocking so the transaction failed, so nothing happened, so - -- no cleanup necessary. - atomically $ do - n <- readTVar semaphore - when (n == 0) retry - writeTVar semaphore $! n - 1 - let increment = atomically (modifyTVar' semaphore (+1)) - - (conn, _peer) <- accept sock `onException` increment - let cleanup = close conn `finally` increment - - onException - (do allowInterrupt -- we're masked but we just blocked (in `accept` in FFI), so let exceptions through - -- Now either the forkIO succeeds (and the responsibility for - -- closing and incrementing is passed to the thread) or it fails - -- (and we retain both responsibilities). - void $ forkIO $ - handleConnection settings conn handler `finally` cleanup) - cleanup - --- | Will not close the connection, instead will just return, expecting the --- caller to close the connection then. -handleConnection :: Settings -> Socket -> (Request -> IO Response) -> IO () -handleConnection settings conn handler = - readRequest (setMaxRequestSize settings) (recv conn) >>= \case - Nothing -> return () - Just req -> do - resp <- handler req - sendResponse conn resp 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 diff --git a/tirclogv.cabal b/tirclogv.cabal index cb7f58b..c212830 100644 --- a/tirclogv.cabal +++ b/tirclogv.cabal @@ -52,8 +52,9 @@ library mini-http-server Network.HTTP.Server.Mini Network.HTTP.Server.Mini.URI Network.HTTP.Server.Mini.Types + + Network.HTTP.Server.Mini.Internal.Parser other-modules: - Network.HTTP.Server.Mini.Parser Network.HTTP.Server.Mini.Printer Network.HTTP.Server.Mini.Util build-depends: @@ -63,7 +64,7 @@ library mini-http-server network, transformers, stm - hs-source-dirs: mini-http + hs-source-dirs: mini-http-server default-language: Haskell2010 default-extensions: ImportQualifiedPost -- cgit v1.3.1