Browse Source

trying to get new date fields to work

image-sizing
Logan McGrath 11 months ago
parent
commit
25f5b58731
  1. 12
      config.ini
  2. 2
      green.cabal
  3. 6
      site/404.md
  4. 2
      site/contact.md
  5. 2
      site/index.html
  6. 2
      site/resume.md
  7. 25
      src/Green/Config.hs
  8. 101
      src/Green/Context.hs
  9. 109
      src/Green/Context/DateFields.hs
  10. 13
      src/Green/Context/FieldError.hs
  11. 2
      test/data/applyLayoutFromMetadata/content.md

12
config.ini

@ -1,4 +1,4 @@
[site]
[Site]
title = This Field Was Green
description = ""
root = https://thisfieldwas.green
@ -7,11 +7,17 @@ authorEmail = blog@thisfieldwas.green
linkedInProfile = https://www.linkedin.com/in/loganmcgrath
gitWebUrl = https://bitsof.thisfieldwas.green/ThisFieldWasGreen/thisfieldwas.green
[hakyll]
[DisplayFormats]
dateShortFormat = %B %e, %Y
dateLongFormat = %B %e, %Y %l:%M %p %EZ
timeFormat = %l:%M %p %EZ
[Hakyll]
providerDirectory = site
destinationDirectory = _site
allowedFiles = .nojekyll
[debug]
[Debug]
printItems = false
rawCss = false

2
green.cabal

@ -31,6 +31,8 @@ library
Green.Compiler.Pandoc
Green.Config
Green.Context
Green.Context.DateFields
Green.Context.FieldError
Green.Context.GitCommits
Green.Lens.Hakyll
Green.Lens.TH

6
site/404.md

@ -1,7 +1,7 @@
---
layout: page
title: 404 Field Not Found
updated: 2021-05-24T20:07:11-05:00
title: "404 Field Is Brown"
date: 2021-05-24T20:07:11-05:00
---
The resource you were looking for does not exist.
The field you were looking for has browned and vanished.

2
site/contact.md

@ -1,6 +1,6 @@
---
layout: page
title: Contact
title: "Contact Me"
updated: 2021-05-24T20:07:11-05:00
---

2
site/index.html

@ -1,5 +1,5 @@
---
title: Mowing My Technical Lawn
title: "Mowing My Technical Lawn"
layout: page
body-class: homepage
---

2
site/resume.md

@ -1,6 +1,6 @@
---
layout: page
title: My Resume
title: "My Resume"
updated: 2021-05-24T20:07:11-05:00
---

25
src/Green/Config.hs

@ -23,6 +23,15 @@ defaultSiteDebug =
_debugRawCss = False
}
data SiteDisplayFormat = SiteDisplayFormat
{ _displayDateLongFormat :: String,
_displayDateShortFormat :: String,
_displayTimeFormat :: String
-- new fields should be appended, do not rearrange
}
makeLenses ''SiteDisplayFormat
data SiteConfig = SiteConfig
{ _siteEnv :: [(String, String)],
_siteRoot :: String,
@ -36,7 +45,8 @@ data SiteConfig = SiteConfig
_siteHakyllConfiguration :: Configuration,
_siteTime :: ZonedTime,
_siteContext :: Context String,
_siteTimeLocale :: TimeLocale
_siteTimeLocale :: TimeLocale,
_siteDisplayFormat :: SiteDisplayFormat
-- new fields should be appended, do not rearrange
}
@ -71,7 +81,7 @@ hasEnvFlag f e = isJust (lookup f e)
parseConfigIni :: [(String, String)] -> TimeLocale -> ZonedTime -> Text -> Either String SiteConfig
parseConfigIni env timeLocale zonedTime iniText = parseIniFile iniText do
hakyllConfiguration <- section "hakyll" do
hakyllConfiguration <- section "Hakyll" do
providerDirectory' <- fieldOf "providerDirectory" string
destinationDirectory' <- fieldOf "destinationDirectory" string
allowedFiles <- fieldOfStrings "allowedFiles"
@ -82,12 +92,18 @@ parseConfigIni env timeLocale zonedTime iniText = parseIniFile iniText do
ignoreFile = customIgnoreFile allowedFiles
}
debugSettings <- sectionDef "debug" defaultSiteDebug do
debugSettings <- sectionDef "Debug" defaultSiteDebug do
SiteDebug
<$> configFlag "printItems" "SITE_PREVIEW" False env
<*> configFlag "rawCss" "SITE_RAW_CSS" False env
section "site" do
displayFormat <- section "DisplayFormats" do
SiteDisplayFormat
<$> fieldOf "dateLongFormat" string
<*> fieldOf "dateShortFormat" string
<*> fieldOf "timeFormat" string
section "Site" do
SiteConfig env
<$> fieldOf "root" string
<*> fieldOf "title" string
@ -101,6 +117,7 @@ parseConfigIni env timeLocale zonedTime iniText = parseIniFile iniText do
<*> pure zonedTime
<*> pure mempty
<*> pure timeLocale
<*> pure displayFormat
where
customIgnoreFile allowedFiles path =
ignoreFile defaultConfiguration path

101
src/Green/Context.hs

@ -1,15 +1,17 @@
module Green.Context
( module Green.Context,
module Green.Context.DateFields,
module Green.Context.GitCommits,
)
where
import Data.List (intercalate, tails)
import Data.String.Utils (endswith)
import Green.Common
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
@ -17,16 +19,16 @@ baseContext config = do
mconcat
[ siteRootField (config ^. siteRoot),
linkedInProfileField (config ^. siteLinkedInProfile),
trimmedUrlField,
dateFields (config ^. siteTimeLocale),
contactEmailField (config ^. siteAuthorEmail),
dateFields config,
gitCommits (config ^. siteGitWebUrl),
bodyClassField "default",
trimmedUrlField,
imgField,
youtubeField,
getRouteField,
commentField,
defaultContext,
bodyClassField "default",
contactEmailField (config ^. siteAuthorEmail)
defaultContext
]
dependentContexts =
[ getCodeField,
@ -43,9 +45,6 @@ contactEmailField = constField "contactEmail"
linkedInProfileField :: String -> Context String
linkedInProfileField = constField "linkedInProfile"
dateFields :: TimeLocale -> Context String
dateFields = undefined
-- | Trims @index.html@ from @$url$@'s
trimmedUrlField :: Context String
trimmedUrlField = mapContext dropIndex (urlField "url")
@ -65,9 +64,7 @@ getCodeField siteContext' = functionField key f
where
codeId = fromFilePath $ "code/" ++ contentsPath
templateId = fromFilePath "_templates/code.md"
f args item = error $ msg ++ " in " ++ show (itemIdentifier item)
where
msg = key ++ " expected [lexer, contentsPath] but received " ++ show args
f args item = fieldError key ["lexer, contentsPath"] args item
imgField :: Context String
imgField = functionField key f
@ -87,9 +84,9 @@ imgField = functionField key f
constField "imgAlt" alt
]
)
f args = \item -> error $ msg ++ " in " ++ show (itemIdentifier item)
f args = fieldError key expectedArgs args
where
msg = key ++ " expected [imgId, imgSrc, imgTitle, imgAlt] but received " ++ show args
expectedArgs = ["imgId", "imgSrc", "imgTitle", "imgAlt"]
youtubeField :: Context String
youtubeField = functionField key f
@ -108,9 +105,9 @@ youtubeField = functionField key f
constField "youtubeVideoTitle" title
]
)
f args = \item -> error $ msg ++ " in " ++ show (itemIdentifier item)
f args = fieldError key expectedArgs args
where
msg = key ++ " expected [youtubeAsideId, youtubeVideoId, youtubeVideoTitle] but received " ++ show args
expectedArgs = ["youtubeAsideId", "youtubeVideoId", "youtubeVideoTitle"]
commentField :: Context String
commentField = functionField "comment" \_ _ -> return ""
@ -124,9 +121,7 @@ getRouteField = functionField key f
getRoute id' >>= \case
Just r -> return $ "/" ++ stripSuffix "index.html" r
Nothing -> error $ "no route to " ++ show id'
f args item = error $ msg ++ " in " ++ show (itemIdentifier item)
where
msg = key ++ " expected [filePath] but received " ++ show args
f args item = fieldError key ["filePath"] args item
unContextString :: Context String -> String -> [String] -> Item String -> Compiler String
unContextString context key args item =
@ -135,9 +130,9 @@ unContextString context key args item =
_ -> error $ "Got a non-string value in field " ++ key
linkedTitleField :: Context String -> Context String
linkedTitleField context = functionField linkedTitleKey f
linkedTitleField context = functionField targetKey f
where
linkedTitleKey = "linkedTitle"
targetKey = "linkedTitle"
f [filePath] _ = do
linkedItem <- load (fromFilePath filePath)
makeLink <$> getTitle linkedItem <*> getUrl linkedItem
@ -151,64 +146,4 @@ linkedTitleField context = functionField linkedTitleKey f
isHtml = endswith ".html" filePath
isMarkdown = endswith ".md" filePath || endswith ".markdown" filePath
getField key = unContextString context key []
f args item = error $ msg ++ " in " ++ show (itemIdentifier item)
where
msg = linkedTitleKey ++ " expected [filePath] but received " ++ show args
dateFromMetadataFields :: TimeLocale -> String -> [String] -> String -> Context String
dateFromMetadataFields timeLocale targetKey sourceKeys targetFormat = Context \k _ i ->
if k == targetKey
then f $ itemIdentifier i
else return EmptyField
where
f id' = foldl (<|>) (return EmptyField) (findDate id' <$> sourceKeys)
findDate id' sourceKey = do
maybeString <- lookupString sourceKey <$> getMetadata id'
let maybeDate = tryParseDate' =<< maybeString
let maybeFormat = formatTime timeLocale targetFormat <$> maybeDate
return $ maybe EmptyField StringField maybeFormat
tryParseDate' :: String -> Maybe ZonedTime
tryParseDate' = tryParseDate timeLocale sourceDateFormats
sourceDateFormats =
[ "%FT%T%Z",
"%Y-%m-%d",
"%Y-%m-%dT%H:%M:%S%Z",
"%Y-%m-%dT%H:%M:%S",
"%Y-%m-%d %H:%M:%S%Z",
"%Y-%m-%d %H:%M:%S",
"%a, %d %b %Y %H:%M:%S %Z",
"%a, %d %b %Y %H:%M:%S %Z",
"%a, %d %b %Y %H:%M:%S",
"%a, %d %b %Y %I:%M:%S %P %Z",
"%a, %d %b %Y %I:%M:%S %P %Z",
"%a, %d %b %Y %I:%M:%S %P ",
"%a, %d %b %Y %I:%M:%S %p %Z",
"%a, %d %b %Y %I:%M:%S %p %Z",
"%a, %d %b %Y %I:%M:%S %p",
"%B %e, %Y %l:%M %p",
"%B %e, %Y",
"%b %d, %Y"
]
tryParseDate :: (ParseTime a) => TimeLocale -> [String] -> String -> Maybe a
tryParseDate timeLocale dateFormats = firstMaybe . flip fmap dateFormats . parse
where
parse = flip $ parseTimeM True timeLocale
dateFromFilePath :: TimeLocale -> String -> String -> Context String
dateFromFilePath timeLocale targetKey targetFormat = Context \k _ i ->
if k == targetKey
then return . maybe EmptyField StringField . f $ itemIdentifier i
else return EmptyField
where
f :: Identifier -> Maybe String
f = fmap (formatTime timeLocale targetFormat) . tryParseDate'
paths = splitDirectories . dropExtension . toFilePath
tryParseDate' :: Identifier -> Maybe ZonedTime
tryParseDate' id' =
let paths' = paths id'
in firstMaybe $
dateFromPath
<$> [take 3 $ splitAll "-" fnCand | fnCand <- reverse paths']
++ [fnCand | fnCand <- map (take 3) $ reverse $ tails paths']
dateFromPath = tryParseDate timeLocale ["%Y-%m-%d"] . intercalate "-"
f args item = fieldError targetKey ["filePath"] args item

109
src/Green/Context/DateFields.hs

@ -0,0 +1,109 @@
module Green.Context.DateFields where
import Data.List (intercalate, tails)
import Green.Common
import Green.Config
import Green.Context.FieldError
import Green.Util (firstMaybe)
dateFields :: SiteConfig -> Context String
dateFields config =
mconcat fields
<> shortDateFormatField
<> timeFormatField
where
timeLocale = config ^. siteTimeLocale
displayFormat = config ^. siteDisplayFormat
longDateFormat = displayFormat ^. displayDateLongFormat
shortDateFormatField = constField "shortDate" $ displayFormat ^. displayDateShortFormat
timeFormatField = constField "timeFormat" $ displayFormat ^. displayTimeFormat
fields = uncurry mkFields <$> fieldKeys
mkFields f k = f longDateFormat timeLocale k
fieldKeys = [(dateField, "date")]
-- [ (dateField, "date"),
-- (publishedField, "published"),
-- (updatedField, "updated")
-- ]
dateField :: String -> TimeLocale -> String -> Context String
dateField = dateField' ["published", "date"]
-- <> dateFromFilePathField timeLocale targetKey
publishedField :: String -> TimeLocale -> String -> Context String
publishedField = dateField' ["published"]
updatedField :: String -> TimeLocale -> String -> Context String
updatedField = dateField' ["updated"]
dateField' :: [String] -> String -> TimeLocale -> String -> Context String
dateField' sourceKeys defaultFormat timeLocale targetKey = functionField targetKey f
where
f [] item = f [defaultFormat] item
f [dateFormat] item = do
maybeDate :: Maybe ZonedTime <- dateFromMetadata sourceKeys timeLocale item
let maybeFormatted = formatTime timeLocale dateFormat <$> maybeDate
maybe notFound found maybeFormatted
where
notFound = noResult $ "Could not find $" ++ targetKey ++ "$ from metadata keys " ++ show sourceKeys
found = return
f args item = fieldError targetKey ["dateFormat"] args item
dateFromMetadata :: (ParseTime a) => [String] -> TimeLocale -> Item String -> Compiler (Maybe a)
dateFromMetadata sourceKeys timeLocale item = do
maybeDates <- mapM findDate sourceKeys
return $ firstMaybe maybeDates
where
id' = itemIdentifier item
tryParseDate' = tryParseDate timeLocale metadataDateFormats
findDate sourceKey = do
maybeString <- lookupString sourceKey <$> getMetadata id'
return (tryParseDate' =<< maybeString)
dateFromFilePathField :: TimeLocale -> String -> Context String
dateFromFilePathField timeLocale targetKey = Context \k a i ->
if k == targetKey
then return $ f a i
else return EmptyField
where
f [dateFormat] item =
let maybeFormatted = formatTime timeLocale dateFormat <$> maybeDate
in maybe EmptyField StringField maybeFormatted
where
maybeDate :: Maybe ZonedTime = resolveDateFromFilePath timeLocale item
f args item = fieldError targetKey ["dateFormat"] args item
resolveDateFromFilePath :: (ParseTime a) => TimeLocale -> Item String -> Maybe a
resolveDateFromFilePath timeLocale item =
let paths = splitDirectories $ dropExtension $ toFilePath $ itemIdentifier item
in firstMaybe $
dateFromPath
<$> [take 3 $ splitAll "-" fnCand | fnCand <- reverse paths]
++ [fnCand | fnCand <- map (take 3) $ reverse $ tails paths]
where
dateFromPath = tryParseDate timeLocale ["%Y-%m-%d"] . intercalate "-"
tryParseDate :: (ParseTime a) => TimeLocale -> [String] -> String -> Maybe a
tryParseDate timeLocale dateFormats = firstMaybe . flip fmap dateFormats . parse
where
parse = flip $ parseTimeM True timeLocale
metadataDateFormats :: [String]
metadataDateFormats =
[ "%Y-%m-%d",
"%Y-%m-%dT%H:%M:%S%Z",
"%Y-%m-%dT%H:%M:%S",
"%Y-%m-%d %H:%M:%S%Z",
"%Y-%m-%d %H:%M:%S",
"%a, %d %b %Y %H:%M:%S %Z",
"%a, %d %b %Y %H:%M:%S",
"%B %e, %Y %l:%M %p %EZ",
"%B %e, %Y %l:%M %p",
"%b %e, %Y %l:%M %p %EZ",
"%b %e, %Y %l:%M %p",
"%B %e, %Y",
"%B %d, %Y",
"%b %e, %Y",
"%b %d, %Y"
]

13
src/Green/Context/FieldError.hs

@ -0,0 +1,13 @@
module Green.Context.FieldError where
import Green.Common
fieldError :: String -> [String] -> [String] -> Item a -> b
fieldError targetKey argNames argValues item =
error $ msg ++ " in " ++ show (itemIdentifier item)
where
msg = targetKey
++ " expected "
++ show argNames
++ " but received "
++ show argValues

2
test/data/applyLayoutFromMetadata/content.md

@ -1,6 +1,6 @@
---
layout: applyLayoutFromMetadata/layout.md
title: It worked!
title: "It worked!"
---
The layout `applyLayoutFromMetadata/layout.md.md` should be applied to me.

Loading…
Cancel
Save