support special pages that are not concatenations of posts

package.yaml

@@ -36,3 +36,4 @@ executables:
       - mtl
       - megaparsec
       - text
+      - network-uri

special/imprint.md

@@ -0,0 +1,62 @@
+---
+title: Impressum
+---
+# Recessu sumus se aliquem foliis saetigeri vult
+
+## Navit quod auras
+
+Lorem markdownum ut *flamina* et mensura fracta, unius rubra. Manibus per rex
+pondere, lucoque dotaliaque non festa cera, et. Mercurio dabantur cernens.
+Vixque stabat Aeetias Zetesque scrutantur nisi, *tu quam* nec, in sit oculos.
+Ille suo ad fecit rector auras hiemsque Thebas illi nunc constitit crinem
+Dictaeaque utiliter eras duorum.
+
+1. Commenta periuria quaeque fuit
+2. Quicquid aut essent ora fuit Hiberi oblitus
+3. Per est atque ambitione increpor violentam
+4. Semineces sedit
+5. Iam usus levavit satis nocens
+
+## Latique volvuntur gnatae
+
+Inpediunt in remisit miserabile patrem cervix sonantibus
+[talia](http://nec.org/) nec *deieci capitis* retraxi mediocris in deos, *sub*.
+Addere spelunca, Achilleos: est orbe comminus tangere, nec deus ventos sumptae.
+Prius de fuit, dum manibus rubor mitis Denique et inpedientibus sole.
+Adpellatque dubio Ericthonium tanto terras, tendebat vulgus divitibusque suarum.
+Corpus huic portans Oceanum multiplicique passa quodcumque tu omnes; Chimaera
+non verba contentus tellus, tellus tibi.
+
+- Minos sonat datis celare illic balteus
+- Hymettia Neptunus genitore stridentibus longa quoque limine
+- Vidit viro vices
+- Non insula liquida herbis turba fumabant presso
+- Ter laqueosque vices aliter ait femina concipit
+
+Elice studioque in Eurytidos molimine passu vulgi passim partique ait inprudens
+pontum. Titan est en quamvis manibus incubuit iuvenale erat lapis thalamosque
+nymphas gaudetque educta ignibus, Troiaeque ait verba quod timor. Digitique
+pennas Trachasque errabat cava, sed limina oculos est, carne, et huius triplex
+esse; ipse. **Interea sibi** terras; pellant mittit exclamant, lumina prosilit,
+matura.
+
+## Omnibus deos nec lacrimas nec est
+
+Moriri **temporis** galeae super vestigia nec istis arida: revocantis viroque
+excidit et cornua tabellae ferrea. Est dona placent novissimus qui canisve
+cumque tu quaerit avari virgis metuitque hominum de duabus undas Hyantius.
+Recessit succede forsitan nubere mihi exsistunt iugulo germanam lanas.
+
+- Quater nisi tumidi
+- Ument illam vir Talibus placet vulnera longius
+- Nubila ignarus
+
+In est quid aequora iam clipei, ab gutture Arachnes nymphae inpete, per tamen
+saevit. Ego sed animo potiatur, esset, quam sed vinces fuga. **Te** saevus,
+parva adhuc gravitas nebulas. Triplici et Niseia domitamque: iussus miles.
+
+Non nunc! Volventia excussit da quae, mihi accipit sidera flexere aurora
+Polydegmona ascensu. Rerum vultus, referebat exiluit urnam, inmiti gener,
+laborem, quod date natura quodcumque. Calidi fortunaeque faces, quod ipsa
+cultusque illi. Has barba viscera, hospes vera communia munus tremit inque
+praemia terrae.

src/Main.hs

@@ -37,6 +37,8 @@ import System.IO.Error
 
 import Data.Void
 
+import Network.URI
+
 config :: Configuration
 config =
   defaultConfiguration
@@ -53,6 +55,15 @@ stripPathPrefix (splitDirectories -> prefix) =
 handleIf :: Exception e => (e -> Bool) -> (e -> IO a) -> IO a -> IO a
 handleIf predicate handler = handle $ \exc -> bool throwIO handler (predicate exc) exc
 
+metadataSort :: [Item w] -> Compiler [Item w]
+metadataSort = sortOnM $ \Item{itemIdentifier} -> maybe (0 :: Integer) read <$> getMetadataField itemIdentifier "sort"
+  where
+    sortOnM :: forall m a b. (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
+    sortOnM f = fmap (map snd . List.sortOn fst) . mapM (\x -> (,x) <$> f x)
+
+unwrapped :: Snapshot
+unwrapped = "unwrapped"
+
 main :: IO ()
 main = hakyllWith config $ do
   frontendManifest <-
@@ -142,15 +153,62 @@ main = hakyllWith config $ do
               | "/" `List.isPrefixOf` x && not ("//" `List.isPrefixOf` x) ->
                   toSiteRoot r ++ x
             _other -> x
-      return $ withUrls (relativizeUrls' . renderRoute) <$> item
+          overPath f str = case parseURIReference str of
+            Nothing -> f str
+            Just uri@URI{uriPath} -> uriToString id uri{uriPath = f uriPath} mempty
+      return $ withUrls (relativizeUrls' . overPath renderRoute) <$> item
 
   tags <- buildTags "content/**" $ fromCapture "tags/*.html"
 
+  let
+    applySiteLayout = loadAndApplyTemplate "templates/site-layout.html" . (<> ctx')
+      where
+        ctx' =
+          mconcat
+            [ listField "tags-nav" defaultContext (metadataSort <=< mapM (uncurry renderTagNav) $ tagsMap tags)
+            , listField "special-nav" defaultContext $ metadataSort =<< mapM (flip loadSnapshot unwrapped) =<< getMatches (fromGlob "special/**")
+            , frontendContext
+            , defaultContext
+            ]
+        renderTagNav tag' ids = do
+          tagItems' <- getMatches . fromGlob $ toFilePath (tagsMakeId tags tag') -<.> "*"
+          let
+            tagItem' = return $ Item (fromMaybe (tagsMakeId tags tag') $ listToMaybe tagItems') (mempty :: String)
+
+            navRoute = "/" <> tag' <> ".html"
+
+            tagNavCtx =
+              mconcat
+                [ constField "tag" tag'
+                , field "title" . const $
+                    fmap (fromMaybe tag') . runMaybeT . asum $
+                      map (\itemId -> MaybeT $ getMetadataField itemId "title") tagItems'
+                , constField "route" navRoute
+                , listField "posts" (constField "tag" tag' <> constField "route" navRoute <> postContext) (metadataSort =<< mapM load ids)
+                ]
+          tagItem'
+            >>= loadAndApplyTemplate "templates/tag-nav.html" tagNavCtx
+            >>= normalizeUrls
+    postContext =
+      mconcat
+        [ field "identifier" (return . takeBaseName . toFilePath . itemIdentifier)
+        , defaultContext
+        ]
+    specialContext = defaultContext
+
   match "content/**" $ do
-    compile $ do
+    compile $
       pandocCompiler
         >>= normalizeUrls
 
+  match "special/**" $ do
+    route . routeAsFilePath $ (-<.> "html") . stripPathPrefix "special"
+    compile $
+      pandocCompiler
+        >>= saveSnapshot unwrapped
+        >>= applySiteLayout specialContext
+        >>= normalizeUrls
+
   forM_ (tagsMap tags) $ \(tag, fromList -> posts) ->
     rulesExtraDependencies [tagsDependency tags] $ do
       tagItems <- getMatches . fromGlob $ toFilePath (tagsMakeId tags tag) -<.> "*"
@@ -165,47 +223,13 @@ main = hakyllWith config $ do
           let
             ctx =
               mconcat
-                [ listField "tags-nav" defaultContext (metadataSort <=< mapM (uncurry renderTagNav) $ tagsMap tags)
+                [ listField "posts" postContext (metadataSort =<< loadAll posts)
-                , listField "posts" postContext (metadataSort =<< loadAll posts)
-                , frontendContext
                 , defaultContext
                 ]
 
-            renderTagNav tag' ids = do
-              tagItems' <- getMatches . fromGlob $ toFilePath (tagsMakeId tags tag') -<.> "*"
-              let
-                tagItem' = return $ Item (fromMaybe (tagsMakeId tags tag') $ listToMaybe tagItems') (mempty :: String)
-
-                navRoute = renderRoute $ "/" <> tag' <> ".html"
-
-                tagNavCtx =
-                  mconcat
-                    [ constField "tag" tag'
-                    , field "title" . const $
-                        fmap (fromMaybe tag') . runMaybeT . asum $
-                          map (\itemId -> MaybeT $ getMetadataField itemId "title") tagItems'
-                    , constField "route" navRoute
-                    , listField "posts" (constField "tag" tag' <> constField "route" navRoute <> postContext) (metadataSort =<< mapM load ids)
-                    ]
-              tagItem'
-                >>= loadAndApplyTemplate "templates/tag-nav.html" tagNavCtx
-                >>= normalizeUrls
-
-            postContext =
-              mconcat
-                [ field "identifier" (return . takeBaseName . toFilePath . itemIdentifier)
-                , defaultContext
-                ]
-
-            metadataSort :: [Item w] -> Compiler [Item w]
-            metadataSort = sortOnM $ \Item{itemIdentifier} -> maybe (0 :: Integer) read <$> getMetadataField itemIdentifier "sort"
-              where
-                sortOnM :: forall m a b. (Monad m, Ord b) => (a -> m b) -> [a] -> m [a]
-                sortOnM f = fmap (map snd . List.sortOn fst) . mapM (\x -> (,x) <$> f x)
-
           tagItem
             >>= loadAndApplyTemplate "templates/tag.html" ctx
-            >>= loadAndApplyTemplate "templates/site-layout.html" ctx
+            >>= applySiteLayout ctx
             >>= normalizeUrls
 
   match "frontend/dist/wp-*/**" $ do

templates/site-layout.html

@@ -7,13 +7,33 @@
     $for(css)$
       <link rel="stylesheet" href="$url$">
     $endfor$
-    <title>UniWorX Systems</title>
+    <title>UniWorX Systems$if(title)$ - $title$$endif$</title>
   </head>
 
   <body>
+    <header>
+      <nav>
+	<ul>
+	  $for(tags-nav)$
+	  $body$
+	  $endfor$
+	</ul>
+      </nav>
+    </header>
     <main>
       $body$
     </main>
+    <footer>
+      <nav>
+	<ul>
+	  $for(special-nav)$
+	  <li>
+	    <a href="$url$">$title$</a>
+	  </li>
+	  $endfor$
+	</ul>
+      </nav>
+    </footer>
     $for(js)$
       <script src="$url$"></script>
     $endfor$

templates/tag.html

@@ -1,10 +1,3 @@
-<nav>
-  <ul>
-    $for(tags-nav)$
-    $body$
-    $endfor$
-  </ul>
-</nav>
 $for(posts)$
 <article id="$identifier$">
   $body$