diff --git a/src/Site.hs b/src/Site.hs new file mode 100644 index 0000000..0eb03fa --- /dev/null +++ b/src/Site.hs @@ -0,0 +1,21 @@ +module Site ( fetch ) where + +import Foundation ( Handler ) +import Model +import Util ( compileMustache, entityToTuple ) + +import Text.Mustache ( Template ) +import Yesod ( Key, runDB, selectList, (<-.) ) + +import qualified Data.Map as M +import qualified Data.Text as T + +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 + +fetch :: [Key Site] -> Handler (M.Map (Key Site) (Site, Template)) +fetch = fmap compileTemplates . fetchSites + +fetchSites :: [SiteId] -> Handler (M.Map (Key Site) Site) +fetchSites siteIds = runDB $ M.fromList . map entityToTuple <$> selectList [SiteId <-. siteIds] [] diff --git a/src/Util.hs b/src/Util.hs index 4a7ac39..82a2ffe 100644 --- a/src/Util.hs +++ b/src/Util.hs @@ -1,5 +1,6 @@ -module Util ( compileMustache, mapFirst ) where +module Util ( compileMustache, entityToTuple, mapFirst ) where +import Database.Persist ( Entity(..), Key ) import Text.Mustache ( Template(..), compileTemplate ) import Text.Mustache.Types ( Node(TextBlock) ) import Text.Parsec.Error ( ParseError ) @@ -20,3 +21,6 @@ errorTemplate err = Template , ast = [TextBlock . T.pack $ show err] , partials = M.empty } + +entityToTuple :: Entity t -> (Key t, t) +entityToTuple (Entity key value) = (key, value) diff --git a/src/Widget/Card.hs b/src/Widget/Card.hs index e5214b1..e919528 100644 --- a/src/Widget/Card.hs +++ b/src/Widget/Card.hs @@ -4,20 +4,14 @@ module Widget.Card ( hCard ) where import Import -import Util ( compileMustache ) + +import qualified Site 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) - -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 @@ -33,9 +27,9 @@ routeFromPgp PgpKey { pgpKeyFingerprint = f } = staticR ["pgp", T.takeEnd 8 f ++ hCard :: Entity User -> Widget hCard (Entity userId user) = do mcurrentRoute <- getCurrentRoute - userProfiles <- handlerToWidget . runDB $ do - profiles <- map entityVal <$> selectList [ProfileUserId ==. userId] [] - sites <- M.fromList . map entityToTuple <$> selectList [SiteId <-. (profileSiteId <$> profiles)] [] - return . arrangeProfiles profiles . compileTemplates $ sites + userProfiles <- handlerToWidget $ do + profiles <- runDB $ map entityVal <$> selectList [ProfileUserId ==. userId] [] + sites <- Site.fetch $ profileSiteId <$> profiles + return . arrangeProfiles profiles $ sites pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] [] $(widgetFile "mf2/h-card")