add webmention.io integration

render ugly likes with templates/post.html
add github action to automatically sync webmentios every 24hr
save webmentions to webmentions.json

.github/workflows/build-deploy.yml

@@ -12,7 +12,21 @@ jobs:
       - uses: DeterminateSystems/magic-nix-cache-action@v2
       - run: nix profile install nixpkgs#python312Packages.pygments
       - run: nix build
-      - run: ./result/bin/site rebuild
+      - name: Rebuild and Sync webmentions
+        env:
+          WMTOKEN: ${{ secrets.WMTOKEN }}
+        run: ./result/bin/site rebuild -v
+
+      - name: Commit webmentions to repository
+        env:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+        run: |
+            git config user.name "github-actions[bot]"
+            git config user.email "github-actions[bot]@users.noreply.github.com"
+            set +e
+            git add webmentions.json
+            git diff --quiet && git diff --staged --quiet || (git commit -m "Sync webmentions [skip actions]"; git push origin test)
+            set -e
 
       - name: Deploy
         uses: JamesIves/github-pages-deploy-action@v4

.github/workflows/webmentions-sync.yml

@@ -0,0 +1,40 @@
+name: Webmentions Sync and Redeploy
+
+on:
+  schedule:
+    - cron: "0 */24 * * *"
+  workflow_dispatch:
+
+jobs:
+  webmentions-sync-rebuild-redeploy:
+    runs-on: ubuntu-latest
+    steps:
+      - uses: actions/checkout@v3
+      - uses: cachix/install-nix-action@v20
+        with:
+          nix_path: nixpkgs=channel:nixos-unstable
+      - uses: DeterminateSystems/magic-nix-cache-action@v2
+      - run: nix profile install nixpkgs#python312Packages.pygments
+      - run: nix build
+      - name: Rebuild and Sync webmentions
+        env:
+          WMTOKEN: ${{ secrets.WMTOKEN }}
+        run: ./result/bin/site rebuild -v
+
+      - name: Commit webmentions to repository
+        env:
+          GITHUB_TOKEN: ${{ secrets.GITHUB_TOKEN }}
+      - name: Check for changes and commit
+        run: |
+            git config user.name "github-actions[bot]"
+            git config user.email "github-actions[bot]@users.noreply.github.com"
+            set +e
+            git add webmentions.json
+            git diff --quiet && git diff --staged --quiet || (git commit -m "Sync webmentions [skip actions]"; git push origin test)
+
+            set -e
+
+      - name: Deploy
+        uses: JamesIves/github-pages-deploy-action@v4
+        with:
+          folder: _site

css/default.css

@@ -162,6 +162,55 @@ h3 {
   font-size: 1rem;
 }
 
+.mentions {
+  margin: 0;
+  padding: 0;
+}
+
+.mention {
+  display: flex;
+  margin-bottom: 1.5em;
+}
+
+.mention__authorImageLink {
+  flex-shrink: 0;
+  margin-right: 0.8em;
+}
+
+.mention__image {
+  width: 60px;
+  height: 60px;
+}
+
+.mention__authorLink {
+  display: block;
+  margin-bottom: 0.1em;
+}
+
+.mention__content {
+  margin-bottom: 0.1em;
+}
+
+.likes {
+  margin: 0;
+  padding: 0;
+}
+
+.like {
+  margin-right: 0.5em;
+}
+
+.like__image {
+  width: 40px;
+  height: 40px;
+  margin-bottom: 0.1em;
+  transition: scale linear 0.1s;
+}
+
+.like__image:hover {
+  scale: 1.33;
+}
+
 .post-meta {
   color: var(--main-fg-secondary-color);
   display: flex;

jgt.cabal

@@ -7,9 +7,19 @@ cabal-version: >=1.10
 
 executable site
   main-is:          Main.hs
-  other-modules:    Redirects
+  other-modules:
+      Redirects
+    , WMentions
   build-depends:
       base                >=4    && <5
+    , wreq
+    , aeson
+    , lens
+    , vector
+    , vector-algorithms
+    , unix
+    , text
+    , scientific
     , blaze-html
     , bytestring
     , containers

src/Main.hs

@@ -3,6 +3,8 @@
 {-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveGeneric #-}
 
 import Control.Monad (forM_)
 import Data.ByteString.Char8 (pack)
@@ -20,12 +22,19 @@ import Data.Time.Locale.Compat (defaultTimeLocale)
 import Debug.Trace
 import Hakyll hiding (host)
 import Redirects
-import System.FilePath.Posix (takeBaseName, takeDirectory, (</>))
+import System.FilePath.Posix (takeBaseName, takeDirectory, (</>), splitPath, joinPath, dropExtension)
 import Text.Pandoc
 import Text.Pandoc.Citeproc
 import Text.Pandoc.Highlighting (pygments, styleToCss, zenburn)
 import Text.Pandoc.Options
 import Text.Pandoc.Walk (walkM)
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Data.Vector (Vector, fromList)
+import Data.Vector qualified as V
+import Data.Aeson (Value)
+
+import WMentions
 
 host :: String
 host = "https://jezenthomas.com"
@@ -62,6 +71,8 @@ styleSheets =
 main :: IO ()
 main = hakyll $ do
 
+  mentions <- preprocess getFromFileOrWebmentionIO
+
   compiledStylesheetPath <- preprocess $ do
     styles <- mapM readFile styleSheets
     let h = md5 $ fromStrict $ pack $ compressCss $ mconcat styles
@@ -102,10 +113,28 @@ main = hakyll $ do
     dep <- makePatternDependency "css/*"
     rulesExtraDependencies [dep] $ compile $ do
       ident <- getUnderlying
+
+      let wmreplies = listField "replies" (field "repl" (return . itemBody))
+            (traverse (makeItem  . fromMaybe "" . renderReply)
+                (V.toList . fromMaybe V.empty . Map.lookup (target) $ replies mentions))
+
+          wmlikes = listField "likes" (field "like" (return . itemBody))
+            (traverse (makeItem . fromMaybe "" . renderLike)
+                (V.toList . fromMaybe V.empty . Map.lookup target $ likes mentions))
+
+          wmreposts = listField "reposts" (field "repo" (return . itemBody))
+            (traverse (makeItem .  fromMaybe "" . renderRepost)
+                (V.toList . fromMaybe V.empty . Map.lookup target $ reposts mentions))
+
+          ctx = postCtx <> utcCtx <> wmreplies <> wmlikes
+
+          cleanTarget = dropExtension . joinPath . drop 1 . splitPath . toFilePath
+          target = traceShowId $ drop 8 host </> cleanTarget ident <> "/"
+
       blogCompiler
         >>= loadAndApplyTemplate "templates/post-content.html" postCtx
         >>= saveSnapshot "content"
-        >>= loadAndApplyTemplate "templates/post.html" (postCtx <> utcCtx)
+        >>= loadAndApplyTemplate "templates/post.html" ctx
         >>= loadAndApplyTemplate "templates/default.html" (postCtx <> boolField "page-blog" (const True))
         >>= cleanIndexUrls
 

src/WMentions.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE BlockArguments #-}
+{-# LANGUAGE ImportQualifiedPost #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE DeriveGeneric #-}
+module WMentions where
+
+import Data.Maybe
+import GHC.Generics(Generic)
+import System.Environment.Blank (getEnv)
+import System.Posix.Files (fileExist)
+import Text.Blaze.Html.Renderer.String (renderHtml)
+import Data.Map (Map)
+import Data.Map qualified as Map
+import Text.Blaze.Html5 ((!))
+import Text.Blaze.Html5 qualified as H
+import Text.Blaze.Html5.Attributes qualified as H
+import Data.String (fromString)
+import Network.Wreq qualified as W
+import Data.Aeson
+import Data.Aeson (Value)
+import Data.Aeson.KeyMap qualified as JK
+import Control.Lens ((^.))
+import Data.Vector (Vector, fromList)
+import Data.Vector qualified as V
+import Data.Vector.Algorithms qualified as VAlg
+import Data.Text (Text)
+import Data.Text qualified as T
+import Data.ByteString (ByteString)
+import Data.ByteString qualified as B
+import Data.Ord qualified as Ord
+import Control.Applicative ((<|>))
+
+type WMPost = String
+
+data StoredMentions = SM {
+    likes :: Map WMPost (Vector Value),
+    replies :: Map WMPost (Vector Value),
+    reposts :: Map WMPost (Vector Value)
+} deriving (Show, Generic)
+
+instance ToJSON StoredMentions where
+    toEncoding = genericToEncoding defaultOptions
+
+instance FromJSON StoredMentions
+
+emptySM :: StoredMentions
+emptySM = SM mempty mempty mempty
+
+newtype GetWM = GetWM { unGetWM :: StoredMentions } deriving (Show)
+
+instance FromJSON GetWM where
+    parseJSON = withObject "webmention" $ \v -> do
+        cs <- v .: "children"
+        case cs of
+            Array vec -> pure . GetWM $ SM (foldToMap likes) (foldToMap replies) (foldToMap reposts) where
+
+                foldToMap objs = Map.fromList $ foldl go mempty (V.groupBy gb objs) where
+                    -- go :: [(WMPost, Vector Value)] -> Vector Value -> [(WMPost, Vector Value)]
+                    go wmmap ls
+                        | V.null ls = wmmap
+                        | otherwise = case V.head ls of
+                            Object o -> case JK.lookup "wm-target" o of
+                                Just (String t) -> (drop 8 $ T.unpack t, ls) : wmmap
+                                _ -> wmmap
+                            _ -> wmmap
+
+                gb (Object kmap1) (Object kmap2) = fromMaybe False $ (==)
+                    <$> JK.lookup "wm-target" kmap1
+                    <*> JK.lookup "wm-target" kmap2
+                gb _ _ = False
+
+                (likes, rest) = V.partition (isType "like-of") vec
+                (replies, reposts) = V.partition (isType "in-reply-to") rest
+
+                isType type_ (Object kmap) = maybe False (type_ ==) (JK.lookup "wm-property" kmap)
+                isType _ _ = False
+
+            _ -> fail "failed to parse chidren as an array"
+
+
+renderRepost (Object kmap) = do
+  Object author <- JK.lookup "author" kmap
+  String authorPhotoUrl <- JK.lookup "photo" author
+  String authorUrl <- JK.lookup "url" author
+  pure . renderHtml $ H.img ! H.src (fromString $ T.unpack $ authorPhotoUrl) ! H.alt "like image"
+
+renderReply (Object kmap) = do
+  String (T.unpack -> url) <- JK.lookup "url" kmap
+  String (T.unpack -> published) <- JK.lookup "published" kmap
+  Object author <- JK.lookup "author" kmap
+  Object content <- JK.lookup "content" kmap
+  String (T.unpack -> chtml) <- JK.lookup "html" content <|> JK.lookup "text" content
+  String (T.unpack -> authorPhotoUrl) <- JK.lookup "photo" author
+  String (T.unpack -> authorName) <- JK.lookup "name" author
+  String (T.unpack -> authorUrl) <- JK.lookup "url" author
+  pure . renderHtml $
+      H.div ! H.class_ "mention" $ do
+          H.a ! H.class_ "mention__authorImageLink" ! H.href (fromString url) $
+              H.img ! H.class_ "mention_authorLink" ! H.src (fromString authorPhotoUrl) ! H.alt (fromString authorName)
+          H.div ! H.class_ "mention__authorLink" $ do
+              H.strong (H.a ! H.href (fromString authorUrl) $ (fromString authorName))
+              H.div ! H.class_ "mention__content" $ fromString chtml
+              H.small $ H.a ! H.href (fromString url) $ fromString published
+
+renderLike (Object kmap) = do
+  String (T.unpack -> url) <- JK.lookup "url" kmap
+  Object author <- JK.lookup "author" kmap
+  String authorPhotoUrl <- JK.lookup "photo" author
+  String (T.unpack -> authorPhotoUrl) <- JK.lookup "photo" author
+  String (T.unpack -> authorName) <- JK.lookup "name" author
+  pure . renderHtml $ H.a ! H.class_ "like" ! H.href (fromString url) $
+      H.img ! H.class_ "like__image" ! H.src (fromString authorPhotoUrl) ! H.alt (fromString authorName)
+
+getFromFileOrWebmentionIO :: IO StoredMentions
+getFromFileOrWebmentionIO = do
+    webementionIoToken <- getEnv "WMTOKEN"
+    newMentions <- case webementionIoToken of
+      Nothing -> do
+        putStrLn $ "Warning: no webmention.io token found"
+        putStrLn $ "Warning: please set WMToken environmental variable"
+        pure emptySM
+      Just token -> do
+
+        response <- W.get $ "https://webmention.io/api/mentions.jf2?domain=jezenthomas.com&token=" <> token
+
+        case response ^. W.responseStatus . W.statusCode of
+          200 -> case fmap unGetWM . eitherDecode $ response ^. W.responseBody of
+              Right sm@(SM _ _ _) -> pure sm
+              Left err -> do
+                putStrLn $ "Error: decoding webmentions. aeson error: "
+                    <> show err
+                pure $ SM mempty mempty mempty
+
+          bad -> do
+            putStrLn $ "Error: fetching webmentions. status code: " <> show bad
+            pure emptySM
+
+    fileExist "webmentions.json" >>= \case
+      True -> do
+        SM oldLikes oldReplies oldReposts <- fromMaybe emptySM . decodeStrict <$> B.readFile "webmentions.json"
+
+        let SM newLikes newReplies newReposts = newMentions
+            result = SM (merge newLikes oldLikes) (merge newReplies oldReplies)
+              (merge oldReposts oldReposts)
+
+            merge = Map.unionWith checkIds
+
+            checkIds :: Vector Value -> Vector Value -> Vector Value
+            checkIds vec1 vec2 = VAlg.nubBy comparison (vec1 <> vec2)
+
+            comparison v1@(Object o1) v2@(Object o2) =
+              fromMaybe (Ord.compare (encode v1) (encode v2)) $
+                  Ord.compare <$> JK.lookup "wm-id" o1 <*> JK.lookup "wm-id" o2
+
+            comparison o1 o2 = (Ord.compare (encode o1) (encode o2))
+
+        encodeFile "webmentions.json" result
+        pure result
+
+      False -> do
+        encodeFile "webmentions.json" newMentions
+        pure newMentions
+

templates/default.html

@@ -30,6 +30,7 @@
     <link rel="stylesheet" type="text/css" href="/$cssPath$">
     <link rel="alternate" type="application/rss+xml" href="/feed.xml" title="RSS feed">
     <script src="https://cdn.usefathom.com/script.js" data-site="OTTAMRJZ" defer></script>
+    <link rel="webmention" href="https://webmention.io/jezenthomas.com/webmention" />
   </head>
   <body>
     $partial("templates/header.html")$

templates/footer.html

@@ -1,4 +1,5 @@
 <footer>
   <p>&copy; 2025 Jezen Thomas</p>
+  <a href="https://github.com/jezen" rel="me">github.com/jezen</a>
   $partial("templates/feed.html")$
 </footer>