Merge pull request #155 from blaenk/win32-preview-fix

fix preview functionality on windows

1 files changed, 43 insertions, 3 deletions

diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs
index 7dd266b..ab183f7 100644
--- a/src/Hakyll/Preview/Poll.hs
+++ b/src/Hakyll/Preview/Poll.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 --------------------------------------------------------------------------------
 module Hakyll.Preview.Poll
     ( watchUpdates
@@ -6,13 +8,22 @@ module Hakyll.Preview.Poll
 
 --------------------------------------------------------------------------------
 import           Control.Concurrent.MVar        (newMVar, putMVar, takeMVar)
-import           Control.Monad                  (when)
+import           Control.Monad                  (when, void)
 import           Filesystem.Path.CurrentOS      (decodeString, encodeString)
 import           System.Directory               (canonicalizePath)
-import           System.FilePath                (pathSeparators)
+import           System.FilePath                (pathSeparators, (</>))
 import           System.FSNotify                (Event (..), WatchConfig (..),
                                                  startManagerConf, watchTree)
 
+#ifdef mingw32_HOST_OS
+import           System.IO                      (IOMode(ReadMode), Handle, openFile,
+                                                 hClose)
+import           System.IO.Error                (isPermissionError)
+import           Control.Concurrent             (threadDelay)
+import           Control.Exception              (IOException, throw, try)
+import           System.Exit                    (exitFailure)
+import           System.Directory               (doesFileExist)
+#endif
 
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Configuration
@@ -45,9 +56,38 @@ watchUpdates conf update = do
     watchTree manager providerDir (not . isRemove) $ \event -> do
         ()       <- takeMVar lock
         allowed' <- allowed event
-        when allowed' $ update >> return ()
+        when allowed' $ update' event (encodeString providerDir)
         putMVar lock ()
+    where
+#ifndef mingw32_HOST_OS
+      update' _     _        = void update
+#else
+      update' event provider = do
+          let path = provider </> 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
 
 --------------------------------------------------------------------------------
 eventPath :: Event -> FilePath