Skip to content
Browse files

Don't silently eat startup exceptions (like lack of SSL support).

  • Loading branch information...
1 parent 9e10479 commit a5723f07c56b3e80608a2283c34f7f36bd87e264 @gregorycollins gregorycollins committed Jul 5, 2012
Showing with 31 additions and 2 deletions.
  1. +31 −2 src/Snap/Internal/Http/Server.hs
View
33 src/Snap/Internal/Http/Server.hs
@@ -36,15 +36,18 @@ import Data.List (foldl')
import qualified Data.Map as Map
import Data.Maybe (catMaybes, fromJust, fromMaybe, isJust)
import Data.Monoid
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
import Data.Time
import Data.Typeable
import Data.Version
import GHC.Conc
import Network.Socket (withSocketsDo, Socket)
import Prelude hiding (catch)
+import System.IO
+import System.Locale
import System.PosixCompat.Files hiding (setFileSize)
import System.Posix.Types (FileOffset)
-import System.Locale
------------------------------------------------------------------------------
import System.FastLogger (timestampedLogEntry, combinedLogEntry)
import Snap.Internal.Http.Types
@@ -152,10 +155,36 @@ httpServe :: Int -- ^ default timeout
-> ServerHandler -- ^ handler procedure
-> IO ()
httpServe defaultTimeout ports localHostname alog' elog' initial handler =
- withSocketsDo $ spawnAll alog' elog'
+ withSocketsDo $ spawnAll alog' elog' `catches` errorHandlers
where
--------------------------------------------------------------------------
+ errorHandlers = [ Handler sslException
+ , Handler otherException ]
+
+ --------------------------------------------------------------------------
+ sslException (e :: TLS.TLSException) = do
+ let msg = SC.concat [
+ "This version of snap-server was not built with SSL "
+ , "support.\n"
+ , "Please compile snap-server with -fopenssl to enable it."
+ ]
+
+ logE elog' msg
+ SC.hPutStrLn stderr msg
+ throw e
+
+ ------------------------------------------------------------------------------
+ otherException (e :: SomeException) = do
+ let msg = SC.concat [
+ "Error on startup: \n"
+ , T.encodeUtf8 $ T.pack $ show e
+ ]
+ logE elog' msg
+ SC.hPutStrLn stderr msg
+ throw e
+
+ --------------------------------------------------------------------------
spawnAll alog elog = {-# SCC "httpServe/spawnAll" #-} do
logE elog $ S.concat [ "Server.httpServe: START, binding to "

0 comments on commit a5723f0

Please sign in to comment.
Something went wrong with that request. Please try again.