From 57f65ea30348628d11568e165550effc919d0a2d Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Wed, 17 Feb 2010 15:12:16 +0900
Subject: [PATCH] lockfile and pidfile

---
 Main.hs | 45 ++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 40 insertions(+), 5 deletions(-)

diff --git a/Main.hs b/Main.hs
index 736033f..8ea363b 100644
--- a/Main.hs
+++ b/Main.hs
@@ -1,4 +1,5 @@
 {-# LANGUAGE CPP #-}
+import           Control.Exception
 import           Control.Monad
 import           Data.List
 import           Data.Maybe
@@ -23,10 +24,13 @@ import           System.Console.GetOpt
 import           System.Directory
 import           System.Environment
 import           System.Exit
+import           System.FilePath
 import           System.IO
 import           System.Log.Handler.Simple
 import           System.Log.Logger
 import           System.Posix.Files
+import           System.Posix.IO
+import           System.Posix.Process
 import           System.Posix.Types
 import           System.Posix.User
 
@@ -128,18 +132,23 @@ main = withOpenSSL $
           gid     <- getGroupID opts
           lsdir   <- getLocalStateDir opts
 
+          -- Create our localstatedir *before* dropping privileges.
           createLocalStateDir lsdir uid gid
 
           setGroupID gid
           setUserID  uid
 
-          setupLogger opts
-          env <- setupEnv lsdir portNum
+          -- Now that we have our localstatedir. Let's acquire a lock
+          -- on the lockfile. Then create other files.
+          withSystemLock (lsdir </> "lock") $
+            withPidFile (lsdir </> "pid") $
+              do setupLogger opts
+                 env <- setupEnv lsdir portNum
 
-          rebuildIndexIfRequested env opts
+                 rebuildIndexIfRequested env opts
 
-          infoM logger ("Listening to " ++ show portNum ++ "/tcp...")
-          runHttpd (envLucuConf env) (resTree env) [fallbackPageEntity env]
+                 infoM logger ("Listening to " ++ show portNum ++ "/tcp...")
+                 runHttpd (envLucuConf env) (resTree env) [fallbackPageEntity env]
 
           
 resTree :: Environment -> ResTree
@@ -241,3 +250,29 @@ rebuildIndexIfRequested env opts
                                                _               -> False) opts
          when rebuild
                   $ rebuildIndex (envStorage env)
+
+withSystemLock :: FilePath -> IO a -> IO a
+withSystemLock lockfile = bracket lock' unlock' . const
+    where
+      lock' :: IO Fd
+      lock' = do fd <- openFd
+                       lockfile
+                       ReadWrite
+                       (Just 420) -- 0644, -rw-r--r--
+                       defaultFileFlags
+                 setLock fd (WriteLock, AbsoluteSeek, 0, 0)
+                 return fd
+
+      unlock' :: Fd -> IO ()
+      unlock' = closeFd
+
+withPidFile :: FilePath -> IO a -> IO a
+withPidFile lockfile = bracket mkPid' (const delPid') . const
+    where
+      mkPid' :: IO ()
+      mkPid' = withFile lockfile WriteMode $ \ h ->
+               do pid <- getProcessID
+                  hPutStrLn h (show pid)
+
+      delPid' :: IO ()
+      delPid' = removeFile lockfile
-- 
2.40.0