Browse Source

Fixing template inheritance and git footer

image-sizing
Logan McGrath 10 months ago
parent
commit
4d5a0d6f09
  1. 1
      .gitignore
  2. 10
      commands.sh
  3. 4
      config.ini
  4. 13
      green.cabal
  5. 10
      package.yaml
  6. 16
      site/_drafts/open-source-in-the-age-of-github.md
  7. 11
      site/_layouts/default.html
  8. 22
      site/_layouts/skeleton.html
  9. 26
      site/_posts/2012-11-07-using-perforce-chronicle-for-application-configuration.md
  10. 4
      site/_posts/2012-11-16-scm-backed-application-configuration-with-perforce.md
  11. 2
      site/_templates/code.md
  12. 25
      site/code/LICENSE.md
  13. 23
      site/code/app-config/stack_configuration.json
  14. 14
      site/css/_variables.scss
  15. 3
      site/css/blog/_open-source-in-the-age-of-github.scss
  16. 2
      site/css/elements/_asides.scss
  17. 93
      site/css/elements/_code.scss
  18. 10
      site/css/elements/_default.scss
  19. 4
      site/css/elements/_headers.scss
  20. 1
      site/css/main.scss
  21. 30
      site/js/main.js
  22. 6
      src/Green/Common.hs
  23. 191
      src/Green/Compiler/Layout.hs
  24. 2
      src/Green/Config.hs
  25. 30
      src/Green/Context.hs
  26. 2
      src/Green/Context/DateFields.hs
  27. 92
      src/Green/Context/GitCommits.hs
  28. 16
      src/Green/Lens.hs
  29. 43
      src/Green/Rule.hs
  30. 8
      src/Green/Rule/Blog.hs
  31. 16
      src/Green/Rule/Index.hs
  32. 6
      src/Green/Rule/Page.hs
  33. 29
      src/Green/Util.hs

1
.gitignore

@ -33,3 +33,4 @@ project/
target/
_site/
_test/
gh-pages/

10
commands.sh

@ -1,7 +1,11 @@
#!/usr/bin/env bash
set -e
new_make_path="/usr/local/opt/make/libexec/gnubin"
ARGS=()
if [ -n "$VERBOSE" ]; then
ARGS+=("--verbose")
fi
init () {
git config core.hooksPath .githooks
@ -24,7 +28,7 @@ build () {
fi
stack build
stack exec site build
stack exec site build -- ${ARGS[@]}
}
clean () {
@ -55,7 +59,7 @@ rebuild_all () {
watch () {
build
stack exec site watch
stack exec site watch -- ${ARGS[@]}
}
publish () {

4
config.ini

@ -3,9 +3,9 @@ title = This Field Was Green
description = ""
root = https://thisfieldwas.green
authorName = Logan McGrath
authorEmail = blog@thisfieldwas.green
authorEmail = website@thisfieldwas.green
linkedInProfile = https://www.linkedin.com/in/loganmcgrath
gitWebUrl = https://bitsof.thisfieldwas.green/ThisFieldWasGreen/thisfieldwas.green
gitWebUrl = https://bitsof.thisfieldwas.green/keywordsalad/thisfieldwas.green
[DisplayFormats]
dateShortFormat = %B %e, %Y

13
green.cabal

@ -6,20 +6,18 @@ cabal-version: 1.12
name: green
version: 0.1.0.0
description: Please see the README at <https://github.com/ThisFieldWasGreen/thisfieldwasgreen.github.io#readme>
homepage: https://github.com/ThisFieldWasGreen/thisfieldwasgreen.github.io#readme
bug-reports: https://github.com/ThisFieldWasGreen/thisfieldwasgreen.github.io/issues
description: Please see the README at <https://bitsof.thisfieldwas.green/keywordsalad/thisfieldwas.green#readme>
author: Logan McGrath
maintainer: site@thisfieldwas.green
copyright: 2012 Logan McGrath
license: MIT
maintainer: website@thisfieldwas.green
copyright: Copyright (C) 2012-2021 Logan McGrath
license: bsd-3-clause
build-type: Simple
extra-source-files:
README.md
source-repository head
type: git
location: https://github.com/ThisFieldWasGreen/thisfieldwasgreen.github.io
location: https://bitsof.thisfieldwas.green/keywordsalad/thisfieldwas.green
library
exposed-modules:
@ -34,6 +32,7 @@ library
Green.Context.DateFields
Green.Context.FieldError
Green.Context.GitCommits
Green.Lens
Green.Lens.Hakyll
Green.Lens.TH
Green.Route

10
package.yaml

@ -1,15 +1,15 @@
name: green
version: 0.1.0.0
github: ThisFieldWasGreen/thisfieldwasgreen.github.io
license: MIT
git: https://bitsof.thisfieldwas.green/keywordsalad/thisfieldwas.green
license: bsd-3-clause
author: Logan McGrath
maintainer: "site@thisfieldwas.green"
copyright: "2012 Logan McGrath"
maintainer: "website@thisfieldwas.green"
copyright: "Copyright (C) 2012-2021 Logan McGrath"
extra-source-files:
- README.md
description: Please see the README at <https://github.com/ThisFieldWasGreen/thisfieldwasgreen.github.io#readme>
description: Please see the README at <https://bitsof.thisfieldwas.green/keywordsalad/thisfieldwas.green#readme>
dependencies:
- base >= 4.7 && < 5

16
site/_drafts/open-source-in-the-age-of-github.md

@ -0,0 +1,16 @@
---
title: "Open Source in the Age of GitHub"
author: "Logan McGrath"
date: 2021-06-18T18:02:00-07:00
comments: false
published: false
layout: post
body-class: open-source-in-the-age-of-github
tags:
- Open Source
- Software Licenses
---
```{.markdown}
$getCode("LICENSE.md")$
```

11
site/_layouts/default.html

@ -22,17 +22,18 @@ layout: skeleton
<footer>
<div class="content-bound">
<p class="copyright">Logan McGrath &copy; <span class="copyright-date">2012</span></p>
<p class="copyright">Copyright &copy; <span class="copyright-date">2012</span> Logan McGrath. All rights reserved.</p>
<div class="generated-by-hakyll">
<p>
Site proudly generated by <a href="http://jaspervdj.be/hakyll">Hakyll</a> from source commit <a class="commit-link" href="$gitWebUrl$/commit/$gitSha1$">[$gitSha1$] $gitMessage$</a>$if(isChanged)$ with local changes$endif$.
Site proudly generated by <a href="http://jaspervdj.be/hakyll">Hakyll</a>.
</p>
<p>
$if(isGenerated)$
This page was rendered from derived content.
$if(sourceFileName)$
Generated from <a href="$gitWebUrl$/blob/$gitSha1$/$sourceFilePath$">$sourceFileName$</a>
$else$
This page was rendered from <a href="$gitWebUrl$/blob/$gitSha1$/$path$">$path$</a>.
This page was rendered from derived content
$endif$
at commit <a class="commit-link" href="$gitWebUrl$/commit/$gitSha1$">[$gitSha1$] $gitMessage$</a>$if(isChanged)$ with local changes$endif$.
</p>
</div>
</div>

22
site/_layouts/skeleton.html

@ -1,3 +1,7 @@
---
stylesheet: /css/main.css
script: /js/main.js
---
<!doctype html>
<html lang="en">
<head>
@ -6,22 +10,16 @@
<meta http-equiv="x-ua-compatible" content="ie=edge">
<meta name="viewport" content="width=device-width, initial-scale=1">
$if(siteTitle)$
<title>This Field Was Green - $siteTitle$</title>
$else$
<title>This Field Was Green - $title$</title>
$endif$
<title>$siteTitle$$if(title)$ - $title$$endif$</title>
$if(author)$<link rel="author" content="$author$">$endif$
<link rel="icon" href="/images/grass.svg">
<link rel="stylesheet" href="/css/main.css">
<script src="/js/main.js"></script>
</head>
<body class="$if(body-class)$$body-class$$endif$">
$body$
$for(stylesheets)$<link rel="stylesheet" href="$href$">$endfor$
$for(scripts)$<script src="$src$"></script>$endfor$
</head>
<body class="$bodyClass$">
$body$
</body>
</html>

26
site/_posts/2012-11-07-using-perforce-chronicle-for-application-configuration.md

@ -48,7 +48,7 @@ Plain Text" content type with the fields _title_ and _content_:
1. Click "Add Content Type"
1. Enter the following information:
```ini
```{.ini .numberLines}
Id: plaintext
Label: Plain Text
Group: Assets
@ -82,12 +82,16 @@ with PHP.
The source JSON configuration is the same, albeit sorted:
$getCode("json", "app-config/stack_configuration.json")$
```{.json .numberLines}
$getCode("app-config/stack_configuration.json")$
```
The `index.html` page has been modified from the original to support only the
basic _commit_ and _diffs_ functionality:
$getCode("html", "app-config/index.html")$
```{.html .numberLines}
$getCode("app-config/index.html")$
```
Both of these assets were added by performing:
@ -125,22 +129,30 @@ To create the module, the following paths need to be added:
Declare the module with `INSTALL/application/appconfig/module.ini`:
$getCode("ini", "app-config/module/module.ini")$
```{.ini .numberLines}
$getCode("app-config/module/module.ini")$
```
Add a view script for displaying plaintext
assets, `INSTALL/application/appconfig/views/scripts/index/index.phtml`:
$getCode("php", "app-config/module/views/scripts/index/index.phtml")$
```{.php .numberLines}
$getCode("app-config/module/views/scripts/index/index.phtml")$
```
Add a view script for displaying
diffs, `INSTALL/application/appconfig/views/scripts/index/diffs.phtml`:
$getCode("php", "app-config/module/views/scripts/index/diffs.phtml")$
```{.php .numberLines}
$getCode("app-config/module/views/scripts/index/diffs.phtml")$
```
And a controller
at `INSTALL/application/appconfig/controllers/IndexController.phtml`:
$getCode("php", "app-config/module/controllers/IndexController.php")$
```{.php .numberLines}
$getCode("app-config/module/controllers/IndexController.php")$
```
## AngularJS

4
site/_posts/2012-11-16-scm-backed-application-configuration-with-perforce.md

@ -74,7 +74,7 @@ also have permissions configured in order to view or modify files.
The `setup_example.rb` script creates three test users to demonstrate branch
permissions:
```
```markdown
Username Password Write Read
-------------------------------------------------
sally-runtime bananas prod staging, dev
@ -98,7 +98,7 @@ as the SCM backend rather than Git.
The `setup_example.rb` script also sets up three application users to
demonstrate how an application would consume configuration:
```
```markdown
Username Password Read
-----------------------------
dev-app s3cret1 dev

2
site/_templates/code.md

@ -1,3 +1 @@
```$lexer$
$body$
```

25
site/code/LICENSE.md

@ -0,0 +1,25 @@
Copyright (c) <year> <copyright holder>. All Rights Reserved.
We as individuals and organizations, and as contributors to open source software and thus value produced by their exploitation, have the right to require, collectively or individually, due acknowledgment of resources expended to produce the value provided by this software.
Value produced by this software includes not only the value intended but also any value that may be derived from the software in any form in which it exists at present or in forms derived.
Exploitation of value produced by this software is bound by these five terms.
1. This license permits enforcement of these terms upon exploitation of value related by transitive property to the exploitation of value produced by this software if the copyright holder and contributors, collectively or individually, expend the resources required to do so without blowing the stack.
2. Exploitation of value produced by this software permits the copyright holder and contributors, collectively or individually, to require due acknowledgement of the expenditure of resources required to produce the value provided by this software. Due acknowledgement must be given in a manner that is contemporaneously competitive and under these terms this license thus proposes appropriate due acknowledgement is constituted by hearty high-five.
3. Exploitation of value produced by this software in absence of due acknowledgement required by its copyright holder and contributors, collectively or individually, constitutes a high-five left hanging and implies freeloading.
4. Exploitation of value produced by this software by a freeloader permits the following items.
4.1. The copyright holder and contributors, collectively or individually, may post written notice to the freeloader that exploitation of the value produced by this software requires receipt of a hearty high-five.
4.2. The copyright holder and contributors, collectively or individually, may to the community at large in an accessible, discoverable manner post written notice that a freeloader has left them hanging if the freeloader continues to exploit value produced by this software after any period of time deemed appropriate by the copyright holder and contributors, collectively or individually.
4.3. Posted notices of freeloading must be retracted in writing when the freeloader provides written acknowledgement of having left the copyright holders and contributors hanging and with them collectively brings it in and makes up with a hearty high-five.
5. Pedantism of terms to favor freeloading is provided no rights nor protections by this license whatsoever as the value of such is solely the express enabling of scabbed enlightenment by freeloading upon the value of exploitation itself.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS” WITH ABSOLUTELY NO WARRANTY WHATSOEVER. COPYRIGHT HOLDERS AND CONTRIBUTORS ARE NOT LIABLE FOR ANY DAMAGES CAUSED BY THE SOFTWARE OR ITS MEANS OF PRODUCTION WHATSOEVER INCLUDING ESPECIALLY ANY DESERVED PUNCH TO THE NOSE.

23
site/code/app-config/stack_configuration.json

@ -1,14 +1,13 @@
{
"bannedNicks":[
"derek",
"dino",
"ffff",
"jjjj",
"werwer"
],
"defaultErrorReciever":"piglet@thoughtworks.com",
"lighton":true,
"loadMaxPercent":"88",
"nextShutdownDate":"8\/9\/2012"
"bannedNicks": [
"derek",
"dino",
"ffff",
"jjjj",
"werwer"
],
"defaultErrorReciever": "piglet@thoughtworks.com",
"lighton": true,
"loadMaxPercent": "88",
"nextShutdownDate": "8\/9\/2012"
}

14
site/css/_variables.scss

@ -4,17 +4,17 @@ $text-hyphens: none;
$text-align-default: left;
$code-font-family: "JetBrains Mono", monospace;
$code-font-size: 80%; // because JetBrains Mono runs a bit big
$code-font-size: 0.75rem; // because JetBrains Mono runs a bit big
$color-green: darkgreen;
$color-green-light: lighten($color-green, 78%);
$color-text: darkslategray;
$color-text-light: slategray;
$color-text-em: $color-green;
$color-highlight: yellow;
$color-hover: lemonchiffon;
$bg-content: ivory;
$color-emphasize: $color-green;
$color-highlight: gold;
$color-hover: yellow;
$color-aside: beige;
$color-hyperlink: dodgerblue;
$color-background: ivory;
$border-ginormous-width: 0.5rem;
$border-very-thick-width: 0.4rem;

3
site/css/blog/_open-source-in-the-age-of-github.scss

@ -0,0 +1,3 @@
.high-five-license {
max-width: 60rem;
}

2
site/css/elements/_asides.scss

@ -11,7 +11,7 @@ aside {
}
figure {
background-color: $color-green-light;
background-color: $color-aside;
margin: 1rem 0.5rem;
padding: 0.75rem 1.5rem;
border-top: $border-regular;

93
site/css/elements/_code.scss

@ -1,5 +1,5 @@
code {
color: $color-text-em;
color: $color-emphasize;
font-family: $code-font-family;
font-size: $code-font-size;
font-variant-ligatures: none;
@ -51,47 +51,68 @@ code {
}
}
pre.sourceCode {
div.sourceCode > div.sourceCode {
@include scrollable;
margin: 1rem;
code.sourceCode {
background-color: lighten($color-green, 78%);
border-top: $border-regular;
border-bottom: $border-thin;
display: table;
white-space: pre;
word-wrap: initial;
.line {
display: table-row;
&:target {
background-color: $color-highlight;
}
}
code.sourceCode {
font-size: 0;
display: block;
position: relative;
margin: 0 1rem;
counter-reset: line-number;
.numberLines & {
padding-left: 3rem;
}
> span {
background-color: beige;
display: block;
width: 100%;
padding: 0 0.5rem;
font-size: $code-font-size;
&:first-child {
padding-top: 0.5rem;
border-top: $border-regular;
}
&:last-child {
padding-bottom: 0.5rem;
border-bottom: $border-thin;
}
> a:first-child {
color: $color-emphasize;
}
> *:not(a:first-child) {
width: auto;
}
.numberLines & {
counter-increment: line-number;
&:hover {
background-color: $color-hover;
> a:first-child {
color: $color-hyperlink;
}
}
&:first-child > * {
padding-top: 0.3rem;
}
&:last-child > * {
padding-bottom: 0.3rem;
}
}
.line-number {
display: table-cell;
padding: 0 0.5rem 0 0.5rem;
border-right: $border-thin;
text-align: right;
user-select: none;
text-decoration: none;
}
&:target {
background-color: $color-highlight;
}
.line-content {
display: table-cell;
padding: 0 0.5rem;
width: 100%;
> a:first-child::before {
display: inline-block;
width: 2rem;
margin-left: -3rem;
margin-right: 1rem;
text-align: right;
content: counter(line-number);
user-select: none;
}
}
}
}

10
site/css/elements/_default.scss

@ -22,12 +22,12 @@ body {
margin: 0;
padding: 0;
color: $color-text;
background-color: $bg-content;
background-color: $color-background;
overflow: scroll;
}
strong, em, b, i {
color: $color-text-em
color: $color-emphasize
}
p {
@ -38,12 +38,12 @@ p {
}
blockquote {
background-color: $color-green-light;
background-color: $color-aside;
margin: 1rem;
padding: 0.5rem 1rem;
border-left: $border-regular;
border-right: $border-thin;
color: $color-text-em;
color: $color-emphasize;
font-style: italic;
& > *:first-child {
margin-top: 0;
@ -64,7 +64,7 @@ nav {
}
a {
color: dodgerblue;
color: $color-hyperlink;
text-decoration: underline;
}

4
site/css/elements/_headers.scss

@ -4,12 +4,12 @@ h1, h2, h3, h4, h5, h6 {
@include segment;
line-height: 1.2;
padding: 0;
color: $color-text-em;
color: $color-emphasize;
a {
color: inherit;
text-decoration: none;
&:hover {
color: dodgerblue;
color: $color-hyperlink;
}
}
}

1
site/css/main.scss

@ -1,2 +1,3 @@
@import "theme";
@import "pages/homepage";
@import "blog/open-source-in-the-age-of-github"

30
site/js/main.js

@ -1,6 +1,5 @@
window.addEventListener('load', () => {
writeCopyrightYear()
numberSourceCodes()
})
function writeCopyrightYear() {
@ -11,32 +10,3 @@ function writeCopyrightYear() {
node.innerText = copyrightDate
})
}
function numberSourceCodes() {
let lineTextTemplate = document.createElement("span")
lineTextTemplate.classList.add("line-content")
Array.from(document.querySelectorAll(".sourceCode")).forEach(sourceCode => {
let counter = 1
Array.from(sourceCode.querySelectorAll(":scope > span")).forEach(line => {
line.classList.add("line")
let lineNumber = line.childNodes[0]
lineNumber.classList.add("line-number")
lineNumber.innerText = counter
counter++
let textNodes = [];
for (let i = 1; i < line.childNodes.length; i++) {
textNodes.push(line.childNodes[i])
}
for (let i = 1; i < line.childNodes.length; i++) {
line.removeChild(textNodes[i - 1])
}
let lineText = lineTextTemplate.cloneNode(true)
textNodes.forEach(node => lineText.appendChild(node))
line.appendChild(lineText)
})
})
}

6
src/Green/Common.hs

@ -7,6 +7,7 @@ module Green.Common
module Data.Bool,
module Data.Foldable,
module Data.Functor,
module Data.List,
module Data.Maybe,
module Data.Time,
module Data.Time.Format,
@ -26,11 +27,12 @@ import Data.Bifunctor (bimap, first, second)
import Data.Bool (bool)
import Data.Foldable (sequenceA_)
import Data.Functor ((<&>))
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, maybe)
import Data.List (intercalate)
import Data.Maybe (fromJust, fromMaybe, isJust, isNothing, maybe, maybeToList)
import Data.Time (LocalTime)
import Data.Time.Format
import Hakyll hiding (dateField)
import Lens.Micro hiding ((<&>))
import Lens.Micro.TH
import System.Directory (copyFile, createDirectoryIfMissing, doesFileExist)
import System.FilePath (dropExtension, splitDirectories, takeDirectory, takeFileName, (</>))
import System.FilePath (dropExtension, splitDirectories, splitFileName, takeDirectory, takeFileName, (</>))

191
src/Green/Compiler/Layout.hs

@ -1,93 +1,134 @@
module Green.Compiler.Layout where
import Data.Binary as B
import Data.ByteString.Lazy as LBS
import GHC.Generics hiding (to)
import qualified Data.ByteString.Lazy as LBS
import GHC.Generics
import Green.Common
import Green.Config
import Green.Util
layoutCompiler :: Compiler (Item Layout)
layoutCompiler = do
template <- templateBodyCompiler
fields <- layoutMetadataCompiler =<< getUnderlying
makeItem $ Layout template fields
applyLayout :: SiteConfig -> Item String -> Compiler (Item String)
applyLayout config item = do
metadata <- layoutMetadataCompiler (itemIdentifier item)
stack <- buildStack (metadataParent metadata) (stackFromMetadata metadata)
let context = stackContext stack <> config ^. siteContext
debugCompiler $
"[LayoutStack " ++ toFilePath (itemIdentifier item) ++ "]\n"
++ unlines
[ "templates => " ++ commas (toFilePath . itemIdentifier <$> stackTemplates stack),
"body-class => " ++ commas (stackBodyClasses stack),
"scripts => " ++ commas (itemBody <$> stackScripts stack),
"stylesheets => " ++ commas (itemBody <$> stackStylesheets stack)
]
go (itemBody <$> stackTemplates stack) context item
where
go (template : rest) context body = go rest context =<< applyTemplate template context body
go [] _ body = return body
buildStack Nothing stack = return stack
buildStack (Just parentId) stack = do
layout <- itemBody <$> loadLayout parentId
buildStack (layoutParent layout) (stackAppendLayout layout stack)
layoutParent = metadataParent . layoutMetadata
loadLayout :: Identifier -> Compiler (Item Layout)
loadLayout = load
data Layout = Layout
{ _layoutStack :: [Item Template],
_layoutScripts :: [Item String],
_layoutStylesheets :: [Item String]
{ layoutTemplate :: Item Template,
layoutMetadata :: LayoutMetadata
}
deriving stock (Generic)
makeLenses ''Layout
deriving stock (Show, Generic)
instance Binary Layout where
get = Layout <$> get <*> get <*> get
get = Layout <$> get <*> get
put layout =
put (layout ^. layoutStack)
>> put (layout ^. layoutScripts)
>> put (layout ^. layoutStylesheets)
put (layoutTemplate layout)
>> put (layoutMetadata layout)
instance Writable Layout where
write p = LBS.writeFile p . B.encode . itemBody
layoutKey :: String
layoutKey = "layout"
layoutScriptsKey :: String
layoutScriptsKey = "scripts"
layoutStylesheetsKey :: String
layoutStylesheetsKey = "stylesheets"
layoutContext :: SimpleGetter Layout (Context String)
layoutContext = to \layout ->
listField layoutScriptsKey context (return $ layout ^. layoutScripts)
<> listField layoutStylesheetsKey context (return $ layout ^. layoutStylesheets)
where
context = bodyField "src"
loadLayoutFromMetadata :: Metadata -> Compiler (Maybe (Item Layout))
loadLayoutFromMetadata metadata =
mapM (loadLayout . fromLayoutName) (lookupString layoutKey metadata)
applyLayoutFromMetadata :: SiteConfig -> Item String -> Compiler (Item String)
applyLayoutFromMetadata config item = do
metadata <- getMetadata $ itemIdentifier item
maybeLayout <- loadLayoutFromMetadata metadata
let f layout = applyLayout config layout item
maybe (return item) f maybeLayout
applyLayout :: SiteConfig -> Item Layout -> Item String -> Compiler (Item String)
applyLayout config layout = go templates
where
templates = itemBody <$> layout ^. to itemBody . layoutStack
context = bodyField "body" <> config ^. siteContext
go (t : ts) = go ts <=< applyTemplate t context
go [] = return
loadLayout :: Identifier -> Compiler (Item Layout)
loadLayout = load
layoutCompiler :: Compiler (Item Layout)
layoutCompiler = do
metadata <- getMetadata =<< getUnderlying
template <- makeItem =<< compileTemplateItem =<< getResourceBody
parent <- loadLayoutFromMetadata metadata
let parentScripts = parentItems layoutScripts parent
scripts = parentScripts ++ toUrlItems (lookupStringList layoutScriptsKey metadata)
parentStylesheets = parentItems layoutStylesheets parent
stylesheets = parentStylesheets ++ toUrlItems (lookupStringList layoutStylesheetsKey metadata)
parentStack = parentItems layoutStack parent
stack = template : parentStack
makeItem
Layout
{ _layoutStack = stack,
_layoutScripts = scripts,
_layoutStylesheets = stylesheets
}
data LayoutMetadata = LayoutMetadata
{ metadataParent :: Maybe Identifier,
metadataBodyClasses :: [String],
metadataScripts :: [Item String],
metadataStylesheets :: [Item String]
}
deriving stock (Show, Generic)
instance Binary LayoutMetadata where
get = LayoutMetadata <$> get <*> get <*> get <*> get
put metadata =
put (metadataParent metadata)
>> put (metadataBodyClasses metadata)
>> put (metadataScripts metadata)
>> put (metadataStylesheets metadata)
layoutMetadataCompiler :: Identifier -> Compiler LayoutMetadata
layoutMetadataCompiler id' = do
metadata <- getMetadata id'
let listFromKeys keys = fromMaybe [] $ firstMaybe $ [flip lookupStringList metadata, fmap pure . flip lookupString metadata] <*> keys
scripts = toUrlItems $ listFromKeys ["scripts", "script"]
stylesheets = toUrlItems $ listFromKeys ["stylesheets", "stylesheet"]
bodyClasses = listFromKeys ["body-classes", "body-class"]
parentId = fromLayoutName <$> lookupString "layout" metadata
fields =
LayoutMetadata
{ metadataParent = parentId,
metadataBodyClasses = bodyClasses,
metadataScripts = scripts,
metadataStylesheets = stylesheets
}
debugCompiler $
"[LayoutMetadata " ++ toFilePath id' ++ "]\n"
++ unlines
[ "layout => " ++ maybe "ROOT" show parentId,
"body-class => " ++ commas bodyClasses,
"scripts => " ++ commas (itemBody <$> scripts),
"stylesheets => " ++ commas (itemBody <$> stylesheets)
]
return fields
where
toUrlItems = maybe [] (fmap toUrlItem)
toUrlItems = fmap toUrlItem
toUrlItem filePath = Item (fromFilePath filePath) (toUrl filePath)
parentItems lens' = maybe [] (^. to itemBody . lens')
fromLayoutName name = fromFilePath $ "_layouts/" ++ name ++ ".html"
data LayoutStack = LayoutStack
{ stackTemplates :: [Item Template],
stackBodyClasses :: [String],
stackScripts :: [Item String],
stackStylesheets :: [Item String]
}
fromLayoutName :: String -> Identifier
fromLayoutName name = fromFilePath ("_layouts/" ++ name ++ ".html")
stackFromMetadata :: LayoutMetadata -> LayoutStack
stackFromMetadata metadata =
LayoutStack
{ stackTemplates = mempty,
stackBodyClasses = metadataBodyClasses metadata,
stackScripts = metadataScripts metadata,
stackStylesheets = metadataStylesheets metadata
}
stackAppendLayout :: Layout -> LayoutStack -> LayoutStack
stackAppendLayout layout stack =
let LayoutStack templates bodyClasses scripts stylesheets = stack
Layout template (LayoutMetadata _ mdBodyClasses mdScripts mdStylesheets) = layout
in LayoutStack
(templates <> pure template)
(bodyClasses <> mdBodyClasses)
(scripts <> mdScripts)
(stylesheets <> mdStylesheets)
stackContext :: LayoutStack -> Context String
stackContext (LayoutStack _ bodyClasses scripts stylesheets) =
mconcat
[ constField "bodyClass" (unwords bodyClasses),
listField "scripts" (bodyField "src") (return scripts),
listField "stylesheets" (bodyField "href") (return stylesheets)
]

2
src/Green/Config.hs

@ -5,7 +5,7 @@ import Data.String (IsString)
import Data.Text (Text)
import qualified Data.Text as T
import Green.Common
import Green.Lens.Hakyll
import Green.Lens
import Hakyll.Core.Configuration as HC
data SiteDebug = SiteDebug

30
src/Green/Context.hs

@ -11,18 +11,18 @@ import Green.Config
import Green.Context.DateFields
import Green.Context.FieldError
import Green.Context.GitCommits
import Green.Util (dropIndex, firstMaybe, stripSuffix)
import Green.Util (dropIndex, stripSuffix)
baseContext :: SiteConfig -> Context String
baseContext config = do
let context =
mconcat
[ siteRootField (config ^. siteRoot),
[ constField "siteTitle" (config ^. siteTitle),
siteRootField (config ^. siteRoot),
linkedInProfileField (config ^. siteLinkedInProfile),
authorEmailField (config ^. siteAuthorEmail),
dateFields config,
gitCommits (config ^. siteGitWebUrl),
bodyClassField "default",
gitCommits config,
trimmedUrlField,
imgField,
youtubeField,
@ -36,17 +36,6 @@ baseContext config = do
]
in mconcat (dependentContexts <*> pure context) <> context
bodyClassField :: String -> Context String
bodyClassField defaultValue =
mconcat $ functionField <$> keys <*> pure f
where
keys = ["bodyClass", "body-class"]
f [] item = do
metadata <- getMetadata (itemIdentifier item)
let maybeValue = firstMaybe $ lookupString <$> keys <*> pure metadata
return $ fromMaybe defaultValue maybeValue
f args item = fieldError (show keys) [] args item
authorEmailField :: String -> Context String
authorEmailField = constField "authorEmail"
@ -64,15 +53,14 @@ getCodeField :: Context String -> Context String
getCodeField siteContext' = functionField key f
where
key = "getCode"
f [lexer, contentsPath] _ =
let localContext = constField "lexer" lexer <> siteContext'
in loadSnapshot codeId "code"
>>= loadAndApplyTemplate templateId localContext
<&> itemBody
f [contentsPath] _ = trimStartEndLines <$> (tryLoad codeId <|> tryLoad fileId)
where
codeId = fromFilePath $ "code/" ++ contentsPath
fileId = fromFilePath contentsPath
templateId = fromFilePath "_templates/code.md"
f args item = fieldError key ["lexer, contentsPath"] args item
tryLoad = load >=> fmap itemBody . loadAndApplyTemplate templateId siteContext'
trimStartEndLines = unlines . reverse . dropWhile null . reverse . dropWhile null . lines
f args item = fieldError key ["contentsPath"] args item
imgField :: Context String
imgField = functionField key f

2
src/Green/Context/DateFields.hs

@ -1,6 +1,6 @@
module Green.Context.DateFields where
import Data.List (intercalate, tails)
import Data.List (tails)
import Green.Common
import Green.Config
import Green.Context.FieldError

92
src/Green/Context/GitCommits.hs

@ -1,22 +1,40 @@
module Green.Context.GitCommits (gitCommits) where
import Data.Binary
import GHC.Generics (Generic)
import Green.Common
import Green.Config
import System.Exit
import System.Process
gitCommits :: String -> Context String
gitCommits gitWebUrl =
data SourceFile = SourceFile
{ _sourceFilePath :: String,
_sourceFileIsFromSource :: Bool,
_sourceFileIsChanged :: Bool
}
deriving stock (Generic)
makeLenses ''SourceFile
instance Binary SourceFile where
get = SourceFile <$> get <*> get <*> get
put sourceFile =
put (sourceFile ^. sourceFilePath)
>> put (sourceFile ^. sourceFileIsFromSource)
>> put (sourceFile ^. sourceFileIsChanged)
gitCommits :: SiteConfig -> Context String
gitCommits config =
mconcat
[ constField "gitWebUrl" gitWebUrl,
[ constField "gitWebUrl" (config ^. siteGitWebUrl),
field "gitSha1" gitSha1Compiler,
field "gitMessage" gitMessageCompiler,
field "isChanged" isChangedCompiler,
field "isGenerated" isGeneratedCompiler,
field "gitBranch" gitBranchCompiler
field "gitBranch" gitBranchCompiler,
sourceFileField (config ^. siteProviderDirectory)
]
itemSourcePath :: Item a -> FilePath
itemSourcePath item = toFilePath (itemIdentifier item)
itemFilePath :: Item a -> FilePath
itemFilePath = toFilePath . itemIdentifier
gitSha1Compiler :: Item a -> Compiler String
gitSha1Compiler = gitLogField "%h"
@ -24,42 +42,48 @@ gitSha1Compiler = gitLogField "%h"
gitMessageCompiler :: Item a -> Compiler String
gitMessageCompiler = gitLogField "%s"
type LogFormat = String
gitLogField :: LogFormat -> Item a -> Compiler String
gitLogField format item =
unsafeCompiler do
maybeResult <- gitLog format (Just $ itemSourcePath item)
maybeResult <- gitLog format (Just $ itemFilePath item)
case maybeResult of
Just result -> return result
Nothing -> fromJust <$> gitLog format Nothing
isGeneratedCompiler :: Item a -> Compiler String
isGeneratedCompiler item = do
generated <- unsafeCompiler $ isGenerated filePath
if generated
then return "generated"
else noResult $ "Was not generated: " ++ filePath
sourceFileField :: FilePath -> Context String
sourceFileField providerDirectory = Context \k _ i ->
if k `elem` [filePathKey, fileNameKey]
then getField k =<< sourceFileCompiler providerDirectory i
else unmappedKey k
where
filePath = itemSourcePath item
getField key sourceFile
| key == filePathKey = return $ StringField $ sourceFile ^. sourceFilePath
| key == fileNameKey = return $ StringField $ takeFileName $ sourceFile ^. sourceFilePath
| key == isFromSourceKey = boolField' key $ sourceFile ^. sourceFileIsFromSource
| key == isChangedKey = boolField' key $ sourceFile ^. sourceFileIsChanged
| otherwise = unmappedKey key
boolField' _ True = return EmptyField
boolField' key False = noResult $ "Field " ++ key ++ " is false"
unmappedKey key = noResult $ "Tried sourceFileField with unmapped key " ++ key
filePathKey = "sourceFilePath"
fileNameKey = "sourceFileName"
isFromSourceKey = "isFromSource"
isChangedKey = "isChanged"
isGenerated :: FilePath -> IO Bool
isGenerated = fmap not . doesFileExist
isChangedCompiler :: Item a -> Compiler String
isChangedCompiler item = do
changed <- unsafeCompiler do isChanged filePath
if changed
then return "changed"
else noResult $ "Was not changed: " ++ filePath
sourceFileCompiler :: FilePath -> Item a -> Compiler SourceFile
sourceFileCompiler providerDirectory item = cached cacheKey do
SourceFile itemFilePath'
<$> unsafeCompiler (doesFileExist itemFilePath')
<*> unsafeCompiler (isChanged itemFilePath')
where
filePath = itemSourcePath item
isChanged :: FilePath -> IO Bool
isChanged filePath = do
let args = ["diff", "HEAD", filePath]
(exitCode, stdout, _stderr) <- readProcessWithExitCode "git" args ""
return $ not (exitCode == ExitSuccess && null stdout)
type LogFormat = String
itemFilePath' = providerDirectory </> itemFilePath item
cacheKey = toFilePath (itemIdentifier item) ++ ":sourceFileField"
isChanged filePath = do
let args = ["diff", "HEAD", filePath]
(exitCode, stdout, _stderr) <- readProcessWithExitCode "git" args ""
return $ not (exitCode == ExitSuccess && null stdout)
gitLog :: LogFormat -> Maybe FilePath -> IO (Maybe String)
gitLog format filePath = do

16
src/Green/Lens.hs

@ -0,0 +1,16 @@
module Green.Lens
( module Green.Lens,
module Green.Lens.Hakyll,
module Green.Lens.TH,
)
where
import Green.Common
import Green.Lens.Hakyll
import Green.Lens.TH
(~<>) :: (Monoid a) => ASetter s t a a -> a -> s -> t
(~<>) l a = over l (`mappend` a)
{-# INLINE (~<>) #-}
infixr 4 ~<>

43
src/Green/Rule.hs

@ -15,34 +15,27 @@ import Green.Rule.Sitemap
rules :: SiteConfig -> Rules ()
rules config = do
configDep <- configRules
rulesExtraDependencies [configDep] do
brokenLinks
imageRules
jsRules
cssRules config
downloadRules
codeDep <- codeRules
rulesExtraDependencies [codeDep] do
templateRules
blogRules config
feedRules config
indexRules config
pageRules config
robotsTxtRules config
archiveRules config
sitemapRules config
brokenLinks
imageRules
jsRules
cssRules config
downloadRules
codeDep <- codeRules
rulesExtraDependencies [codeDep] do
templateRules
blogRules config
feedRules config
indexRules config
pageRules config
robotsTxtRules config
archiveRules config
sitemapRules config
brokenLinks
configRules :: Rules Dependency
configRules = do
let configFile = "../config.ini"
makePatternDependency configFile
downloadRules :: Rules ()
downloadRules = do
match "downloads/**" do
route idRoute
route $ setExtension ".txt"
compile copyFileCompiler
codeRules :: Rules Dependency
@ -50,9 +43,7 @@ codeRules = do
let path = "code/**"
match path do
route idRoute
compile do
_ <- getResourceBody >>= saveSnapshot "code"
copyFileCompiler >>= saveSnapshot "_final"
compile getResourceBody
makePatternDependency path
imageRules :: Rules ()

8
src/Green/Rule/Blog.hs

@ -113,7 +113,7 @@ postSnapshotCompiler :: SiteConfig -> String -> Compiler (Item String)
postSnapshotCompiler localConfig snapshot = do
interpolateResourceBody localConfig
>>= saveSnapshot (contentOnly snapshot)
>>= applyLayoutFromMetadata localConfig
>>= applyLayout localConfig
>>= relativizeUrls
blogCompiler :: SiteConfig -> Compiler (Item String)
@ -123,7 +123,7 @@ blogCompiler config = do
let recentPosts = take 5 . drop 1 $ allPostsByRecent
localConfig <- forOf siteContext config (buildBlogContext latestPost recentPosts)
interpolateResourceBody localConfig
>>= applyLayoutFromMetadata localConfig
>>= applyLayout localConfig
>>= relativizeUrls
archivesCompiler :: SiteConfig -> Compiler (Item String)
@ -131,7 +131,7 @@ archivesCompiler config = do
posts <- recentFirst =<< loadPostsContent
let localConfig = config & siteContext %~ archivesContext posts
interpolateResourceBody localConfig
>>= applyLayoutFromMetadata localConfig
>>= applyLayout localConfig
>>= relativizeUrls
draftArchivesCompiler :: SiteConfig -> Compiler (Item String)
@ -139,7 +139,7 @@ draftArchivesCompiler config = do
drafts <- recentFirst =<< loadDraftsContent
let localConfig = config & siteContext %~ draftArchivesContext drafts
interpolateResourceBody localConfig
>>= applyLayoutFromMetadata localConfig
>>= applyLayout localConfig
>>= relativizeUrls
{-----------------------------------------------------------------------------}

16
src/Green/Rule/Index.hs

@ -1,8 +1,9 @@
module Green.Rule.Index where
import Green.Common
import Green.Compiler.Layout
import Green.Compiler
import Green.Config
import Green.Lens
import Green.Rule.Blog
indexRules :: SiteConfig -> Rules ()
@ -14,15 +15,10 @@ indexRules config =
indexCompiler :: SiteConfig -> Compiler (Item String)
indexCompiler config = do
recentPosts <- take 5 <$> (recentFirst =<< loadPostsContent)
let ctx =
listField
"recentPosts"
(teaserCtx <> (config ^. siteContext))
(return recentPosts)
<> (config ^. siteContext)
getResourceBody
>>= applyAsTemplate ctx
>>= applyLayoutFromMetadata config
let localConfig = config & siteContext ~<> recentPostsField recentPosts
interpolateResourceBody localConfig
>>= applyLayout localConfig
>>= relativizeUrls
where
teaserCtx = teaserField "teaser" (contentOnly postSnapshot)
recentPostsField = listField "recentPosts" (teaserCtx <> (config ^. siteContext)) . return

6
src/Green/Rule/Page.hs

@ -18,7 +18,7 @@ pageRules baseCtx =
]
pageCompiler :: SiteConfig -> Compiler (Item String)
pageCompiler localConfig =
interpolateResourceBody localConfig
>>= applyLayoutFromMetadata localConfig
pageCompiler config =
interpolateResourceBody config
>>= applyLayout config
>>= relativizeUrls

29
src/Green/Util.hs

@ -1,12 +1,8 @@
module Green.Util where
import Control.Applicative ((<|>))
import Data.Char
import Data.Foldable (sequenceA_)
import Data.String.Utils as S
import Hakyll
import Lens.Micro
import System.FilePath (splitFileName, takeDirectory)
import Green.Common
dropIndex :: FilePath -> FilePath
dropIndex url = case splitFileName url of
@ -46,16 +42,16 @@ infixr 4 ~<>
kebabCase :: String -> String
kebabCase [] = []
kebabCase (first : rest)
| notAllowed first = go rest
| otherwise = toLower first : go rest
kebabCase (x : xs)
| notAllowed x = go xs
| otherwise = toLower x : go xs
where
go [] = []
go (x : xs)
| isUpper x = '-' : toLower x : kebabCase xs
| notAllowed x = '-' : kebabCase xs
| otherwise = x : kebabCase xs
notAllowed x = not (isAlphaNum x || x `elem` ("_." :: [Char]))
go (y : ys)
| isUpper y = '-' : toLower y : kebabCase ys
| notAllowed y = '-' : kebabCase ys
| otherwise = y : kebabCase ys
notAllowed c = not (isAlphaNum c || c `elem` ("_." :: [Char]))
firstMaybe :: (Foldable m) => m (Maybe a) -> Maybe a
firstMaybe = foldl (<|>) Nothing
@ -65,3 +61,10 @@ uncurry3 f (x, y, z) = f x y z
curry3 :: ((a, b, c) -> d) -> a -> b -> c -> d
curry3 f x y z = f (x, y, z)
maybeHead :: [a] -> Maybe a
maybeHead (x : _) = Just x
maybeHead _ = Nothing
commas :: [String] -> String
commas xs = "[" ++ intercalate ", " xs ++ "]"

Loading…
Cancel
Save