From 2fba64c5adb65a954448e37e2f83772ae865ea17 Mon Sep 17 00:00:00 2001
From: Jorge Israel Peña <jorgepblank@gmail.com>
Date: Wed, 22 May 2013 01:20:43 -0700
Subject: fix preview functionality on windows

---
 src/Hakyll/Preview/Poll.hs | 33 +++++++++++++++++++++++++++++++--
 1 file changed, 31 insertions(+), 2 deletions(-)

(limited to 'src')

diff --git a/src/Hakyll/Preview/Poll.hs b/src/Hakyll/Preview/Poll.hs
index 7dd266b..e1effec 100644
--- a/src/Hakyll/Preview/Poll.hs
+++ b/src/Hakyll/Preview/Poll.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE CPP #-}
+
 --------------------------------------------------------------------------------
 module Hakyll.Preview.Poll
     ( watchUpdates
@@ -9,10 +11,16 @@ import           Control.Concurrent.MVar        (newMVar, putMVar, takeMVar)
 import           Control.Monad                  (when)
 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)
+#endif
 
 --------------------------------------------------------------------------------
 import           Hakyll.Core.Configuration
@@ -45,9 +53,30 @@ watchUpdates conf update = do
     watchTree manager providerDir (not . isRemove) $ \event -> do
         ()       <- takeMVar lock
         allowed' <- allowed event
-        when allowed' $ update >> return ()
+        when allowed' $ update' ((encodeString providerDir) </> (eventPath event))
         putMVar lock ()
+    where
+#ifndef mingw32_HOST_OS
+      update' _ = update >> return ()
+#else
+      update' path = waitOpen path ReadMode (\_ -> update) >> return ()
 
+      -- 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) -> IO r
+      waitOpen path mode handler = 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
+                         else throw ex
+              Right h -> do
+                  handled <- handler h
+                  hClose h
+                  return handled
+#endif
 
 --------------------------------------------------------------------------------
 eventPath :: Event -> FilePath
-- 
cgit v1.2.3