{-# LANGUAGE CPP #-}
--cross-platform file locking utilizing POSIX file locking on Unix/Linux and Windows file locking
--hackage's System.FileLock doesn't support POSIX advisory locks nor locking file based on file descriptors, hence this needless rewrite
module ProjectM36.FileLock where


#if defined(mingw32_HOST_OS)
import System.Win32.Types
import Foreign.Marshal.Alloc
import System.Win32.File
import System.Win32.Mem
import Data.Bits

#if defined(i386_HOST_ARCH)
# define WINDOWS_CCONV stdcall
#elif defined(x86_64_HOST_ARCH)
# define WINDOWS_CCONV ccall
#else
# error Unknown mingw32 arch
#endif
foreign import WINDOWS_CCONV "LockFileEx" c_lockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL

foreign import WINDOWS_CCONV "UnlockFileEx" c_unlockFileEx :: HANDLE -> DWORD -> DWORD -> DWORD -> LPOVERLAPPED -> IO BOOL

type LockFile = HANDLE

openLockFile :: FilePath -> IO LockFile
openLockFile path = createFile path 
                    (gENERIC_READ .|. gENERIC_WRITE)
                    (fILE_SHARE_READ .|. fILE_SHARE_WRITE)
                    Nothing
                    oPEN_ALWAYS
                    fILE_ATTRIBUTE_NORMAL
                    Nothing

closeLockFile :: LockFile -> IO ()
closeLockFile file = do
   closeHandle file

--swiped from System.FileLock package
lockFile :: HANDLE -> LockType -> IO ()
lockFile winHandle lock = do
  let exFlag = case lock of
                 WriteLock -> 2
                 ReadLock -> 0
      blockFlag = 0 --always block
      sizeof_OVERLAPPED = 32

  allocaBytes sizeof_OVERLAPPED $ \op -> do
    zeroMemory op $ fromIntegral sizeof_OVERLAPPED
    failIfFalse_ "LockFileEx" $ c_lockFileEx winHandle (exFlag .|. blockFlag) 0 1 0 op

unlockFile :: HANDLE -> IO ()
unlockFile winHandle = do
  let sizeof_OVERLAPPED = 32
  allocaBytes sizeof_OVERLAPPED $ \op -> do
    zeroMemory op $ fromIntegral sizeof_OVERLAPPED
    failIfFalse_ "UnlockFileEx" $ c_unlockFileEx winHandle 0 1 0 op

#else
--all of this complicated nonsense is fixed if we switch to GHC 8.2 which includes native flock support on handles
import qualified System.Posix.IO as P
import System.Posix.Types
import System.Posix.Files
import System.IO

lockStruct :: P.LockRequest -> P.FileLock
lockStruct :: LockRequest -> FileLock
lockStruct LockRequest
req = (LockRequest
req, SeekMode
AbsoluteSeek, FileOffset
0, FileOffset
0)

newtype LockFile = LockFile Fd

--we cannot use openFile from System.IO because it implements complicated locking which prevents opening the same file twice in write mode in the same process with no way to bypass the check.
openLockFile :: FilePath -> IO LockFile
openLockFile :: FilePath -> IO LockFile
openLockFile FilePath
path =
  Fd -> LockFile
LockFile forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> FileMode -> IO Fd
P.createFile FilePath
path FileMode
ownerWriteMode
  
closeLockFile :: LockFile -> IO ()
closeLockFile :: LockFile -> IO ()
closeLockFile (LockFile Fd
fd) =
  Fd -> IO ()
P.closeFd Fd
fd
  
--blocks on lock, if necessary
lockFile :: LockFile -> LockType -> IO ()    
lockFile :: LockFile -> LockType -> IO ()
lockFile (LockFile Fd
fd) LockType
lock = do
  let lockt :: LockRequest
lockt = case LockType
lock of
        LockType
WriteLock -> LockRequest
P.WriteLock
        LockType
ReadLock -> LockRequest
P.ReadLock
  Fd -> FileLock -> IO ()
P.waitToSetLock Fd
fd (LockRequest -> FileLock
lockStruct LockRequest
lockt)
  
unlockFile :: LockFile -> IO ()  
unlockFile :: LockFile -> IO ()
unlockFile (LockFile Fd
fd) = 
  Fd -> FileLock -> IO ()
P.waitToSetLock Fd
fd (LockRequest -> FileLock
lockStruct LockRequest
P.Unlock)
#endif

data LockType = ReadLock | WriteLock deriving (Int -> LockType -> ShowS
[LockType] -> ShowS
LockType -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LockType] -> ShowS
$cshowList :: [LockType] -> ShowS
show :: LockType -> FilePath
$cshow :: LockType -> FilePath
showsPrec :: Int -> LockType -> ShowS
$cshowsPrec :: Int -> LockType -> ShowS
Show)