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

…to MonadControlIO Conflicts: snap-server.cabal
snapframework · Oct 15, 2011 · 1988b8f · 1988b8f
2 parents 18d9541 + 8cabdea
commit 1988b8f
Show file tree

Hide file tree

Showing 11 changed files with 99 additions and 138 deletions.
diff --git a/snap-server.cabal b/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,

diff --git a/src/Snap/Http/Server.hs b/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

diff --git a/src/Snap/Http/Server/Config.hs b/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
@@ -206,6 +208,17 @@ instance Monoid (Config m a) where
         ov f x y = getLast $! (mappend `on` (Last . f)) x y
 
 
+------------------------------------------------------------------------------
+-- | 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
@@ -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"

diff --git a/src/Snap/Internal/Http/Parser.hs b/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
-
-
diff --git a/src/Snap/Internal/Http/Server.hs b/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,15 +582,15 @@ 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
 
 
     --------------------------------------------------------------------------
     parseForm :: Request -> ServerMonad Request
     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"
 

diff --git a/test/.ghci b/test/.ghci
@@ -0,0 +1,3 @@
+:set -i../src
+:set -isuite
+:set -icommon
diff --git a/test/common/Test/Common/TestHandler.hs b/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              )
           ]
diff --git a/test/pongserver/Main.hs b/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