2017-10-02 09:52:14 -04:00
|
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
|
|
module Widget.Hcard (hcard) where
|
|
|
|
|
|
|
|
import Import
|
2017-10-02 23:21:08 -04:00
|
|
|
import Data.Maybe (fromJust)
|
|
|
|
import qualified Data.Map as M
|
2017-10-03 18:09:39 -04:00
|
|
|
import qualified Data.Text as T
|
2017-10-02 20:48:44 -04:00
|
|
|
import qualified Network.Libravatar as L
|
2017-10-02 09:52:14 -04:00
|
|
|
|
2017-10-03 19:37:37 -04:00
|
|
|
libravatar :: (MonadIO m) => User -> m (Maybe Text)
|
|
|
|
libravatar = liftIO . flip L.avatarUrl opts . L.Email . userEmail
|
|
|
|
where opts = def { L.optSecure = True, L.optSize = L.Size 512, L.optTryGravatar = False }
|
|
|
|
|
2017-10-02 23:21:08 -04:00
|
|
|
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
|
|
|
|
|
2017-10-03 18:09:39 -04:00
|
|
|
prettyPgp :: PgpKey -> Text
|
|
|
|
prettyPgp = T.unwords . T.chunksOf 4 . pgpKeyFingerprint
|
|
|
|
|
|
|
|
routeFromPgp :: PgpKey -> Route App
|
|
|
|
routeFromPgp PgpKey { pgpKeyFingerprint = f, pgpKeyHash = h } =
|
2017-10-04 10:22:34 -04:00
|
|
|
StaticR $ StaticRoute ["pgp", h, T.takeEnd 8 f ++ ".asc"] []
|
2017-10-03 18:09:39 -04:00
|
|
|
|
2017-10-02 21:53:13 -04:00
|
|
|
hcard :: Entity User -> Widget
|
|
|
|
hcard (Entity userId user) = do
|
2017-10-03 19:37:37 -04:00
|
|
|
maybeAvatar <- libravatar user
|
2017-10-03 19:07:51 -04:00
|
|
|
mcurrentRoute <- getCurrentRoute
|
2017-10-02 21:53:13 -04:00
|
|
|
userProfiles <- handlerToWidget . runDB $ do
|
|
|
|
profiles <- map entityVal <$> selectList [ProfileUserId ==. userId] []
|
2017-10-02 23:21:08 -04:00
|
|
|
sites <- M.fromList . map entityToTuple <$> selectList [SiteId <-. (profileSiteId <$> profiles)] []
|
|
|
|
return $ arrangeProfiles sites profiles
|
2017-10-03 18:09:39 -04:00
|
|
|
pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] []
|
2017-10-02 20:48:44 -04:00
|
|
|
$(widgetFile "hcard")
|