Revamp:

- Switch from `cabal2nix` and haskell overlay to `developPackage`
- Restructure directories to have more descriptive names
- Fix `nix run`

static-site-generator/Formats/Gogen.hs

@@ -0,0 +1,71 @@
+{-# LANGUAGE QuasiQuotes, FlexibleContexts #-}
+
+module Formats.Gogen (gogenCtx) where
+
+import Hakyll
+import Debug.Trace (traceId)
+import Data.Maybe (fromMaybe)
+import Control.Applicative (empty)
+import Text.Regex.PCRE.Heavy (Regex, gsub, re)
+
+import Util.Hakyll.Context
+
+--------------------------------------------------------------------------------
+-- FURIGANA CONVERSION
+
+type FuriganaTemplate = String
+
+convertTitle :: (String -> String) -> Item a -> Compiler String
+convertTitle = updateFieldWith "title" "???"
+
+furiganaRegex :: Regex
+furiganaRegex = [re|\[(.*?)\]\((.*?)\)|]
+
+replaceFuriganaWithKanji :: FuriganaTemplate -> String
+replaceFuriganaWithKanji = gsub furiganaRegex (\(kanji:_) -> kanji :: String)
+
+replaceFuriganaWithHtml :: FuriganaTemplate -> String
+replaceFuriganaWithHtml = between "<ruby>" "</ruby>" . gsub furiganaRegex matchToHtml
+  where
+    between :: String -> String -> String -> String
+    between x y s = x ++ s ++ y
+
+    matchToHtml :: [String] -> String
+    matchToHtml (kanji:kana:_) =
+      let defaultKanji = if kanji == "" then "〇" else kanji
+      in foldr1 (++) ["<rb>", defaultKanji, "</rb> <rp>(</rp><rt>", kana, "</rt><rp>)</rp>"]
+
+convertFuriganaTitle :: Item a -> Compiler String
+convertFuriganaTitle =  convertTitle replaceFuriganaWithKanji
+
+convertFuriganaTitleHtml :: Item a -> Compiler String
+convertFuriganaTitleHtml = convertTitle replaceFuriganaWithHtml
+
+convertFinishedValue :: Item a -> Compiler ContextField
+convertFinishedValue i = do 
+  s <- getMetadataField (itemIdentifier i) "finished"
+  case s of
+    Just "true" -> empty
+    _ -> return (StringField "true")
+
+{- |
+  title: String
+  titleHtml: String
+  finished: Boolean
+  updated: String
+  lang: String
+  antonyms: Maybe [String]
+  synonyms: Maybe [String]
+  leads_here: Maybe [String]
+  alternatives: Maybe [String]
+  see_also: Maybe [String]
+  sources: Maybe [String]
+-}
+gogenCtx :: Context String
+gogenCtx =
+  dateField "date" "%Y-%m-%d"
+  <> ifField "notFinishedYet" convertFinishedValue
+  <> field "title" convertFuriganaTitle
+  <> field "titleHtml" convertFuriganaTitleHtml
+  <> constField "lang" "en"
+  <> defaultContext

static-site-generator/Formats/Posts.hs

@@ -0,0 +1,13 @@
+module Formats.Posts where
+
+import Hakyll
+import Util.Hakyll.Routes
+import Data.Maybe (fromMaybe)
+import Util.Hash (FileHashes)
+import Debug.Trace
+
+postRoute :: FileHashes -> Routes
+postRoute hashes = titleRouteElseHash `composeRoutes` prefixRoute "posts/"
+  where
+    titleRouteElseHash :: Routes
+    titleRouteElseHash = metadataRoute $ \metadata -> fromMaybe (hashRoute hashes) $ titleRoute metadata

static-site-generator/Main.hs

@@ -0,0 +1,282 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+import Control.Monad (forM_)
+import Data.Maybe (fromMaybe)
+import Hakyll
+import Text.Pandoc
+  ( Extension (Ext_fenced_code_attributes, Ext_footnotes, Ext_gfm_auto_identifiers, Ext_implicit_header_references, Ext_smart),
+    Extensions,
+    Pandoc,
+    ReaderOptions,
+    WriterOptions (writerHighlightStyle),
+    extensionsFromList,
+    githubMarkdownExtensions,
+    readerExtensions,
+    writerExtensions,
+  )
+import Text.Pandoc.Highlighting (Style, breezeDark, styleToCss)
+import Debug.Trace
+import Data.Map (mapKeys)
+import Text.Pandoc.Walk ( walk, walkM )
+
+-- ---------
+
+import Formats.Gogen
+import Formats.Posts
+import Util.Hakyll.Routes
+import Util.Hakyll.Context
+import Util.Hash
+import Preprocessing.LogoLinks
+import Preprocessing.Graphviz
+
+--------------------------------------------------------------------------------
+-- CONFIG
+
+root :: String
+root =
+  "https://www.nani.wtf/"
+
+siteName :: String
+siteName =
+  "Nani"
+
+config :: Configuration
+config =
+  defaultConfiguration
+    { destinationDirectory = "dist"
+    , ignoreFile = const False
+    , previewHost = "127.0.0.1"
+    , previewPort = 8000
+    , providerDirectory = "www"
+    , storeDirectory = "/tmp/nani-wtf-hakyll/store"
+    , tmpDirectory = "/tmp/nani-wtf-hakyll/tmp"
+    }
+
+--------------------------------------------------------------------------------
+-- BUILD
+
+main :: IO ()
+main = hakyllWith config $ do
+  fileHashes <- preprocess (mapKeys (fromFilePath . drop 4 . toFilePath) <$> mkFileHashes "www/posts")
+
+  forM_
+    [ "CNAME"
+    , "favicon.ico"
+    , "_config.yml"
+    , "images/**"
+    , "js/*"
+    , "fonts/*"
+    ]
+    $ \f -> match f $ do
+      route idRoute
+      compile copyFileCompiler
+
+  match "robots.txt" $ do
+    route (constRoute "public/robots.txt")
+    compile copyFileCompiler
+
+  match "css/*" $ do
+    route idRoute
+    compile compressCssCompiler
+
+  match "posts/*" $ do
+    let ctx = constField "type" "article" <> postCtx
+
+    route $ postRoute fileHashes
+
+    compile $
+      getResourceBody
+      >>= replaceLogoLinks
+      >>= pandocRendererCustom
+      >>= loadAndApplyTemplate "templates/post.html" ctx
+      >>= saveSnapshot "content"
+      >>= loadAndApplyTemplate "templates/default.html" ctx
+
+  match "gogen/**" $ do
+    let ctx =
+          constField "type" "article"
+          <> constField "root" root
+          <> constField "siteName" siteName
+          <> gogenCtx
+
+    route $ setExtension ".html"
+    compile $ do
+      pandocCompilerCustom
+        >>= loadAndApplyTemplate "templates/gogen.html" ctx
+        >>= saveSnapshot "content"
+        >>= loadAndApplyTemplate "templates/default.html" ctx
+
+  match "*debug.md" $ do
+    let ctx = constField "type" "article" <> postCtx
+
+    route $ constRoute "debug.html"
+
+    compile $
+      getResourceBody
+      >>= replaceLogoLinks
+      >>= pandocRendererCustom
+      >>= loadAndApplyTemplate "templates/post.html" ctx
+      >>= saveSnapshot "content"
+      >>= loadAndApplyTemplate "templates/default.html" ctx
+
+  match "index.html" $ do
+    route idRoute
+    compile $ do
+      -- posts :: Compiler
+      posts <- recentFirst =<< loadAll "posts/*"
+      gogen <- loadAll "gogen/**"
+
+      let indexCtx =
+            listField "posts" postCtx (return posts) 
+              <> listField "gogen" gogenCtx (return gogen)
+              <> constField "root" root
+              <> constField "siteName" siteName
+              <> defaultContext
+
+      getResourceBody
+        >>= applyAsTemplate indexCtx
+        >>= loadAndApplyTemplate "templates/default.html" indexCtx
+
+  match "templates/*" $
+    compile templateBodyCompiler
+
+  create ["public/sitemap.xml"] $ do
+    route idRoute
+    compile $ do
+      posts <- recentFirst =<< loadAll "posts/*"
+
+      let pages = posts
+          sitemapCtx =
+            constField "root" root
+              <> constField "siteName" siteName
+              <> listField "pages" postCtx (return pages)
+
+      makeItem ("" :: String)
+        >>= loadAndApplyTemplate "templates/sitemap.xml" sitemapCtx
+
+  create ["public/rss.xml"] $ do
+    route idRoute
+    compile (feedCompiler renderRss)
+
+  create ["public/atom.xml"] $ do
+    route idRoute
+    compile (feedCompiler renderAtom)
+
+  create ["css/code.css"] $ do
+    route idRoute
+    compile (makeStyle pandocHighlightStyle)
+
+
+--------------------------------------------------------------------------------
+-- COMPILER HELPERS
+
+makeStyle :: Style -> Compiler (Item String)
+makeStyle =
+  makeItem . compressCss . styleToCss
+
+--------------------------------------------------------------------------------
+-- CONTEXT
+
+feedCtx :: Context String
+feedCtx =
+  titleCtx
+    <> postCtx
+    <> bodyField "description"
+
+postCtx :: Context String
+postCtx =
+  constField "root" root
+    <> defaultConstField "lang" "en"
+    <> constField "author" "h7x4"
+    <> constField "siteName" siteName
+    <> dateField "date" "%Y-%m-%d"
+    <> defaultContext
+
+titleCtx :: Context String
+titleCtx =
+  field "title" updatedTitle
+
+--------------------------------------------------------------------------------
+-- TITLE HELPERS
+
+replaceAmp :: String -> String
+replaceAmp =
+  replaceAll "&" (const "&amp;")
+
+replaceTitleAmp :: Metadata -> String
+replaceTitleAmp =
+  replaceAmp . safeTitle
+
+safeTitle :: Metadata -> String
+safeTitle =
+  fromMaybe "no title" . lookupString "title"
+
+updatedTitle :: Item a -> Compiler String
+updatedTitle =
+  fmap replaceTitleAmp . getMetadata . itemIdentifier
+
+--------------------------------------------------------------------------------
+-- PANDOC
+
+pandocCompilerCustom :: Compiler (Item String)
+pandocCompilerCustom =
+  pandocCompilerWith pandocReaderOpts pandocWriterOpts
+
+pandocRendererCustom :: Item String -> Compiler (Item String)
+pandocRendererCustom =
+  renderPandocWithTransformM pandocReaderOpts pandocWriterOpts transform
+    where
+      transform :: Pandoc -> Compiler Pandoc
+      transform = unsafeCompiler . walkM codeBlock
+
+pandocExtensionsCustom :: Extensions
+pandocExtensionsCustom =
+  githubMarkdownExtensions
+    <> extensionsFromList
+      [ Ext_fenced_code_attributes
+      , Ext_gfm_auto_identifiers
+      , Ext_implicit_header_references
+      , Ext_smart
+      , Ext_footnotes
+      ]
+
+pandocReaderOpts :: ReaderOptions
+pandocReaderOpts =
+  defaultHakyllReaderOptions
+    { readerExtensions = pandocExtensionsCustom
+    }
+
+pandocWriterOpts :: WriterOptions
+pandocWriterOpts =
+  defaultHakyllWriterOptions
+    { writerExtensions = pandocExtensionsCustom
+    , writerHighlightStyle = Just pandocHighlightStyle
+    }
+
+pandocHighlightStyle :: Style
+pandocHighlightStyle =
+  breezeDark -- https://hackage.haskell.org/package/pandoc/docs/Text-Pandoc-Highlighting.html
+
+-- FEEDS
+
+type FeedRenderer =
+  FeedConfiguration ->
+  Context String ->
+  [Item String] ->
+  Compiler (Item String)
+
+feedCompiler :: FeedRenderer -> Compiler (Item String)
+feedCompiler renderer =
+  renderer feedConfiguration feedCtx
+    =<< recentFirst
+    =<< loadAllSnapshots "posts/*" "content"
+
+feedConfiguration :: FeedConfiguration
+feedConfiguration =
+  FeedConfiguration
+    { feedTitle = "www.nani.wtf"
+    , feedDescription = "???"
+    , feedAuthorName = "h7x4"
+    , feedAuthorEmail = "h7x4@protonmail.com"
+    , feedRoot = root
+    }

static-site-generator/Preprocessing/Graphviz.hs

@@ -0,0 +1,22 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Preprocessing.Graphviz where
+
+import Data.Text (Text, pack, unpack)
+import System.Process ( readProcess )
+import Text.Pandoc
+  ( Pandoc,
+    Block (RawBlock, CodeBlock),
+    Format (Format),
+  )
+
+codeBlock :: Block -> IO Block
+codeBlock cb@(CodeBlock (id, classes, namevals) contents)
+  | "dot" `elem` classes = RawBlock (Format "html") . pack <$> svg (unpack contents)
+  | otherwise = return cb
+codeBlock x = return x
+
+svg :: String -> IO String
+svg = readProcess "dot" ["-Tsvg"]
+
+-- PlantUML

static-site-generator/Preprocessing/LogoLinks.hs

@@ -0,0 +1,120 @@
+{-# LANGUAGE QuasiQuotes, FlexibleContexts #-}
+module Preprocessing.LogoLinks where
+
+import Hakyll
+import Text.Regex.PCRE.Heavy (Regex, re, gsub)
+import Debug.Trace
+
+type Html = String
+type LLConverter = String -> String -> Html
+
+replaceLogoLinks :: Item String -> Compiler (Item String)
+replaceLogoLinks = return . fmap replaceAllLogoLinks
+
+
+fullLogoLinkRegex :: Regex
+fullLogoLinkRegex = [re|\[(.*?)\|(.*?)\]\((.*?)\)|]
+
+shortLogoLinkRegex :: Regex
+shortLogoLinkRegex = [re|\[(.*?)\|(.*?)\](?!\()|]
+
+replaceAllLogoLinks :: Html -> Html
+replaceAllLogoLinks =  gsub fullLogoLinkRegex f . gsub shortLogoLinkRegex g
+  where
+    g (key:s1:_)
+      | key == "gh"    = github s1 ("https://github.com/" ++ s1)
+      | key == "gl"    = gitlab s1 ("https://gitlab.com/" ++ s1)
+      | key == "ga"    = gitea s1  ("https://gitea.com/" ++ s1)
+      | key == "nani"  = nani s1 ("https://git.nani.wtf/" ++ s1)
+      | key == "pub"   = pub s1 ("https://pub.dev/packages/" ++ s1)
+      | key == "nxp"   = nixpackages s1 ("https://search.nixos.org/packages?query=" ++ s1)
+      | key == "nxo"   = nixoptions s1 ("https://search.nixos.org/options?query=" ++ s1)
+      | key == "npm"   = npm s1 ("https://www.npmjs.com/package/" ++ s1)
+      | key == "crt"   = crates s1 ("https://crates.io/crates/" ++ s1)
+      | key == "hk"   = hackage s1 ("https://hackage.haskell.org/package/" ++ s1)
+      | key == "hg"    = hoogle s1 ("https://hoogle.haskell.org/?hoogle=" ++ s1)
+      | key == "yt"    = youtube s1 ("https://www.youtube.com/embed/" ++ s1)
+      -- Reconstruct the original text
+      | otherwise      = foldr1 (++) ["[", key, "|", s1, "]"]
+
+    f (key:s1:s2:_)
+      | key == "kan"   = kan s1 s2
+      | key == "so"    = stackoverflow s1 s2
+      | key == "rd"    = reddit s1 s2
+      | key == "wiki"  = wikipedia s1 s2
+      | key == "jisho" = jisho s1 s2
+      -- Reconstruct the original text
+      | otherwise      = foldr1 (++) ["[", key, "|", s1, "](", s2, ")"]
+
+{- This should be removed once all icons are added, and all functions are implemented -}
+generateGenericLink :: String -> LLConverter
+generateGenericLink linkTitle = f
+  where 
+    f name link = foldr1 (++) ["<a href=\"", link, "\">", linkTitle, ": ", name, "</a>"]
+
+
+badgeLinkWithCustomClasses :: String -> [String] -> LLConverter
+badgeLinkWithCustomClasses imageName classes = f
+  where
+    f name link = foldr1 (++) [
+        "<span class='bg-dark rounded-3 my-1 px-2 py-1 position-relative nani_logo-link " ++ unwords classes ++ "'>",
+          "<img src='/images/logos/" ++ imageName ++ "' class='card-img-left me-2' alt='GitHub Logo'>",
+          "<span class='text-light'>" ++ name ++ "</span>",
+          "<a href='" ++ link ++ "' class='stretched-link'></a>",
+        "</span>"
+      ]
+
+badgeLink :: String -> LLConverter
+badgeLink imageName = badgeLinkWithCustomClasses imageName []
+
+
+kan :: LLConverter 
+kan kanji kana = foldr1 (++) ["<ruby><rb>", kanji, "</rb> <rp>(</rp><rt>", kana, "</rt><rp>)</rp></ruby>"]
+
+github :: LLConverter 
+github = badgeLink "github.svg"
+
+gitlab :: LLConverter 
+gitlab = badgeLink "gitlab.svg"
+
+gitea :: LLConverter 
+gitea = badgeLink "gitea.svg"
+
+nani :: LLConverter 
+nani = badgeLink "nani.svg"
+
+stackoverflow :: LLConverter 
+stackoverflow = badgeLink "stack_overflow.svg"
+
+pub :: LLConverter 
+pub = badgeLink "dart.svg"
+
+hoogle :: LLConverter 
+hoogle = badgeLink "haskell_orange.svg"
+
+crates :: LLConverter
+crates = badgeLinkWithCustomClasses "rust.svg" ["nani_logo-link-color-inverted"]
+
+hackage :: LLConverter 
+hackage = badgeLink "haskell_purple.svg"
+
+nixpackages :: LLConverter 
+nixpackages = badgeLink "nix_packages.svg"
+
+nixoptions :: LLConverter 
+nixoptions = badgeLink "nix_options.svg"
+
+npm :: LLConverter 
+npm = badgeLink "npm.svg"
+
+reddit :: LLConverter 
+reddit = badgeLink "reddit.svg"
+
+wikipedia :: LLConverter 
+wikipedia = badgeLinkWithCustomClasses "wikipedia.svg" ["nani_logo-link-color-inverted"]
+
+youtube :: LLConverter
+youtube _ link = "<div class='nani_youtube'><iframe src='" ++ link ++ "' frameborder='0' allowfullscreen></iframe></div>"
+
+jisho :: LLConverter 
+jisho name link = undefined

static-site-generator/Util/Hakyll/Context.hs

@@ -0,0 +1,43 @@
+module Util.Hakyll.Context (
+  updateFieldWith,
+  defaultConstField,
+  ifField,
+) where
+
+import Hakyll
+import Data.Maybe (fromMaybe)
+import Control.Applicative (empty)
+
+
+{- |
+  Shortcut function for getting an Items Metadata
+  This is used as a helper function in a lot of places.
+-}
+getItemMetadata :: Item a -> Compiler Metadata
+getItemMetadata = getMetadata . itemIdentifier
+
+{- |
+-}
+updateFieldWith :: String -> String -> (String -> String) -> Item a -> Compiler String
+updateFieldWith field defaultPreviousValue f = 
+  fmap updateField . getMetadata . itemIdentifier
+    where
+      updateField :: Metadata -> String
+      updateField = f . fromMaybe defaultPreviousValue . lookupString field
+
+{- |
+  This function takes a field name, and a default String value.
+  If the field is found, it will leave it be, else inject the default value.
+  Similar to the behaviour of (fromMaybe)
+-}
+defaultConstField :: String -> String -> Context String
+defaultConstField fieldString defaultValue =
+  field fieldString (fmap f . getItemMetadata)
+    where
+      f :: Metadata -> String
+      f = fromMaybe defaultValue . lookupString fieldString
+
+{-
+-}
+ifField :: String -> (Item a -> Compiler ContextField) -> Context a
+ifField key value = Context $ \k _ i -> if k == key then value i else empty

static-site-generator/Util/Hakyll/Routes.hs

@@ -0,0 +1,47 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module Util.Hakyll.Routes where
+
+import Hakyll
+import Data.Maybe (fromMaybe)
+import Data.Map as Map
+import qualified Data.Text as T
+import qualified Data.Text.Slugger as Slugger
+import Debug.Trace
+
+import Util.Hash (FileHashes)
+
+prefixRoute :: FilePath -> Routes
+prefixRoute p = customRoute $ \id' -> p ++ toFilePath id'
+
+titleRouteWithDefault :: String -> Metadata -> Routes
+titleRouteWithDefault defaultValue = constRoute . fileNameFromTitle
+    where
+      getTitleFromMeta :: Metadata -> String
+      getTitleFromMeta =
+        fromMaybe defaultValue . lookupString "title"
+      
+      fileNameFromTitle :: Metadata -> FilePath
+      fileNameFromTitle =
+        T.unpack . (`T.append` ".html") . Slugger.toSlug . T.pack . getTitleFromMeta
+
+titleRoute :: Metadata -> Maybe Routes
+titleRoute metadata = constRoute <$> fileNameFromTitle metadata
+    where
+      slug :: String -> String
+      slug = T.unpack . (`T.append` ".html") . Slugger.toSlug . T.pack
+
+      ignore :: Eq a => a -> a -> Maybe a
+      ignore shouldBeIgnored value
+        | shouldBeIgnored == value = Nothing
+        | otherwise = Just value
+
+      fileNameFromTitle :: Metadata -> Maybe FilePath
+      fileNameFromTitle metadata = slug <$> (ignore "" =<< lookupString "title" metadata)
+
+
+hashRoute :: FileHashes -> Routes
+hashRoute hashes = customRoute hash 
+  where
+    hash :: Identifier -> String
+    hash = flip (++) ".html" . fromMaybe "error" . flip Map.lookup hashes 

static-site-generator/Util/Hash.hs

@@ -0,0 +1,34 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Util.Hash(
+  FileHashes,
+  mkFileHashes
+) where
+
+-- https://groups.google.com/g/hakyll/c/zdkQlDsj9lQ
+
+import Control.Monad (forM)
+import qualified Crypto.Hash.SHA256 as SHA256
+import qualified Data.ByteString.Base16 as Base16
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as BSL
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Hakyll
+import System.FilePath ((</>))
+import Debug.Trace
+
+type FileHashes = Map Identifier String
+
+mkFileHashes :: FilePath -> IO FileHashes
+mkFileHashes dir = do
+  allFiles <- getRecursiveContents (\_ -> return False) dir
+  fmap (Map.fromList . trace "MAPLISTS: " . traceShowId) $ forM allFiles $ \path0 -> do
+    let path1 = dir </> path0
+    !h <- hash $ trace ("HASHING: " ++ show path1) path1
+    return (fromFilePath path1, h)
+      where
+        hash :: FilePath -> IO String
+        hash fp = do
+          !h <- SHA256.hashlazy <$> BSL.readFile fp
+          return $! BS8.unpack $! Base16.encode h