This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "snap-server".
The branch, master has been updated
via 7761dd4fcb79209d2af3f429bd6585288def2861 (commit)
from ae2f4328c1744d4fdfffd180a8149b1786668517 (commit)
Summary of changes:
test/common/Test/Common/TestHandler.hs | 74 ++++++++++++++++++++++++++++++++
1 files changed, 74 insertions(+), 0 deletions(-)
create mode 100644 test/log/LOGS_GO_HERE
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 7761dd4fcb79209d2af3f429bd6585288def2861
Author: Gregory Collins <[email protected]>
Date: Sat Feb 5 16:52:45 2011 -0500
Blackbox test server functionality for file uploads
diff --git a/test/common/Test/Common/TestHandler.hs
b/test/common/Test/Common/TestHandler.hs
index 2c7b774..e02370e 100644
--- a/test/common/Test/Common/TestHandler.hs
+++ b/test/common/Test/Common/TestHandler.hs
@@ -8,12 +8,16 @@ import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as S
import qualified Data.ByteString.Lazy.Char8 as L
+import qualified Data.Map as Map
import Data.Maybe
+import Data.Monoid
import Snap.Iteratee hiding (Enumerator)
import qualified Snap.Iteratee as I
import Snap.Types
import Snap.Util.FileServe
+import Snap.Util.FileUploads
import Snap.Util.GZip
+import System.Directory
import Test.Common.Rot13 (rot13)
@@ -64,6 +68,74 @@ responseHandler = do
writeBS $ S.pack $ show code
+uploadForm :: Snap ()
+uploadForm = do
+ modifyResponse $ setContentType "text/html"
+ writeBS form
+
+ where
+ form = S.concat [ "<html><head><title>Upload a file</title></head><body>\n"
+ , "<p>Upload some <code>text/plain</code> files:</p>\n"
+ , "<form method='post' "
+ , "enctype='multipart/form-data' "
+ , "action='/upload/handle'>\n"
+ , "<input type='file' "
+ , "accept='text/plain' "
+ , "multiple='true' "
+ , "name='file'></input>\n"
+ , "<input type='submit' name='Submit'></input>\n"
+ , "</form></body></html>" ]
+
+
+uploadHandler :: Snap ()
+uploadHandler = do
+ liftIO $ createDirectoryIfMissing True tmpdir
+ handleFileUploads tmpdir defaultUploadPolicy partPolicy hndl
+
+ where
+ isRight (Left _) = False
+ isRight (Right _) = True
+
+ f (_, Left _) = error "impossible"
+ f (p, Right x) = (fromMaybe "-" $ partFileName p, x)
+
+ hndl xs' = do
+ let xs = [ f x | x <- xs', isRight (snd x) ]
+
+ files <- mapM (\(x,fp) -> do
+ c <- liftIO $ S.readFile fp
+ return (x,c)) xs
+
+ let m = Map.toAscList $ Map.fromList files
+
+ params <- liftM (Prelude.map (\(a,b) -> (a,S.concat b)) .
+ Map.toAscList .
+ rqParams) getRequest
+
+ modifyResponse $ setContentType "text/plain"
+ writeBuilder $ buildRqParams params `mappend` buildFiles m
+
+
+ builder _ [] = mempty
+ builder ty ((k,v):xs) =
+ mconcat [ fromByteString ty
+ , fromByteString ":\n"
+ , fromByteString k
+ , fromByteString "\nValue:\n"
+ , fromByteString v
+ , fromByteString "\n\n"
+ , buildRqParams xs ]
+
+
+ buildRqParams = builder "Param"
+ buildFiles = builder "File"
+
+ tmpdir = "dist/filetmp"
+ partPolicy partInfo = if partContentType partInfo == "text/plain"
+ then allowWithMaximumSize 200000
+ else disallow
+
+
testHandler :: Snap ()
testHandler = withCompression $
route [ ("pong" , pongHandler )
@@ -73,4 +145,6 @@ testHandler = withCompression $
, ("fileserve" , fileServe "testserver/static")
, ("bigresponse" , bigResponseHandler )
, ("respcode/:code" , responseHandler )
+ , ("upload/form" , uploadForm )
+ , ("upload/handle" , uploadHandler )
]
diff --git a/test/log/LOGS_GO_HERE b/test/log/LOGS_GO_HERE
new file mode 100644
index 0000000..e69de29
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
