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 afeedf6625885c899a7d1f39f4283e5002a1dfdd (commit)
via 6d1b205439d7ff06ec802d32134901260e97c786 (commit)
from b30a81156df90195769c1533707e7e3c3513c3ce (commit)
Summary of changes:
src/Snap/Http/Server/Config.hs | 3 +-
src/Snap/Internal/Http/Server.hs | 20 ++--
src/Snap/Internal/Http/Server/GnuTLS.hs | 127 +++++++++++++++---------
src/Snap/Internal/Http/Server/LibevBackend.hs | 3 +-
src/Snap/Internal/Http/Server/SimpleBackend.hs | 3 +-
5 files changed, 99 insertions(+), 57 deletions(-)
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 afeedf6625885c899a7d1f39f4283e5002a1dfdd
Merge: 6d1b205 b30a811
Author: Mighty Byte <[email protected]>
Date: Sat Feb 5 15:09:40 2011 -0500
Merge branch 'master' of git.snapframework.com:snap-server
commit 6d1b205439d7ff06ec802d32134901260e97c786
Author: Mighty Byte <[email protected]>
Date: Sat Feb 5 15:09:28 2011 -0500
Style cleanup
diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs
index 144ae43..57df07f 100644
--- a/src/Snap/Http/Server/Config.hs
+++ b/src/Snap/Http/Server/Config.hs
@@ -206,7 +206,8 @@ defaultConfig = Config
finishWith $ setContentType "text/plain; charset=utf-8"
. setContentLength (fromIntegral $ B.length msg)
. setResponseStatus 500 "Internal Server Error"
- . modifyResponseBody (>==> enumBuilder (fromByteString msg))
+ . modifyResponseBody
+ (>==> enumBuilder (fromByteString msg))
$ emptyResponse
, defaultTimeout = Just 60
, other = Nothing
diff --git a/src/Snap/Internal/Http/Server.hs b/src/Snap/Internal/Http/Server.hs
index d67714d..3f4b5c1 100644
--- a/src/Snap/Internal/Http/Server.hs
+++ b/src/Snap/Internal/Http/Server.hs
@@ -156,7 +156,7 @@ httpServe defaultTimeout ports mevType localHostname
alogPath elogPath
nports <- mapM bindPort ports
(runEventLoop evType defaultTimeout nports numCapabilities (logE elog)
- $ runHTTP defaultTimeout alog elog handler localHostname)
+ $ runHTTP defaultTimeout alog elog handler localHostname)
`finally` do
logE elog "Server.httpServe: SHUTDOWN"
@@ -374,8 +374,8 @@ httpSession defaultTimeout writeEnd' buffer onSendFile
tickle handler = do
then do
debug $ "httpSession: Connection: Close, harikari"
liftIO $ myThreadId >>= killThread
- else httpSession defaultTimeout writeEnd' buffer onSendFile tickle
- handler
+ else httpSession defaultTimeout writeEnd' buffer onSendFile
+ tickle handler
Nothing -> do
liftIO $ debug $ "Server.httpSession: parser did not produce a " ++
@@ -651,8 +651,8 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
iterateeDebugWrapper "countBytes writeEnd" $
countBytes writeEnd
(x,bs) <- mapIter fromByteString toByteString
- (enum $$ joinI $
- unsafeBuilderToByteString (return buffer) outstep)
+ (enum $$ joinI $ unsafeBuilderToByteString
+ (return buffer) outstep)
debug $ "sendResponse: whenEnum: " ++ show bs ++
" bytes enumerated"
@@ -740,16 +740,17 @@ sendResponse req rsp' buffer writeEnd' onSendFile = do
>>== chunkIt
--------------------------------------------------------------------------
- fixCLIteratee :: Int -- ^ header length
+ fixCLIteratee :: Int -- ^ header length
-> Response -- ^ response
-> Iteratee ByteString IO a -- ^ write end
-> Iteratee ByteString IO a
fixCLIteratee hlen resp we = maybe we f mbCL
where
f cl = case rspBody resp of
- (Enum _) -> joinI $ takeExactly (cl + fromIntegral hlen) $$ we
+ (Enum _) -> joinI $ takeExactly (cl + fromIntegral hlen)
+ $$ we
(SendFile _ _) -> we
-
+
mbCL = rspContentLength resp
--------------------------------------------------------------------------
@@ -879,7 +880,8 @@ cookieToBS (Cookie k v mbExpTime mbDomain mbPath) = cookie
path = maybe "" (S.append "; path=") mbPath
domain = maybe "" (S.append "; domain=") mbDomain
exptime = maybe "" (S.append "; expires=" . fmt) mbExpTime
- fmt = fromStr . formatTime defaultTimeLocale "%a, %d-%b-%Y %H:%M:%S
GMT"
+ fmt = fromStr . formatTime defaultTimeLocale
+ "%a, %d-%b-%Y %H:%M:%S GMT"
------------------------------------------------------------------------------
diff --git a/src/Snap/Internal/Http/Server/GnuTLS.hs
b/src/Snap/Internal/Http/Server/GnuTLS.hs
index 3ae1c39..d3bf514 100644
--- a/src/Snap/Internal/Http/Server/GnuTLS.hs
+++ b/src/Snap/Internal/Http/Server/GnuTLS.hs
@@ -70,19 +70,19 @@ recv _ _ = throwIO $ GnuTLSException "TLS is not supported"
#else
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- | Init
initTLS :: IO ()
initTLS = gnutls_set_threading_helper >>
throwErrorIf "TLS init" gnutls_global_init
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
stopTLS :: IO ()
stopTLS = gnutls_global_deinit
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
-- | Binds ssl port
bindHttps :: ByteString
-> Int
@@ -102,7 +102,7 @@ bindHttps bindAddress bindPort cert key = do
return $ ListenHttps sock (castPtr creds) (castPtr dh)
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
loadCredentials :: FilePath --- ^ Path to certificate
-> FilePath --- ^ Path to key
-> IO (Ptr GnuTLSCredentials)
@@ -118,7 +118,7 @@ loadCredentials cert key = alloca $ \cPtr -> do
return creds
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
regenerateDHParam :: Ptr GnuTLSCredentials -> IO (Ptr GnuTLSDHParam)
regenerateDHParam creds = alloca $ \dhptr -> do
throwErrorIf "TLS allocate" $ gnutls_dh_params_init dhptr
@@ -128,7 +128,7 @@ regenerateDHParam creds = alloca $ \dhptr -> do
return dh
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
freePort :: ListenSocket -> IO ()
freePort (ListenHttps _ creds dh) = do
gnutls_certificate_free_credentials $ castPtr creds
@@ -136,7 +136,7 @@ freePort (ListenHttps _ creds dh) = do
freePort _ = return ()
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
createSession :: ListenSocket -> Int -> CInt -> IO () -> IO NetworkSession
createSession (ListenHttps _ creds _) recvSize socket on_block =
alloca $ \sPtr -> do
@@ -160,7 +160,7 @@ createSession (ListenHttps _ creds _) recvSize socket
on_block =
createSession _ _ _ _ = error "Invalid socket"
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
endSession :: NetworkSession -> IO ()
endSession (NetworkSession _ session buffer _) = do
throwErrorIf "TLS bye" $ gnutls_bye (castPtr session) 1 `finally` do
@@ -168,7 +168,7 @@ endSession (NetworkSession _ session buffer _) = do
free buffer
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
handshake :: NetworkSession -> IO () -> IO ()
handshake s@(NetworkSession { _session = session}) on_block = do
rc <- gnutls_handshake $ castPtr session
@@ -179,7 +179,7 @@ handshake s@(NetworkSession { _session = session}) on_block
= do
| otherwise -> throwError "TLS handshake" rc
--------------------------------------------------------------------------------
+------------------------------------------------------------------------------
send :: IO () -> IO () -> NetworkSession -> ByteString -> IO ()
send tickleTimeout onBlock (NetworkSession { _session = session}) bs =
unsafeUseAsCStringLen bs $ uncurry loop
@@ -268,90 +268,127 @@ data GnuTLSCredentials
data GnuTLSSession
data GnuTLSDHParam
+------------------------------------------------------------------------------
-- Global init/errors
-foreign import ccall safe "gnutls_set_threading_helper"
- gnutls_set_threading_helper :: IO ()
+foreign import ccall safe
+ "gnutls_set_threading_helper"
+ gnutls_set_threading_helper :: IO ()
-foreign import ccall safe "gnutls/gnutls.h gnutls_global_init"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_global_init"
gnutls_global_init :: IO ReturnCode
-foreign import ccall safe "gnutls/gnutls.h gnutls_global_deinit"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_global_deinit"
gnutls_global_deinit :: IO ()
-foreign import ccall safe "gnutls/gnutls.h gnutls_strerror"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_strerror"
gnutls_strerror :: ReturnCode -> IO CString
+------------------------------------------------------------------------------
-- Sessions. All functions here except handshake and bye just
-- allocate memory or update members of structures, so they are ok with
-- unsafe ccall.
-foreign import ccall unsafe "gnutls/gnutls.h gnutls_init"
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_init"
gnutls_init :: Ptr (Ptr GnuTLSSession) -> CInt -> IO ReturnCode
-foreign import ccall unsafe "gnutls/gnutls.h gnutls_deinit"
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_deinit"
gnutls_deinit :: Ptr GnuTLSSession -> IO ()
-foreign import ccall safe "gnutls/gnutls.h gnutls_handshake"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_handshake"
gnutls_handshake :: Ptr GnuTLSSession -> IO ReturnCode
-foreign import ccall safe "gnutls/gnutls.h gnutls_bye"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_bye"
gnutls_bye :: Ptr GnuTLSSession -> CInt -> IO ReturnCode
-foreign import ccall unsafe "gnutls/gnutls.h gnutls_set_default_priority"
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_set_default_priority"
gnutls_set_default_priority :: Ptr GnuTLSSession -> IO ReturnCode
-foreign import ccall unsafe "gnutls/gnutls.h
gnutls_session_enable_compatibility_mode"
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_session_enable_compatibility_mode"
gnutls_session_enable_compatibility_mode :: Ptr GnuTLSSession -> IO ()
-foreign import ccall unsafe "gnutls/gnutls.h
gnutls_certificate_send_x509_rdn_sequence"
- gnutls_certificate_send_x509_rdn_sequence :: Ptr GnuTLSSession -> CInt ->
IO ()
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_certificate_send_x509_rdn_sequence"
+ gnutls_certificate_send_x509_rdn_sequence
+ :: Ptr GnuTLSSession -> CInt -> IO ()
--- Certificates. Perhaps these could be unsafe but they are not performance
critical,
--- since they are called only once during server startup.
+------------------------------------------------------------------------------
+-- Certificates. Perhaps these could be unsafe but they are not performance
+-- critical, since they are called only once during server startup.
-foreign import ccall safe "gnutls/gnutls.h
gnutls_certificate_allocate_credentials"
- gnutls_certificate_allocate_credentials :: Ptr (Ptr GnuTLSCredentials) ->
IO ReturnCode
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_certificate_allocate_credentials"
+ gnutls_certificate_allocate_credentials
+ :: Ptr (Ptr GnuTLSCredentials) -> IO ReturnCode
-foreign import ccall safe "gnutls/gnutls.h gnutls_certificate_free_credentials"
- gnutls_certificate_free_credentials :: Ptr GnuTLSCredentials -> IO ()
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_certificate_free_credentials"
+ gnutls_certificate_free_credentials
+ :: Ptr GnuTLSCredentials -> IO ()
gnutls_x509_fmt_pem :: CInt
gnutls_x509_fmt_pem = 1
-foreign import ccall safe "gnutls/gnutls.h
gnutls_certificate_set_x509_key_file"
- gnutls_certificate_set_x509_key_file :: Ptr GnuTLSCredentials -> CString
-> CString -> CInt -> IO ReturnCode
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_certificate_set_x509_key_file"
+ gnutls_certificate_set_x509_key_file
+ :: Ptr GnuTLSCredentials -> CString -> CString -> CInt -> IO ReturnCode
--- Credentials. This is ok as unsafe because it just sets members in the
session structure.
+------------------------------------------------------------------------------
+-- Credentials. This is ok as unsafe because it just sets members in the
+-- session structure.
-foreign import ccall unsafe "gnutls/gnutls.h gnutls_credentials_set"
- gnutls_credentials_set :: Ptr GnuTLSSession -> CInt -> Ptr a -> IO
ReturnCode
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_credentials_set"
+ gnutls_credentials_set
+ :: Ptr GnuTLSSession -> CInt -> Ptr a -> IO ReturnCode
--- Records. These are marked unsafe because they are very performance
critical. Since
--- we are using non-blocking sockets send and recv will not block.
+------------------------------------------------------------------------------
+-- Records. These are marked unsafe because they are very performance
+-- critical. Since we are using non-blocking sockets send and recv will not
+-- block.
-foreign import ccall unsafe "gnutls/gnutls.h gnutls_transport_set_ptr"
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_transport_set_ptr"
gnutls_transport_set_ptr :: Ptr GnuTLSSession -> Ptr a -> IO ()
-foreign import ccall unsafe "gnutls/gnutls.h gnutls_record_recv"
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_record_recv"
gnutls_record_recv :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize
-foreign import ccall unsafe "gnutls/gnutls.h gnutls_record_send"
+foreign import ccall unsafe
+ "gnutls/gnutls.h gnutls_record_send"
gnutls_record_send :: Ptr GnuTLSSession -> Ptr a -> CSize -> IO CSize
--- DHParam. Perhaps these could be unsafe but they are not performance
critical.
+------------------------------------------------------------------------------
+-- DHParam. Perhaps these could be unsafe but they are not performance
+-- critical.
-foreign import ccall safe "gnutls/gnutls.h gnutls_dh_params_init"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_dh_params_init"
gnutls_dh_params_init :: Ptr (Ptr GnuTLSDHParam) -> IO ReturnCode
-foreign import ccall safe "gnutls/gnutls.h gnutls_dh_params_deinit"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_dh_params_deinit"
gnutls_dh_params_deinit :: Ptr GnuTLSDHParam -> IO ()
-foreign import ccall safe "gnutls/gnutls.h gnutls_dh_params_generate2"
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_dh_params_generate2"
gnutls_dh_params_generate2 :: Ptr GnuTLSDHParam -> CUInt -> IO ReturnCode
-foreign import ccall safe "gnutls/gnutls.h gnutls_certificate_set_dh_params"
- gnutls_certificate_set_dh_params :: Ptr GnuTLSCredentials -> Ptr
GnuTLSDHParam -> IO ()
+foreign import ccall safe
+ "gnutls/gnutls.h gnutls_certificate_set_dh_params"
+ gnutls_certificate_set_dh_params
+ :: Ptr GnuTLSCredentials -> Ptr GnuTLSDHParam -> IO ()
#endif
diff --git a/src/Snap/Internal/Http/Server/LibevBackend.hs
b/src/Snap/Internal/Http/Server/LibevBackend.hs
index c2d463b..0b6ce46 100644
--- a/src/Snap/Internal/Http/Server/LibevBackend.hs
+++ b/src/Snap/Internal/Http/Server/LibevBackend.hs
@@ -219,7 +219,8 @@ acceptCallback :: Int
-> Int
-> ListenSocket
-> IoCallback
-acceptCallback defaultTimeout back handler elog cpu sock _loopPtr _ioPtr _ = do
+acceptCallback defaultTimeout back handler
+ elog cpu sock _loopPtr _ioPtr _ = do
debug "inside acceptCallback"
r <- c_accept $ fdSocket $ Listen.listenSocket sock
diff --git a/src/Snap/Internal/Http/Server/SimpleBackend.hs
b/src/Snap/Internal/Http/Server/SimpleBackend.hs
index ea2b84a..3a7e489 100644
--- a/src/Snap/Internal/Http/Server/SimpleBackend.hs
+++ b/src/Snap/Internal/Http/Server/SimpleBackend.hs
@@ -209,7 +209,8 @@ runSession defaultTimeout handler tt lsock sock addr = do
eatException $ shutdown sock ShutdownBoth
eatException $ sClose sock
)
- (\s -> let writeEnd = writeOut lsock s sock (timeout
defaultTimeout)
+ (\s -> let writeEnd = writeOut lsock s sock
+ (timeout defaultTimeout)
in handler sinfo
(enumerate lsock s sock)
writeEnd
-----------------------------------------------------------------------
hooks/post-receive
--
snap-server
_______________________________________________
Snap mailing list
[email protected]
http://mailman-mail5.webfaction.com/listinfo/snap
