Skip to content

Commit

Permalink
Merge pull request #973 from Vlix/format-files-with-cpp
Browse files Browse the repository at this point in the history 
Format files with CPP
  • Loading branch information
@kazu-yamamoto
kazu-yamamoto authored Jan 15, 2024
2 parents 9d2f7d8 + 2bcf0fa commit 64e42a2
Show file tree
Hide file tree
Showing 19 changed files with 2,354 additions and 1,798 deletions.
78 changes: 41 additions & 37 deletions recv/Network/Socket/BufferPool/Recv.hs
View file
Original file line number Diff line number Diff line change
@@ -1,28 +1,29 @@
{-# LANGUAGE ForeignFunctionInterface, OverloadedStrings #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE OverloadedStrings #-}

module Network.Socket.BufferPool.Recv (
receive
, makeRecvN
) where
receive,
makeRecvN,
) where

import qualified Data.ByteString as BS
import Data.ByteString.Internal (ByteString(..), unsafeCreate)
import Data.ByteString.Internal (ByteString (..), unsafeCreate)
import Data.IORef
import Foreign.C.Error (eAGAIN, getErrno, throwErrno)
import Foreign.C.Types
import Foreign.Ptr (Ptr, castPtr)
import GHC.Conc (threadWaitRead)
import Network.Socket (Socket, withFdSocket)
import System.Posix.Types (Fd(..))
import System.Posix.Types (Fd (..))

#ifdef mingw32_HOST_OS
import GHC.IO.FD (FD(..), readRawBufferPtr)
import Network.Socket.BufferPool.Windows
#endif

import Network.Socket.BufferPool.Types
import Network.Socket.BufferPool.Buffer
import Network.Socket.BufferPool.Types

----------------------------------------------------------------

Expand All @@ -31,14 +32,14 @@ import Network.Socket.BufferPool.Buffer
receive :: Socket -> BufferPool -> Recv
receive sock pool = withBufferPool pool $ \ptr size -> do
#if MIN_VERSION_network(3,1,0)
withFdSocket sock $ \fd -> do
withFdSocket sock $ \fd -> do
#elif MIN_VERSION_network(3,0,0)
fd <- fdSocket sock
fd <- fdSocket sock
#else
let fd = fdSocket sock
let fd = fdSocket sock
#endif
let size' = fromIntegral size
fromIntegral <$> tryReceive fd ptr size'
let size' = fromIntegral size
fromIntegral <$> tryReceive fd ptr size'

----------------------------------------------------------------

Expand All @@ -47,19 +48,20 @@ tryReceive sock ptr size = go
where
go = do
#ifdef mingw32_HOST_OS
bytes <- windowsThreadBlockHack $ fromIntegral <$> readRawBufferPtr "tryReceive" (FD sock 1) (castPtr ptr) 0 size
bytes <- windowsThreadBlockHack $
fromIntegral <$> readRawBufferPtr "tryReceive" (FD sock 1) (castPtr ptr) 0 size
#else
bytes <- c_recv sock (castPtr ptr) size 0
bytes <- c_recv sock (castPtr ptr) size 0
#endif
if bytes == -1 then do
errno <- getErrno
if errno == eAGAIN then do
threadWaitRead (Fd sock)
go
else
throwErrno "tryReceive"
else
return bytes
if bytes == -1
then do
errno <- getErrno
if errno == eAGAIN
then do
threadWaitRead (Fd sock)
go
else throwErrno "tryReceive"
else return bytes

----------------------------------------------------------------

Expand Down Expand Up @@ -89,29 +91,31 @@ recvN ref recv size = do

tryRecvN :: ByteString -> Int -> IO ByteString -> IO (ByteString, ByteString)
tryRecvN init0 siz0 recv
| siz0 <= len0 = return $ BS.splitAt siz0 init0
| otherwise = go (init0:) (siz0 - len0)
| siz0 <= len0 = return $ BS.splitAt siz0 init0
| otherwise = go (init0 :) (siz0 - len0)
where
len0 = BS.length init0
go build left = do
bs <- recv
let len = BS.length bs
if len == 0 then
return ("", "")
else if len >= left then do
let (consume, leftover) = BS.splitAt left bs
ret = concatN siz0 $ build [consume]
return (ret, leftover)
else do
let build' = build . (bs :)
left' = left - len
go build' left'
if len == 0
then return ("", "")
else
if len >= left
then do
let (consume, leftover) = BS.splitAt left bs
ret = concatN siz0 $ build [consume]
return (ret, leftover)
else do
let build' = build . (bs :)
left' = left - len
go build' left'

concatN :: Int -> [ByteString] -> ByteString
concatN total bss0 = unsafeCreate total $ \ptr -> goCopy bss0 ptr
where
goCopy [] _ = return ()
goCopy (bs:bss) ptr = do
goCopy [] _ = return ()
goCopy (bs : bss) ptr = do
ptr' <- copy ptr bs
goCopy bss ptr'

Expand Down
174 changes: 105 additions & 69 deletions wai-app-static/WaiAppStatic/CmdLine.hs
View file
Original file line number Diff line number Diff line change
@@ -1,29 +1,40 @@
{-# LANGUAGE CPP, RecordWildCards #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}

-- | Command line version of wai-app-static, used for the warp-static server.
module WaiAppStatic.CmdLine
( runCommandLine
, Args (..)
) where
module WaiAppStatic.CmdLine (
runCommandLine,
Args (..),
) where

import Network.Wai (Middleware)
import Network.Wai.Application.Static (staticApp, defaultFileServerSettings)
import Network.Wai.Handler.Warp
( runSettings, defaultSettings, setHost, setPort
)
import Options.Applicative
import Text.Printf (printf)
import System.Directory (canonicalizePath)
import Control.Arrow (second, (***))
import Control.Monad (unless)
import Network.Wai.Middleware.RequestLogger (logStdout)
import Network.Wai.Middleware.Gzip
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as S8
import Data.Text (pack)
import Data.String (fromString)
import Network.Mime (defaultMimeMap, mimeByExt, defaultMimeType)
import WaiAppStatic.Types (ssIndices, toPiece, ssGetMimeType, fileName, fromPiece)
import qualified Data.Map as Map
import Data.Maybe (mapMaybe)
import Control.Arrow (second, (***))
import Data.String (fromString)
import Data.Text (pack)
import Network.Mime (defaultMimeMap, defaultMimeType, mimeByExt)
import Network.Wai (Middleware)
import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)
import Network.Wai.Handler.Warp (
defaultSettings,
runSettings,
setHost,
setPort,
)
import Network.Wai.Middleware.Gzip
import Network.Wai.Middleware.RequestLogger (logStdout)
import Options.Applicative
import System.Directory (canonicalizePath)
import Text.Printf (printf)
import WaiAppStatic.Types (
fileName,
fromPiece,
ssGetMimeType,
ssIndices,
toPiece,
)
#if __GLASGOW_HASKELL__ < 804
import Data.Monoid ((<>))
#endif
Expand All @@ -47,44 +58,59 @@ option' = option
#endif

args :: Parser Args
args = Args
<$> strOption
args =
Args
<$> strOption
( long "docroot"
<> short 'd'
<> metavar "DOCROOT"
<> value "."
<> help "directory containing files to serve")
<*> (defIndex <$> many (strOption
( long "index"
<> short 'i'
<> metavar "INDEX"
<> help "index files to serve when a directory is required"
)))
<*> option'
<> short 'd'
<> metavar "DOCROOT"
<> value "."
<> help "directory containing files to serve"
)
<*> ( defIndex
<$> many
( strOption
( long "index"
<> short 'i'
<> metavar "INDEX"
<> help "index files to serve when a directory is required"
)
)
)
<*> option'
( long "port"
<> short 'p'
<> metavar "PORT"
<> value 3000)
<*> switch
<> short 'p'
<> metavar "PORT"
<> value 3000
)
<*> switch
( long "noindex"
<> short 'n')
<*> switch
<> short 'n'
)
<*> switch
( long "quiet"
<> short 'q')
<*> switch
<> short 'q'
)
<*> switch
( long "verbose"
<> short 'v')
<*> many (toPair <$> strOption
( long "mime"
<> short 'm'
<> metavar "MIME"
<> help "extra file extension/mime type mappings"))
<*> strOption
<> short 'v'
)
<*> many
( toPair
<$> strOption
( long "mime"
<> short 'm'
<> metavar "MIME"
<> help "extra file extension/mime type mappings"
)
)
<*> strOption
( long "host"
<> short 'h'
<> metavar "HOST"
<> value "*"
<> help "interface to bind to, special values: *, *4, *6")
<> short 'h'
<> metavar "HOST"
<> value "*"
<> help "interface to bind to, special values: *, *4, *6"
)
where
toPair = second (drop 1) . break (== '=')
defIndex [] = ["index.html", "index.htm"]
Expand All @@ -95,29 +121,39 @@ args = Args
-- Since 2.0.1
runCommandLine :: (Args -> Middleware) -> IO ()
runCommandLine middleware = do
clArgs@Args {..} <- execParser $ info (helperOption <*> args) fullDesc
clArgs@Args{..} <- execParser $ info (helperOption <*> args) fullDesc
let mime' = map (pack *** S8.pack) mime
let mimeMap = Map.fromList mime' `Map.union` defaultMimeMap
docroot' <- canonicalizePath docroot
unless quiet $ printf "Serving directory %s on port %d with %s index files.\n" docroot' port (if noindex then "no" else show index)
let middle = gzip def { gzipFiles = GzipCompress }
. (if verbose then logStdout else id)
. middleware clArgs
unless quiet $
printf
"Serving directory %s on port %d with %s index files.\n"
docroot'
port
(if noindex then "no" else show index)
let middle =
gzip def{gzipFiles = GzipCompress}
. (if verbose then logStdout else id)
. middleware clArgs
runSettings
( setPort port
$ setHost (fromString host)
defaultSettings
( setPort port $
setHost
(fromString host)
defaultSettings
)
$ middle $ staticApp (defaultFileServerSettings $ fromString docroot)
{ ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
, ssGetMimeType = return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
}
where
helperOption :: Parser (a -> a)
helperOption =
$ middle
$ staticApp
(defaultFileServerSettings $ fromString docroot)
{ ssIndices = if noindex then [] else mapMaybe (toPiece . pack) index
, ssGetMimeType =
return . mimeByExt mimeMap defaultMimeType . fromPiece . fileName
}
where
helperOption :: Parser (a -> a)
helperOption =
#if MIN_VERSION_optparse_applicative(0,16,0)
abortOption (ShowHelpText Nothing) $
#else
abortOption ShowHelpText $
#endif
mconcat [long "help", help "Show this help text", hidden]
mconcat [long "help", help "Show this help text", hidden]
Loading

0 comments on commit 64e42a2

Please sign in to comment.