Refactor site-fetching into a reusable module

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] []

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)

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