{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Rib.App
( App (..),
run,
runWith,
)
where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Control.Concurrent.Chan
import Control.Exception.Safe (catch)
import Development.Shake
import Development.Shake.Forward (shakeForward)
import Path
import Relude
import qualified Rib.Server as Server
import Rib.Shake (RibSettings (..))
import System.Console.CmdArgs
import System.FSNotify (watchTreeChan, withManager)
import System.IO (BufferMode (LineBuffering), hSetBuffering)
data App
=
Generate
{
full :: Bool
}
|
WatchAndGenerate
|
Serve
{
port :: Int,
dontWatch :: Bool
}
deriving (Data, Typeable, Show, Eq)
run ::
Path Rel Dir ->
Path Rel Dir ->
Action () ->
IO ()
run src dst buildAction = runWith src dst buildAction =<< cmdArgs ribCli
where
ribCli =
modes
[ Serve
{ port = 8080 &= help "Port to bind to",
dontWatch = False &= help "Do not watch in addition to serving generated files"
}
&= help "Serve the generated site"
&= auto,
WatchAndGenerate
&= help "Watch for changes and generate",
Generate
{ full = False &= help "Force a full generation of all files"
}
&= help "Generate the site"
]
runWith :: Path Rel Dir -> Path Rel Dir -> Action () -> App -> IO ()
runWith src dst buildAction app = do
when (src == currentRelDir) $
fail "cannot use '.' as source directory."
hSetBuffering stdout LineBuffering
case app of
Generate fullGen ->
runShake fullGen
WatchAndGenerate ->
runShakeAndObserve
Serve p dw -> do
race_ (Server.serve p $ toFilePath dst) $ do
if dw
then threadDelay maxBound
else runShakeAndObserve
where
currentRelDir = [reldir|.|]
runShakeAndObserve = do
runShake True
onTreeChange src $
runShake False
runShake fullGen = do
putStrLn $ "[Rib] Generating " <> toFilePath src <> " (full=" <> show fullGen <> ")"
shakeForward (ribShakeOptions fullGen) buildAction
`catch` \(e :: ShakeException) ->
putStrLn $
"[Rib] Unhandled exception when building " <> shakeExceptionTarget e <> ": " <> show e
ribShakeOptions fullGen =
shakeOptions
{ shakeVerbosity = Verbose,
shakeRebuild = bool [] [(RebuildNow, "**")] fullGen,
shakeLintInside = [""],
shakeExtra = addShakeExtra (RibSettings src dst) (shakeExtra shakeOptions)
}
onTreeChange fp f = do
putStrLn $ "[Rib] Watching " <> toFilePath src <> " for changes"
withManager $ \mgr -> do
events <- newChan
void $ watchTreeChan mgr (toFilePath fp) (const True) events
forever $ do
void $ readChan events
f