reflex-dom-contrib-0.2: src/Reflex/Dom/Contrib/Pagination.hs
{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE RecursiveDo #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Reflex.Dom.Contrib.Pagination where
------------------------------------------------------------------------------
import Control.Lens hiding ((.=))
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Default
import Data.Function (on)
import Data.List
import Data.Ord
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe
import Data.Monoid
import Data.Time
import Data.Word
import Reflex
import Reflex.Dom
------------------------------------------------------------------------------
import Reflex.Dom.Contrib.Xhr
------------------------------------------------------------------------------
-----------------
-- Data Types --
-----------------
------------------------------------------------------------------------------
-- | General data structure needed for running queries with paginated results.
data PaginationQuery = PaginationQuery
{ _pqLimit :: Word64
, _pqOffset :: Word64
, _pqSearchString :: String
} deriving (Eq,Show,Read,Ord)
makeLenses ''PaginationQuery
------------------------------------------------------------------------------
instance Default PaginationQuery where
def = PaginationQuery 5000 0 ""
------------------------------------------------------------------------------
instance FromJSON PaginationQuery where
parseJSON (Object o) = PaginationQuery
<$> o .:? "limit" .!= 5000
<*> o .:? "offset" .!= 0
<*> o .: "searchString"
parseJSON _ = fail "PaginationQuery JSON representation must be an object"
------------------------------------------------------------------------------
instance ToJSON PaginationQuery where
toJSON (PaginationQuery l o s) =
object
[ "limit" .= l
, "offset" .= o
, "searchString" .= s
]
------------------------------------------------------------------------------
-- | Data structure wrapping results.
data PaginationResults a = PaginationResults
{ _prOffset :: Word64
, _prTotalCount :: Word64
, _prTimestamp :: UTCTime
, _prResults :: [a]
} deriving (Eq,Show,Read,Ord)
makeLenses ''PaginationResults
------------------------------------------------------------------------------
instance FromJSON a => FromJSON (PaginationResults a) where
parseJSON (Object o) = PaginationResults
<$> o .: "offset"
<*> o .: "totalCount"
<*> o .: "timestamp"
<*> o .: "results"
parseJSON _ = fail "PaginationResults JSON representation must be an object"
------------------------------------------------------------------------------
instance ToJSON a => ToJSON (PaginationResults a) where
toJSON (PaginationResults o c t r) =
object $
[ "offset" .= o
, "totalCount" .= c
, "timestamp" .= t
, "results" .= r
]
-------------------------
-- Front-end Functions --
-------------------------
------------------------------------------------------------------------------
-- Some convenient type aliases
type PaginationCache k v = Map k [CacheVal v]
type PaginationInput k = (k, PaginationQuery)
type PaginationOutput k v = (k, Maybe (CacheVal v))
------------------------------------------------------------------------------
-- | Along with the query results we also need to store the PaginationQuery
-- structure that generated it as well as a flag indicating whether this data
-- should be stored in the cache. This prevents results that are sub-searches
-- of a previous search from overwriting the results of a more general query.
data CacheVal a = CacheVal
{ _pvQuery :: PaginationQuery
, _pvShouldStore :: Bool
, _pvValue :: a
} deriving (Eq, Show, Ord)
makeLenses ''CacheVal
------------------------------------------------------------------------------
data PQParams = PQParams
{ pqpMaxCacheSize :: Int
-- ^ The max number of queries to cache
, pqpPruneAmount :: Int
-- ^ The number of queries to discard when we reach the size limit
} deriving (Eq, Show, Ord)
instance Default PQParams where
def = PQParams 5 3
--def = PQParams 20 5
------------------------------------------------------------------------------
-- | Paginated querying with built-in search and results caching.
paginatedQuery
:: forall t m k a. (MonadWidget t m, Show k, Ord k, FromJSON a)
=> PQParams
-> (String -> a -> Bool)
-> String
-> Event t (Map String ByteString, PaginationInput k)
-- ^ Param map and pagination structure. k is any additional information
-- that you need to disambiguate multiple PaginationQuery entries.
-> m (Event t (Maybe (PaginationResults a)))
paginatedQuery pqp matchSearchString url input = do
rec pcache <- foldDyn ($) mempty (addToCache pqp <$> r)
let eme = attachWith (cachedQuery matchSearchString url)
(current pcache) input
de <- widgetHold (return never) eme
let r = switchPromptlyDyn $ de
return $ fmap _pvValue . snd <$> r
------------------------------------------------------------------------------
addToCache
:: Ord k
=> PQParams
-> PaginationOutput k (PaginationResults v)
-> PaginationCache k (PaginationResults v)
-> PaginationCache k (PaginationResults v)
addToCache PQParams{..} (k, v) m =
if fmap _pvShouldStore v == Just True
then M.insertWith (++) k [fromJust v] m2
else m
where
m2 = if M.size m > pqpMaxCacheSize then prune pqpPruneAmount m else m
------------------------------------------------------------------------------
-- | Prunes the PaginationCache of the oldest n entries. This is not the
-- oldest (k,v) pairs. It is the oldest vs out of all the (k,[v]) pairs.
prune
:: Ord k
=> Int
-> PaginationCache k (PaginationResults v)
-> PaginationCache k (PaginationResults v)
prune n m =
M.fromList $ map g $ groupBy ((==) `on` fst) $ sortBy (comparing fst) $
drop n $ sortBy (comparing $ _prTimestamp . _pvValue . snd) $
concatMap f $ M.toList m
where
f (k,vs) = map (k,) vs
g [] = error "prune impossible error"
g ps = (fst $ head ps, map snd ps)
------------------------------------------------------------------------------
-- | Checks a cache and makes a request to the supplied URL if the cached data
-- cannot be used to serve the results of the current requested query.
cachedQuery
:: (MonadWidget t m, Show k, Ord k, FromJSON a)
=> (String -> a -> Bool)
-> String
-> PaginationCache k (PaginationResults a)
-> (Map String ByteString, PaginationInput k)
-> m (Event t (PaginationOutput k (PaginationResults a)))
cachedQuery matchSearchString url cache input = do
let (k, pq) = snd input
pb <- getPostBuild
let getData = do
res <- getAndDecode (mkFullPath input <$ pb)
return $ (\v -> (k, CacheVal pq True <$> v)) <$> res
case M.lookup k cache of
Nothing -> getData
Just pvs ->
case filter (isSubSearch pq) pvs of
[] -> getData
pv:_ -> do
let pv2 = pv & (pvValue . prResults) %~
filter (matchSearchString $ _pqSearchString pq)
& pvShouldStore .~ False
return $ (k,Just pv2) <$ pb
where
mkFullPath p = url <> "?" <> queryString p
queryString (ps, (_,pq)) = formEncode $
M.insert "pagination" (encode pq) ps
------------------------------------------------------------------------------
-- | Checks whether a previous cached search string is a substring of the
-- current search string. In this case we don't need to requery the server.
isSubSearch
:: PaginationQuery
-> CacheVal (PaginationResults a)
-- ^ Cached query results
-> Bool
isSubSearch pq pv =
(_pqSearchString (_pvQuery pv) `isInfixOf` _pqSearchString pq) &&
(_prTotalCount pr == fromIntegral (length (_prResults pr))) &&
(_prOffset pr == 0)
where
pr = _pvValue pv