rib-core (empty) → 1.0.0.0

raw patch · 8 files changed

+637/−0 lines, 8 filesdep +aesondep +asyncdep +base-noprelude

Dependencies added: aeson, async, base-noprelude, binary, cmdargs, containers, directory, exceptions, filepath, foldl, fsnotify, iso8601-time, megaparsec, modern-uri, mtl, optparse-applicative, relude, safe-exceptions, shake, text, time, wai, wai-app-static, warp

Files

rib-core.cabal +62/−0
src/Rib/App.hs +130/−0
src/Rib/Cli.hs +166/−0
src/Rib/Log.hs +28/−0
src/Rib/Route.hs +76/−0
src/Rib/Server.hs +36/−0
src/Rib/Shake.hs +96/−0
src/Rib/Watch.hs +43/−0

+ rib-core.cabal view

@@ -0,0 +1,62 @@+cabal-version: 2.4+name: rib-core+version: 1.0.0.0+license: BSD-3-Clause+copyright: 2019 Sridhar Ratnakumar+maintainer: srid@srid.ca+author: Sridhar Ratnakumar+homepage: https://github.com/srid/rib#readme+bug-reports: https://github.com/srid/rib/issues+synopsis:+    Static site generator based on Shake+description:+    Haskell static site generator based on Shake, with a delightful development experience.+category: Web+build-type: Simple++source-repository head+    type: git+    location: https://github.com/srid/rib++library+    hs-source-dirs: src+    default-language: Haskell2010+    default-extensions: NoImplicitPrelude+    ghc-options:+        -Wall+        -Wincomplete-record-updates+        -Wincomplete-uni-patterns+    build-depends:+        aeson >=1.4.2 && <1.5,+        async,+        base-noprelude >=4.12 && <4.14,+        binary >=0.8.6 && <0.9,+        cmdargs >=0.10.20 && <0.11,+        containers >=0.6.0 && <0.7,+        directory >= 1.0 && <2.0,+        exceptions,+        foldl,+        fsnotify >=0.3.0 && <0.4,+        filepath,+        megaparsec >= 8.0,+        modern-uri,+        mtl >=2.2.2 && <2.3,+        optparse-applicative >= 0.15,+        relude >= 0.6 && < 0.8,+        safe-exceptions,+        shake >= 0.18.5,+        text >=1.2.3 && <1.3,+        time,+        iso8601-time,+        wai >=3.2.2 && <3.3,+        wai-app-static >=3.1.6 && <3.2,+        warp+  exposed-modules:+      Rib.App+      Rib.Cli+      Rib.Watch+      Rib.Log+      Rib.Route+      Rib.Shake+  other-modules:+      Rib.Server

+ src/Rib/App.hs view

@@ -0,0 +1,130 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | CLI interface for Rib.+--+-- Mostly you would only need `Rib.App.run`, passing it your Shake build action.+module Rib.App+  ( run,+    runWith,+  )+where++import Control.Concurrent.Async (race_)+import Control.Exception.Safe (catch)+import Development.Shake hiding (command)+import Development.Shake.Forward (shakeForward)+import Options.Applicative+import Relude+import Rib.Cli (CliConfig (CliConfig), cliParser)+import qualified Rib.Cli as Cli+import Rib.Log+import qualified Rib.Server as Server+import Rib.Watch (onTreeChange)+import System.Directory+import System.FSNotify (Event (..), eventPath)+import System.FilePath+import System.IO (BufferMode (LineBuffering), hSetBuffering)++-- | Run Rib using arguments passed in the command line.+run ::+  -- | Default value for `Cli.inputDir`+  FilePath ->+  -- | Deault value for `Cli.outputDir`+  FilePath ->+  -- | Shake build rules for building the static site+  Action () ->+  IO ()+run src dst buildAction = runWith buildAction =<< execParser opts+  where+    opts =+      info+        (cliParser src dst <**> helper)+        ( fullDesc+            <> progDesc "Generate a static site at OUTPUTDIR using input from INPUTDIR"+        )++-- | Like `run` but with an explicitly passed `CliConfig`+runWith :: Action () -> CliConfig -> IO ()+runWith buildAction cfg@CliConfig {..} = do+  -- For saner output+  flip hSetBuffering LineBuffering `mapM_` [stdout, stderr]+  case (watch, serve) of+    (True, Just (host, port)) -> do+      race_+        (Server.serve cfg host port $ outputDir)+        (runShakeAndObserve cfg buildAction)+    (True, Nothing) ->+      runShakeAndObserve cfg buildAction+    (False, Just (host, port)) ->+      Server.serve cfg host port $ outputDir+    (False, Nothing) ->+      runShakeBuild cfg buildAction++shakeOptionsFrom :: CliConfig -> ShakeOptions+shakeOptionsFrom cfg'@CliConfig {..} =+  shakeOptions+    { shakeVerbosity = verbosity,+      shakeFiles = shakeDbDir,+      shakeRebuild = bool [] [(RebuildNow, "**")] rebuildAll,+      shakeLintInside = [""],+      shakeExtra = addShakeExtra cfg' (shakeExtra shakeOptions)+    }++runShakeBuild :: CliConfig -> Action () -> IO ()+runShakeBuild cfg@CliConfig {..} buildAction = do+  runShake cfg $ do+    logStrLn cfg $ "[Rib] Generating " <> inputDir <> " (rebuildAll=" <> show rebuildAll <> ")"+    buildAction++runShake :: CliConfig -> Action () -> IO ()+runShake cfg shakeAction = do+  shakeForward (shakeOptionsFrom cfg) shakeAction+    `catch` handleShakeException+  where+    handleShakeException (e :: ShakeException) =+      -- Gracefully handle any exceptions when running Shake actions. We want+      -- Rib to keep running instead of crashing abruptly.+      logErr $+        "[Rib] Unhandled exception when building " <> shakeExceptionTarget e <> ": " <> show e++runShakeAndObserve :: CliConfig -> Action () -> IO ()+runShakeAndObserve cfg@CliConfig {..} buildAction = do+  -- Begin with a *full* generation as the HTML layout may have been changed.+  -- TODO: This assumption is not true when running the program from compiled+  -- binary (as opposed to say via ghcid) as the HTML layout has become fixed+  -- by being part of the binary. In this scenario, we should not do full+  -- generation (i.e., toggle the bool here to False). Perhaps provide a CLI+  -- flag to disable this.+  runShakeBuild (cfg {Cli.rebuildAll = True}) buildAction+  -- And then every time a file changes under the current directory+  logStrLn cfg $ "[Rib] Watching " <> inputDir <> " for changes"+  onSrcChange $ runShakeBuild cfg buildAction+  where+    onSrcChange :: IO () -> IO ()+    onSrcChange f = do+      -- Canonicalizing path is important as we are comparing path ancestor using isPrefixOf+      dir <- canonicalizePath inputDir+      -- Top-level directories to ignore from notifications+      let isBlacklisted :: FilePath -> Bool+          isBlacklisted p = or $ flip fmap watchIgnore $ \b -> (dir </> b) `isPrefixOf` p+      onTreeChange dir $ \allEvents -> do+        let events = filter (not . isBlacklisted . eventPath) allEvents+        unless (null events) $ do+          -- Log the changed events for diagnosis.+          logEvent `mapM_` events+          f+    logEvent :: Event -> IO ()+    logEvent e = do+      logStrLn cfg $ eventLogPrefix e <> " " <> eventPath e+    eventLogPrefix = \case+      -- Single character log prefix to indicate file actions is a convention in Rib.+      Added _ _ _ -> "A"+      Modified _ _ _ -> "M"+      Removed _ _ _ -> "D"+      Unknown _ _ _ -> "?"

+ src/Rib/Cli.hs view

@@ -0,0 +1,166 @@+{-# LANGUAGE ApplicativeDo #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Rib.Cli+  ( CliConfig (..),+    cliParser,+    Verbosity (..),++    -- * Parser helpers+    directoryReader,+    watchOption,+    serveOption,++    -- * Internal+    hostPortParser,+  )+where++import Development.Shake (Verbosity (..))+import Options.Applicative+import Relude+import Relude.Extra.Tuple+import System.FilePath+import qualified Text.Megaparsec as M+import qualified Text.Megaparsec.Char as M++-- Rib's CLI configuration+--+-- Can be retrieved using `Rib.Shake.getCliConfig` in the `Development.Shake.Action` monad.+data CliConfig+  = CliConfig+      { -- | Whether to rebuild all sources in Shake.+        rebuildAll :: Bool,+        -- | Whether to monitor `inputDir` for changes and re-generate+        watch :: Bool,+        -- | Whether to run a HTTP server on `outputDir`+        serve :: Maybe (Text, Int),+        -- | Shake's verbosity level.+        --+        -- Setting this to `Silent` will affect Rib's own logging as well.+        verbosity :: Verbosity,+        -- | Directory from which source content will be read.+        inputDir :: FilePath,+        -- | The path where static files will be generated.  Rib's server uses this+        -- directory when serving files.+        outputDir :: FilePath,+        -- | Path to shake's database directory.+        shakeDbDir :: FilePath,+        -- | List of relative paths to ignore when watching the source directory+        watchIgnore :: [FilePath]+      }+  deriving (Show, Eq, Generic, Typeable)++cliParser :: FilePath -> FilePath -> Parser CliConfig+cliParser inputDirDefault outputDirDefault = do+  rebuildAll <-+    switch+      ( long "rebuild-all"+          <> help "Rebuild all sources"+      )+  watch <- watchOption+  serve <- serveOption+  verbosity <-+    fmap+      (bool Verbose Silent)+      ( switch+          ( long "quiet"+              <> help "Log nothing"+          )+      )+  ~(inputDir, shakeDbDir) <-+    fmap (toSnd shakeDbDirFrom) $+      option+        directoryReader+        ( long "input-dir"+            <> metavar "INPUTDIR"+            <> value inputDirDefault+            <> help ("Directory containing the source files (" <> "default: " <> inputDirDefault <> ")")+        )+  outputDir <-+    option+      directoryReader+      ( long "output-dir"+          <> metavar "OUTPUTDIR"+          <> value outputDirDefault+          <> help ("Directory where files will be generated (" <> "default: " <> outputDirDefault <> ")")+      )+  ~(watchIgnore) <- pure builtinWatchIgnores+  pure CliConfig {..}++watchOption :: Parser Bool+watchOption =+  switch+    ( long "watch"+        <> short 'w'+        <> help "Watch for changes and regenerate"+    )++serveOption :: Parser (Maybe (Text, Int))+serveOption =+  optional+    ( option+        (megaparsecReader hostPortParser)+        ( long "serve"+            <> short 's'+            <> metavar "[HOST]:PORT"+            <> help "Run a HTTP server on the generated directory"+        )+    )+    <|> ( fmap (bool Nothing $ Just (defaultHost, 8080)) $+            switch (short 'S' <> help ("Like `-s " <> toString defaultHost <> ":8080`"))+        )++builtinWatchIgnores :: [FilePath]+builtinWatchIgnores =+  [ ".shake",+    ".git"+  ]++shakeDbDirFrom :: FilePath -> FilePath+shakeDbDirFrom inputDir =+  -- Keep shake database directory under the src directory instead of the+  -- (default) current working directory, which may not always be a project+  -- root (as in the case of neuron).+  inputDir </> ".shake"++-- | Like `str` but adds a trailing slash if there isn't one.+directoryReader :: ReadM FilePath+directoryReader = fmap addTrailingPathSeparator str++megaparsecReader :: M.Parsec Void Text a -> ReadM a+megaparsecReader p =+  eitherReader (first M.errorBundlePretty . M.parse p "<optparse-input>" . toText)++hostPortParser :: M.Parsec Void Text (Text, Int)+hostPortParser = do+  host <-+    optional $+      M.string "localhost"+        <|> M.try parseIP+  void $ M.char ':'+  port <- parseNumRange 1 65535+  pure (fromMaybe defaultHost host, port)+  where+    readNum = maybe (fail "Not a number") pure . readMaybe+    parseIP :: M.Parsec Void Text Text+    parseIP = do+      a <- parseNumRange 0 255 <* M.char '.'+      b <- parseNumRange 0 255 <* M.char '.'+      c <- parseNumRange 0 255 <* M.char '.'+      d <- parseNumRange 0 255+      pure $ toText $ intercalate "." $ show <$> [a, b, c, d]+    parseNumRange :: Int -> Int -> M.Parsec Void Text Int+    parseNumRange a b = do+      n <- readNum =<< M.some M.digitChar+      if a <= n && n <= b+        then pure n+        else fail $ "Number not in range: " <> show a <> "-" <> show b++defaultHost :: Text+defaultHost = "127.0.0.1"

+ src/Rib/Log.hs view

@@ -0,0 +1,28 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++module Rib.Log+  ( logStrLn,+    logErr,+  )+where++import Development.Shake (Verbosity (..))+import Relude+import Rib.Cli (CliConfig (..))+import System.IO (hPutStrLn)++logStrLn :: MonadIO m => CliConfig -> String -> m ()+logStrLn CliConfig {..} s =+  unless (verbosity == Silent) $ do+    putStrLn s++logErr :: MonadIO m => String -> m ()+logErr s =+  liftIO $ hPutStrLn stderr s

+ src/Rib/Route.hs view

@@ -0,0 +1,76 @@+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Type-safe routes for static sites.+module Rib.Route+  ( -- * Defining routes+    IsRoute (..),++    -- * Rendering routes+    routeUrl,+    routeUrlRel,++    -- * Writing routes+    writeRoute,+  )+where++import Control.Monad.Catch+import Data.Kind+import qualified Data.Text as T+import Development.Shake (Action)+import Relude+import Rib.Shake (writeFileCached)+import System.FilePath++-- | A route is a GADT which represents the individual routes in a static site.+--+-- `r` represents the data used to render that particular route.+class IsRoute (r :: Type -> Type) where+  -- | Return the filepath (relative to `Rib.Shake.ribInputDir`) where the+  -- generated content for this route should be written.+  routeFile :: MonadThrow m => r a -> m (FilePath)++data UrlType = Relative | Absolute++path2Url :: FilePath -> UrlType -> Text+path2Url fp = toText . \case+  Relative ->+    fp+  Absolute ->+    "/" </> fp++-- | The absolute URL to this route (relative to site root)+routeUrl :: IsRoute r => r a -> Text+routeUrl = routeUrl' Absolute++-- | The relative URL to this route+routeUrlRel :: IsRoute r => r a -> Text+routeUrlRel = routeUrl' Relative++-- | Get the URL to a route+routeUrl' :: IsRoute r => UrlType -> r a -> Text+routeUrl' urlType = stripIndexHtml . flip path2Url urlType . either (error . toText . displayException) id . routeFile+  where+    stripIndexHtml s =+      -- Because path2Url can return relative URL, we must account for there+      -- not being a / at the beginning.+      if  | "/index.html" `T.isSuffixOf` s ->+            T.dropEnd (T.length "index.html") s+          | s == "index.html" ->+            "."+          | otherwise ->+            s++-- | Write the content `s` to the file corresponding to the given route.+--+-- This is similar to `Rib.Shake.writeFileCached`, but takes a route instead of+-- a filepath as its argument.+writeRoute :: (IsRoute r, ToString s) => r a -> s -> Action ()+writeRoute r content = do+  fp <- liftIO $ routeFile r+  writeFileCached fp $ toString $ content

+ src/Rib/Server.hs view

@@ -0,0 +1,36 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Serve generated static files with HTTP+module Rib.Server+  ( serve,+  )+where++import Network.Wai.Application.Static (defaultFileServerSettings, staticApp)+import qualified Network.Wai.Handler.Warp as Warp+import Relude+import Rib.Cli (CliConfig)+import Rib.Log++-- | Run a HTTP server to serve a directory of static files+--+-- Binds the server to host 127.0.0.1.+serve ::+  CliConfig ->+  -- | Host+  Text ->+  -- | Port number to bind to+  Int ->+  -- | Directory to serve.+  FilePath ->+  IO ()+serve cfg host port path = do+  logStrLn cfg $ "[Rib] Serving " <> path <> " at http://" <> toString host <> ":" <> show port+  Warp.runSettings settings app+  where+    app = staticApp $ defaultFileServerSettings path+    settings =+      Warp.setHost (fromString $ toString host)+        $ Warp.setPort port+        $ Warp.defaultSettings

+ src/Rib/Shake.hs view

@@ -0,0 +1,96 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ViewPatterns #-}++-- | Combinators for working with Shake.+module Rib.Shake+  ( -- * Basic helpers+    buildStaticFiles,+    forEvery,++    -- * Writing only+    writeFileCached,++    -- * Misc+    getCliConfig,+    ribInputDir,+    ribOutputDir,+  )+where++import Control.Monad.Catch+import Development.Shake+import Relude+import Rib.Cli (CliConfig)+import qualified Rib.Cli as Cli+import System.Directory+import System.FilePath+import System.IO.Error (isDoesNotExistError)++-- | Get rib settings from a shake Action monad.+getCliConfig :: Action CliConfig+getCliConfig = getShakeExtra >>= \case+  Just v -> pure v+  Nothing -> fail "CliConfig not initialized"++-- | Input directory containing source files+--+-- This is same as the first argument to `Rib.App.run`+ribInputDir :: Action FilePath+ribInputDir = Cli.inputDir <$> getCliConfig++-- | Output directory where files are generated+--+-- This is same as the second argument to `Rib.App.run`+ribOutputDir :: Action FilePath+ribOutputDir = do+  output <- Cli.outputDir <$> getCliConfig+  liftIO $ createDirectoryIfMissing True output+  return output++-- | Shake action to copy static files as is.+buildStaticFiles :: [FilePath] -> Action ()+buildStaticFiles staticFilePatterns = do+  input <- ribInputDir+  output <- ribOutputDir+  files <- getDirectoryFiles input staticFilePatterns+  void $ forP files $ \f ->+    copyFileChanged (input </> f) (output </> f)++-- | Run the given action when any file matching the patterns changes+forEvery ::+  -- | Source file patterns (relative to `ribInputDir`)+  [FilePath] ->+  (FilePath -> Action a) ->+  Action [a]+forEvery pats f = do+  input <- ribInputDir+  fs <- getDirectoryFiles input pats+  forP fs f++-- | Write the given file but only when it has been modified.+--+-- Also, always writes under ribOutputDir+writeFileCached :: FilePath -> String -> Action ()+writeFileCached !k !s = do+  f <- fmap (</> k) ribOutputDir+  currentS <- liftIO $ forgivingAbsence $ readFile f+  unless (Just s == currentS) $ do+    writeFile' f $! s+    -- Use a character (like +) that contrasts with what Shake uses (#) for+    -- logging modified files being read.+    putInfo $ "+ " <> f++-- | If argument of the function throws a+-- 'System.IO.Error.doesNotExistErrorType', 'Nothing' is returned (other+-- exceptions propagate). Otherwise the result is returned inside a 'Just'.+forgivingAbsence :: (MonadIO m, MonadCatch m) => m a -> m (Maybe a)+forgivingAbsence f =+  catchIf+    isDoesNotExistError+    (Just <$> f)+    (const $ return Nothing)

+ src/Rib/Watch.hs view

@@ -0,0 +1,43 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE ScopedTypeVariables #-}++-- | Filesystem watching using fsnotify+module Rib.Watch+  ( onTreeChange,+  )+where++import Control.Concurrent (threadDelay)+import Control.Concurrent.Async (race)+import Control.Concurrent.Chan+import Relude+import System.FSNotify (Event (..), watchTreeChan, withManager)++-- | Recursively monitor the contents of the given path and invoke the given IO+-- action for every event triggered.+--+-- If multiple events fire rapidly, the IO action is invoked only once, taking+-- those multiple events as its argument.+onTreeChange :: FilePath -> ([Event] -> IO ()) -> IO ()+onTreeChange fp f = do+  withManager $ \mgr -> do+    eventCh <- newChan+    void $ watchTreeChan mgr fp (const True) eventCh+    forever $ do+      firstEvent <- readChan eventCh+      events <- debounce 100 [firstEvent] $ readChan eventCh+      f events++debounce :: Int -> [event] -> IO event -> IO [event]+debounce millies events f = do+  -- Race the readEvent against the timelimit.+  race f (threadDelay (1000 * millies)) >>= \case+    Left event ->+      -- If the read event finishes first try again.+      debounce millies (events <> [event]) f+    Right () ->+      -- Otherwise continue+      return events