{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Rib.App
( Command (..),
commandParser,
run,
runWith,
)
where
import Control.Concurrent (threadDelay)
import Control.Concurrent.Async (race_)
import Control.Exception.Safe (catch)
import Development.Shake hiding (command)
import Development.Shake.Forward (shakeForward)
import Options.Applicative
import Path
import Path.IO
import Relude
import qualified Rib.Server as Server
import Rib.Settings (RibSettings (..))
import Rib.Watch (onTreeChange)
import System.FSNotify (Event (..), eventIsDirectory, eventPath)
import System.IO (BufferMode (LineBuffering), hSetBuffering)
data Command
=
OneOff
|
Generate
{
Command -> Bool
full :: Bool
}
|
Watch
|
Serve
{
Command -> Int
port :: Int,
Command -> Bool
dontWatch :: Bool
}
deriving (Int -> Command -> ShowS
[Command] -> ShowS
Command -> String
(Int -> Command -> ShowS)
-> (Command -> String) -> ([Command] -> ShowS) -> Show Command
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Command] -> ShowS
$cshowList :: [Command] -> ShowS
show :: Command -> String
$cshow :: Command -> String
showsPrec :: Int -> Command -> ShowS
$cshowsPrec :: Int -> Command -> ShowS
Show, Command -> Command -> Bool
(Command -> Command -> Bool)
-> (Command -> Command -> Bool) -> Eq Command
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Command -> Command -> Bool
$c/= :: Command -> Command -> Bool
== :: Command -> Command -> Bool
$c== :: Command -> Command -> Bool
Eq, (forall x. Command -> Rep Command x)
-> (forall x. Rep Command x -> Command) -> Generic Command
forall x. Rep Command x -> Command
forall x. Command -> Rep Command x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Command x -> Command
$cfrom :: forall x. Command -> Rep Command x
Generic)
commandParser :: Parser Command
commandParser :: Parser Command
commandParser =
Mod CommandFields Command -> Parser Command
forall a. Mod CommandFields a -> Parser a
hsubparser (Mod CommandFields Command -> Parser Command)
-> Mod CommandFields Command -> Parser Command
forall a b. (a -> b) -> a -> b
$
[Mod CommandFields Command] -> Mod CommandFields Command
forall a. Monoid a => [a] -> a
mconcat
[ String -> ParserInfo Command -> Mod CommandFields Command
forall a. String -> ParserInfo a -> Mod CommandFields a
command "generate" (ParserInfo Command -> Mod CommandFields Command)
-> ParserInfo Command -> Mod CommandFields Command
forall a b. (a -> b) -> a -> b
$ Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser Command
generateCommand (InfoMod Command -> ParserInfo Command)
-> InfoMod Command -> ParserInfo Command
forall a b. (a -> b) -> a -> b
$ String -> InfoMod Command
forall a. String -> InfoMod a
progDesc "Run one-off generation of static files",
String -> ParserInfo Command -> Mod CommandFields Command
forall a. String -> ParserInfo a -> Mod CommandFields a
command "watch" (ParserInfo Command -> Mod CommandFields Command)
-> ParserInfo Command -> Mod CommandFields Command
forall a b. (a -> b) -> a -> b
$ Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser Command
watchCommand (InfoMod Command -> ParserInfo Command)
-> InfoMod Command -> ParserInfo Command
forall a b. (a -> b) -> a -> b
$ String -> InfoMod Command
forall a. String -> InfoMod a
progDesc "Watch the source directory, and generate when it changes",
String -> ParserInfo Command -> Mod CommandFields Command
forall a. String -> ParserInfo a -> Mod CommandFields a
command "serve" (ParserInfo Command -> Mod CommandFields Command)
-> ParserInfo Command -> Mod CommandFields Command
forall a b. (a -> b) -> a -> b
$ Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser Command
serveCommand (InfoMod Command -> ParserInfo Command)
-> InfoMod Command -> ParserInfo Command
forall a b. (a -> b) -> a -> b
$ String -> InfoMod Command
forall a. String -> InfoMod a
progDesc "Like watch, but also starts a HTTP server"
]
where
generateCommand :: Parser Command
generateCommand =
Bool -> Command
Generate (Bool -> Command) -> Parser Bool -> Parser Command
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "full" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help "Do a full generation (toggles shakeRebuild)")
watchCommand :: Parser Command
watchCommand =
Command -> Parser Command
forall (f :: * -> *) a. Applicative f => a -> f a
pure Command
Watch
serveCommand :: Parser Command
serveCommand =
Int -> Bool -> Command
Serve
(Int -> Bool -> Command) -> Parser Int -> Parser (Bool -> Command)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadM Int -> Mod OptionFields Int -> Parser Int
forall a. ReadM a -> Mod OptionFields a -> Parser a
option ReadM Int
forall a. Read a => ReadM a
auto (String -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "port" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Char -> Mod OptionFields Int
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short 'p' Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. String -> Mod f a
help "HTTP server port" Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Mod OptionFields Int
forall a (f :: * -> *). Show a => Mod f a
showDefault Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> Int -> Mod OptionFields Int
forall (f :: * -> *) a. HasValue f => a -> Mod f a
value 8080 Mod OptionFields Int
-> Mod OptionFields Int -> Mod OptionFields Int
forall a. Semigroup a => a -> a -> a
<> String -> Mod OptionFields Int
forall (f :: * -> *) a. HasMetavar f => String -> Mod f a
metavar "PORT")
Parser (Bool -> Command) -> Parser Bool -> Parser Command
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Mod FlagFields Bool -> Parser Bool
switch (String -> Mod FlagFields Bool
forall (f :: * -> *) a. HasName f => String -> Mod f a
long "no-watch" Mod FlagFields Bool -> Mod FlagFields Bool -> Mod FlagFields Bool
forall a. Semigroup a => a -> a -> a
<> String -> Mod FlagFields Bool
forall (f :: * -> *) a. String -> Mod f a
help "Serve only; don't watch and regenerate")
run ::
Path Rel Dir ->
Path Rel Dir ->
Action () ->
IO ()
run :: Path Rel Dir -> Path Rel Dir -> Action () -> IO ()
run src :: Path Rel Dir
src dst :: Path Rel Dir
dst buildAction :: Action ()
buildAction = Path Rel Dir -> Path Rel Dir -> Action () -> Command -> IO ()
runWith Path Rel Dir
src Path Rel Dir
dst Action ()
buildAction (Command -> IO ()) -> IO Command -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ParserInfo Command -> IO Command
forall a. ParserInfo a -> IO a
execParser ParserInfo Command
opts
where
opts :: ParserInfo Command
opts =
Parser Command -> InfoMod Command -> ParserInfo Command
forall a. Parser a -> InfoMod a -> ParserInfo a
info
(Parser Command
commandParser Parser Command -> Parser (Command -> Command) -> Parser Command
forall (f :: * -> *) a b. Applicative f => f a -> f (a -> b) -> f b
<**> Parser (Command -> Command)
forall a. Parser (a -> a)
helper)
( InfoMod Command
forall a. InfoMod a
fullDesc
InfoMod Command -> InfoMod Command -> InfoMod Command
forall a. Semigroup a => a -> a -> a
<> String -> InfoMod Command
forall a. String -> InfoMod a
progDesc "Rib static site generator CLI"
)
runWith :: Path Rel Dir -> Path Rel Dir -> Action () -> Command -> IO ()
runWith :: Path Rel Dir -> Path Rel Dir -> Action () -> Command -> IO ()
runWith src :: Path Rel Dir
src dst :: Path Rel Dir
dst buildAction :: Action ()
buildAction ribCmd :: Command
ribCmd = do
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Path Rel Dir
src Path Rel Dir -> Path Rel Dir -> Bool
forall a. Eq a => a -> a -> Bool
== Path Rel Dir
forall b t. Path b t
currentRelDir) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
String -> IO ()
forall (m :: * -> *) a. MonadFail m => String -> m a
fail "cannot use '.' as source directory."
(Handle -> BufferMode -> IO ()) -> BufferMode -> Handle -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Handle -> BufferMode -> IO ()
hSetBuffering BufferMode
LineBuffering (Handle -> IO ()) -> [Handle] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [Handle
stdout, Handle
stderr]
let ribSettings :: RibSettings
ribSettings =
case Command
ribCmd of
OneOff ->
Path Rel Dir -> Path Rel Dir -> Verbosity -> Bool -> RibSettings
RibSettings Path Rel Dir
src Path Rel Dir
dst Verbosity
Silent Bool
False
Generate fullGen :: Bool
fullGen ->
Path Rel Dir -> Path Rel Dir -> Verbosity -> Bool -> RibSettings
RibSettings Path Rel Dir
src Path Rel Dir
dst Verbosity
Verbose Bool
fullGen
_ ->
Path Rel Dir -> Path Rel Dir -> Verbosity -> Bool -> RibSettings
RibSettings Path Rel Dir
src Path Rel Dir
dst Verbosity
Verbose Bool
False
case Command
ribCmd of
OneOff ->
RibSettings -> Action () -> IO ()
runShake RibSettings
ribSettings Action ()
buildAction
Generate _ ->
RibSettings -> IO ()
runShakeBuild RibSettings
ribSettings
Watch ->
RibSettings -> IO ()
runShakeAndObserve RibSettings
ribSettings
Serve p :: Int
p dw :: Bool
dw -> do
IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO ()
race_ (Int -> String -> IO ()
Server.serve Int
p (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath Path Rel Dir
dst) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
if Bool
dw
then Int -> IO ()
threadDelay Int
forall a. Bounded a => a
maxBound
else RibSettings -> IO ()
runShakeAndObserve RibSettings
ribSettings
where
currentRelDir :: Path b t
currentRelDir = [reldir|.|]
Path Rel Dir
shakeDatabaseDir :: Path Rel Dir = Path Rel Dir
src Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|.shake|]
runShakeAndObserve :: RibSettings -> IO ()
runShakeAndObserve ribSettings :: RibSettings
ribSettings = do
RibSettings -> IO ()
runShakeBuild (RibSettings -> IO ()) -> RibSettings -> IO ()
forall a b. (a -> b) -> a -> b
$ RibSettings
ribSettings {_ribSettings_fullGen :: Bool
_ribSettings_fullGen = Bool
True}
String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ "[Rib] Watching " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath Path Rel Dir
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " for changes"
IO () -> IO ()
onSrcChange (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ RibSettings -> IO ()
runShakeBuild RibSettings
ribSettings
runShakeBuild :: RibSettings -> IO ()
runShakeBuild ribSettings :: RibSettings
ribSettings = do
RibSettings -> Action () -> IO ()
runShake RibSettings
ribSettings (Action () -> IO ()) -> Action () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
String -> Action ()
putInfo (String -> Action ()) -> String -> Action ()
forall a b. (a -> b) -> a -> b
$ "[Rib] Generating " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath Path Rel Dir
src String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " (full=" String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Bool -> String
forall b a. (Show a, IsString b) => a -> b
show (RibSettings -> Bool
_ribSettings_fullGen RibSettings
ribSettings) String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ")"
Action ()
buildAction
runShake :: RibSettings -> Action () -> IO ()
runShake ribSettings :: RibSettings
ribSettings shakeAction :: Action ()
shakeAction = do
ShakeOptions -> Action () -> IO ()
shakeForward (RibSettings -> ShakeOptions
shakeOptionsFrom RibSettings
ribSettings) Action ()
shakeAction
IO () -> (ShakeException -> IO ()) -> IO ()
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
`catch` ShakeException -> IO ()
forall (m :: * -> *). MonadIO m => ShakeException -> m ()
handleShakeException
handleShakeException :: ShakeException -> m ()
handleShakeException (ShakeException
e :: ShakeException) =
String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$
"[Rib] Unhandled exception when building " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShakeException -> String
shakeExceptionTarget ShakeException
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ": " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> ShakeException -> String
forall b a. (Show a, IsString b) => a -> b
show ShakeException
e
shakeOptionsFrom :: RibSettings -> ShakeOptions
shakeOptionsFrom settings :: RibSettings
settings =
ShakeOptions
shakeOptions
{ shakeVerbosity :: Verbosity
shakeVerbosity = RibSettings -> Verbosity
_ribSettings_verbosity RibSettings
settings,
shakeFiles :: String
shakeFiles = Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath Path Rel Dir
shakeDatabaseDir,
shakeRebuild :: [(Rebuild, String)]
shakeRebuild = [(Rebuild, String)]
-> [(Rebuild, String)] -> Bool -> [(Rebuild, String)]
forall a. a -> a -> Bool -> a
bool [] [(Rebuild
RebuildNow, "**")] (RibSettings -> Bool
_ribSettings_fullGen RibSettings
settings),
shakeLintInside :: [String]
shakeLintInside = [""],
shakeExtra :: HashMap TypeRep Dynamic
shakeExtra = RibSettings -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
forall a.
Typeable a =>
a -> HashMap TypeRep Dynamic -> HashMap TypeRep Dynamic
addShakeExtra RibSettings
settings (ShakeOptions -> HashMap TypeRep Dynamic
shakeExtra ShakeOptions
shakeOptions)
}
onSrcChange :: IO () -> IO ()
onSrcChange f :: IO ()
f = do
Path Abs Dir
workDir <- IO (Path Abs Dir)
forall (m :: * -> *). MonadIO m => m (Path Abs Dir)
getCurrentDir
[Path Abs Dir]
dirBlacklist <- (Path Rel Dir -> IO (Path Abs Dir))
-> [Path Rel Dir] -> IO [Path Abs Dir]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Path Rel Dir -> IO (Path Abs Dir)
forall path (m :: * -> *).
(AnyPath path, MonadIO m) =>
path -> m (AbsPath path)
makeAbsolute [Path Rel Dir
shakeDatabaseDir, Path Rel Dir
src Path Rel Dir -> Path Rel Dir -> Path Rel Dir
forall b t. Path b Dir -> Path Rel t -> Path b t
</> [reldir|.git|]]
let isBlacklisted :: FilePath -> Bool
isBlacklisted :: String -> Bool
isBlacklisted p :: String
p = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ ((Path Abs Dir -> Bool) -> [Path Abs Dir] -> [Bool])
-> [Path Abs Dir] -> (Path Abs Dir -> Bool) -> [Bool]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Path Abs Dir -> Bool) -> [Path Abs Dir] -> [Bool]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [Path Abs Dir]
dirBlacklist ((Path Abs Dir -> Bool) -> [Bool])
-> (Path Abs Dir -> Bool) -> [Bool]
forall a b. (a -> b) -> a -> b
$ \b :: Path Abs Dir
b -> Path Abs Dir -> String
forall b t. Path b t -> String
toFilePath Path Abs Dir
b String -> String -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
p
Path Rel Dir -> ([Event] -> IO ()) -> IO ()
forall b t. Path b t -> ([Event] -> IO ()) -> IO ()
onTreeChange Path Rel Dir
src (([Event] -> IO ()) -> IO ()) -> ([Event] -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \allEvents :: [Event]
allEvents -> do
let events :: [Event]
events = (Event -> Bool) -> [Event] -> [Event]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (Event -> Bool) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Bool
isBlacklisted (String -> Bool) -> (Event -> String) -> Event -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Event -> String
eventPath) [Event]
allEvents
Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Event] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Event]
events) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
Path Abs Dir -> Event -> IO ()
forall (m :: * -> *).
(MonadThrow m, MonadIO m) =>
Path Abs Dir -> Event -> m ()
logEvent Path Abs Dir
workDir (Event -> IO ()) -> [Event] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
`mapM_` [Event]
events
IO ()
f
logEvent :: Path Abs Dir -> Event -> m ()
logEvent workDir :: Path Abs Dir
workDir e :: Event
e = do
String
eventRelPath <-
if Event -> Bool
eventIsDirectory Event
e
then (Path Rel Dir -> String) -> m (Path Rel Dir) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Rel Dir -> String
forall b t. Path b t -> String
toFilePath (m (Path Rel Dir) -> m String)
-> (Path Abs Dir -> m (Path Rel Dir)) -> Path Abs Dir -> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Abs Dir -> m (RelPath (Path Abs Dir))
forall path (m :: * -> *).
(AnyPath path, MonadThrow m) =>
Path Abs Dir -> path -> m (RelPath path)
makeRelative Path Abs Dir
workDir (Path Abs Dir -> m String) -> m (Path Abs Dir) -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> m (Path Abs Dir)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs Dir)
parseAbsDir (Event -> String
eventPath Event
e)
else (Path Rel File -> String) -> m (Path Rel File) -> m String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Path Rel File -> String
forall b t. Path b t -> String
toFilePath (m (Path Rel File) -> m String)
-> (Path Abs File -> m (Path Rel File))
-> Path Abs File
-> m String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Path Abs Dir -> Path Abs File -> m (RelPath (Path Abs File))
forall path (m :: * -> *).
(AnyPath path, MonadThrow m) =>
Path Abs Dir -> path -> m (RelPath path)
makeRelative Path Abs Dir
workDir (Path Abs File -> m String) -> m (Path Abs File) -> m String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> m (Path Abs File)
forall (m :: * -> *). MonadThrow m => String -> m (Path Abs File)
parseAbsFile (Event -> String
eventPath Event
e)
String -> m ()
forall (m :: * -> *). MonadIO m => String -> m ()
putStrLn (String -> m ()) -> String -> m ()
forall a b. (a -> b) -> a -> b
$ Event -> String
eventLogPrefix Event
e String -> ShowS
forall a. Semigroup a => a -> a -> a
<> " " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
eventRelPath
eventLogPrefix :: Event -> String
eventLogPrefix = \case
Added _ _ _ -> "A"
Modified _ _ _ -> "M"
Removed _ _ _ -> "D"
Unknown _ _ _ -> "?"