Add support for social profiles on the h-card, which become rel="me" links

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)

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")

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 :: Entity User -> Widget
-hcard user = do
+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")

templates/hcard.cassius

@@ -1,3 +1,5 @@
 .card.h-card
   margin: 2em auto
-  width: 20rem
+  width: 22rem
+  .card-link
+    white-space: nowrap

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}