Addition of setInitHandler

src/Snap/Http/Server.hs

@@ -73,6 +73,8 @@ simpleHttpServe config handler = do
                              (fromJust $ getHostname  conf)
                              alog
                              elog
+                             (\sockets -> let dat = setStartupHookSockets sockets $ setStartupHookConfig config emptyStartupHookData
+                                          in maybe (return ()) ($ dat) $ getStartupHook config)
                              (runSnap handler)
 
     maybeSpawnLogger f (ConfigFileLog fp) =

src/Snap/Http/Server/Config.hs

@@ -41,6 +41,7 @@ module Snap.Http.Server.Config
   , getSSLKey
   , getSSLPort
   , getVerbose
+  , getStartupHook
 
   , setAccessLog
   , setBackend
@@ -59,6 +60,14 @@ module Snap.Http.Server.Config
   , setSSLKey
   , setSSLPort
   , setVerbose
+  , setStartupHook
+
+  , StartupHookData
+  , emptyStartupHookData
+  , getStartupHookSockets
+  , getStartupHookConfig
+  , setStartupHookSockets
+  , setStartupHookConfig
   ) where
 
 ------------------------------------------------------------------------------
@@ -76,6 +85,7 @@ import           Data.Monoid
 import qualified Data.Text as T
 import qualified Data.Text.Encoding as T
 import           Data.Typeable
+import           Network(Socket)
 import           Prelude hiding (catch)
 import           Snap.Core
 import           Snap.Iteratee ((>==>), enumBuilder)
@@ -141,6 +151,7 @@ data Config m a = Config
     , other          :: Maybe a
     , backend        :: Maybe ConfigBackend
     , proxyType      :: Maybe ProxyType
+    , startupHook    :: Maybe (StartupHookData m a -> IO ())
     }
 
 instance Show (Config m a) where
@@ -207,6 +218,7 @@ instance Monoid (Config m a) where
         , other          = Nothing
         , backend        = Nothing
         , proxyType      = Nothing
+        , startupHook    = Nothing
         }
 
     a `mappend` b = Config
@@ -227,6 +239,7 @@ instance Monoid (Config m a) where
         , other          = ov other
         , backend        = ov backend
         , proxyType      = ov proxyType
+        , startupHook    = ov startupHook
         }
       where
         ov f = getLast $! (mappend `on` (Last . f)) a b
@@ -332,6 +345,11 @@ getBackend = backend
 getProxyType :: Config m a -> Maybe ProxyType
 getProxyType = proxyType
 
+-- | An action that is run after the server has been started, given a
+--   'StartupHookData'.
+getStartupHook :: Config m a -> Maybe (StartupHookData m a -> IO ())
+getStartupHook = startupHook
+
 
 ------------------------------------------------------------------------------
 setHostname       :: ByteString              -> Config m a -> Config m a
@@ -385,6 +403,35 @@ setBackend x c = c { backend = Just x }
 setProxyType      :: ProxyType               -> Config m a -> Config m a
 setProxyType x c = c { proxyType = Just x }
 
+setStartupHook    :: (StartupHookData m a -> IO ()) -> Config m a -> Config m a
+setStartupHook x c = c { startupHook = Just x }
+
+
+------------------------------------------------------------------------------
+
+-- | Arguments passed to 'setStartupHook'.
+data StartupHookData m a = StartupHookData
+    { startupHookConfig :: Config m a
+    , startupHookSockets :: [Socket]
+    }
+
+emptyStartupHookData :: StartupHookData m a
+emptyStartupHookData = StartupHookData emptyConfig []
+
+-- | The the 'Socket's opened by the server. There will be two 'Socket's for SSL connections, and one otherwise.
+getStartupHookSockets :: StartupHookData m a -> [Socket]
+getStartupHookSockets = startupHookSockets
+
+-- The 'Config', after any command line parsing has been performed.
+getStartupHookConfig :: StartupHookData m a -> Config m a
+getStartupHookConfig = startupHookConfig
+
+setStartupHookSockets :: [Socket] -> StartupHookData m a -> StartupHookData m a
+setStartupHookSockets x c = c { startupHookSockets = x }
+
+setStartupHookConfig :: Config m a -> StartupHookData m a -> StartupHookData m a
+setStartupHookConfig x c = c { startupHookConfig = x }
+
 
 ------------------------------------------------------------------------------
 completeConfig :: (MonadSnap m) => Config m a -> IO (Config m a)

src/Snap/Internal/Http/Server.hs

@@ -40,7 +40,7 @@ import           Data.Time
 import           Data.Typeable
 import           Data.Version
 import           GHC.Conc
-import           Network.Socket (withSocketsDo)
+import           Network.Socket (withSocketsDo, Socket)
 import           Prelude hiding (catch)
 import           System.PosixCompat.Files hiding (setFileSize)
 import           System.Posix.Types (FileOffset)
@@ -166,9 +166,10 @@ httpServe :: Int                         -- ^ default timeout
           -> ByteString                  -- ^ local hostname (server name)
           -> Maybe (ByteString -> IO ()) -- ^ access log action
           -> Maybe (ByteString -> IO ()) -- ^ error log action
+          -> ([Socket] -> IO ())         -- ^ initialisation
           -> ServerHandler               -- ^ handler procedure
           -> IO ()
-httpServe defaultTimeout ports mevType localHostname alog' elog'
+httpServe defaultTimeout ports mevType localHostname alog' elog' initial
           handler = withSocketsDo $ spawnAll alog' elog'
   where
     --------------------------------------------------------------------------
@@ -187,8 +188,9 @@ httpServe defaultTimeout ports mevType localHostname alog' elog'
             else return ()
 
         nports <- mapM bindPort ports
+        let socks = map (\x -> case x of ListenHttp s -> s; ListenHttps s _ -> s) nports
 
-        (runEventLoop evType defaultTimeout nports numCapabilities (logE elog)
+        (runEventLoop evType defaultTimeout nports numCapabilities (logE elog) (initial socks)
                     $ runHTTP defaultTimeout alog elog handler localHostname)
           `finally` do
             logE elog "Server.httpServe: SHUTDOWN"

src/Snap/Internal/Http/Server/Backend.hs

@@ -51,6 +51,7 @@ type EventLoop = Int                       -- ^ default timeout
               -> [ListenSocket]            -- ^ list of ports
               -> Int                       -- ^ number of capabilities
               -> (ByteString -> IO ())     -- ^ error log
+              -> IO ()                     -- ^ initialisation function
               -> SessionHandler            -- ^ session handler
               -> IO ()
 

src/Snap/Internal/Http/Server/LibevBackend.hs

@@ -22,7 +22,7 @@ data LibevException = LibevException String
 instance Exception LibevException
 
 libEvEventLoop :: EventLoop
-libEvEventLoop _ _ _ _ _ = throwIO $
+libEvEventLoop _ _ _ _ _ _ = throwIO $
     LibevException "libev event loop is not supported"
 
 #else
@@ -108,10 +108,11 @@ data Connection = Connection
 
 ------------------------------------------------------------------------------
 libEvEventLoop :: EventLoop
-libEvEventLoop defaultTimeout sockets cap elog handler = do
+libEvEventLoop defaultTimeout sockets cap elog initial handler = do
     backends <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)
                              [0..(cap-1)]
 
+    initial
     debug "libevEventLoop: waiting for loop exit"
     ignoreException (Prelude.mapM_ (takeMVar . _loopExit) backends)
     debug "libevEventLoop: stopping all backends"

src/Snap/Internal/Http/Server/SimpleBackend.hs

@@ -59,10 +59,11 @@ data EventLoopCpu = EventLoopCpu
 
 ------------------------------------------------------------------------------
 simpleEventLoop :: EventLoop
-simpleEventLoop defaultTimeout sockets cap elog handler = do
+simpleEventLoop defaultTimeout sockets cap elog initial handler = do
     loops <- Prelude.mapM (newLoop defaultTimeout sockets handler elog)
                           [0..(cap-1)]
 
+    initial
     debug "simpleEventLoop: waiting for mvars"
 
     --wait for all threads to exit

test/suite/Snap/Internal/Http/Server/Tests.hs

@@ -945,7 +945,7 @@ testSendFile = testCase "server/sendFile" $ do
 
   where
     serve = (httpServe 60 [HttpPort "*" port] Nothing "localhost"
-                       Nothing Nothing
+                       Nothing Nothing (const $ return ())
                     $ runSnap sendFileFoo)
             `catch` \(_::SomeException) -> return ()
 
@@ -974,6 +974,7 @@ testServerStartupShutdown = testCase "server/startup/shutdown" $ do
                        "localhost"
                        (Just $ const (return ())) -- dummy logging
                        (Just $ const (return ())) -- dummy logging
+                       (const $ return ())
                        (runSnap pongServer))
             (killThread)
             (\tid -> do
@@ -1013,6 +1014,7 @@ testServerShutdownWithOpenConns = testCase "server/shutdown-open-conns" $ do
                      "localhost"
                      Nothing
                      Nothing
+                     (const $ return ())
                      (runSnap pongServer)
 
     waitabit