24 lines
1 KiB
Haskell
24 lines
1 KiB
Haskell
|
{-# LANGUAGE DeriveDataTypeable #-}
|
||
|
|
{-# LANGUAGE FlexibleContexts #-}
|
||
|
|
{-# LANGUAGE TypeFamilies #-}
|
||
|
|
module Model.Cache ( getCached ) where
|
||
|
|
|
||
|
|
import Data.Typeable ( Typeable )
|
||
|
|
import Database.Persist ( Entity (..), Key (..), PersistStore, PersistRecordBackend, keyToValues )
|
||
|
|
import Yesod ( MonadHandler, HandlerSite, YesodPersist, YesodPersistBackend, cachedBy, get404, liftHandlerT, runDB )
|
||
|
|
|
||
|
|
import qualified Data.ByteString.Char8 as C
|
||
|
|
|
||
|
|
newtype CachedEntity t = CachedEntity { unCachedEntity :: Entity t } deriving Typeable
|
||
|
|
|
||
|
|
getCached :: ( MonadHandler m
|
||
|
|
, YesodPersist (HandlerSite m)
|
||
|
|
, PersistStore (YesodPersistBackend (HandlerSite m))
|
||
|
|
, PersistRecordBackend entity (YesodPersistBackend (HandlerSite m))
|
||
|
|
, Typeable entity
|
||
|
|
) => Key entity -> m (Entity entity)
|
||
|
|
getCached entId = liftHandlerT . cached . runDB . withId . get404 $ entId
|
||
|
|
where key = C.pack . show . keyToValues $ entId
|
||
|
|
withId = fmap $ Entity entId
|
||
|
|
cached = fmap unCachedEntity . cachedBy key . fmap CachedEntity
|