This is the Hakyll program for generating sigkill.dk. Look at this Git repository for the data files as well. The most defining trait of the site is the tree menu at the top, which contains every content page on the site. Apart from that, I also do a lot of small hacks to generate various bits of the site.
> {-# LANGUAGE OverloadedStrings, Arrows #-}
> module Main(main) whereI want an improved identify function. Yes, really! The one from Control.Category also works for identity arrows.
> import Control.Category (id)
> import Prelude hiding (id)The remaining imports are not very interesting.
> import Control.Arrow
> import Control.Monad
> import Data.Char
> import Data.List hiding (group)
> import Data.Ord
> import Data.Maybe
> import Data.Monoid
> import System.FilePath> import Text.Blaze.Html5((!))
> import qualified Text.Blaze.Html5 as H
> import qualified Text.Blaze.Html5.Attributes as A
> import Text.Blaze.Renderer.String> import HakyllWe are going to define a data type and associated helper functions for generating a menu. Conceptually, the site is a directory tree, with a page being a leaf of the tree. The menu for a given page will illustrate the path taken from the root to the page, namely which intermediary directories were entered.
A level (or “line”, if you look at its actual visual appearance) of the menu consists of two lists: the elements preceding and succeeding the focused element. The focused element itself is the first element of the aftItems list. This definition ensures that we have at most a single focused element per menu level. Each element is a pair consisting of an URL and a name.
> data MenuLevel = MenuLevel { prevItems :: [(FilePath,String)]
> , aftItems :: [(FilePath,String)]
> }
>
> allItems :: MenuLevel -> [(FilePath, String)]
> allItems l = prevItems l ++ aftItems l> emptyMenuLevel :: MenuLevel
> emptyMenuLevel = MenuLevel [] []First, let us define a function for inserting an element into a sorted list, returning the original list if the element is already there.
> insertUniq :: Ord a => a -> [a] -> [a]
> insertUniq x xs | x `elem` xs = xs
> | otherwise = insert x xsWe can use this function to insert a non-focused element into a MenuLevel. We take care to put the new element in its proper sorted position relative to the focused element, if any.
> insertItem :: MenuLevel -> (FilePath, String) -> MenuLevel
> insertItem l v = case aftItems l of
> [] -> atPrev
> (x:xs) | v < x -> atPrev
> | otherwise -> l { aftItems = x:insertUniq v xs }
> where atPrev = l { prevItems = insertUniq v (prevItems l) }When inserting a focused element, we have to split the elements into those that go before and those that come after the focused element.
> insertFocused :: MenuLevel -> (FilePath, String) -> MenuLevel
> insertFocused l v = MenuLevel bef (v:aft)
> where (bef, aft) = partition (<v) (delete v $ allItems l)Finally, a menu is just a list of menu levels.
> newtype Menu = Menu { menuLevels :: [MenuLevel] }
>
> emptyMenu :: Menu
> emptyMenu = Menu []I am using the BlazeHTML library for HTML generation, so the result of rendering a menu is an H.Html value. The rendering will consist of one HTML <ul> block per menu level, each with the CSS class menuN, where N is the number of the level.
> showMenu :: Menu -> H.Html
> showMenu = zipWithM_ showMenuLevel [0..] . menuLevelsThe focus element is tagged with the CSS class thisPage.
> showMenuLevel :: Int -> MenuLevel -> H.Html
> showMenuLevel d m =
> H.ul (mapM_ H.li elems) ! A.class_ (H.toValue $ "menu" ++ show d)
> where showElem (p,k) = H.a (H.toHtml k) ! A.href (H.toValue p)
> showFocusElem (p,k) = showElem (p,k) ! A.class_ "thisPage"
> elems = map showElem (prevItems m) ++
> case aftItems m of [] -> []
> (l:ls) -> showFocusElem l :
> map showElem lsRecall that the directory structure of the site is a tree. To construct a menu, we are given the current node (page) and a list of all possible nodes of the tree (all pages on the site), and we then construct the minimum tree that contains all nodes on the path from the root to the current node, as well as all siblings of those nodes. In file system terms, we show the files contained in each directory traversed from the root to the current page (as well as any children of the current page, if it is a directory).
To begin, we define a function that given the current path, decomposes some another path into the part that should be visible. For example:
relevant "foo/bar/baz" "foo/bar/quux" = ["foo/","bar/","quux"]
relevant "foo/bar/baz" "foo/bar/quux/" = ["foo/","bar/","quux/"]
relevant "foo/bar/baz" "foo/bar/quux/zog" = ["foo/","bar/","quux/"]
relevant "foo/bar/baz" "quux/zog" = ["quux/"]> relevant :: FilePath -> FilePath -> [FilePath]
> relevant this other = relevant' (splitPath this) (splitPath other)
> where relevant' (x:xs) (y:ys) = y : if x == y then relevant' xs ys else []
> relevant' [] (y:_) = [y]
> relevant' _ _ = []To construct a full menu given the current path and a list of all paths, we repeatedly extend it by a single path. Recall that menu elements are pairs of names and paths - we generate those names by taking the file name and dropping the extension of the path, also dropping any trailing “index.html” from paths.
> buildMenu :: FilePath -> [FilePath] -> Menu
> buildMenu this = foldl (extendMenu this) emptyMenu
> . map (first dropIndex . (id &&& dropExtension . takeFileName))
>
> dropIndex :: FilePath -> FilePath
> dropIndex p | takeBaseName p == "index" = dropFileName p
> | otherwise = p> extendMenu :: FilePath -> Menu -> (FilePath, String) -> Menu
> extendMenu this m (path, name) =
> if path' `elem` ["./", "/", ""] then m else
> Menu $ add (menuLevels m) (relevant this' path') "/"
> where add ls [] _ = ls
> add ls (x:xs) p
> | x `elem` focused = insertFocused l (p++x,name') : add ls' xs (p++x)
> | otherwise = insertItem l (p++x,name') : add ls' xs (p++x)
> where (l,ls') = case ls of [] -> (emptyMenuLevel, [])
> k:ks -> (k,ks)
> name' = if hasTrailingPathSeparator x then x else name
> focused = splitPath this'
> path' = normalise path
> this' = normalise thisFor convenience, we define a Hakyll rule that adds the route of the current selection to the group “menu”. This group will contain an identifier for every page that should show up in the site menu, with the compiler for each identifier generating a pathname.
> addToMenu :: Rules
> addToMenu = group "menu" $ mapM_ (`create` normalDest) =<< resourcesTo generate the menu for a given page, we use requireAll_ to obtain a list of everything in the “menu” group (the pathnames) and use it to build the menu, which is immediately rendered to HTML. If a compiler has been added to the “menu” group that creates anything but a FilePath, Hakyll will signal a run-time type error.
> getMenu :: Compiler a String
> getMenu = this &&& items >>> arr (renderHtml . showMenu . uncurry buildMenu)
> where items = requireAll_ $ inGroup $ Just "menu"
> this = getRoute >>> arr (fromMaybe "/")Finally, a menu is added to a page by setting the “menu” metadata field. The default template contains information on where exactly to put the menu.
> addMenu :: Compiler (Page a) (Page a)
> addMenu = id &&& getMenu >>> setFieldA "menu" idI have a number of small programs and scripts of my site, and I want to automatically generate a list and description for each of them. Each program starts with a descriptive comment containing Markdown markup, so the challenge becomes extracting that comment. I define functions for extracting the leading comment from shell, C and Haskell, respectively.
> shDocstring :: String -> String
> shDocstring = unlines
> . map (drop 2)
> . takeWhile ("#" `isPrefixOf`)
> . dropWhile (all (`elem` "# "))
> . dropWhile ("#!" `isPrefixOf`)
> . lines> cDocstring :: String -> String
> cDocstring = unlines
> . map (dropWhile (==' ')
> . dropWhile (=='*')
> . dropWhile (==' '))
> . maybe [] lines
> . (return . reverse . cut . reverse
> <=< find ("*/" `isSuffixOf`) . inits
> <=< return . cut
> <=< find ("/*" `isPrefixOf`) . tails)
> where cut s | "/*" `isPrefixOf` s = cut $ drop 2 s
> | otherwise = dropWhile isSpace s> hsDocstring :: String -> String
> hsDocstring = unlines
> . map (drop 3)
> . takeWhile ("--" `isPrefixOf`)
> . dropWhile ("#!" `isPrefixOf`)
> . lines> hackCompiler :: Compiler Resource (Page String)
> hackCompiler = proc r -> do
> desc <- byExtension (arr shDocstring)
> [(".c", arr cDocstring)
> ,(".hs", arr hsDocstring)] <<< getResourceString -< r
> ident <- getIdentifier -< ()
> name <- arr (takeFileName . toFilePath) -< ident
> dest <- normalDest -< ()
> arr (fromBody
> . writePandoc
> . uncurry (readPandoc Markdown))
> -< (Just ident, "[`"++name++"`](/"++dest++")\n" ++"---\n"++desc)> addHacks :: Compiler (Page String) (Page String)
> addHacks = requireAllA (inGroup $ Just "hacks") (arr asList)
> where asList (p,hs) =
> p { pageBody = pageBody p ++ renderHtml (H.ul $ mapM_ asLi hs) }
> asLi = H.li . H.preEscapedString . pageBody> groupPaths :: [Page FilePath] -> [[(FilePath,FilePath)]]
> groupPaths = map collapse . groupBy samedir . sortBy (comparing dir)
> where samedir x y = dir x == dir y && dir x /= ["./"]
> dir = take 1 . splitPath . addTrailingPathSeparator . takeDirectory . pageBody
> collapse = map (pageBody &&& getField "url")> addConfigs :: Compiler (Page String) (Page String)
> addConfigs = requireAllA (inGroup $ Just "configs")
> (arr (second groupPaths) >>> arr addList)
> where addList (p,cs) =
> p { pageBody = pageBody p ++ renderHtml (H.ul $ mapM_ asLi cs) }
> asLi l = case progname l of
> Nothing -> return ()
> Just k | "." `isPrefixOf` k -> return ()
> | otherwise -> H.li $ do
> H.toHtml k >> H.ul (mapM_ disp l)
> disp (c,u) = H.li $ H.a (H.toHtml $ filename c)
> ! A.href (H.toValue $ '/':u)
> filename c = case splitPath c of
> [] -> ""
> [x] -> x
> (_:xs) -> joinPath xs
> progname [] = Nothing
> progname ((x,_):_) = Just $ dropTrailingPathSeparator
> $ joinPath $ take 1 $ splitPath
> $ takeDirectory xIf the page we’re compiling has a path in the “source” group, generate a button pointing to it.
> addSourceButton :: Compiler (Page a) (Page a)
> addSourceButton = proc p -> do
> sd <- destInGroup $ Just "source" -< ()
> returnA -< case sd of Nothing -> p
> Just sd' -> changeField "topitems" (++button sd') p
> where button u = renderHtml $ H.li $ H.a "source"
> ! A.href (H.toValue $ toUrl u)> complement :: Pattern a -> Pattern a
> complement p = predicate (not . matches p)> main :: IO ()
> main = hakyllWith config $ do
> _ <- match "css/*" $ do
> route idRoute
> compile compressCssCompiler> _ <- match "files/**" static> _ <- match "pubkey.asc" static> let inContentDir x = any (`matches` x)
> ["config/**", "writings/**", "hacks/**"
> , "programs/**", "projects/**", "*.md"]
> content = predicate inContentDir `mappend` nothidden
> nothidden = mconcat [complement "**/.**", complement ".*/**"]
> contentPages = content `mappend` regex "\\.(md|lhs|man)$"
> contentData = content `mappend` complement contentPages> _ <- match contentData static> _ <- match contentPages $ do
> route $ setExtension "html"
> addToMenu
> compile $ byPattern pageCompiler [("**.man", manCompiler)]
> >>> byPattern id [("hacks/index.md", addHacks)
> ,("config/index.md", addConfigs)]
> >>> finalizePage> _ <- group "source" $ match (contentPages `mappend` "**lhs") static> _ <- group "hacks" $ match "hacks/scripts/*" $ compile hackCompiler> _ <- group "configs" $ match ("config/configs/**" `mappend` nothidden) $
> compile $ getIdentifier
> >>> arr (joinPath . drop 2 . splitPath . toFilePath)
> >>> normalDest &&& arr fromBody
> >>> arr (uncurry $ setField "url")> match "templates/*" $ compile templateCompiler> config :: HakyllConfiguration
> config = defaultHakyllConfiguration
> { deployCommand = "rsync --chmod=Do+rx,Fo+r --checksum -ave 'ssh -p 22' \
> \_site/* --exclude pub athas@sigkill.dk:/var/www/sigkill.dk"
> }> static :: Rules
> static = route idRoute >> compile copyFileCompiler >> return ()> destInGroup :: (Maybe String) -> Compiler a (Maybe String)
> destInGroup g = getIdentifier >>> arr (setGroup g) >>> getRouteFor> normalDest :: Compiler a String
> normalDest = destInGroup Nothing >>> arr (fromMaybe "/")> finalizePage :: Compiler (Page String) (Page String)
> finalizePage = arr (trySetField "topitems" "")
> >>> addMenu
> >>> addSourceButton
> >>> setTitle
> >>> applyTemplateCompiler "templates/default.html"
> >>> relativizeUrlsCompiler> setTitle :: Compiler (Page b) (Page b)
> setTitle = id &&& getIdentifier >>> setFieldA "title" (arr title)
> where title = dropIndex . dropExtension . toFilePath> manCompiler :: Compiler Resource (Page String)
> manCompiler = getResourceString
> >>> unixFilter "groff" (words "-m mandoc -T utf8")
> >>> unixFilter "col" ["-b"]
> >>> arr (fromBody . renderHtml . H.pre . H.toHtml)