From e81a44d12201e51336383f407715f9bfc9ec6b5b Mon Sep 17 00:00:00 2001
From: Danielle McLean <dani@00dani.me>
Date: Tue, 3 Oct 2017 12:53:13 +1100
Subject: [PATCH] Add support for social profiles on the h-card, which become
 rel="me" links

---
 config/models           | 7 +++++++
 src/Handler/Home.hs     | 2 +-
 src/Widget/Hcard.hs     | 8 ++++++--
 templates/hcard.cassius | 4 +++-
 templates/hcard.hamlet  | 4 ++++
 5 files changed, 21 insertions(+), 4 deletions(-)

diff --git a/config/models b/config/models
index 087cbc7..81efd2c 100644
--- a/config/models
+++ b/config/models
@@ -15,5 +15,12 @@ Comment json -- Adding "json" causes ToJSON and FromJSON instances to be derived
     userId UserId Maybe default=NULL
     deriving Eq
     deriving Show
+Site
+    icon Text sqltype=varchar(255)
+    url Text sqltype=varchar(255)
+Profile
+    userId UserId
+    siteId SiteId
+    username Text sqltype=varchar(255)
 
  -- By default this file is used in Model.hs (which is imported by Foundation.hs)
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index c6a7a3a..a36b181 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -10,5 +10,5 @@ import Widget.Hcard (hcard)
 
 getHomeR :: Handler Html
 getHomeR = do
-    (Entity _ user) <- runDB . getBy404 $ UniqueUser "dani"
+    user <- runDB . getBy404 $ UniqueUser "dani"
     defaultLayout $(widgetFile "home")
diff --git a/src/Widget/Hcard.hs b/src/Widget/Hcard.hs
index d6a34fa..5a1d1cb 100644
--- a/src/Widget/Hcard.hs
+++ b/src/Widget/Hcard.hs
@@ -6,7 +6,11 @@ module Widget.Hcard (hcard) where
 import Import
 import qualified Network.Libravatar as L
 
-hcard :: User -> Widget
-hcard user = do
+hcard :: Entity User -> Widget
+hcard (Entity userId user) = do
     maybeAvatar <- liftIO $ L.avatarUrl (L.Email $ userEmail user) def { L.optSecure = True, L.optSize = L.Size 512 }
+    userProfiles <- handlerToWidget . runDB $ do
+        profiles <- map entityVal <$> selectList [ProfileUserId ==. userId] []
+        sites <- belongsToJust profileSiteId `mapM` profiles
+        return . sortBy (comparing $ siteIcon . fst) $ zip sites profiles
     $(widgetFile "hcard")
diff --git a/templates/hcard.cassius b/templates/hcard.cassius
index cac5feb..219aca0 100644
--- a/templates/hcard.cassius
+++ b/templates/hcard.cassius
@@ -1,3 +1,5 @@
 .card.h-card
   margin: 2em auto
-  width: 20rem
+  width: 22rem
+  .card-link
+    white-space: nowrap
diff --git a/templates/hcard.hamlet b/templates/hcard.hamlet
index ba775ad..243ab1f 100644
--- a/templates/hcard.hamlet
+++ b/templates/hcard.hamlet
@@ -6,3 +6,7 @@
     <a .card-link.u-email rel="me" href="mailto:#{userEmail user}">
       <i .fa.fa-envelope>
       #{userEmail user}
+    $forall (site, profile) <- userProfiles
+      <a .card-link.u-url rel="me" href="#{siteUrl site}#{profileUsername profile}">
+        <i .fa.fa-#{siteIcon site}>
+        #{profileUsername profile}