content: {-# LANGUAGE RecordWildCards, CPP #-}
  {- Copyright 2015-2019 NGLess Authors
   - License: MIT
   -}
  
  module Utils.LockFile
      ( withLockFile
      , LockParameters(..)
      , WhenExistsStrategy(..)
      , acquireLock
      , fileAge
      , removeFileIfExists
      ) where
  
  import qualified Control.Concurrent.Async as A
  
  #ifndef WINDOWS
  import           System.Posix.Process
  import           System.Posix.Files (touchFile)
  #endif
  
  
  import System.IO.Error (isDoesNotExistError)
  import System.Directory (getModificationTime, removeFile)
  import Data.Time (NominalDiffTime
                   , getZonedTime
                   , formatTime
                   , defaultTimeLocale
                   , getCurrentTime
                   , diffUTCTime
                   )
  import Control.Monad.IO.Class
  import Control.Monad
  import Control.Monad.Except
  import Control.Exception
  import Control.Concurrent (threadDelay)
  
  import Data.Bits ((.|.))
  import Foreign.C (eEXIST, errnoToIOError, getErrno)
  import GHC.IO.Handle.FD (fdToHandle)
  import System.IO (Handle, hClose, hPutStrLn)
  import System.Posix.Internals
      ( c_close
      , c_open
      , o_BINARY
      , o_CREAT
      , o_EXCL
      , o_NOCTTY
      , o_NONBLOCK
      , o_RDWR
      , withFilePath
      )
  import Control.Monad.Trans.Resource
  import Network.HostName (getHostName)
  
  import NGLess.NGError
  import Output
  
  data LockParameters = LockParameters
                  { lockFname :: FilePath
                  , maxAge :: NominalDiffTime
                  , whenExistsStrategy :: WhenExistsStrategy
                  , mtimeUpdate :: Bool -- ^ start a thread which updates the mtime on the file every 10 minutes
                  } deriving (Eq, Show)
  
  data WhenExistsStrategy =
                  IfLockedNothing
                  | IfLockedThrow NGError
                  | IfLockedRetry { nrLockRetries :: !Int, timeBetweenRetries :: !NominalDiffTime }
              deriving (Eq, Show)
  
  pidAsStr :: IO String
  #ifndef WINDOWS
  pidAsStr = show <$> getProcessID
  #else
  pidAsStr = return "(PID is not available on Windows)"
  #endif
  
  #ifdef WINDOWS
  touchFile fname = writeFile fname "lock file"
  #endif
  
  -- | Executes the action specified with a lock file around it so that multiple
  -- ngless do not clash with each other
  withLockFile :: LockParameters -> NGLessIO a -> NGLessIO a
  withLockFile params act =
      acquireLock params >>= \case
          Just rk -> do
              v <- act
              release rk
              return v
          Nothing -> throwSystemError "Could not acquire required lock file."
  
  
  sleep :: NominalDiffTime -> IO ()
  sleep = threadDelay . toMicroSeconds
      where
          toMicroSeconds :: NominalDiffTime -> Int
          toMicroSeconds = (1000000 *) . fromInteger . round
  
  
  -- | Atomically create a lock file
  -- If file already exists, returns 'Nothing'
  acquireLock :: LockParameters -> NGLessIO (Maybe ReleaseKey)
  acquireLock params@LockParameters{..} = liftIO (openLockFile lockFname) >>= \case
      Just h -> do
          -- rkC is for the case where an exception is raised between this line and the release call below
          rkC <- register (hClose h)
          rk <- register (removeFileIfExists lockFname)
          outputListLno' DebugOutput ["Acquired lock file ", lockFname]
          liftIO $ do
              pid <- pidAsStr
              hostname <- getHostName
              t <- getZonedTime
              let tformat = "%a %d-%m-%Y %R"
                  tstr = formatTime defaultTimeLocale tformat t
              hPutStrLn h ("Lock file created for PID " ++ pid ++ " on hostname " ++ hostname ++ " at time " ++ tstr)
              release rkC
          Just <$> if mtimeUpdate
                  then do
                      let updateloop :: IO ()
                          updateloop = threadDelay (10*60*1000*1000) >> touchFile lockFname >> updateloop
                      (rk', _) <- allocate (A.async updateloop) A.cancel
                      register (release rk' >> release rk)
                  else return rk
      Nothing -> liftIO (fileAge lockFname) >>= \case
          Nothing -> do
              outputListLno' InfoOutput ["Lock file ", lockFname, " existed but has been removed. Retrying."]
              acquireLock params
          Just age | age > maxAge -> do
              outputListLno' InfoOutput ["Lock file ", lockFname, " exists but is too old. Assuming it is stale and removing it."]
              liftIO $ removeFileIfExists lockFname
              acquireLock params
          _ -> case whenExistsStrategy of
              IfLockedNothing -> return Nothing
              IfLockedThrow err -> throwError err
              IfLockedRetry{ .. }
                  | nrLockRetries > 0 -> do
                      outputListLno' InfoOutput ["Lock file ", lockFname, " exists and seems current, sleeping for ", show timeBetweenRetries, "."]
                      liftIO $ sleep timeBetweenRetries
                      let lessOneTry = IfLockedRetry (nrLockRetries - 1) timeBetweenRetries
                      acquireLock (params { whenExistsStrategy = lessOneTry })
                  | otherwise -> throwSystemError ("Could not obtain lock " ++ lockFname ++ " even after waiting for its release.")
  
  -- This code is adapted from
  -- https://hackage.haskell.org/package/lock-file-0.5.0.2/docs/src/System-IO-LockFile-Internal.html
  openLockFile :: FilePath -> IO (Maybe Handle)
  openLockFile lockFileName = do
      let openFlags = o_NONBLOCK .|. o_NOCTTY .|. o_RDWR .|. o_CREAT .|. o_EXCL .|. o_BINARY
      fd <- withFilePath lockFileName $ \ fp -> c_open fp openFlags 0o644
      if fd > 0
          then Just <$> fdToHandle fd `onException` c_close fd
          else do
              errno <- getErrno
              when (errno /= eEXIST) . ioError
                  . errnoToIOError "lock" errno Nothing $ Just lockFileName
              -- Failed to open lock file because it already exists
              return Nothing
  
  handleIf :: Exception e => (e -> Bool) -> IO a -> IO a -> IO a
  handleIf cond alt act = handleJust
      (\e -> if cond e then return (Just ()) else return Nothing)
      (const alt)
      act
  
  fileAge :: FilePath -> IO (Maybe NominalDiffTime)
  fileAge fname = handleIf isDoesNotExistError (return Nothing) $ Just <$> do
      mtime <- getModificationTime fname
      cur <- getCurrentTime
      return (cur `diffUTCTime` mtime)
  
  removeFileIfExists :: FilePath -> IO ()
  removeFileIfExists fp = removeFile fp `catch` ignoreDoesNotExistError
      where
          ignoreDoesNotExistError e
                  | isDoesNotExistError e = return ()
                  | otherwise = throwIO e
  