{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS -fno-warn-unused-do-bind #-}

module System.Posix.Daemon
(
  daemonize,
  status,
  kill,
  pidLive,
  Options(..)
)
where

import Data.Maybe
import Control.Monad hiding (forever,void)
import qualified Control.Monad as Monad (void)

import System.IO
import System.Exit
import System.Posix
import System.Posix.Process
import Foreign
import Foreign.C
import System.Posix.Daemon.IORedirection

data Options = Options {
  optionsPidFile :: FilePath,
  optionsStdout :: Maybe FilePath,
  optionsStderr :: Maybe FilePath
} deriving (Eq, Show)

kill :: Int -> FilePath -> IO ()
kill timeout pidFile = pidRead pidFile >>= f where
  f Nothing = return ()
  f (Just pid) = do
    islive <- pidLive pid
    when islive $ do
      signalProcess sigTERM pid
      wait timeout pid
    removeLink pidFile
          
status :: FilePath -> IO ()
status pidFile = fileExist pidFile >>= f where
  f False = putStrLn "stopped"
  f True = do
    mpid <- pidRead pidFile
    case mpid of
      Nothing -> putStrLn "stopped"
      Just pid -> do
        res <- pidLive pid
        if res
          then putStrLn "running"
          else putStrLn "stopped, pidfile remaining"   

daemonize :: Options -> IO () -> IO ()
daemonize Options{..} program = do
  Monad.void $ forkProcess $ do
    createSession
    forkProcess $ do
      pidWrite optionsPidFile
      installHandler sigHUP Ignore Nothing
      
      redirectStdin "/dev/null"
      case optionsStdout of
        Nothing -> redirectStdout "/dev/null"
        Just p -> redirectStdout p
      case optionsStderr of
        Nothing -> redirectStderr "/dev/null"
        Just p -> redirectStderr p

      program
    exitImmediately ExitSuccess
  exitImmediately ExitSuccess

{- Internal -}

wait :: Int -> CPid -> IO ()
wait secs pid = (when <$> pidLive pid) >>= \w -> w f
  where f | secs > 0 = do
            usleep 1000000
            wait (secs-1) pid
          | otherwise = do
            putStrLn $ "force killing PID " ++ (show pid)
            signalProcess sigKILL pid

pidWrite :: FilePath -> IO ()
pidWrite pidPath = getProcessID >>= writeFile pidPath . show

pidRead :: FilePath -> IO (Maybe CPid)
pidRead pidFile = fileExist pidFile >>= f where
  f True  = fmap (Just . read) . readFile $ pidFile
  f False = return Nothing

{- PID status -}

foreign import ccall unsafe "kill"
  c_kill :: CPid -> CInt -> IO CInt

pidLive :: CPid -> IO Bool
pidLive pid = do
  v <- (c_kill (fromIntegral pid) nullSignal)
  return $ v >= 0