lebd/src/Widget/Hcard.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
module Widget.Hcard (hcard) where

import Import
import Data.Maybe (fromJust)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Network.Libravatar as L

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
    where findSite = fromJust . flip M.lookup sites . profileSiteId
          profileSites = findSite <$> profiles
          icon = comparing $ siteIcon . fst

prettyPgp :: PgpKey -> Text
prettyPgp = T.unwords . T.chunksOf 4 . pgpKeyFingerprint

routeFromPgp :: PgpKey -> Route App
routeFromPgp PgpKey { pgpKeyFingerprint = f, pgpKeyHash = h } =
    StaticR $ StaticRoute ["pgp", f, h, T.takeEnd 8 f ++ ".asc"] []

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 <- M.fromList . map entityToTuple <$> selectList [SiteId <-. (profileSiteId <$> profiles)] []
        return $ arrangeProfiles sites profiles
    pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] []
    $(widgetFile "hcard")