pansite (empty) → 0.1.0.0
raw patch · 19 files changed
+1153/−0 lines, 19 filesdep +Globdep +MissingHdep +aesonsetup-changed
Dependencies added: Glob, MissingH, aeson, base, blaze-html, bytestring, data-default, directory, doctest, filepath, hspec, http-types, optparse-applicative, pandoc, pandoc-types, pansite, shake, split, template-haskell, text, time, unordered-containers, vcs-revision, vector, wai, wai-logger, warp, yaml
Files
- LICENSE +20/−0
- README.md +138/−0
- Setup.hs +16/−0
- app/Main.hs +16/−0
- app/PansiteApp/App.hs +107/−0
- app/PansiteApp/Build.hs +53/−0
- app/PansiteApp/CommandLine.hs +70/−0
- app/PansiteApp/ConfigInfo.hs +81/−0
- app/PansiteApp/CopyTool.hs +33/−0
- app/PansiteApp/PandocTool.hs +143/−0
- app/PansiteApp/Util.hs +100/−0
- app/PansiteApp/VersionInfo.hs +31/−0
- doctest/Main.hs +26/−0
- pansite.cabal +92/−0
- spec/Spec.hs +11/−0
- src/Pansite.hs +15/−0
- src/Pansite/Config.hs +17/−0
- src/Pansite/Config/Funcs.hs +130/−0
- src/Pansite/Config/Types.hs +54/−0
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2017 Richard Cook++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE+LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION+OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION+WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.md view
@@ -0,0 +1,138 @@+# Pansite: a simple web site management tool++## Development++This project uses [Stack][stack], [Pandoc][pandoc], [Warp][warp] and [Shake][shake]++## Why are you doing this?++I want a [Hakyll][hakyll]-like static web site generator that can be easily used in conjunction with a dynamic site built with [Yesod][yesod]. I want it to use Pandoc so that I can build rich content, possibly with embedded mathematics. I also want it to be responsive, so that when I make changes to the underlying Markdown files, I can view the updated output in my browser quickly instead of having to wait thirty seconds for the Hakyll build to complete. There are probably tools that already do this (probably Hakyll itself can be made to do this), but I love reinventing the wheel. So, that's what I'm going to do.++The system is intended to be extensible in the future, so I will put some thought into how to extract its core functionality into a library.++## Work in progress++This project is a prototype and, therefore, _should not be used for any real work yet!_++## Current features++* Uses Pandoc to render Markdown into HTML (and, also, Microsoft Word documents)+* Supports static resources such as CSS+* Supports dynamic refresh of routes+* Shake-based build ensure that outputs are correctly maintained as long as dependencies are fully specified++## The vision++Currently Pansite is a trivial web app built on top of Warp. Routes are defined in a `.pansite.yaml` file using the following schema:++```yaml+# $(@D) is an automatic variable meaning "the output directory" (a la GNU Make)+# All other paths are resolved relative to this directory containing this file++routes:+- path: ""+ target: $(@D)/index.html+- path: page1+ target: $(@D)/page1.html+- path: page2+ target: $(@D)/page2.html+- path: css/buttondown.css+ target: buttondown.css++targets:+- path: $(@D)/index.html+ tool: pandoc+ tool-settings:+ number-sections: false+ inputs:+ - index.md+ dependencies:+ - .pansite.yaml+- path: $(@D)/page1.html+ tool: pandoc+ tool-settings:+ number-sections: false+ inputs:+ - page1.md+ dependencies:+ - .pansite.yaml+- path: $(@D)/page2.html+ tool: pandoc+ tool-settings:+ mathjax: true+ inputs:+ - page2.md+ dependencies:+ - .pansite.yaml++tool-settings:+ pandoc:+ number-sections: true+ template-path: template.html+ vars:+ - [css, css/buttondown.css]+```++Each `path` entry defines a route that the web app will respond to. The `target` key defines the cached content file to return in response to this route.++The cached content files are currently built using [Shake][shake] using rules generated from the `.pansite.yaml` file. Thus, the app itself defines how to build the cached content files using a simple declarative format. There is a silly test site defined under `_app`, specifically in [`_app/.pansite.yaml`][app-example] that demonstrates the idea. I do not want to allow the app's content itself to provide a Shake build script since I do not want to allow the user-provided content to run arbitrary commands on my server. Instead, the simple declarative rules in `.pansite.yaml` constrain what the build system can do while still keeping it useful.++Currently this prototype demonstrates the use of a single build tool, namely Pandoc. I intend to refactor the code to make it straightforward to specify additional build tools: some will be embedded directly, like Pandoc, others can use the Shake's [`cmd`][cmd-hackage] function to invoke external processes.++Build tools currently supported:++* Pandoc (`pandoc`): Process input files using Pandoc+* Copy (`copy`): Copy input file to output++## How to run it++Build it:++```bash+stack build+```++Run the example site:++```bash+cd _app/+stack exec -- pansite-app --port 3000+```++In your web browser, navigate to a route defined in `.pansite.yaml`, e.g. `http://localhost:3000/page2`.++## Command-line options++```terminal+$ stack exec -- pansite-app --help+Pansite development server 0.1.0.0.772a2d5 (locally modified)++Usage: pansite-app ([-p|--port PORT] [-c|--config CONFIG]+ [-o|--output-dir OUTPUTDIR] | [-v|--version])+ Run Pansite development server++Available options:+ -h,--help Show this help text+ -p,--port PORT Port+ -c,--config CONFIG Path to YAML application configuration file+ -o,--output-dir OUTPUTDIR+ Output directory+ -v,--version Show version+```++## Licence++Released under [MIT License][licence]++Copyright © 2017 Richard Cook++[app-example]: _app/.pansite.yaml+[cmd-hackage]: https://hackage.haskell.org/package/shake-0.15.11/docs/Development-Shake-Command.html+[gnu-make]: https://www.gnu.org/software/make/+[hakyll]: https://jaspervdj.be/hakyll/+[licence]: LICENSE+[pandoc]: http://pandoc.org/+[shake]: http://shakebuild.com/+[stack]: https://haskellstack.org/+[warp]: https://hackage.haskell.org/package/warp+[yesod]: http://www.yesodweb.com/
+ Setup.hs view
@@ -0,0 +1,16 @@+{-|+Module : Setup+Description : Setup for Pansite+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++module Main (main) where++import Distribution.Simple++main :: IO ()+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,16 @@+{-|+Module : Main+Description : Main entrypoint for Pansite app+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++module Main (main) where++import PansiteApp.App++main :: IO ()+main = appMain
+ app/PansiteApp/App.hs view
@@ -0,0 +1,107 @@+{-|+Module : PansiteApp.App+Description : Main entrypoint for Pansite application+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE OverloadedStrings #-}++module PansiteApp.App (appMain) where++import Control.Monad.IO.Class+import qualified Data.ByteString.Lazy as BL+import qualified Data.HashMap.Strict as HashMap+import Data.IORef+import qualified Data.Text as Text+import qualified Data.Text.Encoding as Text+import Network.HTTP.Types+import Network.Wai+import Network.Wai.Handler.Warp+import Network.Wai.Logger+import Pansite+import PansiteApp.Build+import PansiteApp.CommandLine+import PansiteApp.ConfigInfo+import PansiteApp.Util+import PansiteApp.VersionInfo+import System.Directory+import System.FilePath++productVersion :: String+productVersion = "Pansite " ++ fullVersionString++runApp :: ApacheLogger -> ServerConfig -> ConfigInfo -> IO ()+runApp logger (ServerConfig port) configInfo = do+ putStrLn $ "Listening on port " ++ show port+ configInfoRef <- newIORef configInfo+ run port (app logger configInfoRef)++app :: ApacheLogger -> IORef ConfigInfo -> Application+app logger configInfoRef req f = do+ -- TODO: Think about concurrent accesses...+ -- TODO: This is a mess..+ oldConfigInfo <- liftIO $ readIORef configInfoRef+ mbConfigInfo <- liftIO $ updateConfigInfo oldConfigInfo+ configInfo <- case mbConfigInfo of+ Nothing -> return oldConfigInfo+ Just configInfo' -> do+ liftIO $ atomicWriteIORef configInfoRef configInfo'+ return configInfo'++ let (ConfigInfo _ _ (App routes _)) = configInfo++ -- TODO: Let's not rebuild this on every request+ let m = HashMap.fromList (map (\(Route ps targetPath) -> (map Text.pack ps, targetPath)) routes)++ let requestPath = pathInfo req+ putStrLn $ "requestPath=" ++ show requestPath++ case HashMap.lookup requestPath m of+ Just targetPath -> do+ liftIO $ logger req status200 (Just 0)++ build configInfo targetPath++ putStrLn $ "Read from " ++ targetPath++ -- TODO: Ugh. Let's make this less hacky. It works for now though.+ let (rawDataAction, contentType) = case (takeExtension targetPath) of+ ".css" -> (makeUtf8Response targetPath, "text/css; charset=utf-8")+ ".docx" -> (makeRawResponse targetPath, "application/vnd.openxmlformats-officedocument.wordprocessingml.document")+ ".html" -> (makeUtf8Response targetPath, "text/html; charset=utf-8")+ _ -> (makeUtf8Response targetPath, "text/plain; charset=utf-8")++ rawData <- rawDataAction+ f $ responseLBS status200 [(hContentType, contentType)] rawData+ Nothing -> f $ responseLBS status404 [(hContentType, "text/plain")] "404 - Not Found"++makeUtf8Response :: FilePath -> IO BL.ByteString+makeUtf8Response targetPath = do+ -- TODO: Eliminate multiple encoding redundancy!+ content <- Text.pack <$> readFileUtf8 targetPath+ return $ BL.fromStrict (Text.encodeUtf8 content)++makeRawResponse :: FilePath -> IO BL.ByteString+makeRawResponse = BL.readFile++mkAppPaths :: FilePath -> FilePath -> IO AppPaths+mkAppPaths appYamlPath outputDir = do+ appYamlPath' <- canonicalizePath appYamlPath+ let appDir = takeDirectory appYamlPath'+ outputDir' <- canonicalizePath $ appDir </> outputDir+ let cacheDir = outputDir' </> "cache"+ shakeDir = outputDir' </> "shake"+ return $ AppPaths appYamlPath' appDir cacheDir shakeDir++appMain :: IO ()+appMain = parseCommand >>= handleCommand+ where+ handleCommand (RunCommand serverConfig appYamlPath outputDir) = withStdoutLogger $ \logger -> do+ appPaths <- mkAppPaths appYamlPath outputDir+ configInfo <- readConfigInfo appPaths+ runApp logger serverConfig configInfo+ handleCommand VersionCommand = putStrLn productVersion
+ app/PansiteApp/Build.hs view
@@ -0,0 +1,53 @@+{-|+Module : PansiteApp.Build+Description : Shake build function+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE RecordWildCards #-}++module PansiteApp.Build (build) where++import Control.Monad+import Data.String.Utils+import Development.Shake+import Pansite+import PansiteApp.ConfigInfo+import PansiteApp.Util++-- TODO: Patterns must only contain zero or one "%" characters+-- This should be enforced!+shakePattern :: FilePath -> FilePath+shakePattern = replace "%" "*"++-- TODO: Patterns must only contain zero or one "%" characters+-- This should be enforced!+expandWildcardPattern :: String -> String -> FilePath+expandWildcardPattern = replace "%"++build :: ConfigInfo -> FilePath -> IO ()+build (ConfigInfo AppPaths{..} _ (App _ targets)) targetPath =+ shake shakeOptions { shakeFiles = apShakeDir } $ do+ liftIO $ putStrLn ("want: " ++ targetPath)+ want [targetPath]++ forM_ targets $ \(Target path toolConfig inputPaths dependencyPaths) -> do+ liftIO $ putStrLn ("rule: " ++ path)+ shakePattern path %> \outputPath -> do+ let (stem, "%") = stems outputPath path -- TODO: Is this kind of irrefutable pattern OK? It's an assert of sorts.+ replaceWithStem = expandWildcardPattern stem+ inputPaths' = map replaceWithStem inputPaths+ dependencyPaths' = map replaceWithStem dependencyPaths++ liftIO $ do+ putStrLn ("need: " ++ show inputPaths')+ putStrLn ("need: " ++ show dependencyPaths')+ need inputPaths'+ need dependencyPaths'++ let ctx = ToolContext outputPath inputPaths' dependencyPaths'+ liftIO $ toolConfigRunner ctx toolConfig
+ app/PansiteApp/CommandLine.hs view
@@ -0,0 +1,70 @@+{-|+Module : PansiteApp.CommandLine+Description : Command-line parsers for Pansite app+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++module PansiteApp.CommandLine+ ( Command (..)+ , ServerConfig (..)+ , parseCommand+ ) where++import Options.Applicative+import PansiteApp.VersionInfo++-- TODO: Move into separate module+type Port = Int++-- TODO: Move into separate module+data ServerConfig = ServerConfig Port deriving Show++data Command = RunCommand ServerConfig FilePath FilePath | VersionCommand++portArg :: Parser Port+portArg = option auto+ (long "port"+ <> short 'p'+ <> value 3000+ <> metavar "PORT"+ <> help "Port")++configParser :: Parser FilePath+configParser = strOption+ (long "config"+ <> short 'c'+ <> value ".pansite.yaml"+ <> metavar "CONFIG"+ <> help "Path to YAML application configuration file")++outputDirParser :: Parser FilePath+outputDirParser = strOption+ (long "output-dir"+ <> short 'o'+ <> value "_output"+ <> metavar "OUTPUTDIR"+ <> help "Output directory")++serverConfigParser :: Parser ServerConfig+serverConfigParser = ServerConfig <$> portArg++runCommandParser :: Parser Command+runCommandParser = RunCommand+ <$> serverConfigParser+ <*> configParser+ <*> outputDirParser++versionCommandParser :: Parser Command+versionCommandParser = flag' VersionCommand (short 'v' <> long "version" <> help "Show version")++commandParser :: Parser Command+commandParser = runCommandParser <|> versionCommandParser++parseCommand :: IO Command+parseCommand = execParser $ info+ (helper <*> commandParser)+ (fullDesc <> progDesc "Run Pansite development server" <> header ("Pansite development server " ++ fullVersionString))
+ app/PansiteApp/ConfigInfo.hs view
@@ -0,0 +1,81 @@+{-|+Module : PansiteApp.ConfigInfo+Description : Configuration info for Pansite app+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE RecordWildCards #-}++module PansiteApp.ConfigInfo+ ( AppPaths (..)+ , ConfigInfo (..)+ , readConfigInfo+ , updateConfigInfo+ ) where++import Data.Time+import Pansite+import PansiteApp.CopyTool+import PansiteApp.PandocTool+import PansiteApp.Util+import System.Directory+import System.FilePath++data AppPaths = AppPaths+ { apAppYamlPath :: FilePath+ , apAppDir :: FilePath+ , apCacheDir :: FilePath+ , apShakeDir :: FilePath+ }++data ConfigInfo = ConfigInfo+ { ciAppPaths :: AppPaths+ , ciTimestamp :: UTCTime+ , ciApp :: App+ }++outputDirMeta :: FilePath+outputDirMeta = "$(@D)"++resolveFilePath :: AppPaths -> FilePathResolver+resolveFilePath AppPaths{..} path+ | takeDirectory path == outputDirMeta = apCacheDir </> skipDirectory path+ | otherwise = apAppDir </> path++emptyConfigInfo :: AppPaths -> UTCTime -> ConfigInfo+emptyConfigInfo appPaths timestamp = ConfigInfo appPaths timestamp(App [] [])++readConfigInfo :: AppPaths -> IO ConfigInfo+readConfigInfo appPaths@AppPaths{..} = do+ let ctx = ParserContext (resolveFilePath appPaths)++ -- TODO: Use UTCTime field to determine if shakeVersion should be incremented+ currentTime <- getCurrentTime++ appYamlExists <- doesFileExist apAppYamlPath+ if appYamlExists+ then do+ putStrLn $ "Getting timestamp for configuration file " ++ apAppYamlPath+ t <- getModificationTime apAppYamlPath+ mbApp <- readApp ctx [copyToolSpec, pandocToolSpec] apAppYamlPath+ case mbApp of+ Left message -> do+ putStrLn $ "Could not parse configuration file at " ++ apAppYamlPath ++ ": " ++ message+ return $ emptyConfigInfo appPaths currentTime+ Right app -> return $ ConfigInfo appPaths t app+ else do+ putStrLn $ "Configuration file does not exist at " ++ apAppYamlPath+ return $ emptyConfigInfo appPaths currentTime++updateConfigInfo :: ConfigInfo -> IO (Maybe ConfigInfo)+updateConfigInfo ConfigInfo{..} = do+ t <- getModificationTime (apAppYamlPath ciAppPaths)+ if (t > ciTimestamp)+ then do+ configInfo' <- readConfigInfo ciAppPaths+ return $ Just configInfo'+ else return Nothing
+ app/PansiteApp/CopyTool.hs view
@@ -0,0 +1,33 @@+{-|+Module : PansiteApp.CopyTool+Description : Copy tool+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE OverloadedStrings #-}++module PansiteApp.CopyTool (copyToolSpec) where++import Data.Aeson+import Data.Aeson.Types+import Data.Default+import Pansite++data CopySettings = CopySettings++instance Default CopySettings where+ def = CopySettings++updater :: ParserContext -> CopySettings -> Value -> Parser CopySettings+updater _ orig =+ withObject "copy" $ \_ -> pure orig++runner :: ToolContext -> CopySettings -> IO ()+runner _ _ = error "Not implemented"++copyToolSpec :: ToolSpec+copyToolSpec = ToolSpec "copy" updater runner
+ app/PansiteApp/PandocTool.hs view
@@ -0,0 +1,143 @@+{-|+Module : PansiteApp.PandocTool+Description : Pandoc tool+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module PansiteApp.PandocTool (pandocToolSpec) where++import Data.Aeson+import Data.Aeson.Types+import qualified Data.ByteString.Lazy as BL+import Data.Default+import Data.List+import Pansite+import PansiteApp.Util+import System.FilePath+import Text.Blaze.Html.Renderer.String+import Text.Pandoc+import Text.Pandoc.Walk+import Text.Pandoc.XML++data PandocSettings = PandocSettings+ { psNumberSections :: Bool+ , psVars :: [(String, String)]+ , psTemplatePath :: Maybe FilePath+ , psTableOfContents :: Bool+ , psReferenceDocx :: Maybe FilePath+ , psMathJaxEnabled :: Bool+ , psIncludeInHeaderPath :: Maybe FilePath+ , psIncludeBeforeBodyPath :: Maybe FilePath+ , psIncludeAfterBodyPath :: Maybe FilePath+ }++instance Default PandocSettings where+ def = PandocSettings False [] Nothing False Nothing False Nothing Nothing Nothing++updater :: ParserContext -> PandocSettings -> Value -> Parser PandocSettings+updater (ParserContext resolveFilePath) PandocSettings{..} =+ withObject "pandoc" $ \o ->+ let getFilePath key d = fmap (resolveFilePath <$>) (o .:? key .!= d)+ in PandocSettings+ <$> o .:? "number-sections" .!= psNumberSections+ <*> o .:? "vars" .!= psVars+ <*> getFilePath "template-path" psTemplatePath+ <*> o .:? "table-of-contents" .!= psTableOfContents+ <*> getFilePath "reference-docx" psReferenceDocx+ <*> o .:? "mathjax" .!= psMathJaxEnabled+ <*> getFilePath "include-in-header-path" psIncludeInHeaderPath+ <*> getFilePath "include-before-body-path" psIncludeBeforeBodyPath+ <*> getFilePath "include-after-body-path" psIncludeAfterBodyPath++mathJaxUrl :: String+mathJaxUrl = "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS_CHTML-full"++maybeReadFileUtf8 :: Maybe FilePath -> IO (Maybe String)+maybeReadFileUtf8 (Just path) = Just <$> readFileUtf8 path+maybeReadFileUtf8 Nothing = return Nothing++mkWriterOptions :: PandocSettings -> IO WriterOptions+mkWriterOptions PandocSettings{..} = do+ mbTemplate <- maybeReadFileUtf8 psTemplatePath+ mbIncludeInHeader <- maybeReadFileUtf8 psIncludeInHeaderPath+ mbIncludeBeforeBody <- maybeReadFileUtf8 psIncludeBeforeBodyPath+ mbIncludeAfterBody <- maybeReadFileUtf8 psIncludeAfterBodyPath++ -- TODO: Let's do this more elegantly! Looks a little like a fold...+ let psVars1 = case mbIncludeInHeader of+ Nothing -> psVars+ Just s -> ("header-includes", s) : psVars+ psVars2 = case mbIncludeBeforeBody of+ Nothing -> psVars1+ Just s -> ("include-before", s) : psVars1+ psVars3 = case mbIncludeAfterBody of+ Nothing -> psVars2+ Just s -> ("include-after", s) : psVars2++ let htmlMathMethod = if psMathJaxEnabled+ then MathJax mathJaxUrl+ else PlainMath++ return $ def+ { writerNumberSections = psNumberSections+ , writerReferenceDocx = psReferenceDocx+ , writerTemplate = mbTemplate+ , writerTableOfContents = psTableOfContents+ , writerHTMLMathMethod = htmlMathMethod+ , writerVariables = psVars3+ }++runner :: ToolContext -> PandocSettings -> IO ()+runner+ (ToolContext outputPath inputPaths _)+ ps@PandocSettings{..} = do++ putStrLn "PandocTool"+ putStrLn $ " outputPath=" ++ outputPath+ putStrLn $ " inputPaths=" ++ show inputPaths+ putStrLn $ " psNumberSections=" ++ show psNumberSections+ putStrLn $ " psReferenceDocx=" ++ show psReferenceDocx+ putStrLn $ " psTableOfContents=" ++ show psTableOfContents+ putStrLn $ " psTemplatePath=" ++ show psTemplatePath+ putStrLn $ " psVars=" ++ show psVars++ md <- (intercalate "\n\n") <$> sequence (map readFileUtf8 inputPaths)++ let Right doc' = readMarkdown def md -- TODO: Irrefutable pattern+ doc = walk rewriteLinks doc'++ writerOpts <- mkWriterOptions ps++ -- TODO: Ugh. Let's make this less hacky. It works for now though.+ case (takeExtension outputPath) of+ ".docx" -> do+ docx <- writeDocx writerOpts doc+ BL.writeFile outputPath docx+ _ -> do+ let html = toEntities (renderHtml (writeHtml writerOpts doc))+ writeFileUtf8 outputPath html++-- TODO: This is very application-specific+-- TODO: Figure out how to allow this behaviour to be specified in app configuration+transformUrl :: String -> String+transformUrl url =+ let (path, ext) = splitExtension url+ in case ext of+ ".md" -> path+ _ -> url++-- TODO: This is very application-specific+-- TODO: Figure out how to allow this behaviour to be specified in app configuration+rewriteLinks :: Inline -> Inline+rewriteLinks (Link attr is (url, title)) = Link attr is (transformUrl url, title)+rewriteLinks i = i++pandocToolSpec :: ToolSpec+pandocToolSpec = ToolSpec "pandoc" updater runner
+ app/PansiteApp/Util.hs view
@@ -0,0 +1,100 @@+{-|+Module : Pansite.Config.Types+Description : Helper functions for Pansite application+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++module PansiteApp.Util+ ( readFileUtf8+ , readFileWithEncoding+ , skipDirectory+ , stems+ , writeFileUtf8+ , writeFileWithEncoding+ ) where++import System.FilePath+import System.IO+++-- | Compute common prefix of two lists+--+-- Examples:+--+-- >>> commonPrefix "abcdefghi" "abcdefghi"+-- "abcdefghi"+-- >>> commonPrefix "abcdefghi" "abcfoo"+-- "abc"+-- >>> commonPrefix "abc" "xyz"+-- ""+commonPrefix :: (Eq a) => [a] -> [a] -> [a]+commonPrefix _ [] = []+commonPrefix [] _ = []+commonPrefix (x : xs) (y : ys)+ | x == y = x : commonPrefix xs ys+ | otherwise = []++-- | Compute common suffix of two lists+--+-- Examples:+--+-- >>> commonSuffix "abcdefghi" "abcdefghi"+-- "abcdefghi"+-- >>> commonSuffix "abcdefghi" "fooghi"+-- "ghi"+-- >>> commonSuffix "abc" "xyz"+-- ""+commonSuffix :: (Eq a) => [a] -> [a] -> [a]+commonSuffix xs ys = reverse (commonPrefix (reverse xs) (reverse ys))++-- | Slice of list+--+-- Examples:+--+-- >>> slice 4 10 "helloworldgoodbye"+-- "oworld"+slice :: Int -> Int -> [a] -> [a]+slice p0 p1 xs = take (p1 - p0) (drop p0 xs)++-- | Stems of lists+--+-- Examples:+--+-- >>> stems "abcmiddledef" "abcfoodef"+-- ("middle","foo")+-- >>> stems "abc" "xyz"+-- ("abc","xyz")+stems :: (Eq a) => [a] -> [a] -> ([a], [a])+stems xs ys =+ let prefix = commonPrefix xs ys+ prefixCount = length prefix+ suffix = commonSuffix xs ys+ suffixCount = length suffix+ xsCount = length xs+ ysCount = length ys+ in (slice prefixCount (xsCount - suffixCount) xs, slice prefixCount (ysCount - suffixCount) ys)++readFileWithEncoding :: TextEncoding -> FilePath -> IO String+readFileWithEncoding encoding path = do+ h <- openFile path ReadMode+ hSetEncoding h encoding+ hGetContents h++readFileUtf8 :: FilePath -> IO String+readFileUtf8 = readFileWithEncoding utf8++writeFileWithEncoding :: TextEncoding -> FilePath -> String -> IO ()+writeFileWithEncoding encoding path content =+ withFile path WriteMode $ \h -> do+ hSetEncoding h encoding+ hPutStr h content++writeFileUtf8 :: FilePath -> String -> IO ()+writeFileUtf8 = writeFileWithEncoding utf8++skipDirectory :: FilePath -> FilePath+skipDirectory p = let d = takeDirectory p in drop (length d + 1) p
+ app/PansiteApp/VersionInfo.hs view
@@ -0,0 +1,31 @@+{-|+Module : Pansite.VersionInfo+Description : Version information for Pansite application+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE TemplateHaskell #-}++module PansiteApp.VersionInfo (fullVersionString) where++import Data.Version+import Distribution.VcsRevision.Git+import Language.Haskell.TH.Syntax+import Paths_pansite++gitVersionString :: String+gitVersionString = $(do+ v <- qRunIO getRevision+ lift $ case v of+ Nothing -> []+ Just (commit, True) -> commit ++ " (locally modified)"+ Just (commit, False) -> commit)++fullVersionString :: String+fullVersionString = case gitVersionString of+ [] -> showVersion version+ v -> showVersion version ++ "." ++ v
+ doctest/Main.hs view
@@ -0,0 +1,26 @@+{-|+Module : Main+Description : Main entrypoint for Pansite doctests+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++module Main (main) where++import System.FilePath.Glob+import Test.DocTest++defaultIncludeDirs :: [FilePath]+defaultIncludeDirs = []++doctestWithIncludeDirs :: [FilePath] -> IO ()+doctestWithIncludeDirs fs = doctest (map ("-I" ++) defaultIncludeDirs ++ fs)++sourceDirs :: [FilePath]+sourceDirs = ["app", "src"]++main :: IO ()+main = mconcat (map (glob . (++ "/**/*.hs")) sourceDirs) >>= doctestWithIncludeDirs
+ pansite.cabal view
@@ -0,0 +1,92 @@+name: pansite+version: 0.1.0.0+synopsis: Pansite: a simple web site management tool+description: Please see README.md+homepage: https://github.com/rcook/pansite#readme+license: MIT+license-file: LICENSE+author: Richard Cook+maintainer: rcook@rcook.org+copyright: 2017 Richard Cook+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >= 1.10++source-repository head+ type: git+ location: https://github.com/rcook/pansite.git++library+ default-language: Haskell2010+ ghc-options: -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports+ hs-source-dirs: src+ exposed-modules: Pansite+ other-modules: Pansite.Config+ , Pansite.Config.Funcs+ , Pansite.Config.Types+ build-depends: aeson+ , base >= 4.7 && < 5+ , bytestring+ , data-default+ , split+ , text+ , unordered-containers+ , vector+ , yaml++executable pansite-app+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports+ hs-source-dirs: app+ main-is: Main.hs+ other-modules: PansiteApp.App+ , PansiteApp.Build+ , PansiteApp.CommandLine+ , PansiteApp.ConfigInfo+ , PansiteApp.CopyTool+ , PansiteApp.PandocTool+ , PansiteApp.Util+ , PansiteApp.VersionInfo+ build-depends: MissingH+ , aeson+ , base >= 4.7 && < 5+ , blaze-html+ , bytestring+ , data-default+ , directory+ , filepath+ , http-types+ , optparse-applicative+ , pandoc+ , pandoc-types+ , pansite+ , shake+ , template-haskell+ , text+ , time+ , unordered-containers+ , vcs-revision+ , wai+ , wai-logger+ , warp++test-suite pansite-doctest+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports+ hs-source-dirs: doctest+ main-is: Main.hs+ build-depends: Glob+ , base >= 4.7 && < 5+ , doctest++test-suite pansite-spec+ type: exitcode-stdio-1.0+ default-language: Haskell2010+ ghc-options: -threaded -rtsopts -with-rtsopts=-N -W -Wall -fwarn-incomplete-patterns -fwarn-unused-imports+ hs-source-dirs: spec+ main-is: Spec.hs+ build-depends: base >= 4.7 && < 5+ , hspec+ , pansite
+ spec/Spec.hs view
@@ -0,0 +1,11 @@+{-|+Module : Main+Description : Main entrypoint for Pansite spec tests+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+ src/Pansite.hs view
@@ -0,0 +1,15 @@+{-|+Module : Pansite+Description : Umbrella module for Pansite+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++module Pansite+ ( module Pansite.Config+ ) where++import Pansite.Config
+ src/Pansite/Config.hs view
@@ -0,0 +1,17 @@+{-|+Module : Pansite.Config+Description : Umbrella module for Pansite app configuration+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++module Pansite.Config+ ( module Pansite.Config.Funcs+ , module Pansite.Config.Types+ ) where++import Pansite.Config.Funcs+import Pansite.Config.Types
+ src/Pansite/Config/Funcs.hs view
@@ -0,0 +1,130 @@+{-|+Module : Pansite.Config.Types+Description : Functions for Pansite app configuration+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE OverloadedStrings #-}++module Pansite.Config.Funcs+ ( readApp+ , toolConfigRunner+ ) where++import Control.Monad+import Data.Aeson.Types+import qualified Data.ByteString.Char8 as C8+import Data.Default+import Data.HashMap.Strict (HashMap)+import qualified Data.HashMap.Strict as HashMap+import Data.List.Split+import Data.Text (Text)+import qualified Data.Text as Text+import Data.Traversable+import qualified Data.Vector as Vector+import Data.Yaml+import Pansite.Config.Types++type ToolConfigMap = HashMap String ToolConfig++defaultToolConfig :: ToolSpec -> ToolConfig+defaultToolConfig (ToolSpec _ u r) = ToolConfig u r def++toolConfigUpdater :: ParserContext -> ToolConfig -> Value -> Parser ToolConfig+toolConfigUpdater ctx (ToolConfig u r a) value = do+ result <- u ctx a value+ return $ ToolConfig u r result++toolConfigRunner :: ToolContext -> ToolConfig -> IO ()+toolConfigRunner ctx (ToolConfig _ r a) = r ctx a++arrayParser :: Object -> Text -> (Value -> Parser a) -> Parser [a]+arrayParser o key parser = helper (Text.unpack key) parser =<< (o .: key)+ where helper expected f = withArray expected $ \arr -> mapM f (Vector.toList arr)++-- TODO: Create a unit test for this!+parseRoutePath :: String -> [String]+parseRoutePath path =+ let fragments = splitOn "/" path+ fragmentCount = length fragments+ in if (fragmentCount == 1 && fragments !! 0 == "")+ then []+ else fragments++appParser :: ParserContext -> [ToolSpec] -> Value -> Parser App+appParser ctx toolSpecs = withObject "App" $ \o -> do+ let toolConfigMapOrig = HashMap.fromList (map (\t@(ToolSpec k _ _) -> (k, defaultToolConfig t)) toolSpecs)+ toolConfigPairs <- toolConfigsParser =<< o .:? "tool-settings" .!= emptyObject+ toolConfigMap <- updateToolConfigs ctx toolConfigMapOrig toolConfigPairs+ routes <- arrayParser o "routes" (routeParser ctx)+ targets <- arrayParser o "targets" (targetParser ctx toolConfigMap)+ return $ App routes targets++toolConfigsParser :: Value -> Parser [(String, Value)]+toolConfigsParser = withObject "tool-settings" $ \o ->+ for (HashMap.toList o) $ \(name, value) -> return (Text.unpack name, value)++updateToolConfigs :: ParserContext -> ToolConfigMap -> [(String, Value)] -> Parser ToolConfigMap+updateToolConfigs ctx = foldM (\m (key, value) -> case HashMap.lookup key m of+ Nothing -> fail $ "Unsupported tool " ++ key+ Just toolConfigOrig -> do+ toolConfig <- toolConfigUpdater ctx toolConfigOrig value+ return $ HashMap.insert key toolConfig m)++routeParser :: ParserContext -> Value -> Parser Route+routeParser (ParserContext resolveFilePath) =+ withObject "route" $ \o -> Route+ <$> parseRoutePath <$> o .: "path"+ <*> (resolveFilePath <$> o .: "target")++targetParser :: ParserContext -> ToolConfigMap -> Value -> Parser Target+targetParser ctx@(ParserContext resolveFilePath) toolConfigMap =+ withObject "target" $ \o -> do+ path <- resolveFilePath <$> o .: "path"+ key <- o .: "tool"+ toolConfigOrig <- case HashMap.lookup key toolConfigMap of+ Nothing -> fail $ "Unsupported tool " ++ key+ Just p -> return p+ toolConfig <- toolConfigUpdater ctx toolConfigOrig =<< o .:? "tool-settings" .!= emptyObject+ inputPaths <- ((map resolveFilePath) <$> o .: "inputs")+ dependencyPaths <- ((map resolveFilePath) <$> o .: "dependencies")+ return $ Target path toolConfig inputPaths dependencyPaths++parseExceptionMessage :: FilePath -> ParseException -> String+parseExceptionMessage appYamlPath (InvalidYaml (Just (YamlException problem))) =+ "Invalid YAML: " ++ problem ++ "\n" +++ "Location: " ++ appYamlPath+parseExceptionMessage appYamlPath (InvalidYaml (Just (YamlParseException problem ctx (YamlMark _ line column)))) =+ "Invalid YAML: " ++ problem ++ " " ++ ctx ++ "\n" +++ "Location: " ++ appYamlPath ++ ":" ++ show line ++ ":" ++ show column+parseExceptionMessage appYamlPath (InvalidYaml _) = "Invalid YAML in " ++ appYamlPath+parseExceptionMessage _ e = error $ "Unhandled exception: " ++ show e++resultErrorMessage :: FilePath -> String -> String+resultErrorMessage appYamlPath problem =+ "Invalid configuration: " ++ problem ++ "\n" +++ "Location: " ++ appYamlPath++readApp :: ParserContext -> [ToolSpec] -> FilePath -> IO (Either String App)+readApp ctx toolSpecs appYamlPath = do+ yaml <- C8.readFile appYamlPath+ case decodeEither' yaml of+ Left e -> do+ putStrLn $ "WARNING: " ++ parseExceptionMessage appYamlPath e+ return $ Left (show e)+ Right value -> do+ case parse (appParser ctx toolSpecs) value of+ Error problem -> do+ putStrLn $ "WARNING: " ++ resultErrorMessage appYamlPath problem+ return $ Left problem+ Success app@(App routes targets) -> do+ forM_ routes $ \(Route path target) ->+ putStrLn $ "Route: " ++ show path ++ " -> " ++ target+ forM_ targets $ \(Target path _ inputPaths dependencyPaths) -> do+ putStrLn $ "Target: " ++ path ++ ", " ++ show inputPaths ++ ", " ++ show dependencyPaths+ return $ Right app
+ src/Pansite/Config/Types.hs view
@@ -0,0 +1,54 @@+{-|+Module : Pansite.Config.Types+Description : Types for Pansite app configuration+Copyright : (C) Richard Cook, 2017+Licence : MIT+Maintainer : rcook@rcook.org+Stability : experimental+Portability : portable+-}++{-# LANGUAGE ExistentialQuantification #-}++module Pansite.Config.Types+ ( App (..)+ , FilePathResolver+ , ParserContext (..)+ , Route (..)+ , Target (..)+ , ToolConfig (..)+ , ToolConfigRunner+ , ToolConfigUpdater+ , ToolContext (..)+ , ToolSpec (..)+ ) where++import Data.Default+import Data.Yaml++type FilePathResolver = FilePath -> FilePath++type ToolConfigUpdater a = ParserContext -> a -> Value -> Parser a++type ToolConfigRunner a = ToolContext -> a -> IO ()++data ParserContext = ParserContext+ FilePathResolver -- file path resolver++data ToolContext = ToolContext+ FilePath -- output path+ [FilePath] -- input paths+ [FilePath] -- dependency paths++data ToolSpec = forall a. Default a => ToolSpec+ String -- key+ (ToolConfigUpdater a) -- updater function+ (ToolConfigRunner a) -- runner function++data App = App [Route] [Target]++data Route = Route [String] FilePath++data Target = Target FilePath ToolConfig [FilePath] [FilePath]++data ToolConfig = forall a. ToolConfig (ToolConfigUpdater a) (ToolConfigRunner a) a