Move src/ to lib/, put Init.hs in src/

2 files changed, 154 insertions, 0 deletions

diff --git a/lib/Hakyll/Preview/Poll.hs b/lib/Hakyll/Preview/Poll.hs
new file mode 100644
index 0000000..e197d3f
--- /dev/null
+++ b/lib/Hakyll/Preview/Poll.hs
@@ -0,0 +1,119 @@
+--------------------------------------------------------------------------------
+{-# 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           System.FSNotify                (Event (..), startManager,
+                                                 watchTree)
+
+#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 conf update = do
+    let providerDir = providerDirectory conf
+    shouldBuild     <- newEmptyMVar
+    pattern         <- update
+    fullProviderDir <- canonicalizePath $ providerDirectory conf
+    manager         <- startManager
+
+    let allowed 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       = eventPath event
+                relative   = dropWhile (`elem` pathSeparators) $
+                    drop (length fullProviderDir) path
+                identifier = fromFilePath relative
+
+            shouldIgnore <- shouldIgnoreFile conf path
+            return $ not shouldIgnore && matches pattern identifier
+
+    -- This thread continually watches the `shouldBuild` MVar and builds
+    -- whenever a value is present.
+    _ <- forkIO $ forever $ do
+        event <- takeMVar shouldBuild
+        handle
+            (\e -> case fromException e of
+                Nothing    -> putStrLn (show e)
+                Just async -> throw (async :: AsyncException))
+            (update' event providerDir)
+
+    -- Send an event whenever something occurs so that the thread described
+    -- above will do a build.
+    void $ watchTree manager providerDir (not . isRemove) $ \event -> do
+        allowed' <- allowed event
+        when allowed' $ void $ tryPutMVar shouldBuild event
+  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
+eventPath evt = evtPath evt
+  where
+    evtPath (Added p _)    = p
+    evtPath (Modified p _) = p
+    evtPath (Removed p _)  = p
+
+
+--------------------------------------------------------------------------------
+isRemove :: Event -> Bool
+isRemove (Removed _ _) = True
+isRemove _             = False
diff --git a/lib/Hakyll/Preview/Server.hs b/lib/Hakyll/Preview/Server.hs
new file mode 100644
index 0000000..a84016a
--- /dev/null
+++ b/lib/Hakyll/Preview/Server.hs
@@ -0,0 +1,35 @@
+--------------------------------------------------------------------------------
+-- | Implements a basic static file server for previewing options
+{-# LANGUAGE OverloadedStrings #-}
+module Hakyll.Preview.Server
+    ( staticServer
+    ) where
+
+
+--------------------------------------------------------------------------------
+import           Data.String
+import qualified Network.Wai.Handler.Warp       as Warp
+import qualified Network.Wai.Application.Static as Static
+import qualified Network.Wai                    as Wai
+import           Network.HTTP.Types.Status      (Status)
+
+--------------------------------------------------------------------------------
+import           Hakyll.Core.Logger    (Logger)
+import qualified Hakyll.Core.Logger    as Logger
+
+staticServer :: Logger               -- ^ Logger
+             -> FilePath             -- ^ Directory to serve
+             -> String               -- ^ Host to bind on
+             -> Int                  -- ^ Port to listen on
+             -> IO ()                -- ^ Blocks forever
+staticServer logger directory host port = do
+    Logger.header logger $ "Listening on http://" ++ host ++ ":" ++ show port
+    Warp.runSettings warpSettings $
+        Static.staticApp (Static.defaultFileServerSettings directory)
+  where
+    warpSettings = Warp.setLogger noLog
+        $ Warp.setHost (fromString host)
+        $ Warp.setPort port Warp.defaultSettings
+
+noLog :: Wai.Request -> Status -> Maybe Integer -> IO ()
+noLog _ _ _ = return ()