← Back to branch summary

~ubuntu-branches/ubuntu/raring/haskell-wai-extra/raring

« back to all changes in this revision

Viewing changes to Network/Wai/Middleware/Debug.hs

  • Committer: Package Import Robot
  • Author(s): Clint Adams
  • Date: 2012-03-09 14:12:00 UTC
  • mfrom: (2.1.6 sid)
  • Revision ID: package-import@ubuntu.com-20120309141200-pwnlh5b9fme9ps47
Tags: 1.1.0.1-2
http://bugs.debian.org/663242
Add missing build dependencies on ansi-terminal.  closes: #663242.

Show diffs side-by-side

added added

removed removed

Lines of Context:
Network/Wai/Middleware/Debug.hs
1
 
{-# LANGUAGE OverloadedStrings #-}
2
 
module Network.Wai.Middleware.Debug
3
 
    ( debug
4
 
    , debugHandle
5
 
    ) where
6
 
 
7
 
import Network.Wai (Request(..), Middleware)
8
 
import Network.Wai.Parse (parseRequestBody, lbsSink, fileName, Param, File)
9
 
import Data.ByteString.Char8 (unpack)
10
 
import qualified Data.ByteString as S
11
 
import qualified Data.ByteString.Lazy as L
12
 
import System.IO (hPutStrLn, stderr)
13
 
import Control.Monad.IO.Class (liftIO)
14
 
import qualified Data.Text.Lazy as T
15
 
import Data.Enumerator (run_, ($$), enumList)
16
 
import Data.Enumerator.List (consume)
17
 
 
18
 
debug :: Middleware
19
 
debug = debugHandle $ hPutStrLn stderr . T.unpack
20
 
 
21
 
debugHandle :: (T.Text -> IO ()) -> Middleware
22
 
debugHandle cb app req = do
23
 
    body <- consume
24
 
    postParams <- if any (requestMethod req ==) ["GET", "HEAD"]
25
 
      then return []
26
 
      else do postParams <- liftIO $ allPostParams req body
27
 
              return $ collectPostParams postParams
28
 
    let getParams = map emptyGetParam $ queryString req
29
 
 
30
 
    liftIO $ cb $ T.pack $ concat
31
 
        [ unpack $ requestMethod req
32
 
        , " "
33
 
        , unpack $ rawPathInfo req
34
 
        , "\n"
35
 
        , (++) "Accept: " $ maybe "" unpack $ lookup "Accept" $ requestHeaders req
36
 
        , paramsToStr  "GET " getParams
37
 
        , paramsToStr "POST " postParams
38
 
        ]
39
 
    -- we just consumed the body- fill the enumerator back up so it is available again
40
 
    liftIO $ run_ $ enumList 1 body $$ app req
41
 
  where
42
 
    paramsToStr prefix params = if null params then "" else "\n" ++ prefix ++ (show params)
43
 
 
44
 
    allPostParams req' body = run_ $ enumList 1 body $$ parseRequestBody lbsSink req'
45
 
 
46
 
    emptyGetParam :: (S.ByteString, Maybe S.ByteString) -> (S.ByteString, S.ByteString)
47
 
    emptyGetParam (k, Just v) = (k,v)
48
 
    emptyGetParam (k, Nothing) = (k,"")
49
 
 
50
 
    collectPostParams :: ([Param], [File L.ByteString]) -> [Param]
51
 
    collectPostParams (postParams, files) = postParams ++
52
 
      (map (\(k,v) -> (k, S.append "FILE: " (fileName v))) files)