{-# LANGUAGE CPP #-}

module General.FileLock(usingLockFile) where

import Control.Exception.Extra
import System.FilePath
import General.Extra
import General.Cleanup
#ifdef mingw32_HOST_OS
import Control.Monad
import Data.Bits
import Data.Word
import Foreign.Ptr
import Foreign.C.String
#else
import System.IO
import System.Posix.IO
#endif

#ifdef mingw32_HOST_OS

#ifdef x86_64_HOST_ARCH
#define CALLCONV ccall
#else
#define CALLCONV stdcall
#endif

foreign import CALLCONV unsafe "Windows.h CreateFileW" c_CreateFileW :: CWString -> Word32 -> Word32 -> Ptr () -> Word32 -> Word32 -> Ptr () -> IO (Ptr ())
foreign import CALLCONV unsafe "Windows.h CloseHandle" c_CloseHandle :: Ptr () -> IO Bool
foreign import CALLCONV unsafe "Windows.h GetLastError" c_GetLastError :: IO Word32

c_GENERIC_WRITE = 0x40000000 :: Word32
c_GENERIC_READ  = 0x80000000 :: Word32
c_FILE_SHARE_NONE = 0 :: Word32
c_OPEN_ALWAYS = 4 :: Word32
c_FILE_ATTRIBUTE_NORMAL = 0x80 :: Word32
c_INVALID_HANDLE_VALUE = intPtrToPtr (-1)
c_ERROR_SHARING_VIOLATION = 32
#endif

usingLockFile :: Cleanup -> FilePath -> IO ()

#ifdef mingw32_HOST_OS

usingLockFile b file = do
    createDirectoryRecursive $ takeDirectory file
    let open = withCWString file $ \cfile ->
            c_CreateFileW cfile (c_GENERIC_READ .|. c_GENERIC_WRITE) c_FILE_SHARE_NONE nullPtr c_OPEN_ALWAYS c_FILE_ATTRIBUTE_NORMAL nullPtr
    h <- allocate b open (void . c_CloseHandle)
    when (h == c_INVALID_HANDLE_VALUE) $ do
        err <- c_GetLastError
        errorIO $ "Shake failed to acquire a file lock on " ++ file ++ "\n" ++
                    (if err == c_ERROR_SHARING_VIOLATION
                        then "ERROR_SHARING_VIOLATION - Shake is probably already running."
                        else "Code " ++ show err ++ ", unknown reason for failure.")

#else

usingLockFile :: Cleanup -> FilePath -> IO ()
usingLockFile Cleanup
cleanup FilePath
file = do
    FilePath -> IO ()
createDirectoryRecursive (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
takeDirectory FilePath
file
    IO () -> IO (Either IOException ())
forall a. IO a -> IO (Either IOException a)
tryIO (IO () -> IO (Either IOException ()))
-> IO () -> IO (Either IOException ())
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> IO ()
writeFile FilePath
file FilePath
""

    Fd
fd <- Cleanup -> IO Fd -> (Fd -> IO ()) -> IO Fd
forall a. Cleanup -> IO a -> (a -> IO ()) -> IO a
allocate Cleanup
cleanup (FilePath -> OpenMode -> IO Fd
openSimpleFd FilePath
file OpenMode
ReadWrite) Fd -> IO ()
closeFd
    let lock :: (LockRequest, SeekMode, FileOffset, FileOffset)
lock = (LockRequest
WriteLock, SeekMode
AbsoluteSeek, FileOffset
0, FileOffset
0)
    Fd -> (LockRequest, SeekMode, FileOffset, FileOffset) -> IO ()
setLock Fd
fd (LockRequest, SeekMode, FileOffset, FileOffset)
lock IO () -> (IOException -> IO ()) -> IO ()
forall a. IO a -> (IOException -> IO a) -> IO a
`catchIO` \IOException
e -> do
        Maybe (ProcessID, (LockRequest, SeekMode, FileOffset, FileOffset))
res <- Fd
-> (LockRequest, SeekMode, FileOffset, FileOffset)
-> IO
     (Maybe
        (ProcessID, (LockRequest, SeekMode, FileOffset, FileOffset)))
getLock Fd
fd (LockRequest, SeekMode, FileOffset, FileOffset)
lock
        FilePath -> IO ()
forall a. Partial => FilePath -> IO a
errorIO (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Shake failed to acquire a file lock on " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    (case Maybe (ProcessID, (LockRequest, SeekMode, FileOffset, FileOffset))
res of
                        Maybe (ProcessID, (LockRequest, SeekMode, FileOffset, FileOffset))
Nothing -> FilePath
""
                        Just (ProcessID
pid, (LockRequest, SeekMode, FileOffset, FileOffset)
_) -> FilePath
"Shake process ID " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ ProcessID -> FilePath
forall a. Show a => a -> FilePath
show ProcessID
pid FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" is using this lock.\n") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                    IOException -> FilePath
forall a. Show a => a -> FilePath
show IOException
e

#ifndef MIN_VERSION_unix
#define MIN_VERSION_unix(a,b,c) 0
#endif
#if MIN_VERSION_unix(2,8,0)
openSimpleFd file mode = openFd file mode defaultFileFlags
#else
openSimpleFd :: FilePath -> OpenMode -> IO Fd
openSimpleFd FilePath
file OpenMode
mode = FilePath -> OpenMode -> Maybe FileMode -> OpenFileFlags -> IO Fd
openFd FilePath
file OpenMode
mode Maybe FileMode
forall a. Maybe a
Nothing OpenFileFlags
defaultFileFlags
#endif

#endif