Skip to content

Instantly share code, notes, and snippets.

@andrevdm

andrevdm/blog.cabal

Last active Apr 27, 2018
Embed
What would you like to do?
Hakyll build test and include example code
name: blog
version: 0.1.0.0
build-type: Simple
cabal-version: >= 1.10
executable site
main-is: site.hs
build-depends: base >= 4.7 && < 5
, protolude
, text
, containers
, hakyll
, filepath
, directory
, process
, safe-exceptions
ghc-options: -threaded -rtsopts -with-rtsopts=-N -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wimplicit-prelude
default-language: Haskell2010
---
title: testing
---
[<code setup.repo>] https://gist.github.com/53e179c4244411493ae1f9deebc3cc3f.git
[<code setup.sha>] 5a95ece18ecb248fb745b3e7cb19f5c4d410240f
[<code setup.run>] stack init --resolver lts-10.4
[<code setup.run>] stack build
[<code setup.run>] stack test
Some text
[<code>] match
More text
[<code>] IMPORTS;
```javascript
[<include>] /home/user/static/interestingStuff.json
```
## See
- Code at: [<repo>] @ [<sha>]
{-! SECTION< IMPORTS !-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
import Protolude hiding (onException)
import Prelude (String)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import qualified Data.List as Lst
import qualified Data.Text as Txt
import qualified Data.Text.IO as Txt
import Data.Monoid (mappend)
import Hakyll
import qualified System.Exit as Xit
import qualified System.Process as Proc
import System.FilePath ((</>))
import qualified System.FilePath as FP
import qualified System.Directory as Dir
import Control.Exception.Safe (onException, throwString)
{-! SECTION> IMPORTS !-}
--------------------------------------------------------------------------------
main :: IO ()
main = hakyll $ do
match "css/*" $ do
route idRoute
compile compressCssCompiler
{-! SECTION< match !-}
match "posts/*" $ do
route $ setExtension "html"
compile $ includeCodeCompiler
>>= renderPandoc
>>= loadAndApplyTemplate "templates/post.html" postCtx
>>= saveSnapshot "content"
>>= loadAndApplyTemplate "templates/default.html" postCtx
>>= relativizeUrls
{-! SECTION> match !-}
--------------------------------------------------------------------------------
postCtx :: Context String
postCtx =
dateField "date" "%B %e, %Y" `mappend`
defaultContext
{-! SECTION< compiler_start !-}
includeCodeCompiler :: Compiler (Item String)
includeCodeCompiler = do
p <- getResourceFilePath
getResourceString >>= withItemBody (unsafeCompiler . includeCompile p)
where
includeCompile :: FilePath -> String -> IO String
includeCompile compilingPath source =
includeCompile' source
`onException`
putStr ("Exception compiling includes for: " <> compilingPath)
includeCompile' :: String -> IO String
includeCompile' source = do
let ls1 = Txt.lines $ Txt.pack source
let (sourceNoSetup, repoPath', sha', cmds', path') = getConfig ls1
{-! SECTION> compiler_start !-}
{-! SECTION< compiler_body !-}
case path' of
Nothing ->
case (repoPath', sha', cmds') of
(Nothing, Nothing, []) -> pure $ Txt.unpack . Txt.unlines $ sourceNoSetup
(Just _, Nothing, _) -> throwString "No sha found"
(Just _, _, []) -> throwString "No run commands found"
(Nothing, _, (_:_)) -> throwString "No repo setup found"
(Nothing, Just _, []) -> throwString "No repo setup found"
(Just repoPath, Just sha, cmds) -> do
root <- Dir.getCurrentDirectory
let tempPath = root </> tmpDirectory defaultConfiguration </> "codeIncludeGit"
-- Cleanup from previous post
removeDirectoryRecursiveIfExists tempPath
Dir.createDirectoryIfMissing True tempPath
-- Clone the git repo
runShell' root $ "git clone \"" <> repoPath <> "\" \"" <> Txt.pack tempPath <> "\""
-- Goto the correct sha (if it was specified)
gotoSha sha tempPath
-- Execute the run commands (buid, test etc)
executeRunCommands cmds tempPath
-- Delete all dirs we are not interested in (exclude .git and .stack-work)
removeDirectoryRecursiveIfExists $ tempPath </> ".git"
removeDirectoryRecursiveIfExists $ tempPath </> ".stack-work"
includeCode tempPath repoPath sha sourceNoSetup
Just path ->
includeCode (Txt.unpack path) "**local**" "**local**" sourceNoSetup
includeCode tempPath repoPath sha sourceNoSetup = do
-- Get all files in the repo
files <- getFilesRec tempPath
-- All sections from all files
sections' <- Map.fromList . concat <$> traverse getSections files
let sections = Map.map (\(p, s, e, lang, ls) -> (drop (length tempPath + 1) p, s, e, lang, ls)) sections'
-- Replace sections in the file
replaced' <- traverse (replaceCodeLineSection tempPath sections) sourceNoSetup
let replaced = Txt.unlines . concat $ replaced'
-- Replace sha and repo tokens
pure . Txt.unpack . Txt.replace "[<sha>]" sha $ Txt.replace "[<repo>]" repoPath replaced
{-! SECTION> compiler_body !-}
{-! SECTION< compiler_misc !-}
executeRunCommands :: [Text] -> FilePath -> IO ()
executeRunCommands cmds path =
traverse_ (runShell' path) cmds
gotoSha :: Text -> FilePath -> IO ()
gotoSha sha tmpPath = do
runShell' tmpPath ("git reset " <> sha <> " --hard")
void $ runShell tmpPath "git clean -dfx"
{-! SECTION> compiler_misc !-}
{-! SECTION< getConfig !-}
getConfig ls =
let
cfgPath = "[<code setup.path>]"
cfgRepo = "[<code setup.repo>]"
cfgSha = "[<code setup.sha>]"
cfgRun = "[<code setup.run>]"
path = Txt.strip . Txt.drop (Txt.length cfgRepo) <$> headMay (filter (Txt.isPrefixOf cfgPath) ls)
repo = Txt.strip . Txt.drop (Txt.length cfgRepo) <$> headMay (filter (Txt.isPrefixOf cfgRepo) ls)
sha = Txt.strip . Txt.drop (Txt.length cfgSha) <$> headMay (filter (Txt.isPrefixOf cfgSha) ls)
run = Txt.strip . Txt.drop (Txt.length cfgRun) <$> filter (Txt.isPrefixOf cfgRun) ls
in
(filter (not . Txt.isPrefixOf "[<code setup.") ls, repo, sha, run, path)
removeDirectoryRecursiveIfExists p =
Dir.doesDirectoryExist p >>= \case
True -> Dir.removeDirectoryRecursive p
False -> pass
{-! SECTION> getConfig !-}
{-! SECTION< replaceLineSection !-}
replaceCodeLineSection :: FilePath -> Map Text (FilePath, Int, Int, Text, [Text]) -> Text -> IO [Text]
replaceCodeLineSection tempPath sections line = do
let codeTag = "[<code>]"
let includeTag = "[<include>]"
if Txt.isPrefixOf codeTag line
then
let secName = Txt.strip . Txt.drop (Txt.length codeTag) $ line in
case Map.lookup secName sections of
Nothing -> throwString $ Txt.unpack $ "No section named " <> secName
Just (path, start, end, lang, code) ->
let title = Txt.pack path <> " (" <> show start <> " to " <> show end <> ")" in
pure [ "###### " <> title
, ""
, "~~~{." <> lang <> "}"
, Txt.unlines code
, "~~~"
, ""
]
else
if not $ Txt.isPrefixOf includeTag line
then pure [line]
else
let
incRelPath = Txt.strip . Txt.drop (Txt.length includeTag) $ line
incFullPath = tempPath </> Txt.unpack incRelPath
in
sequenceA [Txt.readFile incFullPath]
{-! SECTION> replaceLineSection !-}
{-! SECTION< getSections !-}
type LineState = (Int, [(Text, (FilePath, Int, Int, Text, [Text]))])
getSections :: FilePath -> IO [(Text, (FilePath, Int, Int, Text, [Text]))]
getSections f =
case FP.takeExtension f of
".hs" -> getLangSections "{-! SECTION< " "{-! SECTION> " "{-! SECTION" "haskell"
".js" -> getLangSections "//!SECTION< " "//!SECTION> " "//!SECTION" "javascript"
".html" -> getLangSections "<!-- !SECTION+ " "<!-- !SECTION- " "<!-- !SECTION" "html"
".css" -> getLangSections "/* !SECTION< " "/* !SECTION> " "/* !SECTION" "html"
_ -> pure []
where
getLangSections startToken endToken cleanToken lang = do
ls <- Txt.lines <$> Txt.readFile f
(_, r) <- foldlM (parseLine ls) (1, []) ls
pure r
where
parseLine :: [Text] -> LineState -> Text -> IO LineState
parseLine ls (lineNum, hist) l =
if not . Txt.isPrefixOf startToken . Txt.strip $ l
then pure (lineNum + 1, hist)
else do
let secName = Txt.strip . fst . Txt.breakOn " " . Txt.strip . Txt.drop (Txt.length startToken) . Txt.strip $ l
end <- scanForEnd ls secName lineNum
pure (lineNum + 1, (secName, (f, lineNum + 1, lineNum + length end, lang, end)) : hist)
scanForEnd ls secName fromLine =
let fromOffset = drop fromLine ls in
case Lst.span (not . Txt.isPrefixOf (endToken <> secName) . Txt.strip) fromOffset of
(_, []) -> throwString $ "No section end found for: " <> Txt.unpack secName
(r, _) -> pure $ filter cleanLine r
cleanLine =
not . Txt.isPrefixOf cleanToken . Txt.strip
{-! SECTION> getSections !-}
{-! SECTION< io !-}
runShell' :: FilePath -> Text -> IO ()
runShell' workingDir cmd = do
putText cmd
runShell workingDir cmd >>= \case
Right _ -> pass
Left e -> throwString $ Txt.unpack "Error running `" <> Txt.unpack cmd <> "` " <> show e
runShell :: FilePath -> Text -> IO (Either Int ())
runShell workingDir cmd = do
let p = Proc.shell $ Txt.unpack cmd
(_, _, _, phandle) <- Proc.createProcess p { Proc.cwd = Just workingDir }
Proc.waitForProcess phandle >>= \case
Xit.ExitSuccess -> pure $ Right ()
Xit.ExitFailure i -> pure $ Left i
getFilesRec :: FilePath -> IO [FilePath]
getFilesRec p = do
fs <- (p </>) <<$>> getFiles p
ds <- (p </>) <<$>> getDirs p
cs <- traverse getFilesRec ds
pure $ fs <> join cs
getDirs :: FilePath -> IO [FilePath]
getDirs p = do
entries <- (p </>) <<$>> Dir.listDirectory p
filterM Dir.doesDirectoryExist entries
getFiles :: FilePath -> IO [FilePath]
getFiles p = do
entries <- (p </>) <<$>> Dir.listDirectory p
filterM Dir.doesFileExist entries
{-! SECTION> io !-}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment