graceful-0.1.0.0: sample/sample.hs

import Network
import Network.Socket ( send )
import Control.Concurrent
import Control.Monad
import System.Exit
import System.Posix.Directory
import System.Posix.Files
import System.Posix.IO
import System.Posix.Process
import System.Posix.Signals

import System.Posix.Graceful

main :: IO ()
main = daemonize $ graceful settings worker
    where
      settings = GracefulSettings
                 { gracefulSettingsListen = listenOn $ PortNumber 8080
                 , gracefulSettingsWorkerCount = 4
                 , gracefulSettingsSockFile = "/tmp/sample.sock"
                 , gracefulSettingsPidFile = "/tmp/sample.pid"
                 , gracefulSettingsBinary = "/tmp/sample"
                 }
      worker = GracefulWorker { gracefulWorkerInitialize = return ()
                              , gracefulWorkerApplication = application
                              , gracefulWorkerFinalize = const $ return ()
                              }
      application sock _ = do
        pid <- getProcessID
        let content = shows pid "\n"
        mapM_ (send sock)
                  [ "HTTP/1.1 200 OK\r\n"
                  , "Connection: close\r\n"
                  , "Content-Type: text/plain; charset=utf-8\r\n"
                  , "Content-Length: " ++ show (length content) ++ "\r\n"
                  , "\r\n"
                  , content
                  ]

daemonize :: IO () -> IO ()
daemonize application = do
  void $ setFileCreationMask 0
  void $ forkProcess $ do
    void createSession
    void $ forkProcess $ do
      changeWorkingDirectory "/"
      devnull <- openFd "/dev/null" ReadWrite Nothing defaultFileFlags
      let sendTo fd' fd = closeFd fd >> dupTo fd' fd
      mapM_ (sendTo devnull) [ stdInput, stdOutput, stdError ]
      void $ installHandler sigHUP Ignore Nothing
      application
    exitImmediately ExitSuccess
  exitImmediately ExitSuccess