From bbe563dee7757b78aa7bb2025807ce1612b740d3 Mon Sep 17 00:00:00 2001
From: Danielle McLean <dani@00dani.me>
Date: Tue, 10 Oct 2017 15:16:50 +1100
Subject: [PATCH] Use Mustache templates for site URL so that the username can
 be inserted anywhere in the template rather than only at the end

---
 config/models               |  2 +-
 package.yaml                |  2 ++
 src/Model.hs                |  7 +++++++
 src/Util.hs                 | 19 ++++++++++++++++++-
 src/Widget/Card.hs          | 15 +++++++++++----
 templates/mf2/h-card.hamlet |  4 ++--
 6 files changed, 41 insertions(+), 8 deletions(-)

diff --git a/config/models b/config/models
index cfd49b8..a2ee315 100644
--- a/config/models
+++ b/config/models
@@ -16,7 +16,7 @@ PgpKey
 
 Site
     icon Text sqltype=varchar(255)
-    url Text sqltype=varchar(255)
+    template Text sqltype=varchar(255)
 
 Profile
     userId UserId
diff --git a/package.yaml b/package.yaml
index a945380..1eb3eef 100644
--- a/package.yaml
+++ b/package.yaml
@@ -51,6 +51,8 @@ dependencies:
 - conduit-combinators >= 1.1 && <1.2
 - friendly-time >=0.4 && <0.5
 - foreign-store >=0.2 && <0.3
+- mustache >=2.2 && <2.3
+- parsec >=3.1 && <3.2
 - slug >=0.1 && <0.2
 - split >=0.2 && <0.3
 - unix >=2.7 && <2.8
diff --git a/src/Model.hs b/src/Model.hs
index 90b4c0c..154df89 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -13,6 +13,8 @@ import ClassyPrelude.Yesod
 import Database.Persist.Quasi
 import Yesod.Auth.HashDB ( HashDBUser(..) )
 import Web.Slug ( Slug )
+import Text.Mustache ( (~>) )
+import qualified Text.Mustache as M
 
 import Entry.Kind ( EntryKind )
 
@@ -26,3 +28,8 @@ share [mkPersist sqlSettings, mkMigrate "migrateAll"]
 instance HashDBUser User where
   userPasswordHash = Just . userPassword
   setPasswordHash pw u = u { userPassword = pw }
+
+instance M.ToMustache Profile where
+  toMustache p = M.object
+    [ "username" ~> profileUsername p
+    ]
diff --git a/src/Util.hs b/src/Util.hs
index bffa975..4a7ac39 100644
--- a/src/Util.hs
+++ b/src/Util.hs
@@ -1,5 +1,22 @@
-module Util where
+module Util ( compileMustache, mapFirst ) where
+
+import Text.Mustache ( Template(..), compileTemplate )
+import Text.Mustache.Types ( Node(TextBlock) )
+import Text.Parsec.Error ( ParseError )
+
+import qualified Data.Text as T
+import qualified Data.HashMap.Lazy as M
 
 mapFirst :: (a -> a) -> [a] -> [a]
 mapFirst f (x:xs) = f x : xs
 mapFirst _ [] = []
+
+compileMustache :: String -> T.Text -> Template
+compileMustache n = either errorTemplate id . compileTemplate n
+
+errorTemplate :: ParseError -> Template
+errorTemplate err = Template
+    { name = "error"
+    , ast = [TextBlock . T.pack $ show err]
+    , partials = M.empty
+    }
diff --git a/src/Widget/Card.hs b/src/Widget/Card.hs
index ed1ca88..e5214b1 100644
--- a/src/Widget/Card.hs
+++ b/src/Widget/Card.hs
@@ -4,18 +4,25 @@
 module Widget.Card ( hCard ) where
 
 import Import
+import Util ( compileMustache )
+
 import Data.Maybe (fromJust)
+import Text.Mustache ( Template, substitute )
 import qualified Data.Map as M
 import qualified Data.Text as T
 
 entityToTuple :: Entity t -> (Key t, t)
 entityToTuple (Entity key value) = (key, value)
 
-arrangeProfiles :: M.Map (Key Site) Site -> [Profile] -> [(Site,Profile)]
-arrangeProfiles sites profiles = sortBy icon $ zip profileSites profiles
+compileTemplates :: M.Map (Key Site) Site -> M.Map (Key Site) (Site, Template)
+compileTemplates = fmap $ \site -> (site, compile site)
+    where compile site = T.unpack (siteIcon site) `compileMustache` siteTemplate site
+
+arrangeProfiles :: [Profile] -> M.Map (Key Site) (Site, Template) -> [((Site, Template), Profile)]
+arrangeProfiles profiles sites = sortBy icon $ zip profileSites profiles
     where findSite = fromJust . flip M.lookup sites . profileSiteId
           profileSites = findSite <$> profiles
-          icon = comparing $ siteIcon . fst
+          icon = comparing $ siteIcon . fst . fst
 
 prettyPgp :: PgpKey -> Text
 prettyPgp = T.unwords . T.chunksOf 4 . pgpKeyFingerprint
@@ -29,6 +36,6 @@ hCard (Entity userId user) = do
     userProfiles <- handlerToWidget . runDB $ do
         profiles <- map entityVal <$> selectList [ProfileUserId ==. userId] []
         sites <- M.fromList . map entityToTuple <$> selectList [SiteId <-. (profileSiteId <$> profiles)] []
-        return $ arrangeProfiles sites profiles
+        return . arrangeProfiles profiles . compileTemplates $ sites
     pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] []
     $(widgetFile "mf2/h-card")
diff --git a/templates/mf2/h-card.hamlet b/templates/mf2/h-card.hamlet
index 78a1948..16d3209 100644
--- a/templates/mf2/h-card.hamlet
+++ b/templates/mf2/h-card.hamlet
@@ -18,8 +18,8 @@
         <a .u-email itemprop="email" rel="me" href="mailto:#{userEmail user}">
           <i .fa.fa-envelope>
           #{userEmail user}
-      $forall (site, profile) <- userProfiles
+      $forall ((site, template), profile) <- userProfiles
         <li>
-          <a .u-url itemprop="sameAs" rel="me" href="#{siteUrl site}#{profileUsername profile}">
+          <a .u-url itemprop="sameAs" rel="me" href="#{substitute template profile}">
             <i .fa.fa-#{siteIcon site}>
             #{profileUsername profile}