From b620e6f8b3f143065449e34e26cefa6d8668bcbe Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Sun, 9 Feb 2020 20:43:30 +1100
Subject: [PATCH 01/13] Remove web-routes and boomerang

---
 package.yaml    |  5 -----
 stack.yaml      |  4 ----
 stack.yaml.lock | 28 ----------------------------
 3 files changed, 37 deletions(-)

diff --git a/package.yaml b/package.yaml
index 399a138..0716a6d 100644
--- a/package.yaml
+++ b/package.yaml
@@ -29,7 +29,6 @@ library:
   dependencies:
   - aeson
   - authenticate-oauth
-  - boomerang
   - directory
   - filepath
   - http-conduit
@@ -46,10 +45,6 @@ library:
   - transformers
   - twitter-types
   - unix
-  - web-routes
-  - web-routes-boomerang
-  - web-routes-happstack
-  - web-routes-th
 executables:
   multiblog:
     main: Main.hs
diff --git a/stack.yaml b/stack.yaml
index ff829f4..929b471 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -4,14 +4,10 @@ packages:
 ghc-options:
   '$everything': -threaded
 extra-deps:
-  - boomerang-1.4.5.5
   - derive-2.6.4
   - twitter-conduit-0.3.0
   - twitter-types-0.7.2.2
   - twitter-types-lens-0.7.2
-  - web-routes-boomerang-0.28.4.2
-  - web-routes-happstack-0.23.11
-  - web-routes-th-0.22.6.3
 flags:
   pandoc:
     embed_data_files: true
diff --git a/stack.yaml.lock b/stack.yaml.lock
index 4945754..f399fd5 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -4,13 +4,6 @@
 #   https://docs.haskellstack.org/en/stable/lock_files
 
 packages:
-- completed:
-    hackage: boomerang-1.4.5.5@sha256:a6ea7b0cdc82e7d9d8c66bd63047da13453e20acd5e299e92fa8d286f8663041,1951
-    pantry-tree:
-      size: 791
-      sha256: 71b50b11f18cc0e27d040802a8d811caee9066a4bf40dd7e8b44cc57c8133fee
-  original:
-    hackage: boomerang-1.4.5.5
 - completed:
     hackage: derive-2.6.4@sha256:f697cbe62828b5d777ea148814978940bd8707cb2ad4adff9415fc6139a7c05d,3184
     pantry-tree:
@@ -39,27 +32,6 @@ packages:
       sha256: 2b4a738a9ca4f6c98bc82f39b92e09f18e298f524f7121e568582e8f0f4dfe2c
   original:
     hackage: twitter-types-lens-0.7.2
-- completed:
-    hackage: web-routes-boomerang-0.28.4.2@sha256:5885435f8527a056d820630e26f76567d4106c8e13fe67a0bc191149dc9f4242,1060
-    pantry-tree:
-      size: 228
-      sha256: bac758a18c07d100c5a259e4e9c49eea3412c0d8d3b96fa1660a8b07dd97d30f
-  original:
-    hackage: web-routes-boomerang-0.28.4.2
-- completed:
-    hackage: web-routes-happstack-0.23.11@sha256:c61a497a13810c15e3b3a17db4fef05357cbf31a4a56bd73cdfbb9f9ae521b10,1044
-    pantry-tree:
-      size: 228
-      sha256: 37f74334eadaf5380f76f9f42e0da6ff678ab5961f7e72b35bbe28638e069523
-  original:
-    hackage: web-routes-happstack-0.23.11
-- completed:
-    hackage: web-routes-th-0.22.6.3@sha256:9a71de3770de13445bf116b16a5468d12e3dac0b91b8d3546088333a96bd235d,1533
-    pantry-tree:
-      size: 267
-      sha256: d2d7656d3cc35177ae51689dbe849d5c48d339339ba97018921d858f0a2bca0b
-  original:
-    hackage: web-routes-th-0.22.6.3
 snapshots:
 - completed:
     size: 508835

From 9e52248f254b872d7c90d3cdd6dc9fc430ee10a6 Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Sun, 9 Feb 2020 21:22:03 +1100
Subject: [PATCH 02/13] Manual routeURL and parseURL

---
 package.yaml            |  2 +-
 src/App.hs              | 54 ++++++-----------------
 src/CrossPost.hs        |  9 ++--
 src/Routes.hs           | 96 +++--------------------------------------
 src/Views.hs            | 62 +++++++++++---------------
 src/Views/Export.hs     | 12 ++----
 src/Views/Feed.hs       | 12 +++---
 testsuite/TestRoutes.hs | 26 +++++++----
 8 files changed, 73 insertions(+), 200 deletions(-)

diff --git a/package.yaml b/package.yaml
index 0716a6d..27bbc70 100644
--- a/package.yaml
+++ b/package.yaml
@@ -20,6 +20,7 @@ dependencies:
 - pandoc
 - pandoc-types
 - text
+- time
 - twitter-conduit
 - xml-conduit
 - xml-types
@@ -41,7 +42,6 @@ library:
   - shakespeare
   - split
   - tagsoup
-  - time
   - transformers
   - twitter-types
   - unix
diff --git a/src/App.hs b/src/App.hs
index c94960e..c358f70 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -22,10 +22,6 @@ import System.Directory
 import System.Environment
 import System.FilePath
 
-import Web.Routes
-import Web.Routes.Boomerang (boomerangSiteRouteT)
-import Web.Routes.Happstack
-
 import Cache
 import Import
 import Models
@@ -39,7 +35,7 @@ import Views.Feed
 
 type App = StateT AppCache (ReaderT AppData IO)
 
-type AppPart a = RouteT Sitemap (ServerPartT App) a
+type AppPart a = ServerPartT App a
 
 loadApp ::
        String -- ^ directory to load from
@@ -87,33 +83,19 @@ site :: ServerPartT App Response
 site = do
     address <- lift $ asks appAddress
     appDir <- lift $ asks appDirectory
-    let routedSite = boomerangSiteRouteT handler sitemap
     let staticDir = appDir </> "static"
     let staticSite = serveDirectory DisableBrowsing ["index.html"] staticDir
-    implSite address "" routedSite `mplus` staticSite
-
--- Run an action in application routing context
-runRoute :: RouteT Sitemap m a -> m a
-runRoute act
-    -- Supply a known good URL (root) to run the site,
-    -- producing the result of the given action
- =
-    let (Right res) = runSite "" (boomerangSiteRouteT (const act) sitemap) []
-    in res
-
-parseRoute :: T.Text -> Either String Sitemap
-parseRoute =
-    fmap runIdentity . runSite "" (boomerangSiteRouteT pure sitemap) . segments
-  where
-    segments = decodePathInfo . T.encodeUtf8
+    let mainSite = do
+                       method GET
+                       uriRest $ \uri -> case parseURL (T.pack uri) of
+                                             Nothing -> mzero
+                                             Just route -> handler route
+    mainSite `mplus` staticSite
 
 handler :: Sitemap -> AppPart Response
 handler route =
     case route of
         Index -> index
-        Yearly y -> yearlyIndex y
-        Monthly y m -> monthlyIndex y m
-        Daily d -> dailyIndex d
         ArticleView d s -> article d s
         MetaView s f -> meta s f
         Feed lang -> feedIndex lang
@@ -124,15 +106,6 @@ handler route =
 index :: AppPart Response
 index = articleList $ const True
 
-yearlyIndex :: Integer -> AppPart Response
-yearlyIndex = articleList . byYear
-
-monthlyIndex :: Integer -> Int -> AppPart Response
-monthlyIndex year month = articleList $ byYearMonth year month
-
-dailyIndex :: Day -> AppPart Response
-dailyIndex = articleList . byDate
-
 -- Find the most relevant language preference in a request
 -- Includes: explicit GET parameter, cookie and Accept-Language header
 languageHeaderM :: AppPart LanguagePreference
@@ -169,12 +142,11 @@ articleList articleFilter = do
 
 meta :: Text -> Maybe PageFormat -> AppPart Response
 meta slug format' = do
-    let format = fromMaybe Html format'
     language <- languageHeaderM
     m <- askMeta slug
-    case format of
-        Html -> metaDisplay language m >>= okResponse
-        _ -> metaExport format language m >>= okResponse
+    case format' of
+        Nothing -> metaDisplay language m >>= okResponse
+        Just format -> metaExport format language m >>= okResponse
 
 feedIndex :: Language -> AppPart Response
 feedIndex language = do
@@ -183,10 +155,10 @@ feedIndex language = do
     feedDisplay language sorted >>= okResponse
 
 siteScript :: AppPart Response
-siteScript = renderSiteScript >>= okResponse
+siteScript = okResponse renderSiteScript
 
 printStylesheet :: AppPart Response
-printStylesheet = renderPrintStylesheet >>= okResponse
+printStylesheet = okResponse renderPrintStylesheet
 
 codeStylesheet :: AppPart Response
-codeStylesheet = renderCodeStylesheet >>= okResponse
+codeStylesheet = okResponse renderCodeStylesheet
diff --git a/src/CrossPost.hs b/src/CrossPost.hs
index ce83f92..cc0caeb 100644
--- a/src/CrossPost.hs
+++ b/src/CrossPost.hs
@@ -21,7 +21,6 @@ import qualified Data.Text as T
 
 import Network.HTTP.Conduit (newManager, tlsManagerSettings)
 
-import Web.Routes
 import Web.Twitter.Conduit (OAuth, TWInfo(..), call, twCredential, twOAuth)
 import Web.Twitter.Conduit.Api
 import Web.Twitter.Conduit.Parameters hiding (map)
@@ -40,11 +39,11 @@ import Views
 crossPost :: App ()
 crossPost = do
     liftIO $ putStrLn "Cross-posting new articles..."
-    runRoute crossPostTwitter
+    crossPostTwitter
     liftIO $ putStrLn "All new articles cross-posted."
 
 crossPostTwitter ::
-       (MonadRoute m, URL m ~ Sitemap, MonadIO m, MonadReader AppData m) => m ()
+       (MonadIO m, MonadReader AppData m) => m ()
 crossPostTwitter = do
     mgr <- liftIO $ newManager tlsManagerSettings
     address <- asks appAddress
@@ -68,7 +67,7 @@ crossPostTwitter = do
             let lpref = singleLanguage credLang
             forM unposted $ \art -> do
                 let title = langTitle lpref art
-                articleLink <- linkTo art
+                let articleLink = linkTo art
                 let content = title <> " " <> address <> articleLink
                 doCall $ update content
     return ()
@@ -84,7 +83,7 @@ twitterArticleLinks statuses = do
     -- Filter out the ones for the article route
     let articleLinks =
             [ (date, slug)
-            | Right (ArticleView date slug) <- map parseRoute urls
+            | Just (ArticleView date slug) <- map parseURL urls
             ]
     -- Get the matched articles
     let articleFilter art = any (\(d, s) -> byDateSlug d s art) articleLinks
diff --git a/src/Routes.hs b/src/Routes.hs
index f0282fb..7b00a25 100644
--- a/src/Routes.hs
+++ b/src/Routes.hs
@@ -12,26 +12,18 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time
 
-import Text.Boomerang.TH (makeBoomerangs)
-
-import Web.Routes.Boomerang
-
 import Types.Language
 
 data PageFormat
-    = Html
-    | Pdf
+    = Pdf
     | Docx
     deriving (Eq, Ord, Show)
 
--- TODO: use Boomerang for these
 formatToStr :: PageFormat -> Text
-formatToStr Html = "pdf"
 formatToStr Pdf = "pdf"
 formatToStr Docx = "docx"
 
 strToFormat :: Text -> Maybe PageFormat
-strToFormat "html" = Just Html
 strToFormat "pdf" = Just Pdf
 strToFormat "docx" = Just Docx
 strToFormat _ = Nothing
@@ -40,10 +32,6 @@ type MaybeFormat = Maybe PageFormat
 
 data Sitemap
     = Index
-    | Yearly Integer
-    | Monthly Integer
-              Int
-    | Daily Day
     | ArticleView Day
                   Text
     | MetaView Text
@@ -54,87 +42,13 @@ data Sitemap
     | CodeStylesheet
     deriving (Eq, Ord, Show)
 
-makeBoomerangs ''Sitemap
-
-rDay :: Boomerang TextsError [Text] r (Day :- r)
-rDay = xpure mkDay parseDay . (integer </> int </> int)
-  where
-    mkDay (y :- m :- d :- x) = fromGregorian y m d :- x
-    parseDay (day :- x) =
-        let (y, m, d) = toGregorian day
-        in Just $ y :- m :- d :- x
-
--- TODO: This will error on strings which are not language codes
-rLanguage :: Boomerang TextsError [Text] r (Language :- r)
-rLanguage = xpure mkLang parseLang . anyString
-  where
-    mkLang (str :- x) =
-        let Just lang = parseLanguageM str
-        in lang :- x
-    parseLang (lang :- x) = Just $ showLanguage lang :- x
-
-rString :: Boomerang e tok i (Text :- o) -> Boomerang e tok i (String :- o)
-rString = xmaph T.unpack (Just . T.pack)
-
-anyString :: Boomerang TextsError [Text] o (String :- o)
-anyString = rString anyText
+routeURL :: Sitemap -> Text
+routeURL = undefined
 
-rExtension ::
-       Boomerang e tok i (Text :- o)
-    -> Boomerang e tok i (Text :- Maybe Text :- o)
-rExtension = xmap splitExt' (Just . joinExt')
-  where
-    splitExt' :: Text :- o -> Text :- Maybe Text :- o
-    splitExt' (seg :- o) =
-        let (seg', ext) = splitExt seg
-        in seg' :- ext :- o
-    joinExt' :: Text :- Maybe Text :- o -> Text :- o
-    joinExt' (seg :- ext :- o) = joinExt seg ext :- o
-
--- Swap the top 2 components in a Boomerang
-xflip :: Boomerang e tok i (a :- b :- o) -> Boomerang e tok i (b :- a :- o)
-xflip = xmap pflip (Just . pflip)
-  where
-    pflip (a :- b :- o) = b :- a :- o
-
--- Apply a transformation to the second topmost component of a Boomerang
-xmaph2 ::
-       (b -> c)
-    -> (c -> Maybe b)
-    -> Boomerang e tok i (a :- b :- o)
-    -> Boomerang e tok i (a :- c :- o)
-xmaph2 f g = xflip . xmaph f g . xflip
-
--- Split a path component into basename and extension
-splitExt :: Text -> (Text, Maybe Text)
-splitExt segment =
-    case T.splitOn "." segment of
-        [] -> ("", Nothing)
-        [s] -> (s, Nothing)
-        ss -> (T.intercalate "." $ init ss, Just $ last ss)
+parseURL :: Text -> Maybe Sitemap
+parseURL = undefined
 
 -- Join a basename and extension together
 joinExt :: Text -> Maybe Text -> Text
 joinExt segment Nothing = segment
 joinExt segment (Just ext) = segment <> "." <> ext
-
--- Convert the second topmost component into a MaybeFormat
-xFormat ::
-       Boomerang e tok i (Text :- Maybe Text :- o)
-    -> Boomerang e tok i (Text :- MaybeFormat :- o)
-xFormat = xmaph2 (strToFormat =<<) (Just . fmap formatToStr)
-
-sitemap :: Boomerang TextsError [Text] r (Sitemap :- r)
-sitemap =
-    mconcat
-        [ rIndex
-        , rYearly . integer
-        , rMonthly . integer </> int
-        , rDaily . rDay
-        , rFeed . "feed" </> rLanguage
-        , rSiteScript . "site.js"
-        , rPrintStylesheet . "print.css"
-        , rCodeStylesheet . "code.css"
-        , rArticleView . rDay </> anyText
-        , rMetaView . xFormat (rExtension anyText)
-        ]
diff --git a/src/Views.hs b/src/Views.hs
index 93e09ed..de8e0c9 100644
--- a/src/Views.hs
+++ b/src/Views.hs
@@ -29,8 +29,6 @@ import Text.Pandoc hiding (Meta, Reader)
 import Text.Pandoc.Highlighting
 import Text.Pandoc.Walk
 
-import Web.Routes
-
 import Models
 import Render
 import Routes
@@ -49,8 +47,6 @@ instance Linkable Article where
 instance Linkable Meta where
     link m = MetaView (mtSlug m) Nothing
 
-type AppRoute m = (MonadRoute m, URL m ~ Sitemap)
-
 data PageContent = PageContent
     { pcTitle :: Maybe Text
     , pcLayout :: Layout
@@ -88,10 +84,8 @@ paginate size page allItems = Paginated prev items next
 convRender :: (url -> [(a, Maybe b)] -> c) -> url -> [(a, b)] -> c
 convRender maybeF url params = maybeF url $ map (A.second Just) params
 
-render :: MonadRoute m => HtmlUrl (URL m) -> m Markup
-render html = do
-    route <- fmap convRender askRouteFn
-    return $ html route
+render :: HtmlUrl Sitemap -> Markup
+render html = html perhapsRoute
 
 askLangStringFn ::
        MonadReader AppData m => LanguagePreference -> m (Text -> Text)
@@ -115,15 +109,14 @@ linkTitle lang (MetaLink slug) = do
     pure $ langTitle lang meta
 
 linkDestination ::
-       (AppRoute m, MonadReader AppData m, MonadPlus m) => Link -> m Text
+       (MonadReader AppData m, MonadPlus m) => Link -> m Text
 linkDestination (ExternalLink url _) = pure url
 linkDestination (MetaLink slug) = do
     meta <- askMeta slug
-    route <- askRouteFn
-    pure $ route (link meta) []
+    pure $ perhapsRoute (link meta) []
 
 template ::
-       (AppRoute m, MonadReader AppData m, MonadPlus m)
+       (MonadReader AppData m, MonadPlus m)
     => LanguagePreference
     -> PageContent
     -> m Markup
@@ -139,22 +132,22 @@ template lang page = do
     analyticsIDs <- asks appAnalytics
     let analytics = $(hamletFile "templates/analytics.hamlet")
     case pcLayout page of
-        BaseLayout -> render $(hamletFile "templates/base.hamlet")
+        BaseLayout -> pure $ render $(hamletFile "templates/base.hamlet")
         PresentationLayout ->
-            render $(hamletFile "templates/base_presentation.hamlet")
+            pure $ render $(hamletFile "templates/base_presentation.hamlet")
 
 articleListDisplay ::
-       (AppRoute m, MonadReader AppData m, MonadPlus m)
+       (MonadReader AppData m, MonadPlus m)
     => LanguagePreference
     -> Paginated Article
     -> m Markup
 articleListDisplay lang articles = do
-    articlesContent <- mapM (linkedContent lang) (pageItems articles)
+    let articlesContent = map (linkedContent lang) (pageItems articles)
     langString <- askLangStringFn lang
     template lang $ def {pcContent = $(hamletFile "templates/list.hamlet")}
 
 articleDisplay ::
-       (AppRoute m, MonadReader AppData m, MonadPlus m)
+       (MonadReader AppData m, MonadPlus m)
     => LanguagePreference
     -> Article
     -> m Markup
@@ -166,7 +159,7 @@ articleDisplay lang article =
     }
 
 metaDisplay ::
-       (AppRoute m, MonadReader AppData m, MonadPlus m)
+       (MonadReader AppData m, MonadPlus m)
     => LanguagePreference
     -> Meta
     -> m Markup
@@ -185,20 +178,16 @@ metaDisplay lang meta =
                 $(hamletFile "templates/meta_presentation.hamlet")
 
 -- Generate a link to some content
-linkTo :: (Linkable a, AppRoute m) => a -> m Text
-linkTo a = do
-    routeFn <- askRouteFn
-    pure $ routeFn (link a) []
+linkTo :: (Linkable a) => a -> Text
+linkTo a = perhapsRoute (link a) []
 
 -- Modify the content to have a link to itself and have no anchors
 linkedContent ::
-       (HasContent a, Linkable a, AppRoute m)
+       (HasContent a, Linkable a)
     => LanguagePreference
     -> a
-    -> m Pandoc
-linkedContent lang a = do
-    target <- linkTo a
-    pure $ linkedHeader target $ langContent lang a
+    -> Pandoc
+linkedContent lang a = linkedHeader (linkTo a) $ langContent lang a
 
 -- Modify the first header to be a link to a given place
 -- and remove all anchors from headers
@@ -220,18 +209,17 @@ linkedHeader target doc = evalState (walkM linkHeader doc) True
         return $ Header n ("", [], []) text'
     linkHeader x = return x
 
-renderSiteScript :: MonadRoute m => m JavaScript
-renderSiteScript = do
-    route <- fmap convRender askRouteFn
-    return $ JavaScript $ renderJavascriptUrl route $(juliusFile "templates/site.julius")
+perhapsRoute :: Render Sitemap
+perhapsRoute r _ = routeURL r
+
+renderSiteScript :: JavaScript
+renderSiteScript = JavaScript $ renderJavascriptUrl perhapsRoute $(juliusFile "templates/site.julius")
 
-renderPrintStylesheet :: MonadRoute m => m Stylesheet
-renderPrintStylesheet = do
-    route <- fmap convRender askRouteFn
-    return $ Stylesheet $ renderCssUrl route $(luciusFile "templates/print.lucius")
+renderPrintStylesheet :: Stylesheet
+renderPrintStylesheet = Stylesheet $ renderCssUrl perhapsRoute $(luciusFile "templates/print.lucius")
 
-renderCodeStylesheet :: MonadRoute m => m Stylesheet
-renderCodeStylesheet = pure $ Stylesheet $ TL.pack $ styleToCss highlightingStyle
+renderCodeStylesheet :: Stylesheet
+renderCodeStylesheet = Stylesheet $ TL.pack $ styleToCss highlightingStyle
 
 -- | Presentation can only render the pipe tables. Disable the other kinds
 presentationOptions :: WriterOptions
diff --git a/src/Views/Export.hs b/src/Views/Export.hs
index 8e7371c..a0c78f4 100644
--- a/src/Views/Export.hs
+++ b/src/Views/Export.hs
@@ -31,8 +31,6 @@ import Text.StringLike
 
 import Text.Pandoc hiding (Meta)
 
-import Web.Routes
-
 import Cache
 import Models
 import Render
@@ -43,9 +41,7 @@ import Views
 
 -- Export a meta into one of the supported formats
 metaExport ::
-       ( MonadRoute m
-       , URL m ~ Sitemap
-       , MonadReader AppData m
+       ( MonadReader AppData m
        , MonadState AppCache m
        , MonadIO m
        )
@@ -56,7 +52,6 @@ metaExport ::
 -- Pandoc uses TeX to render PDFs, which requires a lot of packages for Unicode
 -- support, etc. Use wkhtmltopdf instead
 metaExport Pdf lang meta = pdfExport lang meta
-metaExport Html _ _ = error "HTML is not an export format"
 metaExport Docx lang meta = do
     let content = langContent lang meta
     pure $
@@ -68,12 +63,11 @@ metaExportFileName format meta = Text.intercalate "." [metaName, fileExtension f
   where
     metaName = mtExportSlug meta
     fileExtension Docx = "docx"
-    fileExtension Html = error "HTML is not an export format"
     fileExtension Pdf = "pdf"
 
 -- Export a PDF using wkhtmltopdf
 pdfExport ::
-       (MonadRoute m, URL m ~ Sitemap, MonadState AppCache m, MonadIO m)
+       (MonadState AppCache m, MonadIO m)
     => LanguagePreference
     -> Meta
     -> m (Export LB.ByteString)
@@ -82,7 +76,7 @@ pdfExport lang meta =
     withCacheM (bestLanguage lang, mtSlug meta) $ do
         let content = runPandocPure' $ writeHtml $ langContent lang meta
         let title = langTitle lang meta
-        html <- render $(hamletFile "templates/pdf-export.hamlet")
+        let html = render $(hamletFile "templates/pdf-export.hamlet")
         let htmlText = TextRenderer.renderMarkup html
         let fixedHtmlText = fixupHtml htmlText
         wkhtmltopdf $ encodeUtf8 fixedHtmlText
diff --git a/src/Views/Feed.hs b/src/Views/Feed.hs
index 45645b1..115ed7f 100644
--- a/src/Views/Feed.hs
+++ b/src/Views/Feed.hs
@@ -39,8 +39,6 @@ import Text.Blaze.Renderer.Text (renderMarkup)
 
 import qualified Text.XML as C
 
-import Web.Routes
-
 import Models
 import Routes
 import Types.Content
@@ -60,13 +58,13 @@ atomDate :: UTCTime -> Date
 atomDate = (<> "T00:00:00Z") . Text.pack . showGregorian . utctDay
 
 articleEntry ::
-       (MonadRoute m, URL m ~ Sitemap, MonadReader AppData m)
+       MonadReader AppData m
     => Language
     -> Article
     -> m Entry
 articleEntry lang article = do
     let lpref = singleLanguage lang
-    articleLink <- linkTo article
+    let articleLink = linkTo article
     authorName <- askLangString lpref "authorName"
     let entry =
             nullEntry
@@ -84,18 +82,18 @@ articleEntry lang article = do
         }
 
 feedDisplay ::
-       (MonadRoute m, URL m ~ Sitemap, MonadReader AppData m)
+       MonadReader AppData m
     => Language
     -> [Article]
     -> m Response
 feedDisplay lang articles = do
     siteName <- askLangString (singleLanguage lang) "siteName"
     -- TODO: Web.Routes generate a link without the trailing slash
-    home <- (<> "/") <$> linkTo Index
+    let home = linkTo Index <> "/"
     let lastUpdated = arAuthored $ head articles
     let blankFeed = nullFeed home (TextString siteName) (atomDate lastUpdated)
     entries <- mapM (articleEntry lang) articles
-    selfAddress <- linkTo $ Routes.Feed lang
+    let selfAddress = linkTo $ Routes.Feed lang
     let selfLink = (nullLink selfAddress) {linkRel = Just $ Left "self"}
     let feed = blankFeed {feedEntries = entries, feedLinks = [selfLink]}
     pure $ toResponse $ AtomFeed feed
diff --git a/testsuite/TestRoutes.hs b/testsuite/TestRoutes.hs
index 1e21c7b..444306f 100644
--- a/testsuite/TestRoutes.hs
+++ b/testsuite/TestRoutes.hs
@@ -3,18 +3,26 @@
 
 module TestRoutes where
 
+import Data.LanguageCodes
+import Data.Time.Calendar
+
 import Routes
 
 import Test.Framework
 import Test.QuickCheck.Instances ()
 
-test_splitExt = do
-    assertEqual ("segment", Nothing) (splitExt "segment")
-    assertEqual ("segment", Just "ext") (splitExt "segment.ext")
-    assertEqual
-        ("segment.more.dots", Just "ext")
-        (splitExt "segment.more.dots.ext")
+test_routeURL_parseURL = do
+    assertEqual (routeURL Index) ""
+    assertEqual (parseURL "/") $ Just Index
+    let testArticle = ArticleView (fromGregorian 2020 01 01) "test"
+    assertEqual (routeURL testArticle) "/2020-01-01/test"
+    assertEqual (parseURL "/2020/01/01/test") $ Just testArticle
+    assertEqual (parseURL "/2020-01-01/test/") $ Just testArticle
+    assertEqual (routeURL $ MetaView "meta" Nothing) "/meta"
+    assertEqual (parseURL "/meta/") $ Just $ MetaView "meta" Nothing
+    assertEqual (routeURL $ MetaView "meta" (Just Pdf)) "/meta.pdf"
+    assertEqual (routeURL $ Feed EN) "/feed/en"
 
-prop_splitExt_joinExt seg =
-    let (seg', ext) = splitExt seg
-    in joinExt seg' ext == seg
+prop_routeURL_parseURL route =
+    let url = routeURL route
+    in parseURL url == Just route

From f3270adc9c01fcdbe9572bd749b39101b26f5acf Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Sun, 9 Feb 2020 21:28:56 +1100
Subject: [PATCH 03/13] Add Arbitrary instances

---
 package.yaml            | 1 +
 src/Routes.hs           | 9 +++++----
 testsuite/TestRoutes.hs | 8 ++++++++
 3 files changed, 14 insertions(+), 4 deletions(-)

diff --git a/package.yaml b/package.yaml
index 27bbc70..21e7dc7 100644
--- a/package.yaml
+++ b/package.yaml
@@ -67,6 +67,7 @@ tests:
     - HTF
     - HUnit
     - derive
+    - generic-arbitrary
     - QuickCheck
     - quickcheck-instances
 stability: Experimental
diff --git a/src/Routes.hs b/src/Routes.hs
index 7b00a25..4dbf11f 100644
--- a/src/Routes.hs
+++ b/src/Routes.hs
@@ -1,6 +1,5 @@
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE TypeOperators #-}
 
 module Routes where
 
@@ -12,12 +11,14 @@ import Data.Text (Text)
 import qualified Data.Text as T
 import Data.Time
 
+import GHC.Generics
+
 import Types.Language
 
 data PageFormat
     = Pdf
     | Docx
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show, Generic)
 
 formatToStr :: PageFormat -> Text
 formatToStr Pdf = "pdf"
@@ -40,7 +41,7 @@ data Sitemap
     | SiteScript
     | PrintStylesheet
     | CodeStylesheet
-    deriving (Eq, Ord, Show)
+    deriving (Eq, Ord, Show, Generic)
 
 routeURL :: Sitemap -> Text
 routeURL = undefined
diff --git a/testsuite/TestRoutes.hs b/testsuite/TestRoutes.hs
index 444306f..9b09896 100644
--- a/testsuite/TestRoutes.hs
+++ b/testsuite/TestRoutes.hs
@@ -4,12 +4,20 @@
 module TestRoutes where
 
 import Data.LanguageCodes
+import Data.LanguageCodes.Arbitrary ()
 import Data.Time.Calendar
 
 import Routes
 
 import Test.Framework
 import Test.QuickCheck.Instances ()
+import Test.QuickCheck.Arbitrary.Generic
+
+instance Arbitrary PageFormat where
+    arbitrary = genericArbitrary
+
+instance Arbitrary Sitemap where
+    arbitrary = genericArbitrary
 
 test_routeURL_parseURL = do
     assertEqual (routeURL Index) ""

From 7db7d42fbbd58e9f850edf2bb15ae7d9623ec9b9 Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Mon, 10 Feb 2020 08:02:28 +1100
Subject: [PATCH 04/13] Implement URL parsing

---
 package.yaml                  |  1 +
 src/Routes.hs                 | 52 +++++++++++++++++++++++++++++++++--
 src/Types/Language.hs         | 44 +++++++++++++++--------------
 testsuite/Integration/Base.hs |  2 +-
 testsuite/TestRoutes.hs       | 26 +++++++++++-------
 5 files changed, 91 insertions(+), 34 deletions(-)

diff --git a/package.yaml b/package.yaml
index 21e7dc7..54659a3 100644
--- a/package.yaml
+++ b/package.yaml
@@ -32,6 +32,7 @@ library:
   - authenticate-oauth
   - directory
   - filepath
+  - here
   - http-conduit
   - lens
   - lifted-base
diff --git a/src/Routes.hs b/src/Routes.hs
index 4dbf11f..9b209e7 100644
--- a/src/Routes.hs
+++ b/src/Routes.hs
@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
 
 module Routes where
 
@@ -7,12 +8,17 @@ import Prelude hiding ((.))
 
 import Control.Category (Category((.)))
 
+import Data.String.Here (i)
+
+import Data.Char (isDigit)
 import Data.Text (Text)
-import qualified Data.Text as T
+import qualified Data.Text as Text
 import Data.Time
 
 import GHC.Generics
 
+import Text.Read
+
 import Types.Language
 
 data PageFormat
@@ -44,10 +50,50 @@ data Sitemap
     deriving (Eq, Ord, Show, Generic)
 
 routeURL :: Sitemap -> Text
-routeURL = undefined
+routeURL Index = ""
+routeURL (ArticleView date text) = let (year, month, day) = toGregorian date in [i|/${pad 2 year}-${pad 2 month}-${pad 2 day}/${text}|]
+routeURL (MetaView text Nothing) = [i|/${text}|]
+routeURL (MetaView text (Just format)) = [i|/${text}.${formatToStr format}|]
+routeURL (Feed language) = [i|/feed/${showLanguage language}|]
+routeURL SiteScript = "/assets/site.js"
+routeURL PrintStylesheet = "/assets/print.css"
+routeURL CodeStylesheet = "/assets/code.css"
+
+pad :: Show a => Int -> a -> Text
+pad len str = let printed = Text.pack (show str)
+                  padding = Text.replicate (len - Text.length printed) "0"
+               in padding <> printed
+
+splitNonEmpty :: Text -> Text -> [Text]
+splitNonEmpty splitter = filter (not . Text.null) . Text.splitOn splitter
+
+readText :: Read a => Text -> Maybe a
+readText = readMaybe . Text.unpack
 
 parseURL :: Text -> Maybe Sitemap
-parseURL = undefined
+parseURL = parseSegments . splitNonEmpty "/"
+    where
+        parseSegments [] = Just Index
+        parseSegments [metaText] = case splitNonEmpty "." metaText of
+                                                              [text] -> Just $ MetaView text Nothing
+                                                              [text, formatStr] -> do
+                                                                                    format <- strToFormat formatStr
+                                                                                    pure $ MetaView text (Just format)
+                                                              _ -> Nothing
+        parseSegments [date, articleText] | dateLike date = parseArticle (splitNonEmpty "-" date) articleText
+        parseSegments [year, month, day, articleText] = parseArticle [year, month, day] articleText
+        parseSegments ["assets", "site.js"] = Just SiteScript
+        parseSegments ["assets", "print.css"] = Just PrintStylesheet
+        parseSegments ["assets", "code.css"] = Just CodeStylesheet
+        parseSegments _ = Nothing
+        dateLike = Text.all $ \c -> isDigit c || c == '-'
+        parseArticle [yearStr, monthStr, dayStr] text = do
+                                                   year <- readText yearStr
+                                                   month <- readText monthStr
+                                                   day <- readText dayStr
+                                                   date <- fromGregorianValid year month day
+                                                   pure $ ArticleView date text
+        parseArticle _ _ = Nothing
 
 -- Join a basename and extension together
 joinExt :: Text -> Maybe Text -> Text
diff --git a/src/Types/Language.hs b/src/Types/Language.hs
index 69ab13d..43a0a25 100644
--- a/src/Types/Language.hs
+++ b/src/Types/Language.hs
@@ -4,6 +4,7 @@ Language-related types.
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Types.Language where
@@ -16,18 +17,20 @@ import Data.Function
 import Data.LanguageCodes
 import Data.List
 import Data.List.Split
-import qualified Data.Map as M
+import Data.Map (Map)
+import qualified Data.Map as Map
 import Data.Maybe
-import qualified Data.Text as T
+import Data.Text (Text)
+import qualified Data.Text as Text
 
 import Utils
 
 type Language = ISO639_1
 
-type LanguageMap = M.Map Language
+type LanguageMap = Map Language
 
-mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> M.Map k1 a -> m (M.Map k2 a)
-mapKeysM kfunc = fmap M.fromList . traverse kvfunc . M.toList
+mapKeysM :: (Monad m, Ord k2) => (k1 -> m k2) -> Map k1 a -> m (Map k2 a)
+mapKeysM kfunc = fmap Map.fromList . traverse kvfunc . Map.toList
   where
     kvfunc (k, v) = (,) <$> kfunc k <*> pure v
 
@@ -36,7 +39,7 @@ instance A.FromJSON ISO639_1 where
     parseJSON _ = mzero
 
 instance A.FromJSONKey ISO639_1 where
-    fromJSONKey = A.FromJSONKeyTextParser $ parseLanguageM . T.unpack
+    fromJSONKey = A.FromJSONKeyTextParser $ parseLanguageM . Text.unpack
 
 -- | Newtype for parsing either a single value or a map of values
 newtype LanguageChoices a =
@@ -46,7 +49,7 @@ instance A.FromJSON v => A.FromJSON (LanguageChoices v) where
     parseJSON v@(A.Object _) =
         LanguageChoices <$> (A.parseJSON v >>= mapKeysM parseLanguageM)
     parseJSON v@(A.String _) =
-        LanguageChoices . M.singleton defaultLanguage <$> A.parseJSON v
+        LanguageChoices . Map.singleton defaultLanguage <$> A.parseJSON v
     parseJSON _ = mzero
 
 newtype LanguagePreference = LanguagePreference
@@ -57,26 +60,26 @@ defaultLanguage :: Language
 defaultLanguage = EN
 
 singleLanguage :: Language -> LanguagePreference
-singleLanguage lang = LanguagePreference $ M.singleton lang 1
+singleLanguage lang = LanguagePreference $ Map.singleton lang 1
 
 bestLanguage :: LanguagePreference -> Language
 bestLanguage =
     fromMaybe defaultLanguage .
     listToMaybe .
     fmap fst .
-    sortBy (reverseCompare `on` snd) . M.toList . unLanguagePreference
+    sortBy (reverseCompare `on` snd) . Map.toList . unLanguagePreference
 
 rankLanguage :: Language -> LanguagePreference -> Float
-rankLanguage lang = fromMaybe 0 . M.lookup lang . unLanguagePreference
+rankLanguage lang = fromMaybe 0 . Map.lookup lang . unLanguagePreference
 
 matchLanguage :: LanguagePreference -> LanguageMap a -> Maybe a
 matchLanguage = matchLanguageFunc (const 1)
 
 matchLanguageFunc ::
        (a -> Float) -> LanguagePreference -> LanguageMap a -> Maybe a
-matchLanguageFunc quality pref values = fst <$> M.maxView ranked
+matchLanguageFunc quality pref values = fst <$> Map.maxView ranked
   where
-    ranked = M.fromList $ M.elems $ M.mapWithKey rank values
+    ranked = Map.fromList $ Map.elems $ Map.mapWithKey rank values
     rank lang value = (rankLanguage lang pref * quality value, value)
 
 parseLanguage :: MonadError String m => String -> m Language
@@ -93,19 +96,19 @@ parseLanguageM [c1, c2] =
 parseLanguageM (c1:c2:'-':_) = parseLanguageM [c1, c2]
 parseLanguageM _ = mzero
 
-showLanguage :: Language -> String
-showLanguage = (\(a, b) -> [a, b]) . toChars
+showLanguage :: Language -> Text
+showLanguage = Text.pack . (\(a, b) -> [a, b]) . toChars
 
-iso3166 :: Language -> String
+iso3166 :: Language -> Text
 iso3166 EN = "gb"
 iso3166 ZH = "cn"
 iso3166 x = showLanguage x
 
 -- TODO: Parsec or library
 languageHeader :: Maybe String -> LanguagePreference
-languageHeader Nothing = LanguagePreference $ M.singleton defaultLanguage 1
+languageHeader Nothing = LanguagePreference $ Map.singleton defaultLanguage 1
 languageHeader (Just str) =
-    LanguagePreference $ M.fromList $ mapMaybe parsePref $ splitOn "," str
+    LanguagePreference $ Map.fromList $ mapMaybe parsePref $ splitOn "," str
   where
     parsePref pref =
         case splitOn ";q=" pref of
@@ -116,8 +119,9 @@ languageHeader (Just str) =
 
 instance Show LanguagePreference where
     show =
-        intercalate "," .
-        map (uncurry showPref) . M.toList . unLanguagePreference
+        Text.unpack .
+        Text.intercalate "," .
+        map (uncurry showPref) . Map.toList . unLanguagePreference
       where
         showPref lang 1 = showLanguage lang
-        showPref lang qvalue = showLanguage lang ++ ";q=" ++ show qvalue
+        showPref lang qvalue = showLanguage lang <> ";q=" <> Text.pack (show qvalue)
diff --git a/testsuite/Integration/Base.hs b/testsuite/Integration/Base.hs
index 13ebdee..6af85ec 100644
--- a/testsuite/Integration/Base.hs
+++ b/testsuite/Integration/Base.hs
@@ -184,7 +184,7 @@ withLang1 = withLang . singleLanguage
 withLangCookie :: Language -> TestRequest -> TestRequest
 withLangCookie lang req =
     req
-    {trCookies = M.insert "lang" (T.pack $ showLanguage lang) (trCookies req)}
+    {trCookies = M.insert "lang" (showLanguage lang) (trCookies req)}
 
 -- Extract contents from a response
 responseContent :: Response -> IO LB.ByteString
diff --git a/testsuite/TestRoutes.hs b/testsuite/TestRoutes.hs
index 9b09896..57761a3 100644
--- a/testsuite/TestRoutes.hs
+++ b/testsuite/TestRoutes.hs
@@ -19,17 +19,23 @@ instance Arbitrary PageFormat where
 instance Arbitrary Sitemap where
     arbitrary = genericArbitrary
 
-test_routeURL_parseURL = do
-    assertEqual (routeURL Index) ""
-    assertEqual (parseURL "/") $ Just Index
+test_index_URL = do
+    assertEqual "" (routeURL Index)
+    assertEqual (Just Index) $ parseURL "/"
+
+test_article_URL = do
     let testArticle = ArticleView (fromGregorian 2020 01 01) "test"
-    assertEqual (routeURL testArticle) "/2020-01-01/test"
-    assertEqual (parseURL "/2020/01/01/test") $ Just testArticle
-    assertEqual (parseURL "/2020-01-01/test/") $ Just testArticle
-    assertEqual (routeURL $ MetaView "meta" Nothing) "/meta"
-    assertEqual (parseURL "/meta/") $ Just $ MetaView "meta" Nothing
-    assertEqual (routeURL $ MetaView "meta" (Just Pdf)) "/meta.pdf"
-    assertEqual (routeURL $ Feed EN) "/feed/en"
+    assertEqual  "/2020-01-01/test" (routeURL testArticle)
+    assertEqual (Just testArticle) (parseURL "/2020/01/01/test")
+    assertEqual (Just testArticle) (parseURL "/2020-01-01/test/")
+
+test_meta_URL = do
+    assertEqual "/meta" (routeURL $ MetaView "meta" Nothing)
+    assertEqual (Just $ MetaView "meta" Nothing) (parseURL "/meta/")
+    assertEqual "/meta.pdf" (routeURL $ MetaView "meta" (Just Pdf))
+
+test_feed_URL = do
+    assertEqual "/feed/en" (routeURL $ Feed EN)
 
 prop_routeURL_parseURL route =
     let url = routeURL route

From 2bb45ba4e5541dfe49c7e08b9764963ece874881 Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 18:06:49 +1100
Subject: [PATCH 05/13] Fix URL parsing

---
 src/Import.hs             |  2 +-
 src/Routes.hs             |  1 +
 src/Types/Language.hs     | 28 +++++++++++++++-------------
 testsuite/TestLanguage.hs |  1 +
 testsuite/TestRoutes.hs   | 17 ++++++++++++++++-
 5 files changed, 34 insertions(+), 15 deletions(-)

diff --git a/src/Import.hs b/src/Import.hs
index 5298740..fd633e6 100644
--- a/src/Import.hs
+++ b/src/Import.hs
@@ -94,7 +94,7 @@ parseContent dir = do
             case M.lookup (T.pack $ tail ext) readers of
                 Nothing -> pure Nothing
                 Just reader -> do
-                    lang <- parseLanguage fileName
+                    lang <- parseLanguage (T.pack fileName)
                     case reader (T.decodeUtf8 $ sfContent file) of
                         Left err -> throwError $ show err
                         Right res -> pure (Just (lang, res))
diff --git a/src/Routes.hs b/src/Routes.hs
index 9b209e7..8827d28 100644
--- a/src/Routes.hs
+++ b/src/Routes.hs
@@ -85,6 +85,7 @@ parseURL = parseSegments . splitNonEmpty "/"
         parseSegments ["assets", "site.js"] = Just SiteScript
         parseSegments ["assets", "print.css"] = Just PrintStylesheet
         parseSegments ["assets", "code.css"] = Just CodeStylesheet
+        parseSegments ["feed", lang] = Feed <$> parseLanguageM lang
         parseSegments _ = Nothing
         dateLike = Text.all $ \c -> isDigit c || c == '-'
         parseArticle [yearStr, monthStr, dayStr] text = do
diff --git a/src/Types/Language.hs b/src/Types/Language.hs
index 43a0a25..5eee9fc 100644
--- a/src/Types/Language.hs
+++ b/src/Types/Language.hs
@@ -39,7 +39,7 @@ instance A.FromJSON ISO639_1 where
     parseJSON _ = mzero
 
 instance A.FromJSONKey ISO639_1 where
-    fromJSONKey = A.FromJSONKeyTextParser $ parseLanguageM . Text.unpack
+    fromJSONKey = A.FromJSONKeyTextParser $ parseLanguageM
 
 -- | Newtype for parsing either a single value or a map of values
 newtype LanguageChoices a =
@@ -82,19 +82,21 @@ matchLanguageFunc quality pref values = fst <$> Map.maxView ranked
     ranked = Map.fromList $ Map.elems $ Map.mapWithKey rank values
     rank lang value = (rankLanguage lang pref * quality value, value)
 
-parseLanguage :: MonadError String m => String -> m Language
+parseLanguage :: MonadError String m => Text -> m Language
 parseLanguage langStr =
     case parseLanguageM langStr :: Maybe Language of
         (Just lang) -> pure lang
-        Nothing -> throwError $ langStr ++ " is not a valid language code."
-
-parseLanguageM :: MonadPlus m => String -> m Language
-parseLanguageM [c1, c2] =
-    case fromChars c1 c2 of
-        Just lang -> return lang
-        Nothing -> mzero
-parseLanguageM (c1:c2:'-':_) = parseLanguageM [c1, c2]
-parseLanguageM _ = mzero
+        Nothing -> throwError $ Text.unpack $ langStr <> " is not a valid language code."
+
+parseLanguageM :: MonadPlus m => Text -> m Language
+parseLanguageM = parseLanguageStr . Text.unpack
+    where
+        parseLanguageStr [c1, c2] =
+            case fromChars c1 c2 of
+                Just lang -> return lang
+                Nothing -> mzero
+        parseLanguageStr (c1:c2:'-':_) = parseLanguageStr [c1, c2]
+        parseLanguageStr _ = mzero
 
 showLanguage :: Language -> Text
 showLanguage = Text.pack . (\(a, b) -> [a, b]) . toChars
@@ -112,8 +114,8 @@ languageHeader (Just str) =
   where
     parsePref pref =
         case splitOn ";q=" pref of
-            [lang] -> pairWith 1 <$> parseLanguageM lang
-            [lang, qvalue] -> pairWith (read qvalue) <$> parseLanguageM lang
+            [lang] -> pairWith 1 <$> parseLanguageM (Text.pack lang)
+            [lang, qvalue] -> pairWith (read qvalue) <$> parseLanguageM (Text.pack lang)
             _ -> Nothing
     pairWith y x = (x, y)
 
diff --git a/testsuite/TestLanguage.hs b/testsuite/TestLanguage.hs
index 743236d..395bf2c 100644
--- a/testsuite/TestLanguage.hs
+++ b/testsuite/TestLanguage.hs
@@ -1,5 +1,6 @@
 {-# OPTIONS_GHC -F -pgmF htfpp #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
+{-# LANGUAGE OverloadedStrings #-}
 
 module TestLanguage where
 
diff --git a/testsuite/TestRoutes.hs b/testsuite/TestRoutes.hs
index 57761a3..8be315f 100644
--- a/testsuite/TestRoutes.hs
+++ b/testsuite/TestRoutes.hs
@@ -5,19 +5,34 @@ module TestRoutes where
 
 import Data.LanguageCodes
 import Data.LanguageCodes.Arbitrary ()
+
+import Data.Text (Text)
+import qualified Data.Text as Text
+
 import Data.Time.Calendar
 
 import Routes
 
 import Test.Framework
+import Test.QuickCheck
 import Test.QuickCheck.Instances ()
 import Test.QuickCheck.Arbitrary.Generic
 
 instance Arbitrary PageFormat where
     arbitrary = genericArbitrary
 
+arbitraryName :: Gen Text
+arbitraryName = Text.pack <$> listOf (elements ['a'..'z'])
+
 instance Arbitrary Sitemap where
-    arbitrary = genericArbitrary
+    arbitrary = oneof [ pure Index
+                      , ArticleView <$> arbitrary <*> arbitraryName
+                      , MetaView <$> arbitraryName <*> arbitrary
+                      , Feed <$> arbitrary
+                      , pure SiteScript
+                      , pure PrintStylesheet
+                      , pure CodeStylesheet
+                      ]
 
 test_index_URL = do
     assertEqual "" (routeURL Index)

From 6f6441de6d53b2d134c847ca317c84c1d0d8f9cf Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 18:27:29 +1100
Subject: [PATCH 06/13] Remove derive dependency

---
 package.yaml                              |  1 -
 src/Types/Content.hs                      | 11 +++++---
 src/Types/Services.hs                     |  6 ++---
 stack.yaml                                |  1 -
 stack.yaml.lock                           |  7 -----
 testsuite/Data/LanguageCodes/Arbitrary.hs | 11 ++++----
 testsuite/TestModels.hs                   | 33 ++++++++++++++---------
 testsuite/TestRoutes.hs                   |  2 +-
 8 files changed, 38 insertions(+), 34 deletions(-)

diff --git a/package.yaml b/package.yaml
index 54659a3..b272820 100644
--- a/package.yaml
+++ b/package.yaml
@@ -67,7 +67,6 @@ tests:
     - multiblog
     - HTF
     - HUnit
-    - derive
     - generic-arbitrary
     - QuickCheck
     - quickcheck-instances
diff --git a/src/Types/Content.hs b/src/Types/Content.hs
index 975ba2e..ba1dd68 100644
--- a/src/Types/Content.hs
+++ b/src/Types/Content.hs
@@ -1,6 +1,7 @@
 {-|
 Types for the blog content - articles and metas.
 -}
+{-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE OverloadedStrings #-}
 
 module Types.Content where
@@ -15,6 +16,8 @@ import Data.Text (Text)
 import Data.Time
 import Data.Yaml
 
+import GHC.Generics (Generic)
+
 import Text.Blaze.Html (Html)
 
 import Text.Pandoc hiding (Meta)
@@ -40,7 +43,7 @@ data Article = Article
     { arSlug :: Text
     , arContent :: LanguageContent
     , arAuthored :: UTCTime
-    } deriving (Eq, Show)
+    } deriving (Eq, Show, Generic)
 
 instance Ord Article where
     a `compare` b = (arAuthored a, arSlug a) `compare` (arAuthored b, arSlug b)
@@ -55,7 +58,7 @@ instance HasSlug Article where
 data Layout
     = BaseLayout
     | PresentationLayout
-    deriving (Eq, Show)
+    deriving (Eq, Show, Generic)
 
 instance FromJSON Layout where
     parseJSON (String v)
@@ -69,7 +72,7 @@ data Meta = Meta
     , mtLayout :: Layout
     , mtExportSlugOverride :: Maybe Text
     , mtContent :: LanguageContent
-    } deriving (Eq, Show)
+    } deriving (Eq, Show, Generic)
 
 mtExportSlug :: Meta -> Text
 mtExportSlug meta = fromMaybe (mtSlug meta) (mtExportSlugOverride meta)
@@ -85,7 +88,7 @@ data Link
     = MetaLink { lnName :: Text }
     | ExternalLink { lnUrl :: Text
                    , lnText :: LanguageString }
-    deriving (Eq, Show)
+    deriving (Eq, Show, Generic)
 
 instance FromJSON Link where
     parseJSON (Object v) =
diff --git a/src/Types/Services.hs b/src/Types/Services.hs
index 0a4be29..68d704e 100644
--- a/src/Types/Services.hs
+++ b/src/Types/Services.hs
@@ -49,7 +49,7 @@ instance FromJSON AppServices where
 
 newtype AppAuth =
     AppAuthTwitter TwitterAuth
-    deriving (Eq, Show)
+    deriving (Eq, Show, Generic)
 
 class ToJSON a => ServiceAuth a where
     toAppAuth :: a -> AppAuth
@@ -59,7 +59,7 @@ class ToJSON a => ServiceAuth a where
 data TwitterAuth = TwitterAuth
     { taToken :: BS.ByteString
     , taSecret :: BS.ByteString
-    } deriving (Eq, Show)
+    } deriving (Eq, Show, Generic)
 
 instance ServiceAuth TwitterAuth where
     toAppAuth = AppAuthTwitter
@@ -98,7 +98,7 @@ instance ToJSON AppAuth where
 data CrossPost = CrossPost
     { cpLanguage :: Language
     , cpServiceDetails :: AppAuth
-    } deriving (Eq, Show)
+    } deriving (Eq, Show, Generic)
 
 type AppCrossPost = [CrossPost]
 
diff --git a/stack.yaml b/stack.yaml
index 929b471..986860c 100644
--- a/stack.yaml
+++ b/stack.yaml
@@ -4,7 +4,6 @@ packages:
 ghc-options:
   '$everything': -threaded
 extra-deps:
-  - derive-2.6.4
   - twitter-conduit-0.3.0
   - twitter-types-0.7.2.2
   - twitter-types-lens-0.7.2
diff --git a/stack.yaml.lock b/stack.yaml.lock
index f399fd5..f242b91 100644
--- a/stack.yaml.lock
+++ b/stack.yaml.lock
@@ -4,13 +4,6 @@
 #   https://docs.haskellstack.org/en/stable/lock_files
 
 packages:
-- completed:
-    hackage: derive-2.6.4@sha256:f697cbe62828b5d777ea148814978940bd8707cb2ad4adff9415fc6139a7c05d,3184
-    pantry-tree:
-      size: 3967
-      sha256: cb33c5025c4629ea5377dd0fc521700cac79f8a88a5d062cfbb0cd7f9f37bcb5
-  original:
-    hackage: derive-2.6.4
 - completed:
     hackage: twitter-conduit-0.3.0@sha256:67b68511fc19563ff4159ae37188ac3db7dbc6603d81f11c6f1c2dd8ec1f5bd8,4318
     pantry-tree:
diff --git a/testsuite/Data/LanguageCodes/Arbitrary.hs b/testsuite/Data/LanguageCodes/Arbitrary.hs
index aa9f470..3af5935 100644
--- a/testsuite/Data/LanguageCodes/Arbitrary.hs
+++ b/testsuite/Data/LanguageCodes/Arbitrary.hs
@@ -1,13 +1,14 @@
-{-# LANGUAGE TemplateHaskell #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 
 module Data.LanguageCodes.Arbitrary where
 
-import Prelude hiding (LT)
+import Data.LanguageCodes (ISO639_1(..), fromChars)
 
-import Data.DeriveTH
-import Data.LanguageCodes (ISO639_1(..))
+import Data.Maybe
 
 import Test.QuickCheck
 
-derive makeArbitrary ''ISO639_1
+instance Arbitrary ISO639_1 where
+    arbitrary = elements $ catMaybes $ fromChars <$> letter <*> letter
+        where
+            letter = ['a'..'z']
diff --git a/testsuite/TestModels.hs b/testsuite/TestModels.hs
index 98e80dd..a73ea4d 100644
--- a/testsuite/TestModels.hs
+++ b/testsuite/TestModels.hs
@@ -6,8 +6,6 @@
 
 module TestModels where
 
-import Data.DeriveTH
-
 import Data.LanguageCodes.Arbitrary ()
 
 import qualified Data.Map as M
@@ -22,17 +20,23 @@ import Types.Content
 import Types.Services
 
 import Test.Framework
+import Test.QuickCheck.Arbitrary.Generic
 import Test.QuickCheck.Instances ()
 
-derive makeArbitrary ''Article
+instance Arbitrary Article where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''Layout
+instance Arbitrary Layout where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''Meta
+instance Arbitrary Meta where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''Link
+instance Arbitrary Link where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''Analytics
+instance Arbitrary Analytics where
+    arbitrary = genericArbitrary
 
 instance Arbitrary TW.OAuth where
     arbitrary = do
@@ -44,15 +48,20 @@ instance Arbitrary TW.OAuth where
             , TW.oauthConsumerSecret = secret
             }
 
-derive makeArbitrary ''AppServices
+instance Arbitrary AppServices where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''TwitterAuth
+instance Arbitrary TwitterAuth where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''AppAuth
+instance Arbitrary AppAuth where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''CrossPost
+instance Arbitrary CrossPost where
+    arbitrary = genericArbitrary
 
-derive makeArbitrary ''AppData
+instance Arbitrary AppData where
+    arbitrary = genericArbitrary
 
 fall :: [a] -> (a -> Bool) -> Bool
 fall = flip all
diff --git a/testsuite/TestRoutes.hs b/testsuite/TestRoutes.hs
index 8be315f..b2cfef7 100644
--- a/testsuite/TestRoutes.hs
+++ b/testsuite/TestRoutes.hs
@@ -15,8 +15,8 @@ import Routes
 
 import Test.Framework
 import Test.QuickCheck
-import Test.QuickCheck.Instances ()
 import Test.QuickCheck.Arbitrary.Generic
+import Test.QuickCheck.Instances ()
 
 instance Arbitrary PageFormat where
     arbitrary = genericArbitrary

From 7203d8da81a1d09b50da4a9a0792f1aa795576fe Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 21:02:50 +1100
Subject: [PATCH 07/13] Fix routing with query parameters

---
 src/Routes.hs | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/src/Routes.hs b/src/Routes.hs
index 8827d28..35f81e6 100644
--- a/src/Routes.hs
+++ b/src/Routes.hs
@@ -15,6 +15,8 @@ import Data.Text (Text)
 import qualified Data.Text as Text
 import Data.Time
 
+import Debug.Trace
+
 import GHC.Generics
 
 import Text.Read
@@ -71,7 +73,7 @@ readText :: Read a => Text -> Maybe a
 readText = readMaybe . Text.unpack
 
 parseURL :: Text -> Maybe Sitemap
-parseURL = parseSegments . splitNonEmpty "/"
+parseURL = parseSegments . splitNonEmpty "/" . dropQueryParams
     where
         parseSegments [] = Just Index
         parseSegments [metaText] = case splitNonEmpty "." metaText of
@@ -95,6 +97,7 @@ parseURL = parseSegments . splitNonEmpty "/"
                                                    date <- fromGregorianValid year month day
                                                    pure $ ArticleView date text
         parseArticle _ _ = Nothing
+        dropQueryParams = Text.takeWhile (/= '?')
 
 -- Join a basename and extension together
 joinExt :: Text -> Maybe Text -> Text

From c1ce5b3889c28beb62b35e22aa1970ba939467c9 Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 21:15:35 +1100
Subject: [PATCH 08/13] Fix tests for asset locations

---
 testsuite/Integration/TestHome.hs | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/testsuite/Integration/TestHome.hs b/testsuite/Integration/TestHome.hs
index 3fcbfa2..38e4a26 100644
--- a/testsuite/Integration/TestHome.hs
+++ b/testsuite/Integration/TestHome.hs
@@ -53,10 +53,10 @@ test_home_next_page = do
 
 test_css :: IO ()
 test_css = do
-    css <- makeRequestText $ simpleRequest "/code.css"
+    css <- makeRequestText $ simpleRequest "/assets/code.css"
     assertTextContains "color" css
 
 test_js :: IO ()
 test_js = do
-    js <- makeRequestText $ simpleRequest "/site.js"
+    js <- makeRequestText $ simpleRequest "/assets/site.js"
     assertTextContains "function" js

From 14ec1259f4cc4bcb492cfcac65547f90bd13aca8 Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 21:33:37 +1100
Subject: [PATCH 09/13] Add monadic context back to routes

---
 src/App.hs          |  4 ++--
 src/CrossPost.hs    |  2 +-
 src/Views.hs        | 43 +++++++++++++++++++++++--------------------
 src/Views/Export.hs |  4 ++--
 src/Views/Feed.hs   |  6 +++---
 5 files changed, 31 insertions(+), 28 deletions(-)

diff --git a/src/App.hs b/src/App.hs
index c358f70..66cc85f 100644
--- a/src/App.hs
+++ b/src/App.hs
@@ -155,10 +155,10 @@ feedIndex language = do
     feedDisplay language sorted >>= okResponse
 
 siteScript :: AppPart Response
-siteScript = okResponse renderSiteScript
+siteScript = renderSiteScript >>= okResponse
 
 printStylesheet :: AppPart Response
-printStylesheet = okResponse renderPrintStylesheet
+printStylesheet = renderPrintStylesheet >>= okResponse
 
 codeStylesheet :: AppPart Response
 codeStylesheet = okResponse renderCodeStylesheet
diff --git a/src/CrossPost.hs b/src/CrossPost.hs
index cc0caeb..b7cee35 100644
--- a/src/CrossPost.hs
+++ b/src/CrossPost.hs
@@ -67,7 +67,7 @@ crossPostTwitter = do
             let lpref = singleLanguage credLang
             forM unposted $ \art -> do
                 let title = langTitle lpref art
-                let articleLink = linkTo art
+                articleLink <- linkTo art
                 let content = title <> " " <> address <> articleLink
                 doCall $ update content
     return ()
diff --git a/src/Views.hs b/src/Views.hs
index de8e0c9..d2a1487 100644
--- a/src/Views.hs
+++ b/src/Views.hs
@@ -81,11 +81,10 @@ paginate size page allItems = Paginated prev items next
         | null rest = Nothing
         | otherwise = Just (page + 1)
 
-convRender :: (url -> [(a, Maybe b)] -> c) -> url -> [(a, b)] -> c
-convRender maybeF url params = maybeF url $ map (A.second Just) params
-
-render :: HtmlUrl Sitemap -> Markup
-render html = html perhapsRoute
+render :: MonadReader AppData m => HtmlUrl Sitemap -> m Markup
+render html = do
+    r <- routeURLParams
+    pure $ html r
 
 askLangStringFn ::
        MonadReader AppData m => LanguagePreference -> m (Text -> Text)
@@ -113,7 +112,7 @@ linkDestination ::
 linkDestination (ExternalLink url _) = pure url
 linkDestination (MetaLink slug) = do
     meta <- askMeta slug
-    pure $ perhapsRoute (link meta) []
+    linkTo meta
 
 template ::
        (MonadReader AppData m, MonadPlus m)
@@ -132,9 +131,9 @@ template lang page = do
     analyticsIDs <- asks appAnalytics
     let analytics = $(hamletFile "templates/analytics.hamlet")
     case pcLayout page of
-        BaseLayout -> pure $ render $(hamletFile "templates/base.hamlet")
+        BaseLayout -> render $(hamletFile "templates/base.hamlet")
         PresentationLayout ->
-            pure $ render $(hamletFile "templates/base_presentation.hamlet")
+            render $(hamletFile "templates/base_presentation.hamlet")
 
 articleListDisplay ::
        (MonadReader AppData m, MonadPlus m)
@@ -142,7 +141,7 @@ articleListDisplay ::
     -> Paginated Article
     -> m Markup
 articleListDisplay lang articles = do
-    let articlesContent = map (linkedContent lang) (pageItems articles)
+    articlesContent <- mapM (linkedContent lang) (pageItems articles)
     langString <- askLangStringFn lang
     template lang $ def {pcContent = $(hamletFile "templates/list.hamlet")}
 
@@ -178,16 +177,20 @@ metaDisplay lang meta =
                 $(hamletFile "templates/meta_presentation.hamlet")
 
 -- Generate a link to some content
-linkTo :: (Linkable a) => a -> Text
-linkTo a = perhapsRoute (link a) []
+linkTo :: (MonadReader AppData m, Linkable a) => a -> m Text
+linkTo a = do
+    r <- routeURLParams
+    pure $ r (link a) []
 
 -- Modify the content to have a link to itself and have no anchors
 linkedContent ::
-       (HasContent a, Linkable a)
+       (MonadReader AppData m, HasContent a, Linkable a)
     => LanguagePreference
     -> a
-    -> Pandoc
-linkedContent lang a = linkedHeader (linkTo a) $ langContent lang a
+    -> m Pandoc
+linkedContent lang a = do
+    lnk <- linkTo a
+    pure $ linkedHeader lnk $ langContent lang a
 
 -- Modify the first header to be a link to a given place
 -- and remove all anchors from headers
@@ -209,14 +212,14 @@ linkedHeader target doc = evalState (walkM linkHeader doc) True
         return $ Header n ("", [], []) text'
     linkHeader x = return x
 
-perhapsRoute :: Render Sitemap
-perhapsRoute r _ = routeURL r
+routeURLParams :: MonadReader AppData m => m (Render Sitemap)
+routeURLParams = pure $ \r _ -> routeURL r
 
-renderSiteScript :: JavaScript
-renderSiteScript = JavaScript $ renderJavascriptUrl perhapsRoute $(juliusFile "templates/site.julius")
+renderSiteScript :: MonadReader AppData m => m JavaScript
+renderSiteScript = routeURLParams >>= \r -> pure $ JavaScript $ renderJavascriptUrl r $(juliusFile "templates/site.julius")
 
-renderPrintStylesheet :: Stylesheet
-renderPrintStylesheet = Stylesheet $ renderCssUrl perhapsRoute $(luciusFile "templates/print.lucius")
+renderPrintStylesheet :: MonadReader AppData m => m Stylesheet
+renderPrintStylesheet = routeURLParams >>= \r -> pure $ Stylesheet $ renderCssUrl r $(luciusFile "templates/print.lucius")
 
 renderCodeStylesheet :: Stylesheet
 renderCodeStylesheet = Stylesheet $ TL.pack $ styleToCss highlightingStyle
diff --git a/src/Views/Export.hs b/src/Views/Export.hs
index a0c78f4..9c98ecc 100644
--- a/src/Views/Export.hs
+++ b/src/Views/Export.hs
@@ -67,7 +67,7 @@ metaExportFileName format meta = Text.intercalate "." [metaName, fileExtension f
 
 -- Export a PDF using wkhtmltopdf
 pdfExport ::
-       (MonadState AppCache m, MonadIO m)
+       (MonadReader AppData m, MonadState AppCache m, MonadIO m)
     => LanguagePreference
     -> Meta
     -> m (Export LB.ByteString)
@@ -76,7 +76,7 @@ pdfExport lang meta =
     withCacheM (bestLanguage lang, mtSlug meta) $ do
         let content = runPandocPure' $ writeHtml $ langContent lang meta
         let title = langTitle lang meta
-        let html = render $(hamletFile "templates/pdf-export.hamlet")
+        html <- render $(hamletFile "templates/pdf-export.hamlet")
         let htmlText = TextRenderer.renderMarkup html
         let fixedHtmlText = fixupHtml htmlText
         wkhtmltopdf $ encodeUtf8 fixedHtmlText
diff --git a/src/Views/Feed.hs b/src/Views/Feed.hs
index 115ed7f..296b0ee 100644
--- a/src/Views/Feed.hs
+++ b/src/Views/Feed.hs
@@ -64,7 +64,7 @@ articleEntry ::
     -> m Entry
 articleEntry lang article = do
     let lpref = singleLanguage lang
-    let articleLink = linkTo article
+    articleLink <- linkTo article
     authorName <- askLangString lpref "authorName"
     let entry =
             nullEntry
@@ -89,11 +89,11 @@ feedDisplay ::
 feedDisplay lang articles = do
     siteName <- askLangString (singleLanguage lang) "siteName"
     -- TODO: Web.Routes generate a link without the trailing slash
-    let home = linkTo Index <> "/"
+    home <- (<> "/") <$> linkTo Index
     let lastUpdated = arAuthored $ head articles
     let blankFeed = nullFeed home (TextString siteName) (atomDate lastUpdated)
     entries <- mapM (articleEntry lang) articles
-    let selfAddress = linkTo $ Routes.Feed lang
+    selfAddress <- linkTo $ Routes.Feed lang
     let selfLink = (nullLink selfAddress) {linkRel = Just $ Left "self"}
     let feed = blankFeed {feedEntries = entries, feedLinks = [selfLink]}
     pure $ toResponse $ AtomFeed feed

From 88bb30d88d65b67c352872917e8d7b42810f6f33 Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 21:36:37 +1100
Subject: [PATCH 10/13] Prepend site address to links

---
 src/Views.hs | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/src/Views.hs b/src/Views.hs
index d2a1487..364cbff 100644
--- a/src/Views.hs
+++ b/src/Views.hs
@@ -213,7 +213,9 @@ linkedHeader target doc = evalState (walkM linkHeader doc) True
     linkHeader x = return x
 
 routeURLParams :: MonadReader AppData m => m (Render Sitemap)
-routeURLParams = pure $ \r _ -> routeURL r
+routeURLParams = do
+    address <- asks appAddress
+    pure $ \r _ -> address <> routeURL r
 
 renderSiteScript :: MonadReader AppData m => m JavaScript
 renderSiteScript = routeURLParams >>= \r -> pure $ JavaScript $ renderJavascriptUrl r $(juliusFile "templates/site.julius")

From adc8c0142656574810225e755c9e93e8785ebf85 Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 21:37:00 +1100
Subject: [PATCH 11/13] Remove obsolete test

---
 testsuite/Integration/TestMeta.hs | 5 -----
 1 file changed, 5 deletions(-)

diff --git a/testsuite/Integration/TestMeta.hs b/testsuite/Integration/TestMeta.hs
index 42873f7..8a9abb2 100644
--- a/testsuite/Integration/TestMeta.hs
+++ b/testsuite/Integration/TestMeta.hs
@@ -17,11 +17,6 @@ test_meta = do
     meta <- makeRequestText $ simpleRequest "/meta"
     assertTextContains "<h1>Test Meta</h1>" meta
 
-test_meta_html :: IO ()
-test_meta_html = do
-    meta <- makeRequestText $ simpleRequest "/meta.html"
-    assertTextContains "<h1>Test Meta</h1>" meta
-
 test_meta_pdf :: IO ()
 test_meta_pdf = do
     meta_pdf <- makeRequest $ simpleRequest "/meta.pdf"

From 1356906c3ec0ae0b4d0ab49f7fe28e0d952d29ef Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 21:39:17 +1100
Subject: [PATCH 12/13] Disallow empty article/meta names in tests

---
 testsuite/TestRoutes.hs | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/testsuite/TestRoutes.hs b/testsuite/TestRoutes.hs
index b2cfef7..b163bf0 100644
--- a/testsuite/TestRoutes.hs
+++ b/testsuite/TestRoutes.hs
@@ -22,7 +22,7 @@ instance Arbitrary PageFormat where
     arbitrary = genericArbitrary
 
 arbitraryName :: Gen Text
-arbitraryName = Text.pack <$> listOf (elements ['a'..'z'])
+arbitraryName = Text.pack <$> listOf1 (elements ['a'..'z'])
 
 instance Arbitrary Sitemap where
     arbitrary = oneof [ pure Index

From 033914b5e29571b05494f55bd878dc7cad05125b Mon Sep 17 00:00:00 2001
From: Alexey Kotlyarov <a@koterpillar.com>
Date: Tue, 11 Feb 2020 22:12:19 +1100
Subject: [PATCH 13/13] hlint

---
 src/Types/Language.hs   | 2 +-
 src/Views.hs            | 4 +---
 testsuite/TestModels.hs | 2 --
 testsuite/TestRoutes.hs | 3 +--
 4 files changed, 3 insertions(+), 8 deletions(-)

diff --git a/src/Types/Language.hs b/src/Types/Language.hs
index 5eee9fc..2f3c34f 100644
--- a/src/Types/Language.hs
+++ b/src/Types/Language.hs
@@ -39,7 +39,7 @@ instance A.FromJSON ISO639_1 where
     parseJSON _ = mzero
 
 instance A.FromJSONKey ISO639_1 where
-    fromJSONKey = A.FromJSONKeyTextParser $ parseLanguageM
+    fromJSONKey = A.FromJSONKeyTextParser parseLanguageM
 
 -- | Newtype for parsing either a single value or a map of values
 newtype LanguageChoices a =
diff --git a/src/Views.hs b/src/Views.hs
index 364cbff..5960b60 100644
--- a/src/Views.hs
+++ b/src/Views.hs
@@ -82,9 +82,7 @@ paginate size page allItems = Paginated prev items next
         | otherwise = Just (page + 1)
 
 render :: MonadReader AppData m => HtmlUrl Sitemap -> m Markup
-render html = do
-    r <- routeURLParams
-    pure $ html r
+render html = html <$> routeURLParams
 
 askLangStringFn ::
        MonadReader AppData m => LanguagePreference -> m (Text -> Text)
diff --git a/testsuite/TestModels.hs b/testsuite/TestModels.hs
index a73ea4d..59e8d97 100644
--- a/testsuite/TestModels.hs
+++ b/testsuite/TestModels.hs
@@ -1,8 +1,6 @@
 {-# OPTIONS_GHC -F -pgmF htfpp #-}
 {-# OPTIONS_GHC -fno-warn-orphans #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell #-}
 
 module TestModels where
 
diff --git a/testsuite/TestRoutes.hs b/testsuite/TestRoutes.hs
index b163bf0..ddc5cd5 100644
--- a/testsuite/TestRoutes.hs
+++ b/testsuite/TestRoutes.hs
@@ -49,8 +49,7 @@ test_meta_URL = do
     assertEqual (Just $ MetaView "meta" Nothing) (parseURL "/meta/")
     assertEqual "/meta.pdf" (routeURL $ MetaView "meta" (Just Pdf))
 
-test_feed_URL = do
-    assertEqual "/feed/en" (routeURL $ Feed EN)
+test_feed_URL = assertEqual "/feed/en" (routeURL $ Feed EN)
 
 prop_routeURL_parseURL route =
     let url = routeURL route