    {-# 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