wai-extra 1.1.0 → 1.1.0.1
raw patch · 2 files changed
+92/−13 lines, 2 filesdep +ansi-terminaldep ~blaze-builder-conduitdep ~conduitdep ~zlib-conduit
Dependencies added: ansi-terminal
Dependency ranges changed: blaze-builder-conduit, conduit, zlib-conduit
Files
Network/Wai/Middleware/RequestLogger.hs view
@@ -11,9 +11,9 @@ import System.IO (stdout, hFlush) import qualified Data.ByteString as BS-import Data.ByteString.Char8 (pack)+import Data.ByteString.Char8 (pack, unpack) import Control.Monad.IO.Class (liftIO)-import Network.Wai (Request(..), Middleware)+import Network.Wai (Request(..), Middleware, responseStatus) import System.Log.FastLogger import Network.HTTP.Types as H @@ -23,6 +23,10 @@ import qualified Data.Conduit as C import qualified Data.Conduit.List as CL +import System.Console.ANSI+import Data.IORef+import System.IO.Unsafe+ logHandle :: (BS.ByteString -> IO ()) -> Middleware logHandle = logCallback {-# DEPRECATED logHandle "Please use logCallback instead." #-}@@ -66,24 +70,72 @@ toBS :: H.Ascii -> BS.ByteString toBS = id +-- no black or white which are expected to be existing terminal colors.+colors :: IORef [Color]+colors = unsafePerformIO $ newIORef $ [+ Red + , Green + , Yellow + , Blue + , Magenta + , Cyan+ ]++rotateColors :: [Color] -> ([Color], Color)+rotateColors [] = error "Impossible! There must be colors!"+rotateColors (c:cs) = (cs ++ [c], c)+ -- | Prints a message using the given callback function for each request. -- This is not for serious production use- it is inefficient. -- It immediately consumes a POST body and fills it back in and is otherwise inefficient ----- This is lower-level - use "logStdoutDev" unless you need this greater control+-- Note that it logs the request immediately when it is received.+-- This meanst that you can accurately see the interleaving of requests.+-- And if the app crashes you have still logged the request.+-- However, if you are simulating 10 simultaneous users you may find this confusing.+-- The request and response are connected by color on Unix and also by the request path.+--+-- This is lower-level - use "logStdoutDev" unless you need greater control.+--+-- Example ouput:+--+-- GET search+-- Accept: text/html,application/xhtml+xml,application/xml;q=0.9,*/*;q=0.8+--+-- Status: 200 OK. search+-- +-- GET static/css/normalize.css+-- Accept: text/css,*/*;q=0.1+-- GET [("LXwioiBG","")]+--+-- Status: 304 Not Modified. static/css/normalize.css logCallbackDev :: (BS.ByteString -> IO ()) -- ^ A function that logs the ByteString log message. -> Middleware logCallbackDev cb app req = do- body <- requestBody req C.$$ CL.consume+ let mlen = lookup "content-length" (requestHeaders req) >>= readInt+ (req', body) <-+ case mlen of+ -- log the request body if it is small+ Just len | len <= 2048 -> do+ body <- requestBody req C.$$ CL.consume+ -- logging the body here consumes it, so fill it back up+ -- obviously not efficient, but this is the development logger+ let req' = req { requestBody = CL.sourceList body }+ return (req', body)+ _ -> return (req, [])+ postParams <- if any (requestMethod req ==) ["GET", "HEAD"] then return [] else do postParams <- liftIO $ allPostParams body return $ collectPostParams postParams+ let getParams = map emptyGetParam $ queryString req - liftIO $ cb $ BS.concat- [ requestMethod req- , " "+ color <- liftIO $ atomicModifyIORef colors rotateColors++ -- log the request immediately.+ liftIO $ cb $ BS.concat $ ansiColor color (requestMethod req) +++ [ " " , rawPathInfo req , "\n" , "Accept: "@@ -92,9 +144,30 @@ , paramsToBS "POST " postParams , "\n" ]- -- The body was consumed. Fill it back up so it is available again- app req { requestBody = CL.sourceList body }++ rsp <- app req'++ -- log the status of the response+ -- this is color coordinated with the request logging+ -- also includes the request path to connect it to the request+ liftIO $ cb $ BS.concat $ ansiColor color "Status: " ++ [+ sCode rsp+ , " "+ , msg rsp+ , ". "+ , rawPathInfo req -- if you need help matching the 2 logging statements+ , "\n"+ ]+ return rsp where+ ansiColor color bs = [+ pack $ setSGRCode [SetColor Foreground Vivid color]+ , bs+ , pack $ setSGRCode [Reset]+ ]+ sCode = pack . show . statusCode . responseStatus+ msg = statusMessage . responseStatus+ paramsToBS prefix params = if null params then "" else BS.concat ["\n", prefix, pack (show params)]@@ -111,3 +184,8 @@ collectPostParams :: ([Param], [File LBS.ByteString]) -> [Param] collectPostParams (postParams, files) = postParams ++ (map (\(k,v) -> (k, BS.append "FILE: " (fileName v))) files)++ readInt bs =+ case reads $ unpack bs of+ (i, _):_ -> Just (i :: Int)+ [] -> Nothing
wai-extra.cabal view
@@ -1,5 +1,5 @@ Name: wai-extra-Version: 1.1.0+Version: 1.1.0.1 Synopsis: Provides some basic WAI handlers and middleware. Description: The goal here is to provide common features without many dependencies. License: BSD3@@ -34,9 +34,10 @@ , case-insensitive >= 0.2 , data-default >= 0.3 && < 0.4 , fast-logger >= 0.0.2- , conduit >= 0.2- , zlib-conduit >= 0.2- , blaze-builder-conduit >= 0.2+ , conduit >= 0.2 && < 0.3+ , zlib-conduit >= 0.2 && < 0.3+ , blaze-builder-conduit >= 0.2 && < 0.3+ , ansi-terminal Exposed-modules: Network.Wai.Handler.CGI Network.Wai.Middleware.AcceptOverride