{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} module Test.Common.TestHandler (testHandler) where import Blaze.ByteString.Builder import Control.Concurrent (threadDelay) import Control.Monad import Control.Monad.Trans import qualified Data.ByteString.Char8 as S import qualified Data.ByteString.Lazy.Char8 as L import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Monoid import Snap.Internal.Debug import Snap.Iteratee hiding (Enumerator) import qualified Snap.Iteratee as I import Snap.Core import Snap.Util.FileServe import Snap.Util.FileUploads import Snap.Util.GZip import System.Directory import Test.Common.Rot13 (rot13) ------------------------------------------------------------------------------ -- timeout handling ------------------------------------------------------------------------------ timeoutTickleHandler :: Snap () timeoutTickleHandler = do noCompression -- FIXME: remove this when zlib-bindings and -- zlib-enumerator support gzip stream flushing modifyResponse $ setResponseBody (trickleOutput 10) . setContentType "text/plain" . setBufferingMode False setTimeout 2 badTimeoutTickleHandler :: Snap () badTimeoutTickleHandler = do noCompression -- FIXME: remove this when zlib-bindings and -- zlib-enumerator support gzip stream flushing modifyResponse $ setResponseBody (trickleOutput 10) . setContentType "text/plain" setTimeout 2 trickleOutput :: Int -> Enumerator Builder IO a trickleOutput n = concatEnums $ dots `interleave` delays where enumOne i = do debug "enumOne: .\\n" enumList 1 [fromByteString ".\n"] i delay st = do debug "delay 1s" liftIO $ threadDelay 1000000 returnI st interleave x0 y0 = (go id x0 y0) [] where go !dl [] ys = dl . (++ys) go !dl xs [] = dl . (++xs) go !dl (x:xs) (y:ys) = go (dl . (x:) . (y:)) xs ys dots = replicate n enumOne delays = replicate n delay ------------------------------------------------------------------------------ pongHandler :: Snap () pongHandler = modifyResponse $ setResponseBody (enumBuilder $ fromByteString "PONG") . setContentType "text/plain" . setContentLength 4 echoUriHandler :: Snap () echoUriHandler = do req <- getRequest writeBS $ rqURI req echoHandler :: Snap () echoHandler = transformRequestBody returnI rot13Handler :: Snap () rot13Handler = transformRequestBody f where f origStep = do mbX <- I.head maybe (enumEOF origStep) (feedStep origStep) mbX feedStep origStep b = do let x = toByteString b let e = enumBuilder $ fromByteString $ rot13 x step <- lift $ runIteratee $ e origStep f step bigResponseHandler :: Snap () bigResponseHandler = do let sz = 4000000 let s = L.take sz $ L.cycle $ L.fromChunks [S.replicate 400000 '.'] modifyResponse $ setContentLength sz writeLBS s responseHandler :: Snap () responseHandler = do !code <- liftM (read . S.unpack . fromMaybe "503") $ getParam "code" modifyResponse $ setResponseCode code writeBS $ S.pack $ show code uploadForm :: Snap () uploadForm = do modifyResponse $ setContentType "text/html" writeBS form where form = S.concat [ "
Upload some text/plain
files: