Hakyll build test and include example code

blog.cabal

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

example.txt

---
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>]

site.hs

{-! 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 !-}