{-# LANGUAGE CPP #-}
module Hackage.Security.Util.IO (
    -- * Miscelleneous
    getFileSize
  , handleDoesNotExist
  , WithDirLockEvent(..)
  , withDirLock
    -- * Debugging
  , timedIO
  ) where

import Prelude
import Control.Concurrent (threadDelay)
import Control.Exception
import Data.Time
import System.IO hiding (openTempFile, withFile)
import System.IO.Error

import Hackage.Security.Util.Path

#ifdef MIN_VERSION_lukko
import Lukko (FD, fileLockingSupported, fdOpen, fdClose, fdLock, fdUnlock, LockMode(ExclusiveLock))
#else
import GHC.IO.Handle.Lock (hLock, LockMode(ExclusiveLock), FileLockingNotSupported)
#if MIN_VERSION_base(4,11,0)
import GHC.IO.Handle.Lock (hUnlock)
#endif
#endif

{-------------------------------------------------------------------------------
  Miscelleneous
-------------------------------------------------------------------------------}

getFileSize :: (Num a, FsRoot root) => Path root -> IO a
getFileSize :: forall a root. (Num a, FsRoot root) => Path root -> IO a
getFileSize Path root
fp = Integer -> a
forall a. Num a => Integer -> a
fromInteger (Integer -> a) -> IO Integer -> IO a
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Path root -> IOMode -> (Handle -> IO Integer) -> IO Integer
forall root r.
FsRoot root =>
Path root -> IOMode -> (Handle -> IO r) -> IO r
withFile Path root
fp IOMode
ReadMode Handle -> IO Integer
hFileSize

handleDoesNotExist :: IO a -> IO (Maybe a)
handleDoesNotExist :: forall a. IO a -> IO (Maybe a)
handleDoesNotExist IO a
act =
   (IOError -> IO (Maybe a)) -> IO (Maybe a) -> IO (Maybe a)
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO (Maybe a)
forall {a}. IOError -> IO (Maybe a)
aux (a -> Maybe a
forall a. a -> Maybe a
Just (a -> Maybe a) -> IO a -> IO (Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO a
act)
  where
    aux :: IOError -> IO (Maybe a)
aux IOError
e =
      if IOError -> Bool
isDoesNotExistError IOError
e
        then Maybe a -> IO (Maybe a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
        else IOError -> IO (Maybe a)
forall e a. (HasCallStack, Exception e) => e -> IO a
throwIO IOError
e


data WithDirLockEvent
  = WithDirLockEventPre    (Path Absolute)
  | WithDirLockEventPost   (Path Absolute)
  | WithDirLockEventUnlock (Path Absolute)

-- | Attempt to create a filesystem lock in the specified directory.
--
-- This will use OS-specific file locking primitives: "GHC.IO.Handle.Lock" with
-- @base-4.10" and later or a shim for @base@ versions.
--
-- Blocks if the lock is already present.
--
-- The logger callback passed as first argument is invoked before and
-- after acquiring a lock, and after unlocking.
--
-- May fallback to locking via creating a directory:
-- Given a file @/path/to@, we do this by attempting to create the directory
-- @//path/to/hackage-security-lock@, and deleting the directory again
-- afterwards. Creating a directory that already exists will throw an exception
-- on most OSs (certainly Linux, OSX and Windows) and is a reasonably common way
-- to implement a lock file.
withDirLock :: (WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a
withDirLock :: forall a.
(WithDirLockEvent -> IO ()) -> Path Absolute -> IO a -> IO a
withDirLock WithDirLockEvent -> IO ()
logger Path Absolute
dir
  = IO (Maybe Handle)
-> (Maybe Handle -> IO ()) -> (Maybe Handle -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO (Maybe Handle)
takeLock (\Maybe Handle
h -> Maybe Handle -> IO ()
releaseLock Maybe Handle
h IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> WithDirLockEvent -> IO ()
logger (Path Absolute -> WithDirLockEvent
WithDirLockEventUnlock Path Absolute
lock))
            ((Maybe Handle -> IO a) -> IO a)
-> (IO a -> Maybe Handle -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> Maybe Handle -> IO a
forall a b. a -> b -> a
const
  where
    lock :: Path Absolute
    lock :: Path Absolute
lock = Path Absolute
dir Path Absolute -> Path Unrooted -> Path Absolute
forall a. Path a -> Path Unrooted -> Path a
</> String -> Path Unrooted
fragment String
"hackage-security-lock"

    lock' :: FilePath
    lock' :: String
lock' = Path Absolute -> String
toFilePath Path Absolute
lock

    me :: String
me = String
"Hackage.Security.Util.IO.withDirLock: "

    wrapLog :: IO a -> IO a
    wrapLog :: forall a. IO a -> IO a
wrapLog IO a
op = do
      WithDirLockEvent -> IO ()
logger (Path Absolute -> WithDirLockEvent
WithDirLockEventPre Path Absolute
lock)
      h <- IO a
op
      logger (WithDirLockEventPost lock)
      return h

#ifdef MIN_VERSION_lukko
    takeLock :: IO FD
    takeLock
        | fileLockingSupported = do
            h <- fdOpen lock'
            wrapLog (fdLock h ExclusiveLock `onException` fdClose h)
            return h
        | otherwise = wrapLog takeDirLock
      where
        takeDirLock :: IO FD
        takeDirLock = handle onCreateDirError $ do
            createDirectory lock
            return (undefined :: FD)

        onCreateDirError :: IOError -> IO FD
        onCreateDirError ioe
          | isAlreadyExistsError ioe = threadDelay (1*1000*1000) >> takeDirLock
          | otherwise = fail (me++"error creating directory lock: "++show ioe)

    releaseLock h
        | fileLockingSupported = do
            fdUnlock h
            fdClose h
        | otherwise =
            removeDirectory lock

#else
    takeLock :: IO (Maybe Handle)
takeLock = do
        h <- String -> IOMode -> IO Handle
openFile String
lock' IOMode
ReadWriteMode
        wrapLog $ handle (fallbackToDirLock h) $ do
            hLock h ExclusiveLock
            return (Just h)


    -- If file locking isn't supported then we fallback to directory locking,
    -- polling if necessary.
    fallbackToDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle)
    fallbackToDirLock :: Handle -> FileLockingNotSupported -> IO (Maybe Handle)
fallbackToDirLock Handle
h FileLockingNotSupported
_ = IO ()
takeDirLock IO () -> IO (Maybe Handle) -> IO (Maybe Handle)
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe Handle -> IO (Maybe Handle)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Handle
forall a. Maybe a
Nothing
      where
        takeDirLock :: IO ()
        takeDirLock :: IO ()
takeDirLock = do
            -- We fallback to directory locking
            -- so we need to cleanup lock file first: close and remove
            Handle -> IO ()
hClose Handle
h
            (IOError -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO ()
onIOError (Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
removeFile Path Absolute
lock)
            (IOError -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO ()
onCreateDirError (Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
createDirectory Path Absolute
lock)

        onCreateDirError :: IOError -> IO ()
        onCreateDirError :: IOError -> IO ()
onCreateDirError IOError
ioe
          | IOError -> Bool
isAlreadyExistsError IOError
ioe = Int -> IO ()
threadDelay (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000Int -> Int -> Int
forall a. Num a => a -> a -> a
*Int
1000) IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO ()
takeDirLock
          | Bool
otherwise = String -> IO ()
forall a. String -> IO a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String
meString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"error creating directory lock: "String -> String -> String
forall a. [a] -> [a] -> [a]
++IOError -> String
forall a. Show a => a -> String
show IOError
ioe)

        onIOError :: IOError -> IO ()
        onIOError :: IOError -> IO ()
onIOError IOError
_ = Handle -> String -> IO ()
hPutStrLn Handle
stderr
            (String
meString -> String -> String
forall a. [a] -> [a] -> [a]
++String
"cannot remove lock file before directory lock fallback")

    releaseLock :: Maybe Handle -> IO ()
releaseLock (Just Handle
h) =
#if MIN_VERSION_base(4,11,0)
        Handle -> IO ()
hUnlock Handle
h IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
#endif
        Handle -> IO ()
hClose Handle
h
    releaseLock Maybe Handle
Nothing  = Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
removeDirectory Path Absolute
lock
#endif

{-------------------------------------------------------------------------------
  Debugging
-------------------------------------------------------------------------------}

timedIO :: String -> IO a -> IO a
timedIO :: forall a. String -> IO a -> IO a
timedIO String
label IO a
act = do
    before <- IO UTCTime
getCurrentTime
    result <- act
    after  <- getCurrentTime
    hPutStrLn stderr $ label ++ ": " ++ show (after `diffUTCTime` before)
    hFlush stderr
    return result