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 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 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
]
type PaginationCache k v = Map k [CacheVal v]
type PaginationInput k = (k, PaginationQuery)
type PaginationOutput k v = (k, Maybe (CacheVal v))
data CacheVal a = CacheVal
{ _pvQuery :: PaginationQuery
, _pvShouldStore :: Bool
, _pvValue :: a
} deriving (Eq, Show, Ord)
makeLenses ''CacheVal
data PQParams = PQParams
{ pqpMaxCacheSize :: Int
, pqpPruneAmount :: Int
} deriving (Eq, Show, Ord)
instance Default PQParams where
def = PQParams 5 3
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)
-> 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
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)
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
isSubSearch
:: PaginationQuery
-> CacheVal (PaginationResults a)
-> Bool
isSubSearch pq pv =
(_pqSearchString (_pvQuery pv) `isInfixOf` _pqSearchString pq) &&
(_prTotalCount pr == fromIntegral (length (_prResults pr))) &&
(_prOffset pr == 0)
where
pr = _pvValue pv