--------------------------------------------------------------------------------
{-# LANGUAGE CPP #-}
module Hakyll.Preview.Poll
    ( watchUpdates
    ) where


--------------------------------------------------------------------------------
import           Control.Concurrent             (forkIO)
import           Control.Concurrent.MVar        (newEmptyMVar, takeMVar,
                                                 tryPutMVar)
import           Control.Exception              (AsyncException, fromException,
                                                 handle, throw)
import           Control.Monad                  (forever, void, when)
import           System.Directory               (canonicalizePath)
import           System.FilePath                (pathSeparators)
import qualified System.FSNotify                as FSNotify

#ifdef mingw32_HOST_OS
import           Control.Concurrent             (threadDelay)
import           Control.Exception              (IOException, throw, try)
import           System.Directory               (doesFileExist)
import           System.Exit                    (exitFailure)
import           System.FilePath                ((</>))
import           System.IO                      (Handle, IOMode (ReadMode),
                                                 hClose, openFile)
import           System.IO.Error                (isPermissionError)
#endif


--------------------------------------------------------------------------------
import           Hakyll.Core.Configuration
import           Hakyll.Core.Identifier
import           Hakyll.Core.Identifier.Pattern


--------------------------------------------------------------------------------
-- | A thread that watches for updates in a 'providerDirectory' and recompiles
-- a site as soon as any changes occur
watchUpdates :: Configuration -> IO Pattern -> IO ()
watchUpdates :: Configuration -> IO Pattern -> IO ()
watchUpdates Configuration
conf IO Pattern
update = do
    let providerDir :: FilePath
providerDir = Configuration -> FilePath
providerDirectory Configuration
conf
    MVar Event
shouldBuild     <- IO (MVar Event)
forall a. IO (MVar a)
newEmptyMVar
    Pattern
pattern         <- IO Pattern
update
    FilePath
fullProviderDir <- FilePath -> IO FilePath
canonicalizePath FilePath
providerDir
    WatchManager
manager         <- IO WatchManager
FSNotify.startManager
    FilePath -> IO Bool
checkIgnore     <- Configuration -> IO (FilePath -> IO Bool)
shouldWatchIgnore Configuration
conf

    let allowed :: Event -> IO Bool
allowed Event
event = do
            -- Absolute path of the changed file. This must be inside provider
            -- dir, since that's the only dir we're watching.
            let path :: FilePath
path       = Event -> FilePath
FSNotify.eventPath Event
event
                relative :: FilePath
relative   = (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FilePath
pathSeparators) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$
                    Int -> FilePath -> FilePath
forall a. Int -> [a] -> [a]
drop (FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
fullProviderDir) FilePath
path
                identifier :: Identifier
identifier = FilePath -> Identifier
fromFilePath FilePath
relative
            Bool
shouldIgnore <- FilePath -> IO Bool
checkIgnore FilePath
path
            Bool -> IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> IO Bool) -> Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not Bool
shouldIgnore Bool -> Bool -> Bool
&& Pattern -> Identifier -> Bool
matches Pattern
pattern Identifier
identifier

    -- This thread continually watches the `shouldBuild` MVar and builds
    -- whenever a value is present.
    ThreadId
_ <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        Event
event <- MVar Event -> IO Event
forall a. MVar a -> IO a
takeMVar MVar Event
shouldBuild
        (SomeException -> IO ()) -> IO () -> IO ()
forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle
            (\SomeException
e -> case SomeException -> Maybe AsyncException
forall e. Exception e => SomeException -> Maybe e
fromException SomeException
e of
                Maybe AsyncException
Nothing    -> FilePath -> IO ()
putStrLn (SomeException -> FilePath
forall a. Show a => a -> FilePath
show SomeException
e)
                Just AsyncException
async -> AsyncException -> IO ()
forall a e. Exception e => e -> a
throw (AsyncException
async :: AsyncException))
            (Event -> FilePath -> IO ()
forall p p. p -> p -> IO ()
update' Event
event FilePath
providerDir)

    -- Send an event whenever something occurs so that the thread described
    -- above will do a build.
    IO (IO ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (IO ()) -> IO ()) -> IO (IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ WatchManager -> FilePath -> ActionPredicate -> Action -> IO (IO ())
FSNotify.watchTree WatchManager
manager FilePath
providerDir (Bool -> Bool
not (Bool -> Bool) -> ActionPredicate -> ActionPredicate
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ActionPredicate
isRemove) (Action -> IO (IO ())) -> Action -> IO (IO ())
forall a b. (a -> b) -> a -> b
$ \Event
event -> do
        Bool
allowed' <- Event -> IO Bool
allowed Event
event
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
allowed' (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar Event -> Event -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar Event
shouldBuild Event
event
  where
#ifndef mingw32_HOST_OS
    update' :: p -> p -> IO ()
update' p
_     p
_        = IO Pattern -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void IO Pattern
update
#else
    update' event provider = do
        let path = provider </> FSNotify.eventPath event
        -- on windows, a 'Modified' event is also sent on file deletion
        fileExists <- doesFileExist path

        when fileExists . void $ waitOpen path ReadMode (\_ -> update) 10

    -- continuously attempts to open the file in between sleep intervals
    -- handler is run only once it is able to open the file
    waitOpen :: FilePath -> IOMode -> (Handle -> IO r) -> Integer -> IO r
    waitOpen _    _    _       0 = do
        putStrLn "[ERROR] Failed to retrieve modified file for regeneration"
        exitFailure
    waitOpen path mode handler retries = do
        res <- try $ openFile path mode :: IO (Either IOException Handle)
        case res of
            Left ex -> if isPermissionError ex
                       then do
                           threadDelay 100000
                           waitOpen path mode handler (retries - 1)
                       else throw ex
            Right h -> do
                handled <- handler h
                hClose h
                return handled
#endif


--------------------------------------------------------------------------------
isRemove :: FSNotify.Event -> Bool
isRemove :: ActionPredicate
isRemove (FSNotify.Removed {}) = Bool
True
isRemove Event
_                     = Bool
False