Add pages for categories

src/Main.hs

@@ -4,6 +4,7 @@ ScopedTypeVariables,
 TypeFamilies,
 DataKinds,
 MultiWayIf,
+ViewPatterns,
 NoImplicitPrelude
   #-}
 
@@ -305,6 +306,23 @@ main = do
       -- Donation page
       Spock.get "donate" $ do
         lucid $ renderDonate
+      -- Category pages
+      Spock.get var $ \path -> do
+        -- The links look like /generating-feeds-gao238b1 (because it's nice
+        -- when you can find out where a link leads just by looking at it)
+        let (T.init -> urlSlug, catId) = T.breakOnEnd "-" path
+        when (T.null catId) $
+          Spock.jumpNext
+        mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
+        case mbCategory of
+          Nothing -> Spock.jumpNext
+          Just category -> do
+            let slug = makeSlug (category^.title)
+            -- If the slug in the url is old or something (i.e. if it doesn't
+            -- match the one we would've generated now), let's do a redirect
+            when (urlSlug /= slug) $
+              Spock.redirect (format "/{}-{}" (slug, category^.uid))
+            lucid $ renderCategoryPage category
       -- The add/set methods return rendered parts of the structure (added
       -- categories, changed items, etc) so that the Javascript part could
       -- take them and inject into the page. We don't want to duplicate

src/Types.hs

@@ -46,7 +46,7 @@ module Types
   -- ** query
   GetGlobalState(..),
   GetCategories(..),
-  GetCategory(..),
+  GetCategory(..), GetCategoryMaybe(..),
   GetCategoryByItem(..),
   GetItem(..),
   GetTrait(..),
@@ -345,6 +345,9 @@ getCategories = view categories
 getCategory :: Uid -> Acid.Query GlobalState Category
 getCategory uid' = view (categoryById uid')
 
+getCategoryMaybe :: Uid -> Acid.Query GlobalState (Maybe Category)
+getCategoryMaybe uid' = preview (categoryById uid')
+
 getCategoryByItem :: Uid -> Acid.Query GlobalState Category
 getCategoryByItem uid' = view (categoryByItem uid')
 
@@ -559,7 +562,7 @@ makeAcidic ''GlobalState [
   -- queries
   'getGlobalState,
   'getCategories,
-  'getCategory,
+  'getCategory, 'getCategoryMaybe,
   'getCategoryByItem,
   'getItem,
   'getTrait,

src/Utils.hs

@@ -21,6 +21,7 @@ module Utils
   -- * URLs
   Url,
   sanitiseUrl,
+  makeSlug,
 
   -- * UID
   Uid(..),
@@ -94,6 +95,15 @@ sanitiseUrl u
   | "https:" `T.isPrefixOf` u = Just u
   | otherwise                 = Just ("http://" <> u)
 
+-- | Make text suitable for inclusion into an URL (by turning spaces into
+-- hyphens and so on)
+makeSlug :: Text -> Text
+makeSlug =
+  T.intercalate "-" . T.words .
+  T.map toLower .
+  T.filter (\c -> isLetter c || isDigit c || c == ' ' || c == '-') .
+  T.map (\x -> if x == '_' then '-' else x)
+
 -- | Unique id, used for many things – categories, items, and anchor ids.
 newtype Uid = Uid {uidToText :: Text}
   deriving (Eq, Show, PathPiece, Format.Buildable, Data)

src/View.hs

@@ -12,6 +12,7 @@ module View
   -- * Pages
   renderRoot,
   renderDonate,
+  renderCategoryPage,
 
   -- * Tracking
   renderTracking,
@@ -89,9 +90,65 @@ instead of simple
 -}
 
 renderRoot :: GlobalState -> Maybe Text -> HtmlT IO ()
-renderRoot globalState mbSearchQuery = doctypehtml_ $ do
+renderRoot globalState mbSearchQuery =
+  wrapPage "Aelve Guide" $ do
+    renderHelp
+    onPageLoad $ JS.showOrHideHelp (JS.selectId "help", helpVersion)
+    form_ $ do
+      input_ [type_ "text", name_ "q", id_ "search", placeholder_ "search",
+              value_ (fromMaybe "" mbSearchQuery)]
+    textInput [
+      placeholder_ "add a category",
+      autocomplete_ "off",
+      onEnter $ JS.addCategory (JS.selectId "categories", inputValue) <>
+                clearInput ]
+    -- TODO: sort categories by popularity, somehow? or provide a list of
+    -- “commonly used categories” or even a nested catalog
+    case mbSearchQuery of
+      Nothing -> renderCategoryList (globalState^.categories)
+      Just query' -> do
+        let queryWords = T.words query'
+        let rank :: Category -> Int
+            rank cat = sum [
+              length (queryWords `intersect` (cat^..items.each.name)),
+              length (queryWords `intersect` T.words (cat^.title)) ]
+        let rankedCategories
+              | null queryWords = globalState^.categories
+              | otherwise       = filter ((/= 0) . rank) .
+                                  reverse . sortOn rank
+                                    $ globalState^.categories
+        renderCategoryList rankedCategories
+    -- TODO: maybe add a button like “give me random category that is
+    -- unfinished”
+
+-- TODO: when submitting a text field, gray it out (but leave it selectable)
+-- until it's been submitted
+
+renderTracking :: HtmlT IO ()
+renderTracking = do
+  trackingEnabled <- (== Just "1") <$> liftIO (lookupEnv "GUIDE_TRACKING")
+  when trackingEnabled $ do
+    tracking <- liftIO $ T.readFile "static/tracking.html"
+    toHtmlRaw tracking
+
+-- TODO: include jQuery locally so that it'd be possible to test the site
+-- without internet
+
+renderDonate :: HtmlT IO ()
+renderDonate = doctypehtml_ $ do
   head_ $ do
-    title_ "Aelve Guide"
+    title_ "Donate to Artyom"
+    includeCSS "/css.css"
+    renderTracking
+
+  body_ $
+    toHtmlRaw =<< liftIO (readFile "static/donate.html")
+
+-- Include all the necessary things
+wrapPage :: Text -> HtmlT IO () -> HtmlT IO ()
+wrapPage pageTitle page = doctypehtml_ $ do
+  head_ $ do
+    title_ (toHtml pageTitle)
     let cdnjs = "https://cdnjs.cloudflare.com/ajax/libs/"
     includeJS (cdnjs <> "jquery/2.2.0/jquery.min.js")
     -- See Note [autosize]
@@ -127,35 +184,9 @@ renderRoot globalState mbSearchQuery = doctypehtml_ $ do
         Javascript, but since all editing needs Javascript to work,
         you won't be able to edit anything.
         |]
-    renderHelp
-    onPageLoad $ JS.showOrHideHelp (JS.selectId "help", helpVersion)
-    form_ $ do
-      input_ [type_ "text", name_ "q", id_ "search", placeholder_ "search",
-              value_ (fromMaybe "" mbSearchQuery)]
-    textInput [
-      placeholder_ "add a category",
-      autocomplete_ "off",
-      onEnter $ JS.addCategory (JS.selectId "categories", inputValue) <>
-                clearInput ]
-    -- TODO: sort categories by popularity, somehow? or provide a list of
-    -- “commonly used categories” or even a nested catalog
-    case mbSearchQuery of
-      Nothing -> renderCategoryList (globalState^.categories)
-      Just query' -> do
-        let queryWords = T.words query'
-        let rank :: Category -> Int
-            rank cat = sum [
-              length (queryWords `intersect` (cat^..items.each.name)),
-              length (queryWords `intersect` T.words (cat^.title)) ]
-        let rankedCategories
-              | null queryWords = globalState^.categories
-              | otherwise       = filter ((/= 0) . rank) .
-                                  reverse . sortOn rank
-                                    $ globalState^.categories
-        renderCategoryList rankedCategories
-    -- TODO: perhaps use infinite scrolling/loading?
-    -- TODO: maybe add a button like “give me random category that is
-    -- unfinished”
+
+    page
+
     div_ [id_ "footer"] $ do
       "made by " >> a_ [href_ "https://artyom.me"] "Artyom"
       emptySpan "2em"
@@ -166,28 +197,10 @@ renderRoot globalState mbSearchQuery = doctypehtml_ $ do
       a_ [href_ "/donate"] "donate"
       sup_ [style_ "font-size:50%"] "I don't have a job"
 
--- TODO: when submitting a text field, gray it out (but leave it selectable)
--- until it's been submitted
-
-renderTracking :: HtmlT IO ()
-renderTracking = do
-  trackingEnabled <- (== Just "1") <$> liftIO (lookupEnv "GUIDE_TRACKING")
-  when trackingEnabled $ do
-    tracking <- liftIO $ T.readFile "static/tracking.html"
-    toHtmlRaw tracking
-
--- TODO: include jQuery locally so that it'd be possible to test the site
--- without internet
-
-renderDonate :: HtmlT IO ()
-renderDonate = doctypehtml_ $ do
-  head_ $ do
-    title_ "Donate to Artyom"
-    includeCSS "/css.css"
-    renderTracking
-
-  body_ $
-    toHtmlRaw =<< liftIO (readFile "static/donate.html")
+renderCategoryPage :: Category -> HtmlT IO ()
+renderCategoryPage category =
+  wrapPage ("Aelve Guide – " <> category^.title) $ do
+    renderCategory category
 
 -- TODO: allow archiving items if they are in every way worse than the rest,
 -- or something (but searching should still be possible)
@@ -234,14 +247,11 @@ renderCategoryTitle :: Category -> HtmlT IO ()
 renderCategoryTitle category = do
   let thisId = "category-title-" <> uidToText (category^.uid)
       this   = JS.selectId thisId
-  -- TODO: once pagination or something is implemented, we'll have to see
-  -- whether an anchor has been used in the query string and load the
-  -- necessary category if so
   h2_ [id_ thisId] $ do
-    a_ [class_ "anchor", href_ ("/#" <> uidToText (category^.uid))] "#"
-
     sectionSpan "normal" [shown, noScriptShown] $ do
-      toHtml (category^.title)
+      let slug = makeSlug (category^.title)
+      a_ [href_ (format "/{}-{}" (slug, category^.uid))] $
+        toHtml (category^.title)
       emptySpan "1em"
       textButton "edit" $
         JS.switchSection (this, "editing" :: Text)
@@ -666,9 +676,6 @@ clearInput = JS "this.value = '';"
 onFormSubmit :: (JS -> JS) -> Attribute
 onFormSubmit f = onsubmit_ $ format "{} return false;" [f (JS "this")]
 
--- TODO: make links to categories look like id/category-name (where
--- category-name doesn't matter)
-
 button :: Text -> [Attribute] -> JS -> HtmlT IO ()
 button value attrs handler =
   input_ (type_ "button" : value_ value : onclick_ handler' : attrs)