Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Merge branch '0.6' of https://github.com/snapframework/snap-server in…

…to MonadControlIO

Conflicts:
	snap-server.cabal
  • Loading branch information...
commit 1988b8f132b9fa6d4b34efc935e075c79d882828 2 parents 18d9541 + 8cabdea
@norm2782 norm2782 authored
View
8 snap-server.cabal
@@ -1,5 +1,5 @@
name: snap-server
-version: 0.5.5
+version: 0.6.0
synopsis: A fast, iteratee-based, epoll-enabled web server for the Snap Framework
description:
Snap is a simple and fast web development framework and server written in
@@ -108,17 +108,17 @@ Library
blaze-builder-enumerator >= 0.2.0 && <0.3,
bytestring,
bytestring-nums,
- case-insensitive >= 0.2 && < 0.4,
+ case-insensitive >= 0.3 && < 0.4,
containers,
directory-tree >= 0.10 && < 0.11,
enumerator >= 0.4.13.1 && <0.5,
filepath,
monad-control >= 0.2,
- mtl == 2.0.*,
+ mtl >= 2 && <3,
murmur-hash >= 0.1 && < 0.2,
network >= 2.3 && <2.4,
old-locale,
- snap-core >= 0.5.4 && <0.6,
+ snap-core >= 0.6 && < 0.7,
template-haskell,
text >= 0.11 && <0.12,
time >= 1.0 && < 1.4,
View
4 src/Snap/Http/Server.hs
@@ -28,7 +28,7 @@ import Data.Maybe
import Prelude hiding (catch)
import Snap.Http.Server.Config
import qualified Snap.Internal.Http.Server as Int
-import Snap.Types
+import Snap.Core
import Snap.Util.GZip
#ifndef PORTABLE
import System.Posix.Env
@@ -49,7 +49,7 @@ snapServerVersion = Int.snapServerVersion
-- This function is like 'httpServe' except it doesn't setup compression or the
-- error handler; this allows it to be used from 'MonadSnap'.
simpleHttpServe :: MonadSnap m => Config m a -> Snap () -> IO ()
-simpleHttpServe config handler = do
+simpleHttpServe config handler = do
conf <- completeConfig config
let output = when (fromJust $ getVerbose conf) . hPutStrLn stderr
mapM_ (output . ("Listening on "++) . show) $ listeners conf
View
17 src/Snap/Http/Server/Config.hs
@@ -1,5 +1,6 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ScopedTypeVariables #-}
{-|
@@ -66,8 +67,9 @@ import Data.Maybe
import Data.Monoid
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
+import Data.Typeable
import Prelude hiding (catch)
-import Snap.Types
+import Snap.Core
import Snap.Iteratee ((>==>), enumBuilder)
import Snap.Internal.Debug (debug)
import System.Console.GetOpt
@@ -207,6 +209,17 @@ instance Monoid (Config m a) where
------------------------------------------------------------------------------
+-- | The 'Typeable1' instance is here so 'Config' values can be
+-- dynamically loaded with Hint.
+configTyCon :: TyCon
+configTyCon = mkTyCon "Snap.Http.Server.Config.Config"
+{-# NOINLINE configTyCon #-}
+
+instance (Typeable1 m) => Typeable1 (Config m) where
+ typeOf1 _ = mkTyConApp configTyCon [typeOf1 (undefined :: m ())]
+
+
+------------------------------------------------------------------------------
-- | These are the default values for the options
defaultConfig :: MonadSnap m => Config m a
defaultConfig = mempty
@@ -445,7 +458,7 @@ defaultErrorHandler e = do
let sm = smsg req
debug $ toString sm
logError sm
-
+
finishWith $ setContentType "text/plain; charset=utf-8"
. setContentLength (fromIntegral $ B.length msg)
. setResponseStatus 500 "Internal Server Error"
View
51 src/Snap/Internal/Http/Parser.hs
@@ -225,54 +225,3 @@ pGetTransferChunk = do
where
fromHex :: ByteString -> Int
fromHex s = Cvt.hex (L.fromChunks [s])
-
-
-------------------------------------------------------------------------------
--- COOKIE PARSING
-------------------------------------------------------------------------------
-
--- these definitions try to mirror RFC-2068 (the HTTP/1.1 spec) and RFC-2109
--- (cookie spec): please point out any errors!
-
-------------------------------------------------------------------------------
-pCookies :: Parser [Cookie]
-pCookies = do
- -- grab kvps and turn to strict bytestrings
- kvps <- pAvPairs
-
- return $ map toCookie $ filter (not . S.isPrefixOf "$" . fst) kvps
-
- where
- toCookie (nm,val) = Cookie nm val Nothing Nothing Nothing
-
-
-------------------------------------------------------------------------------
-parseCookie :: ByteString -> Maybe [Cookie]
-parseCookie = parseToCompletion pCookies
-
-
-------------------------------------------------------------------------------
--- application/x-www-form-urlencoded
-------------------------------------------------------------------------------
-
-------------------------------------------------------------------------------
-parseUrlEncoded :: ByteString -> Map ByteString [ByteString]
-parseUrlEncoded s = foldl' (\m (k,v) -> Map.insertWith' (++) k [v] m)
- Map.empty
- decoded
- where
- breakApart = (second (S.drop 1)) . S.break (== '=')
-
- parts :: [(ByteString,ByteString)]
- parts = map breakApart $ S.splitWith (\c -> c == '&' || c == ';') s
-
- urldecode = parseToCompletion pUrlEscaped
-
- decodeOne (a,b) = do
- a' <- urldecode a
- b' <- urldecode b
- return (a',b')
-
- decoded = catMaybes $ map decodeOne parts
-
-
View
55 src/Snap/Internal/Http/Server.hs
@@ -18,7 +18,6 @@ import Control.Exception.Control
import Control.Monad.State.Strict
import Control.Exception.Control hiding (catch, throw)
import Data.Char
-import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
import Data.ByteString (ByteString)
import qualified Data.ByteString as S
@@ -60,6 +59,9 @@ import Snap.Internal.Iteratee.Debug
import Snap.Iteratee hiding (head, take, map)
import qualified Snap.Iteratee as I
+import Snap.Types.Headers (Headers)
+import qualified Snap.Types.Headers as H
+
import qualified Paths_snap_server as V
@@ -261,8 +263,8 @@ logA' logger req rsp = do
let reql = S.intercalate " " [ method, rqURI req, ver ]
let status = rspStatus rsp
let cl = rspContentLength rsp
- let referer = maybe Nothing (Just . head) $ Map.lookup "referer" hdrs
- let userAgent = maybe "-" head $ Map.lookup "user-agent" hdrs
+ let referer = maybe Nothing (Just . head) $ H.lookup "referer" hdrs
+ let userAgent = maybe "-" head $ H.lookup "user-agent" hdrs
msg <- combinedLogEntry host user reql status cl referer userAgent
logMsg logger msg
@@ -337,8 +339,8 @@ requestErrorMessage req e =
------------------------------------------------------------------------------
-sERVER_HEADER :: [ByteString]
-sERVER_HEADER = [S.concat ["Snap/", snapServerVersion]]
+sERVER_HEADER :: ByteString
+sERVER_HEADER = S.concat ["Snap/", snapServerVersion]
------------------------------------------------------------------------------
@@ -422,8 +424,8 @@ httpSession defaultTimeout writeEnd' buffer onSendFile tickle handler = do
"sending response"
date <- liftIO getDateString
- let ins = Map.insert "Date" [date] .
- Map.insert "Server" sERVER_HEADER
+ let ins = H.set "Date" date .
+ H.set "Server" sERVER_HEADER
let rsp' = updateHeaders ins rsp
(bytesSent,_) <- sendResponse req rsp' buffer writeEnd onSendFile
`catch` errCatch "sending response" req
@@ -546,7 +548,7 @@ receiveRequest writeEnd = do
where
isChunked = maybe False
((== ["chunked"]) . map CI.mk)
- (Map.lookup "transfer-encoding" hdrs)
+ (H.lookup "transfer-encoding" hdrs)
hasContentLength :: Int64 -> ServerMonad ()
hasContentLength len = do
@@ -580,7 +582,7 @@ receiveRequest writeEnd = do
hdrs = rqHeaders req
- mbCL = Map.lookup "content-length" hdrs >>= return . Cvt.int . head
+ mbCL = H.lookup "content-length" hdrs >>= return . Cvt.int . head
--------------------------------------------------------------------------
@@ -588,7 +590,7 @@ receiveRequest writeEnd = do
parseForm req = {-# SCC "receiveRequest/parseForm" #-}
if doIt then getIt else return req
where
- mbCT = liftM head $ Map.lookup "content-type" (rqHeaders req)
+ mbCT = liftM head $ H.lookup "content-type" (rqHeaders req)
trimIt = fst . SC.spanEnd isSpace . SC.takeWhile (/= ';')
. SC.dropWhile isSpace
mbCT' = liftM trimIt mbCT
@@ -620,7 +622,8 @@ receiveRequest writeEnd = do
e st'
liftIO $ writeIORef (rqBody req) $ SomeEnumerator e'
- return $ req { rqParams = rqParams req `mappend` newParams }
+ return $ req { rqParams = Map.unionWith (++) (rqParams req)
+ newParams }
--------------------------------------------------------------------------
@@ -636,7 +639,7 @@ receiveRequest writeEnd = do
let (serverName, serverPort) = fromMaybe
(localHostname, lport)
(liftM (parseHost . head)
- (Map.lookup "host" hdrs))
+ (H.lookup "host" hdrs))
-- will override in "setEnumerator"
enum <- liftIO $ newIORef $ SomeEnumerator (enumBS "")
@@ -673,12 +676,12 @@ receiveRequest writeEnd = do
hdrs = toHeaders kvps
mbContentLength = liftM (Cvt.int . head) $
- Map.lookup "content-length" hdrs
+ H.lookup "content-length" hdrs
cookies = concat $
maybe []
(catMaybes . map parseCookie)
- (Map.lookup "cookie" hdrs)
+ (H.lookup "cookie" hdrs)
contextPath = "/"
@@ -781,13 +784,12 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
--------------------------------------------------------------------------
- buildHdrs :: Map (CI ByteString) [ByteString]
- -> (Builder,Int)
+ buildHdrs :: Headers -> (Builder,Int)
buildHdrs hdrs =
{-# SCC "buildHdrs" #-}
- Map.foldlWithKey f (mempty,0) hdrs
+ H.fold f (mempty,0) hdrs
where
- f (b,len) k ys =
+ f (!b,!len) !k !ys =
let (!b',len') = h k ys
in (b `mappend` b', len+len')
@@ -871,7 +873,7 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
--------------------------------------------------------------------------
handle304 :: Response -> Response
handle304 r = setResponseBody (enumBuilder mempty) $
- updateHeaders (Map.delete "Transfer-Encoding") $
+ updateHeaders (H.delete "Transfer-Encoding") $
setContentLength 0 r
@@ -881,7 +883,7 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
where
f h = if null cookies
then h
- else Map.insertWith (flip (++)) "Set-Cookie" cookies h
+ else foldl' (\m v -> H.insert "Set-Cookie" v m) h cookies
cookies = fmap cookieToBS . Map.elems $ rspCookies r
@@ -955,28 +957,29 @@ checkConnectionClose ver hdrs =
then modify $ \s -> s { _forceConnectionClose = True }
else return ()
where
- l = liftM (map tl) $ Map.lookup "Connection" hdrs
+ l = liftM (map tl) $ H.lookup "Connection" hdrs
tl = S.map (c2w . toLower . w2c)
------------------------------------------------------------------------------
-- FIXME: whitespace-trim the values here.
toHeaders :: [(ByteString,ByteString)] -> Headers
-toHeaders kvps = foldl' f Map.empty kvps'
+toHeaders kvps = H.fromList kvps'
where
- kvps' = map (first CI.mk . second (:[])) kvps
- f m (k,v) = Map.insertWith' (flip (++)) k v m
+ kvps' = map (first CI.mk) kvps
------------------------------------------------------------------------------
-- | Convert 'Cookie' into 'ByteString' for output.
cookieToBS :: Cookie -> ByteString
-cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie
+cookieToBS (Cookie k v mbExpTime mbDomain mbPath isSec isHOnly) = cookie
where
- cookie = S.concat [k, "=", v, path, exptime, domain]
+ cookie = S.concat [k, "=", v, path, exptime, domain, secure, hOnly]
path = maybe "" (S.append "; path=") mbPath
domain = maybe "" (S.append "; domain=") mbDomain
exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime
+ secure = if isSec then "; Secure" else ""
+ hOnly = if isHOnly then "; HttpOnly" else ""
fmt = fromStr . formatTime defaultTimeLocale
"%a, %d-%b-%Y %H:%M:%S GMT"
View
3  test/.ghci
@@ -0,0 +1,3 @@
+:set -i../src
+:set -isuite
+:set -icommon
View
22 test/common/Test/Common/TestHandler.hs
@@ -15,7 +15,7 @@ import Data.Maybe
import Data.Monoid
import Snap.Iteratee hiding (Enumerator)
import qualified Snap.Iteratee as I
-import Snap.Types
+import Snap.Core
import Snap.Util.FileServe
import Snap.Util.FileUploads
import Snap.Util.GZip
@@ -172,14 +172,14 @@ uploadHandler = do
testHandler :: Snap ()
testHandler = withCompression $
- route [ ("pong" , pongHandler )
- , ("echo" , echoHandler )
- , ("rot13" , rot13Handler )
- , ("echoUri" , echoUriHandler )
- , ("fileserve" , fileServe "testserver/static")
- , ("bigresponse" , bigResponseHandler )
- , ("respcode/:code" , responseHandler )
- , ("upload/form" , uploadForm )
- , ("upload/handle" , uploadHandler )
- , ("timeout/tickle" , timeoutTickleHandler )
+ route [ ("pong" , pongHandler )
+ , ("echo" , echoHandler )
+ , ("rot13" , rot13Handler )
+ , ("echoUri" , echoUriHandler )
+ , ("fileserve" , serveDirectory "testserver/static")
+ , ("bigresponse" , bigResponseHandler )
+ , ("respcode/:code" , responseHandler )
+ , ("upload/form" , uploadForm )
+ , ("upload/handle" , uploadHandler )
+ , ("timeout/tickle" , timeoutTickleHandler )
]
View
2  test/pongserver/Main.hs
@@ -6,7 +6,7 @@ import Control.Concurrent
import Control.Exception (finally)
import Snap.Iteratee
-import Snap.Types
+import Snap.Core
import Snap.Http.Server
-- FIXME: need better primitives for output
View
12 test/snap-server-testsuite.cabal
@@ -45,9 +45,9 @@ Executable testsuite
old-locale,
parallel > 2,
process,
- snap-core >= 0.5.4 && <0.6,
+ snap-core >= 0.6 && < 0.7,
template-haskell,
- test-framework >= 0.3.1 && <0.5,
+ test-framework >= 0.4 && < 0.5,
test-framework-hunit >= 0.2.5 && < 0.3,
test-framework-quickcheck2 >= 0.2.6 && < 0.3,
text >= 0.11 && <0.12,
@@ -105,7 +105,7 @@ Executable pongserver
parallel > 2,
MonadCatchIO-transformers >= 0.2.1 && < 0.3,
network == 2.3.*,
- snap-core >= 0.5.4 && <0.6,
+ snap-core >= 0.6 && < 0.7,
template-haskell,
time,
transformers,
@@ -169,7 +169,7 @@ Executable testserver
blaze-builder-enumerator >= 0.2.0 && <0.3,
bytestring,
bytestring-nums >= 0.3.1 && < 0.4,
- case-insensitive >= 0.2 && < 0.5,
+ case-insensitive >= 0.3 && < 0.4,
containers,
directory-tree,
enumerator >= 0.4.7 && <0.5,
@@ -181,9 +181,9 @@ Executable testserver
network == 2.3.*,
old-locale,
parallel > 2,
- snap-core >= 0.5.4 && <0.6,
+ snap-core >= 0.6 && < 0.7,
template-haskell,
- test-framework >= 0.3.1 && <0.5,
+ test-framework >= 0.4 && < 0.5,
test-framework-hunit >= 0.2.5 && < 0.3,
test-framework-quickcheck2 >= 0.2.6 && < 0.3,
text >= 0.11 && <0.12,
View
6 test/suite/Snap/Internal/Http/Parser/Tests.hs
@@ -137,15 +137,13 @@ testCookie =
assertEqual "cookie parsing" (Just [cv]) cv2
where
- cv = Cookie nm v Nothing Nothing Nothing
+ cv = Cookie nm v Nothing Nothing Nothing False False
cv2 = parseCookie ct
nm = "foo"
v = "bar"
- ct = S.concat [ nm
- , "="
- , v ]
+ ct = S.concat [ nm , "=" , v ]
testFormEncoded :: Test
View
57 test/suite/Snap/Internal/Http/Server/Tests.hs
@@ -44,6 +44,7 @@ import Test.HUnit hiding (Test, path)
import qualified Snap.Http.Server as Svr
+import Snap.Core
import Snap.Internal.Debug
import Snap.Internal.Http.Types
import Snap.Internal.Http.Server
@@ -51,7 +52,7 @@ import qualified Snap.Iteratee as I
import Snap.Iteratee hiding (map)
import Snap.Internal.Http.Server.Backend
import Snap.Test.Common
-import Snap.Types
+import qualified Snap.Types.Headers as H
data TestException = TestException
deriving (Show, Typeable)
@@ -190,11 +191,12 @@ testHttpRequest1 =
assertEqual "parse body" "0123456789" body
- assertEqual "cookie" [Cookie "foo" "bar\"" Nothing Nothing Nothing] $
- rqCookies req
+ assertEqual "cookie"
+ [Cookie "foo" "bar\"" Nothing Nothing Nothing False False]
+ (rqCookies req)
assertEqual "continued headers" (Just ["foo bar"]) $
- Map.lookup "x-random-other-header" $ rqHeaders req
+ H.lookup "x-random-other-header" $ rqHeaders req
assertEqual "parse URI"
"/foo/bar.html?param1=abc&param2=def%20+&param1=abc"
@@ -307,7 +309,7 @@ testHttpRequest3 =
assertEqual "no cookies" [] $ rqCookies req
assertEqual "multiheader" (Just ["1","2"]) $
- Map.lookup "Multiheader" (rqHeaders req)
+ H.lookup "Multiheader" (rqHeaders req)
assertEqual "host" ("localhost", 80) $
(rqServerName req, rqServerPort req)
@@ -396,7 +398,7 @@ testHttpResponse1 = testCase "server/HttpResponse1" $ do
]) b
where
- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
+ rsp1 = updateHeaders (H.insert "Foo" "Bar") $
setContentLength 10 $
setResponseStatus 600 "Test" $
modifyResponseBody (>==> (enumBuilder $
@@ -426,7 +428,7 @@ testHttpResponse2 = testCase "server/HttpResponse2" $ do
, "0123456789"
]) b2
where
- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
+ rsp1 = updateHeaders (H.insert "Foo" "Bar") $
setContentLength 10 $
setResponseStatus 600 "Test" $
modifyResponseBody (>==> (enumBuilder $
@@ -457,7 +459,7 @@ testHttpResponse3 = testCase "server/HttpResponse3" $ do
where
- rsp1 = updateHeaders (Map.insert "Foo" ["Bar"]) $
+ rsp1 = updateHeaders (H.insert "Foo" "Bar") $
setContentLength 10 $
setResponseStatus 600 "Test" $
modifyResponseBody (>==> (enumBuilder $
@@ -492,37 +494,30 @@ testHttpResponseCookies :: Test
testHttpResponseCookies = testCase "server/HttpResponseCookies" $ do
buf <- allocBuffer 16384
req <- mkRequest sampleRequest
+
b <- run_ $ rsm $
- sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=
- return . snd
- b2 <- run_ $ rsm $
- sendResponse req rsp3 buf copyingStream2Stream testOnSendFile >>=
+ sendResponse req rsp2 buf copyingStream2Stream testOnSendFile >>=
return . snd
- assertEqual "http response cookie" (L.concat [
+ -- Having some weird issues here with lazy ByteString comparison; run thru
+ -- strict ByteString to get around it. Slow/lame, but whatever.
+ assertEqual "http response multi-cookies" (L.fromChunks . return . S.concat $ [
"HTTP/1.0 304 Test\r\n"
, "Content-Length: 0\r\n"
- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n"
- ]) b
-
-
- assertEqual "http response multi-cookies" (L.concat [
- "HTTP/1.0 304 Test\r\n"
- , "Content-Length: 0\r\n"
- , "Set-Cookie: foo=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n"
- , "Set-Cookie: zoo=baz; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com\r\n\r\n"
- ]) b2
+ , "Set-Cookie: ck1=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; Secure\r\n"
+ , "Set-Cookie: ck2=bar; path=/; expires=Sat, 30-Jan-2010 00:00:00 GMT; domain=.foo.com; HttpOnly\r\n"
+ , "Set-Cookie: ck3=bar\r\n\r\n"
+ ]) (L.fromChunks . return . S.concat . L.toChunks $ b)
where
- rsp1 = setResponseStatus 304 "Test" $
- emptyResponse { rspHttpVersion = (1,0) }
- rsp2 = addResponseCookie cook rsp1
- rsp3 = addResponseCookie cook2 rsp2
+ rsp1 = setResponseStatus 304 "Test" $ emptyResponse { rspHttpVersion = (1,0) }
+ rsp2 = addResponseCookie cook3 . addResponseCookie cook2
+ . addResponseCookie cook $ rsp1
utc = UTCTime (ModifiedJulianDay 55226) 0
- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
- cook2 = Cookie "zoo" "baz" (Just utc) (Just ".foo.com") (Just "/")
- cook3 = Cookie "boo" "baz" Nothing Nothing Nothing
+ cook = Cookie "ck1" "bar" (Just utc) (Just ".foo.com") (Just "/") True False
+ cook2 = Cookie "ck2" "bar" (Just utc) (Just ".foo.com") (Just "/") False True
+ cook3 = Cookie "ck3" "bar" Nothing Nothing Nothing False False
@@ -549,7 +544,7 @@ echoServer2 _ _ req = do
(rq,rsp) <- echoServer (const $ return ()) (const $ return ()) req
return (rq, addResponseCookie cook rsp)
where
- cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/")
+ cook = Cookie "foo" "bar" (Just utc) (Just ".foo.com") (Just "/") False False
utc = UTCTime (ModifiedJulianDay 55226) 0
Please sign in to comment.
Something went wrong with that request. Please try again.