Merge branch 'master' into front-ps

.gitignore

@@ -25,6 +25,9 @@ state/
 config.json
 
 # IDE/support
+.idea/
+.ideaHaskellLib/
+guide.iml
 .vscode/
 tags
 

favicon/gen.hs

@@ -1,7 +1,5 @@
-{-# LANGUAGE
+{-# LANGUAGE FlexibleContexts #-}
-FlexibleContexts,
+{-# LANGUAGE GADTs #-}
-GADTs
-  #-}
 
 -- run as: ./gen -o favicon.png -w 32 -h 32
 

guide.cabal

@@ -76,6 +76,7 @@ library
         Guide.Views.Utils.Input
     Guide.Cache
     Guide.Api.ClientTypes
+    Guide.Routes
   other-modules:
     Imports
   build-depends:       Spock
@@ -110,6 +111,8 @@ library
                      , hashable
                      , haskell-src-meta
                      , http-api-data
+                     , http-client
+                     , http-client-tls
                      , http-types
                      , hvect
                      , ilist
@@ -139,6 +142,7 @@ library
                      , text-all >= 0.4.1.0 && < 0.5
                      , time >= 1.5
                      , transformers
+                     , uniplate
                      , unix
                      , utf8-string
                      , vector

src/Guide/Handlers.hs

@@ -28,7 +28,7 @@ import qualified Text.Atom.Feed  as Atom
 import qualified Data.Text.All as T
 import qualified Data.Text.Lazy.All as TL
 -- Web
-import Web.Spock hiding (head, get, text)
+import Web.Spock hiding (head, get, renderRoute, text)
 import qualified Web.Spock as Spock
 import Web.Spock.Lucid
 import Network.Wai.Middleware.Cors
@@ -46,6 +46,7 @@ import Guide.Types
 import Guide.Api.ClientTypes (toCGrandCategory, toCCategoryDetail)
 import Guide.Utils
 import Guide.Views
+import Guide.Routes
 
 methods :: GuideM ctx ()
 methods = do
@@ -67,40 +68,40 @@ apiMethods = Spock.subcomponent "api" $ do
     json $ toCCategoryDetail cat
 
 renderMethods :: GuideM ctx ()
-renderMethods = Spock.subcomponent "render" $ do
+renderMethods = do
   -- Notes for a category
-  Spock.get (categoryVar <//> "notes") $ \catId -> do
+  Spock.get (renderRoute <//> categoryVar <//> "notes") $ \catId -> do
     category <- dbQuery (GetCategory catId)
     lucidIO $ renderCategoryNotes category
   -- Item colors
-  Spock.get (itemVar <//> "colors") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "colors") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     category <- dbQuery (GetCategoryByItem itemId)
     let hue = getItemHue category item
     json $ M.fromList [("light" :: Text, hueToLightColor hue),
                        ("dark" :: Text, hueToDarkColor hue)]
   -- Item info
-  Spock.get (itemVar <//> "info") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "info") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     category <- dbQuery (GetCategoryByItem itemId)
     lucidIO $ renderItemInfo category item
   -- Item description
-  Spock.get (itemVar <//> "description") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "description") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     lucidIO $ renderItemDescription item
   -- Item ecosystem
-  Spock.get (itemVar <//> "ecosystem") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     lucidIO $ renderItemEcosystem item
   -- Item notes
-  Spock.get (itemVar <//> "notes") $ \itemId -> do
+  Spock.get (renderRoute <//> itemVar <//> "notes") $ \itemId -> do
     item <- dbQuery (GetItem itemId)
     category <- dbQuery (GetCategoryByItem itemId)
     lucidIO $ renderItemNotes category item
 
 setMethods :: GuideM ctx ()
-setMethods = Spock.subcomponent "set" $ do
+setMethods = do
-  Spock.post (categoryVar <//> "info") $ \catId -> do
+  Spock.post (setRoute <//> categoryVar <//> "info") $ \catId -> do
     -- TODO: [easy] add a cross-link saying where the form is handled in the
     -- code and other notes saying where stuff is rendered, etc
     title' <- T.strip <$> param' "title"
@@ -143,7 +144,7 @@ setMethods = Spock.subcomponent "set" $ do
     category <- dbQuery (GetCategory catId)
     lucidIO $ renderCategoryInfo category
   -- Notes for a category
-  Spock.post (categoryVar <//> "notes") $ \catId -> do
+  Spock.post (setRoute <//> categoryVar <//> "notes") $ \catId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (notes.mdText) <$> dbQuery (GetCategory catId)
@@ -160,7 +161,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Item info
-  Spock.post (itemVar <//> "info") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "info") $ \itemId -> do
     -- TODO: [easy] add a cross-link saying where the form is handled in the
     -- code and other notes saying where stuff is rendered, etc
     name' <- T.strip <$> param' "name"
@@ -206,7 +207,7 @@ setMethods = Spock.subcomponent "set" $ do
     category <- dbQuery (GetCategoryByItem itemId)
     lucidIO $ renderItemInfo category item
   -- Item description
-  Spock.post (itemVar <//> "description") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "description") $ \itemId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (description.mdText) <$> dbQuery (GetItem itemId)
@@ -223,7 +224,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Item ecosystem
-  Spock.post (itemVar <//> "ecosystem") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "ecosystem") $ \itemId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId)
@@ -240,7 +241,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Item notes
-  Spock.post (itemVar <//> "notes") $ \itemId -> do
+  Spock.post (setRoute <//> itemVar <//> "notes") $ \itemId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (notes.mdText) <$> dbQuery (GetItem itemId)
@@ -258,7 +259,7 @@ setMethods = Spock.subcomponent "set" $ do
           ("modified" :: Text, modified),
           ("merged" :: Text, merge original content' modified)]
   -- Trait
-  Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
+  Spock.post (setRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
     original <- param' "original"
     content' <- param' "content"
     modified <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId)
@@ -276,9 +277,9 @@ setMethods = Spock.subcomponent "set" $ do
           ("merged" :: Text, merge original content' modified)]
 
 addMethods :: GuideM ctx ()
-addMethods = Spock.subcomponent "add" $ do
+addMethods = do
   -- New category
-  Spock.post "category" $ do
+  Spock.post (addRoute <//> "category") $ do
     title' <- param' "content"
     -- If the category exists already, don't create it
     cats <- view categories <$> dbQuery GetGlobalState
@@ -296,7 +297,7 @@ addMethods = Spock.subcomponent "add" $ do
     Spock.text ("/haskell/" <> categorySlug category)
 
   -- New item in a category
-  Spock.post (categoryVar <//> "item") $ \catId -> do
+  Spock.post (addRoute <//> categoryVar <//> "item") $ \catId -> do
     name' <- param' "name"
     -- TODO: do something if the category doesn't exist (e.g. has been
     -- already deleted)
@@ -313,7 +314,7 @@ addMethods = Spock.subcomponent "add" $ do
     category <- dbQuery (GetCategory catId)
     lucidIO $ renderItem category newItem
   -- Pro (argument in favor of an item)
-  Spock.post (itemVar <//> "pro") $ \itemId -> do
+  Spock.post (addRoute <//> itemVar <//> "pro") $ \itemId -> do
     content' <- param' "content"
     traitId <- randomLongUid
     (edit, newTrait) <- dbUpdate (AddPro itemId traitId content')
@@ -321,7 +322,7 @@ addMethods = Spock.subcomponent "add" $ do
     addEdit edit
     lucidIO $ renderTrait itemId newTrait
   -- Con (argument against an item)
-  Spock.post (itemVar <//> "con") $ \itemId -> do
+  Spock.post (addRoute <//> itemVar <//> "con") $ \itemId -> do
     content' <- param' "content"
     traitId <- randomLongUid
     (edit, newTrait) <- dbUpdate (AddCon itemId traitId content')
@@ -332,34 +333,32 @@ addMethods = Spock.subcomponent "add" $ do
 otherMethods :: GuideM ctx ()
 otherMethods = do
   -- Moving things
-  Spock.subcomponent "move" $ do
   -- Move item
-    Spock.post itemVar $ \itemId -> do
+  Spock.post (moveRoute <//> itemVar) $ \itemId -> do
     direction :: Text <- param' "direction"
     uncache (CacheItem itemId) $ do
       edit <- dbUpdate (MoveItem itemId (direction == "up"))
       addEdit edit
   -- Move trait
-    Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
+  Spock.post (moveRoute <//> itemVar <//> traitVar) $ \itemId traitId -> do
     direction :: Text <- param' "direction"
     uncache (CacheItemTraits itemId) $ do
       edit <- dbUpdate (MoveTrait itemId traitId (direction == "up"))
       addEdit edit
 
-  -- Deleting things
+-- Deleting things
-  Spock.subcomponent "delete" $ do
   -- Delete category
-    Spock.post categoryVar $ \catId ->
+  Spock.post (deleteRoute <//> categoryVar) $ \catId ->
     uncache (CacheCategory catId) $ do
       mbEdit <- dbUpdate (DeleteCategory catId)
       mapM_ addEdit mbEdit
   -- Delete item
-    Spock.post itemVar $ \itemId ->
+  Spock.post (deleteRoute <//> itemVar) $ \itemId ->
     uncache (CacheItem itemId) $ do
       mbEdit <- dbUpdate (DeleteItem itemId)
       mapM_ addEdit mbEdit
   -- Delete trait
-    Spock.post (itemVar <//> traitVar) $ \itemId traitId ->
+  Spock.post (deleteRoute <//> itemVar <//> traitVar) $ \itemId traitId ->
     uncache (CacheItemTraits itemId) $ do
       mbEdit <- dbUpdate (DeleteTrait itemId traitId)
       mapM_ addEdit mbEdit
@@ -367,14 +366,14 @@ otherMethods = do
   -- Feeds
   -- TODO: this link shouldn't be absolute [absolute-links]
   baseUrl <- (// "haskell") . _baseUrl <$> getConfig
-  Spock.subcomponent "feed" $ do
+
   -- Feed for items in a category
-    Spock.get categoryVar $ \catId -> do
+  Spock.get (feedRoute <//> categoryVar) $ \catId -> do
     category <- dbQuery (GetCategory catId)
     let sortedItems = reverse $ sortBy cmp (category^.items)
           where cmp = comparing (^.created) <> comparing (^.uid)
     let route = "feed" <//> categoryVar
-      let feedUrl = baseUrl // renderRoute route (category^.uid)
+    let feedUrl = baseUrl // Spock.renderRoute route (category^.uid)
         feedTitle = Atom.TextString (T.unpack (category^.title) ++
                                      " – Haskell – Aelve Guide")
         feedLastUpdate = case sortedItems of
@@ -387,13 +386,13 @@ otherMethods = do
       Atom.feedLinks   = [Atom.nullLink (T.unpack feedUrl)] }
 
 adminMethods :: AdminM ctx ()
-adminMethods = Spock.subcomponent "admin" $ do
+adminMethods = do
   -- Accept an edit
-  Spock.post ("edit" <//> var <//> "accept") $ \n -> do
+  Spock.post (adminRoute <//> "edit" <//> var <//> "accept") $ \n -> do
     dbUpdate (RemovePendingEdit n)
     return ()
   -- Undo an edit
-  Spock.post ("edit" <//> var <//> "undo") $ \n -> do
+  Spock.post (adminRoute <//> "edit" <//> var <//> "undo") $ \n -> do
     (edit, _) <- dbQuery (GetEdit n)
     res <- undoEdit edit
     case res of
@@ -402,10 +401,10 @@ adminMethods = Spock.subcomponent "admin" $ do
                      dbUpdate (RemovePendingEdit n)
                      Spock.text ""
   -- Accept a range of edits
-  Spock.post ("edits" <//> var <//> var <//> "accept") $ \m n -> do
+  Spock.post (adminRoute <//> "edits" <//> var <//> var <//> "accept") $ \m n -> do
     dbUpdate (RemovePendingEdits m n)
   -- Undo a range of edits
-  Spock.post ("edits" <//> var <//> var <//> "undo") $ \m n -> do
+  Spock.post (adminRoute <//> "edits" <//> var <//> var <//> "undo") $ \m n -> do
     edits <- dbQuery (GetEdits m n)
     s <- dbQuery GetGlobalState
     failed <- fmap catMaybes $ for edits $ \(edit, details) -> do
@@ -419,7 +418,7 @@ adminMethods = Spock.subcomponent "admin" $ do
       [] -> Spock.text ""
       _  -> lucidIO $ renderEdits s failed
   -- Create a checkpoint
-  Spock.post "create-checkpoint" $ do
+  Spock.post (adminRoute <//> "create-checkpoint") $ do
     db <- _db <$> Spock.getState
     createCheckpoint' db
 
@@ -433,7 +432,7 @@ getLoggedInUser = do
   sess <- readSession
   case sess ^. sessionUserID of
     Nothing -> return Nothing
-    Just uid -> dbQuery $ GetUser uid
+    Just uid' -> dbQuery $ GetUser uid'
 
 itemToFeedEntry
   :: (MonadIO m)

src/Guide/JS.hs

@@ -122,8 +122,8 @@ class JSFunction a where
 instance JSFunction JS where
   makeJSFunction fName fParams fDef =
     let paramList = T.intercalate "," fParams
-    in JS $ format "function "#|fName|#"("#|paramList|#") {\n"
+    in JS $ format "function "+|fName|+"("+|paramList|+") {\n"
-                #|indent 2 (build fDef)|#
+                +|indent 2 (build fDef)|+
             "}\n"
 
 -- This generates a function that takes arguments and produces a Javascript

src/Guide/Main.hs

@@ -68,6 +68,7 @@ import Guide.JS (JS(..), allJSFunctions)
 import Guide.Utils
 import Guide.Cache
 import Guide.Session
+import Guide.Routes (authRoute, haskellRoute)
 
 
 {- Note [acid-state]
@@ -249,7 +250,7 @@ guideApp waiMetrics = do
 
       -- Main page
       Spock.get root $
-        lucidWithConfig $ renderRoot
+        lucidWithConfig renderRoot
 
       -- Admin page
       prehook authHook $ prehook adminHook $ do
@@ -257,10 +258,13 @@ guideApp waiMetrics = do
           s <- dbQuery GetGlobalState
           lucidIO $ renderAdmin s
         adminMethods
+        Spock.get ("admin" <//> "links") $ do
+          s <- dbQuery GetGlobalState
+          lucidIO $ renderAdminLinks s
 
       -- Donation page
       Spock.get "donate" $
-        lucidWithConfig $ renderDonate
+        lucidWithConfig renderDonate
 
       -- Static pages
       Spock.get "unwritten-rules" $ lucidWithConfig $
@@ -271,8 +275,7 @@ guideApp waiMetrics = do
         renderStaticMd "License" "license.md"
 
       -- Haskell
-      Spock.subcomponent "haskell" $ do
+      Spock.get (haskellRoute <//> root) $ do
-        Spock.get root $ do
         s <- dbQuery GetGlobalState
         q <- param "q"
         (time, mbIP, mbReferrer, mbUA) <- getRequestDetails
@@ -283,17 +286,19 @@ guideApp waiMetrics = do
         dbUpdate (RegisterAction act mbIP time baseUrl mbReferrer mbUA)
         lucidWithConfig $ renderHaskellRoot s q
       -- Category pages
-        Spock.get var $ \path -> do
+      Spock.get (haskellRoute <//> var) $ \path -> do
         -- The links look like /parsers-gao238b1 (because it's nice when
         -- you can find out where a link leads just by looking at it)
-          let (_, catId) = fromCategorySlug path
+        let (_, catId) = T.breakOnEnd "-" path
-          mbCategory <- dbQuery (GetCategoryMaybe catId)
+        when (T.null catId)
+          Spock.jumpNext
+        mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
         case mbCategory of
           Nothing -> Spock.jumpNext
           Just category -> do
             (time, mbIP, mbReferrer, mbUA) <- getRequestDetails
             baseUrl <- _baseUrl <$> getConfig
-              dbUpdate $ RegisterAction (Action'CategoryVisit catId)
+            dbUpdate $ RegisterAction (Action'CategoryVisit (Uid catId))
                          mbIP time baseUrl mbReferrer mbUA
             -- If the slug in the url is old (i.e. if it doesn't match the
             -- one we would've generated now), let's do a redirect
@@ -307,19 +312,18 @@ guideApp waiMetrics = do
       -- rendering on server side and on client side.
       methods
 
-      Spock.subcomponent "auth" $ do
       -- plain "/auth" logs out a logged-in user and lets a logged-out user
       -- log in (this is not the best idea, granted, and we should just
       -- shot logged-in users a “logout” link and logged-out users a
       -- “login” link instead)
-        Spock.get root $ do
+      Spock.get (authRoute <//> root) $ do
         user <- getLoggedInUser
         if isJust user
           then Spock.redirect "auth/logout"
           else Spock.redirect "auth/login"
-        Spock.getpost "login" $ authRedirect "/" $ loginAction
+      Spock.getpost "login" $ authRedirect "/" loginAction
-        Spock.get "logout" $ logoutAction
+      Spock.get "logout" logoutAction
-        Spock.getpost "register" $ authRedirect "/" $ signupAction
+      Spock.getpost "register" $ authRedirect "/" signupAction
 
 loginAction :: GuideAction ctx ()
 loginAction = do
@@ -388,7 +392,7 @@ authRedirect :: Text -> GuideAction ctx a -> GuideAction ctx a
 authRedirect path action = do
   user <- getLoggedInUser
   case user of
-    Just _ -> do
+    Just _ ->
       Spock.redirect path
     Nothing -> action
 
@@ -399,9 +403,9 @@ authRedirect path action = do
 -- templates and clears the cache whenever a change occurs, so that you
 -- wouldn't see cached pages.
 startTemplateWatcher :: IO ()
-startTemplateWatcher = void $ do
+startTemplateWatcher = void $
   Slave.fork $ FSNotify.withManager $ \mgr -> do
-    FSNotify.watchTree mgr "templates/" (const True) $ \_ -> do
+    FSNotify.watchTree mgr "templates/" (const True) $ \_ ->
       emptyCache
     forever $ threadDelay 1000000
 

src/Guide/Markdown.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE FlexibleContexts #-}
@@ -71,17 +73,25 @@ data MarkdownInline = MarkdownInline {
   markdownInlineMdText     :: Text,
   markdownInlineMdHtml     :: ByteString,
   markdownInlineMdMarkdown :: ![MD.Node] }
+  deriving (Generic, Data)
 
 data MarkdownBlock = MarkdownBlock {
   markdownBlockMdText     :: Text,
   markdownBlockMdHtml     :: ByteString,
   markdownBlockMdMarkdown :: ![MD.Node] }
+  deriving (Generic, Data)
 
 data MarkdownTree = MarkdownTree {
   markdownTreeMdText     :: Text,
   markdownTreeMdTree     :: !(Document Text ByteString),
   markdownTreeMdIdPrefix :: Text,
   markdownTreeMdTOC      :: Forest ([MD.Node], Text) }
+  deriving (Generic, Data)
+
+-- Orphan instances (to be deleted after migration to newer cmark-sections)
+deriving instance (Data a) => Data (Annotated a)
+deriving instance (Data a, Data b) => Data (Section a b)
+deriving instance (Data a, Data b) => Data (Document a b)
 
 makeFields ''MarkdownInline
 makeFields ''MarkdownBlock

src/Guide/Routes.hs

@@ -0,0 +1,44 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DataKinds #-}
+
+module Guide.Routes
+  ( addRoute
+  , adminRoute
+  , authRoute
+  , deleteRoute
+  , haskellRoute
+  , feedRoute
+  , moveRoute
+  , renderRoute
+  , setRoute
+  ) where
+
+import Web.Spock (Path)
+import Web.Routing.Combinators (PathState(Open))
+
+haskellRoute :: Path '[] 'Open
+haskellRoute = "haskell"
+
+authRoute :: Path '[] 'Open
+authRoute = "auth"
+
+setRoute :: Path '[] 'Open
+setRoute = "set"
+
+addRoute :: Path '[] 'Open
+addRoute = "add"
+
+moveRoute :: Path '[] 'Open
+moveRoute = "move"
+
+deleteRoute :: Path '[] 'Open
+deleteRoute = "delete"
+
+feedRoute :: Path '[] 'Open
+feedRoute = "feed"
+
+renderRoute :: Path '[] 'Open
+renderRoute = "render"
+
+adminRoute :: Path '[] 'Open
+adminRoute = "admin"

src/Guide/Types/Core.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -94,7 +95,7 @@ For an explanation of deriveSafeCopySorted, see Note [acid-state].
 data Trait = Trait {
   _traitUid :: Uid Trait,
   _traitContent :: MarkdownInline }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 deriveSafeCopySorted 4 'extension ''Trait
 makeFields ''Trait
@@ -115,7 +116,7 @@ data ItemKind
   = Library (Maybe Text)  -- Hackage name
   | Tool (Maybe Text)     -- Hackage name
   | Other
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic, Data)
 
 deriveSafeCopySimple 3 'extension ''ItemKind
 
@@ -154,7 +155,7 @@ data ItemSection
   = ItemProsConsSection
   | ItemEcosystemSection
   | ItemNotesSection
-  deriving (Eq, Ord, Show, Generic)
+  deriving (Eq, Ord, Show, Generic, Data)
 
 deriveSafeCopySimple 0 'base ''ItemSection
 
@@ -181,7 +182,7 @@ data Item = Item {
   _itemLink        :: Maybe Url,       -- ^ Link to homepage or something
   _itemKind        :: ItemKind         -- ^ Is it a library, tool, etc
   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 deriveSafeCopySorted 11 'extension ''Item
 makeFields ''Item
@@ -202,7 +203,7 @@ data CategoryStatus
   = CategoryStub                -- ^ “Stub” = just created
   | CategoryWIP                 -- ^ “WIP” = work in progress
   | CategoryFinished            -- ^ “Finished” = complete or nearly complete
-  deriving (Eq, Show, Generic)
+  deriving (Eq, Show, Generic, Data)
 
 deriveSafeCopySimple 2 'extension ''CategoryStatus
 
@@ -250,7 +251,7 @@ data Category = Category {
   -- all items in a group are deleted
   _categoryGroups :: Map Text Hue
   }
-  deriving (Show, Generic)
+  deriving (Show, Generic, Data)
 
 deriveSafeCopySorted 11 'extension ''Category
 makeFields ''Category

src/Guide/Types/Hue.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -25,8 +26,7 @@ import Data.SafeCopy hiding (kind)
 
 
 data Hue = NoHue | Hue Int
-  deriving (Generic, Eq, Ord)
+  deriving (Eq, Ord, Generic, Data)
-  -- generic deriving ^ is needed by purescript-bridge
 
 deriveSafeCopySimple 1 'extension ''Hue
 

src/Guide/Utils.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -296,7 +297,7 @@ sockAddrToIP _ = Nothing
 
 -- | Unique id, used for many things – categories, items, and anchor ids.
 newtype Uid a = Uid {uidToText :: Text}
-  deriving (Eq, Ord, Show,
+  deriving (Eq, Ord, Show, Data,
             ToHttpApiData, FromHttpApiData,
             T.Buildable, Hashable, A.ToJSON)
 

src/Guide/Views.hs

@@ -14,6 +14,7 @@ module Guide.Views
   -- * Pages
   renderRoot,
   renderAdmin,
+  renderAdminLinks,
   renderDonate,
   renderCategoryPage,
   renderHaskellRoot,
@@ -35,6 +36,7 @@ import Guide.Views.Category as X
 
 import Imports
 
+import Data.Monoid ((<>))
 -- Text
 import qualified Data.Text.All as T
 import NeatInterpolation
@@ -42,10 +44,18 @@ import NeatInterpolation
 import Lucid hiding (for_)
 -- Network
 import Data.IP
+import Network.HTTP.Client
+import Network.HTTP.Client.TLS
+import Network.HTTP.Types.Status (Status(..))
+import Network.URI (isURI)
 -- Time
 import Data.Time.Format.Human
 -- Mustache (templates)
 import qualified Data.Aeson as A
+-- CMark
+import qualified CMark as MD
+-- Generic traversal (for finding links in content)
+import Data.Generics.Uniplate.Data (universeBi)
 
 import Guide.Config
 import Guide.State
@@ -161,13 +171,16 @@ enabled, and in this case the relevant tag will always be “shown” and not
 
 -- | Render the subtitle below the “Aelve Guide” header that is present on
 -- every page.
-renderSubtitle :: (MonadReader Config m) => HtmlT m ()
+renderSubtitle :: Monad m => HtmlT m ()
-renderSubtitle =
+renderSubtitle = pure ()
+  {- previous version of the subtitle
+  -----------------------------------
   div_ [class_ "subtitle"] $ do
     "alpha version • don't post on Reddit yet"
     lift (asks _discussLink) >>= \case
       Nothing -> return ()
       Just l  -> " • " >> mkLink "discuss the site" l
+  -}
 
 -- | Render the main page (<https://guide.aelve.com>).
 renderRoot :: (MonadIO m, MonadReader Config m) => HtmlT m ()
@@ -237,8 +250,7 @@ renderStats globalState acts = do
       th_ "Visits"
       th_ "Unique visitors"
     tbody_ $ do
-      let rawVisits :: [(Uid Category, Maybe IP
+      let rawVisits :: [(Uid Category, Maybe IP)]
-                        )]
           rawVisits = [(catId, actionIP d) |
                        (Action'CategoryVisit catId, d) <- acts']
       let visits :: [(Uid Category, (Int, Int))]
@@ -318,7 +330,7 @@ renderEdits globalState edits = do
   let editBlocks = groupBy (equating getIP) edits
   let ipNum = length $ groupWith getIP edits
   h1_ $ toHtml @Text $
-    "Pending edits (IPs: "#|ipNum|#", blocks: "#|length editBlocks|#")"
+    "Pending edits (IPs: "+|ipNum|+", blocks: "+|length editBlocks|+")"
   for_ editBlocks $ \editBlock -> div_ $ do
     blockNode <- thisNode
     h2_ $ do
@@ -793,3 +805,111 @@ on those <div>s.
 -- people instead just write “TODO fix grammar” in description and then such
 -- things could be displayed in gray font and also there'd be an
 -- automatically updated list of TODOs somewhere?)
+
+data LinkStatus = OK | Unparseable | Broken String deriving Show
+
+-- | Render links page with info about broken links
+renderAdminLinks :: (MonadIO m) => GlobalState -> HtmlT m ()
+renderAdminLinks globalState = do
+  head_ $ do
+    includeJS "/js.js"
+    includeJS "/jquery.js"
+    includeJS "/sorttable.js"
+    includeCSS "/markup.css"
+    includeCSS "/admin.css"
+    includeCSS "/loader.css"
+    title_ "Links – Aelve Guide"
+    meta_ [name_ "viewport",
+           content_ "width=device-width, initial-scale=1.0, user-scalable=yes"]
+
+  body_ $ do
+    script_ $ fromJS $ JS.createAjaxIndicator ()
+    h1_ "Links"
+    div_ [id_ "stats"] $ do
+      manager  <- liftIO $ newManager tlsManagerSettings
+      fullList <- liftIO $ forM allLinks $ \(lnk, location) -> do
+            resp <- if isURI (T.unpack lnk) then (do
+                        request <- parseRequest $ T.unpack lnk
+                        status' <- responseStatus <$> httpNoBody request manager
+                        print (lnk, status')
+                        pure $ case status' of
+                          Status 200  _   -> OK
+                          Status code err -> Broken (""+|code|+": "+||err||+"")
+                      ) `catch` (return . handleHttpException)
+                    else
+                      pure Unparseable
+            pure (toHtml location, a_ [href_ lnk] (toHtml lnk), resp)
+      let (ok, unparseable, broken) = sortLinks fullList
+
+      h2_ "Broken Links"
+      table_ [class_ "sortable"] $ do
+        thead_ $ tr_ $ do
+          th_ [class_ "sorttable_nosort"] "Category"
+          th_ [class_ "sorttable_nosort"] "Link"
+          th_ "Status"
+        tbody_ $ do
+          for_ broken $ \(location, lnk, reason) -> do
+            tr_ $ do
+              td_ location
+              td_ lnk
+              td_ $ toHtml reason
+      h2_ "Unparseable Links"
+      table_ [class_ "sortable"] $ do
+          thead_ $ tr_ $ do
+            th_ [class_ "sorttable_nosort"] "Category"
+            th_ [class_ "sorttable_nosort"] "Link"
+          tbody_ $ do
+            for_ unparseable $ \(cat, l) -> do
+              tr_ $ do
+                td_ cat
+                td_ l
+      h2_ "OK Links"
+      table_ [class_ "sortable"] $ do
+          thead_ $ tr_ $ do
+            th_ [class_ "sorttable_nosort"] "Category"
+            th_ [class_ "sorttable_nosort"] "Link"
+          tbody_ $ do
+            for_ ok $ \(cat, l) -> do
+              tr_ $ do
+                td_ cat
+                td_ l
+ where
+  handleHttpException :: HttpException -> LinkStatus
+  handleHttpException (HttpExceptionRequest _ x) = Broken $ show x
+  handleHttpException (InvalidUrlException  _ x) = Broken x
+
+  sortLinks :: [(a, b, LinkStatus)] -> ([(a, b)], [(a, b)], [(a, b, String)])
+  sortLinks = foldr sortLink ([], [], [])
+
+  sortLink (a, b, OK)          = (\(x, y, z) -> ((a, b):x, y, z))
+  sortLink (a, b, Unparseable) = (\(x, y, z) -> (x, (a, b):y, z))
+  sortLink (a, b, Broken text') = (\(x, y, z) -> (x, y, (a, b, text'):z))
+
+  allLinks :: [(Url, Text)]
+  allLinks = ordNub (findLinks globalState)
+
+-- | Find all links in content, along with a human-readable description of
+-- where each link is located.
+findLinks :: GlobalState -> [(Url, Text)]
+findLinks = concatMap findLinksCategory . view categories
+
+-- | Find all links in a single category.
+findLinksCategory :: Category -> [(Url, Text)]
+findLinksCategory cat =
+  [(url, cat^.title <> " (category notes)")
+      | url <- findLinksMD (cat^.notes)] ++
+  [(url, cat^.title <> " / " <> item^.name)
+      | item <- cat^.items
+      , url  <- findLinksItem item]
+
+-- | Find all links in a single item.
+findLinksItem :: Item -> [Url]
+findLinksItem item = findLinksMD item' ++ maybeToList (item^.link)
+  where
+    -- we don't want to find any links in deleted traits
+    item' = item & prosDeleted .~ []
+                 & consDeleted .~ []
+
+-- | Find all Markdown links in /any/ structure, using generics.
+findLinksMD :: Data a => a -> [Url]
+findLinksMD a = [url | MD.LINK url _ <- universeBi a]

src/Guide/Views/Auth/Login.hs

@@ -14,7 +14,6 @@ import Imports
 import Text.Digestive
 -- lucid
 import Lucid hiding (for_)
-
 import Guide.Views.Page
 import Guide.Views.Utils
 import Guide.Config
@@ -36,16 +35,16 @@ loginForm = Login
 --
 -- Use 'Guide.Server.protectForm' to render the appropriate form element with CSRF protection.
 loginFormView :: MonadIO m => View (HtmlT m ()) -> HtmlT m ()
-loginFormView view = do
+loginFormView view' = do
   div_ $ do
-    errorList "email" view
+    errorList "email" view'
-    label     "email" view "Email: "
+    label     "email" view' "Email: "
-    inputText "email" view
+    inputText "email" view'
 
   div_ $ do
-    errorList     "password" view
+    errorList     "password" view'
-    label         "password" view "Password: "
+    label         "password" view' "Password: "
-    inputPassword "password" view
+    inputPassword "password" view'
 
   inputSubmit "Log in"
 

src/Guide/Views/Page.hs

@@ -106,15 +106,18 @@ pageDef = Page {
   }
 
 subtitleDef 
-  :: (MonadIO m, MonadReader Config m)
+  :: MonadIO m
   => Page m
   -> HtmlT m ()
-subtitleDef _page = do
+subtitleDef _page = pure ()
+  {- previous version of the subtitle
+  -----------------------------------
   div_ [class_ "subtitle"] $ do
     "alpha version • don't share yet"
     lift (asks _discussLink) >>= \case
       Nothing -> return ()
       Just l  -> " • " >> mkLink "discuss the site" l
+  -}
 
 headTagDef 
   :: (MonadIO m, MonadReader Config m)

src/Guide/Views/Utils.hs

@@ -110,7 +110,7 @@ import Guide.Views.Utils.Input
 -- | Add a script that does something on page load.
 onPageLoad :: Monad m => JS -> HtmlT m ()
 onPageLoad js = script_ $
-  "$(document).ready(function(){"#|js|#"});"
+  "$(document).ready(function(){"+|js|+"});"
 
 -- | Add some empty space.
 emptySpan :: Monad m => Text -> HtmlT m ()
@@ -120,18 +120,18 @@ emptySpan w = span_ [style_ ("margin-left:" <> w)] mempty
 onEnter :: JS -> Attribute
 onEnter handler = onkeydown_ $
   "if (event.keyCode == 13 || event.keyCode == 10) {"
-      #|handler|#" return false;}\n"
+      +|handler|+" return false;}\n"
 
 onCtrlEnter :: JS -> Attribute
 onCtrlEnter handler = onkeydown_ $
   "if ((event.keyCode == 13 || event.keyCode == 10) && " <>
       "(event.metaKey || event.ctrlKey)) {"
-      #|handler|#" return false;}\n"
+      +|handler|+" return false;}\n"
 
 onEscape :: JS -> Attribute
 onEscape handler = onkeydown_ $
   "if (event.keyCode == 27) {"
-      #|handler|#" return false;}\n"
+      +|handler|+" return false;}\n"
 
 textInput :: Monad m => [Attribute] -> HtmlT m ()
 textInput attrs = input_ (type_ "text" : attrs)
@@ -192,7 +192,7 @@ markdownEditor
   -> HtmlT m ()
 markdownEditor attr (view mdText -> s) submit cancel instr = do
   textareaUid <- randomLongUid
-  let val = JS $ "document.getElementById(\""#|textareaUid|#"\").value"
+  let val = JS $ "document.getElementById(\""+|textareaUid|+"\").value"
   -- Autocomplete has to be turned off thanks to
   -- <http://stackoverflow.com/q/8311455>.
   textarea_ ([uid_ textareaUid,
@@ -224,7 +224,7 @@ smallMarkdownEditor
   -> HtmlT m ()
 smallMarkdownEditor attr (view mdText -> s) submit mbCancel instr = do
   textareaId <- randomLongUid
-  let val = JS $ "document.getElementById(\""#|textareaId|#"\").value"
+  let val = JS $ "document.getElementById(\""+|textareaId|+"\").value"
   textarea_ ([class_ "fullwidth", uid_ textareaId, autocomplete_ "off"] ++
              [onEnter (submit val)] ++
              [onEscape cancel | Just cancel <- [mbCancel]] ++
@@ -368,8 +368,8 @@ readWidget fp = liftIO $ do
 readWidgets :: MonadIO m => m [(SectionType, Text)]
 readWidgets = liftIO $ do
   let isWidget = F.extension F.==? ".widget"
-  files <- F.find F.always isWidget "templates/"
+  files' <- F.find F.always isWidget "templates/"
-  concat <$> mapM readWidget files
+  concat <$> mapM readWidget files'
 
 getJS :: MonadIO m => m Text
 getJS = do
@@ -397,9 +397,9 @@ protectForm :: MonadIO m
   -> View (HtmlT m ())
   -> GuideAction ctx (HtmlT m ())
 protectForm render formView = do
-  (name, value) <- getCsrfTokenPair
+  (name', value) <- getCsrfTokenPair
   return $ form formView "" [id_ "login-form"] $ do
-    input_ [ type_ "hidden", name_ name, value_ value ]
+    input_ [ type_ "hidden", name_ name', value_ value ]
     render formView
 
 getCsrfTokenPair :: GuideAction ctx (Text, Text)
@@ -413,5 +413,3 @@ getCsrfHeader = do
   csrfTokenName <- spc_csrfHeaderName <$> getSpockCfg
   csrfTokenValue <- getCsrfToken
   return (csrfTokenName, csrfTokenValue)
-
-

src/Imports.hs

@@ -9,25 +9,33 @@ module Imports
 (
   module X,
   LByteString,
+  (+|),
+  (|+),
+  (+||),
+  (||+),
+  (|++|),
+  (||++||),
+  (|++||),
+  (||++|)
 )
 where
 
 
 import           BasePrelude            as X hiding (Category, GeneralCategory, lazy, (&))
 -- Lists
+import           Data.List.Extra        as X (dropEnd, takeEnd)
 import           Data.List.Index        as X
-import Data.List.Extra as X (takeEnd, dropEnd)
 -- Lenses
 import           Lens.Micro.Platform    as X
 -- Monads and monad transformers
 import           Control.Monad.IO.Class as X
-import Control.Monad.State as X
 import           Control.Monad.Reader   as X
+import           Control.Monad.State    as X
 -- Common types
-import Data.Text.All as X (Text, LText)
 import           Data.ByteString        as X (ByteString)
 import           Data.Map               as X (Map)
 import           Data.Set               as X (Set)
+import           Data.Text.All          as X (LText, Text)
 -- Time
 import           Data.Time              as X
 -- Files
@@ -40,8 +48,44 @@ import Data.Hashable as X
 -- Lazy bytestring
 import qualified Data.ByteString.Lazy   as BSL
 -- Formatting
-import Fmt as X
+import           Fmt                    as X hiding (( #| ), ( #|| ), (|#), (|##|),
+                                              (|##||), (||#), (||##|), (||##||))
+import qualified Fmt                    as FMT (( #| ), ( #|| ), (|#), (|##|), (|##||),
+                                                (||#), (||##|), (||##||))
+import           Fmt.Internal           (FromBuilder)
 
 
 type LByteString = BSL.ByteString
 -- LText is already provided by Data.Text.All
+
+infixr 1 +|
+(+|) :: FromBuilder b => Builder -> Builder -> b
+(+|) = (FMT.#|)
+
+infixr 1 |+
+(|+) :: (Buildable a, FromBuilder b) => a -> Builder -> b
+(|+) = (FMT.|#)
+
+infixr 1 +||
+(+||) :: FromBuilder b => Builder -> Builder -> b
+(+||) = (FMT.#||)
+
+infixr 1 ||+
+(||+) :: (Show a, FromBuilder b) => a -> Builder -> b
+(||+) = (FMT.||#)
+
+infixr 1 |++|
+(|++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b
+(|++|) = (FMT.|##|)
+
+infixr 1 ||++||
+(||++||) :: (Show a, FromBuilder b) => a -> Builder -> b
+(||++||) = (FMT.||##||)
+
+infixr 1 ||++|
+(|++||) :: (Show a, FromBuilder b) => a -> Builder -> b
+(|++||) = (FMT.|##||)
+
+infixr 1 |++||
+(||++|) :: (Buildable a, FromBuilder b) => a -> Builder -> b
+(||++|) = (FMT.||##|)

templates/search.widget

@@ -23,6 +23,8 @@ CSS
 ============================================================
 
 #search {
+  /* TODO: this should rather be in the "h1+subtitle" block */
+  margin-top: 1em;
   font-size: 200%;
   font-weight: 200;
   border: 1px solid #aaa;

tests/WebSpec.hs

@@ -54,12 +54,12 @@ mainPageTests = session "main page" $ using [chromeCaps] $ do
       ("content", "some-google-token")
   wd "has a title" $ do
     "h1" `shouldHaveText` "Aelve Guide | Haskell"
-  describe "subtitle" $ do
+  -- describe "subtitle" $ do
-    wd "is present" $ do
+  --   wd "is present" $ do
-      sub <- select ".subtitle"
+  --     sub <- select ".subtitle"
-      fs <- fontSize sub; fs `shouldBeInRange` (15,17)
+  --     fs <- fontSize sub; fs `shouldBeInRange` (15,17)
-    wd "has a discuss link" $ do
+  --   wd "has a discuss link" $ do
-      checkPresent ".subtitle a[href='http://discuss.link']"
+  --     checkPresent ".subtitle a[href='http://discuss.link']"
   describe "footer" $ do
     wd "is present" $ do
       checkPresent "#footer"
@@ -90,8 +90,8 @@ categoryTests = session "categories" $ using [chromeCaps] $ do
       titleLink <- select "h1 > a"
       titleLink `shouldHaveText` "Aelve Guide | Haskell"
       titleLink `shouldLinkToRelative` "/haskell"
-    wd "has a subtitle" $ do
+    -- wd "has a subtitle" $ do
-      checkPresent ".subtitle"
+    --   checkPresent ".subtitle"
     wd "doesn't have an add-category field" $ do
       checkNotPresent ".add-category"
     wd "is present on the main page" $ do