{-# 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. 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 FD -> (FD -> IO ()) -> (FD -> IO a) -> IO a
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
bracket IO FD
takeLock (\FD
h -> FD -> IO ()
releaseLock FD
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))
            ((FD -> IO a) -> IO a) -> (IO a -> FD -> IO a) -> IO a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> FD -> 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)
      a
h <- IO a
op
      WithDirLockEvent -> IO ()
logger (Path Absolute -> WithDirLockEvent
WithDirLockEventPost Path Absolute
lock)
      a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
h

#ifdef MIN_VERSION_lukko
    takeLock :: IO FD
    takeLock :: IO FD
takeLock
        | Bool
fileLockingSupported = do
            FD
h <- String -> IO FD
fdOpen String
lock'
            IO () -> IO ()
forall a. IO a -> IO a
wrapLog (FD -> LockMode -> IO ()
fdLock FD
h LockMode
ExclusiveLock IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO a
`onException` FD -> IO ()
fdClose FD
h)
            FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return FD
h
        | Bool
otherwise = IO FD -> IO FD
forall a. IO a -> IO a
wrapLog IO FD
takeDirLock
      where
        takeDirLock :: IO FD
        takeDirLock :: IO FD
takeDirLock = (IOError -> IO FD) -> IO FD -> IO FD
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOError -> IO FD
onCreateDirError (IO FD -> IO FD) -> IO FD -> IO FD
forall a b. (a -> b) -> a -> b
$ do
            Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
createDirectory Path Absolute
lock
            FD -> IO FD
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (FD
forall a. HasCallStack => a
undefined :: FD)

        onCreateDirError :: IOError -> IO FD
        onCreateDirError :: IOError -> IO FD
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 FD -> IO FD
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IO FD
takeDirLock
          | Bool
otherwise = String -> IO FD
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)

    releaseLock :: FD -> IO ()
releaseLock FD
h
        | Bool
fileLockingSupported = do
            FD -> IO ()
fdUnlock FD
h
            FD -> IO ()
fdClose FD
h
        | Bool
otherwise =
            Path Absolute -> IO ()
forall root. FsRoot root => Path root -> IO ()
removeDirectory Path Absolute
lock

#else
    takeLock = do
        h <- openFile lock' 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 h _ = takeDirLock >> return Nothing
      where
        takeDirLock :: IO ()
        takeDirLock = do
            -- We fallback to directory locking
            -- so we need to cleanup lock file first: close and remove
            hClose h
            handle onIOError (removeFile lock)
            handle onCreateDirError (createDirectory lock)

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

        onIOError :: IOError -> IO ()
        onIOError _ = hPutStrLn stderr
            (me++"cannot remove lock file before directory lock fallback")

    releaseLock (Just h) =
#if MIN_VERSION_base(4,11,0)
        hUnlock h >>
#endif
        hClose h
    releaseLock Nothing  = removeDirectory lock
#endif

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

timedIO :: String -> IO a -> IO a
timedIO :: forall a. String -> IO a -> IO a
timedIO String
label IO a
act = do
    UTCTime
before <- IO UTCTime
getCurrentTime
    a
result <- IO a
act
    UTCTime
after  <- IO UTCTime
getCurrentTime
    Handle -> String -> IO ()
hPutStrLn Handle
stderr (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
label String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
": " String -> String -> String
forall a. [a] -> [a] -> [a]
++ NominalDiffTime -> String
forall a. Show a => a -> String
show (UTCTime
after UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
before)
    Handle -> IO ()
hFlush Handle
stderr
    a -> IO a
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result