00dani/lebd
1
0
Fork 0
Code Issues Pull requests Releases Wiki Activity

Refactor site-fetching into a reusable module

Browse source
This commit is contained in:
Danielle McLean 2017-10-10 19:16:12 +11:00
parent ddf86d901b
commit 716769d24e
Signed by: 00dani
GPG key ID: 5A5D2D1AFF12EEC5
3 changed files with 32 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

21
src/Site.hs Normal file
View file

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

6
src/Util.hs
View file

@ -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 ( Template(..), compileTemplate )
import Text.Mustache.Types ( Node(TextBlock) ) import Text.Mustache.Types ( Node(TextBlock) )
import Text.Parsec.Error ( ParseError ) import Text.Parsec.Error ( ParseError )
@ -20,3 +21,6 @@ errorTemplate err = Template
, ast = [TextBlock . T.pack $ show err] , ast = [TextBlock . T.pack $ show err]
, partials = M.empty , partials = M.empty
} }
entityToTuple :: Entity t -> (Key t, t)
entityToTuple (Entity key value) = (key, value)

18
src/Widget/Card.hs
View file

@ -4,20 +4,14 @@
module Widget.Card ( hCard ) where module Widget.Card ( hCard ) where
import Import import Import
import Util ( compileMustache )
import qualified Site
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import Text.Mustache ( Template, substitute ) import Text.Mustache ( Template, substitute )
import qualified Data.Map as M import qualified Data.Map as M
import qualified Data.Text as T 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 :: [Profile] -> M.Map (Key Site) (Site, Template) -> [((Site, Template), Profile)]
arrangeProfiles profiles sites = sortBy icon $ zip profileSites profiles arrangeProfiles profiles sites = sortBy icon $ zip profileSites profiles
where findSite = fromJust . flip M.lookup sites . profileSiteId 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 User -> Widget
hCard (Entity userId user) = do hCard (Entity userId user) = do
mcurrentRoute <- getCurrentRoute mcurrentRoute <- getCurrentRoute
userProfiles <- handlerToWidget . runDB $ do userProfiles <- handlerToWidget $ do
profiles <- map entityVal <$> selectList [ProfileUserId ==. userId] [] profiles <- runDB $ map entityVal <$> selectList [ProfileUserId ==. userId] []
sites <- M.fromList . map entityToTuple <$> selectList [SiteId <-. (profileSiteId <$> profiles)] [] sites <- Site.fetch $ profileSiteId <$> profiles
return . arrangeProfiles profiles . compileTemplates $ sites return . arrangeProfiles profiles $ sites
pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] [] pgpKeys <- handlerToWidget . runDB $ map entityVal <$> selectList [PgpKeyUserId ==. userId] []
$(widgetFile "mf2/h-card") $(widgetFile "mf2/h-card")