module Database.Persist.Zookeeper.Query
where
import Database.Persist
import Data.Monoid
import qualified Data.List as L
import Control.Monad
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Trans.Reader
import qualified Data.Text as T
import qualified Database.Zookeeper as Z
import Database.Persist.Zookeeper.Config
import Database.Persist.Zookeeper.Internal
import Database.Persist.Zookeeper.Store ()
import Database.Persist.Zookeeper.ZooUtil
import Data.Conduit
import qualified Data.Conduit.List as CL
import Data.Acquire
instance PersistQuery Z.Zookeeper where
updateWhere filterList valList = do
stat <- ask
srcRes <- selectKeysRes filterList []
liftIO $ with srcRes ( $$ loop stat)
where
loop stat = do
key <- await
case key of
Just key' -> do
liftIO $ flip runReaderT stat $ update key' valList
loop stat
Nothing ->
return ()
deleteWhere filterList = do
(str::[String]) <- execZookeeper $ \zk -> do
zGetChildren zk (filter2path filterList)
loop str
where
loop [] = return ()
loop (x:xs) = do
let key = txtToKey x
case filterList of
[] -> delete key
_ -> del key
loop xs
del key = do
va <- get key
case va of
Nothing -> return ()
Just v -> do
let (chk,_,_) = filterClause v filterList
if chk
then delete key
else return ()
selectSourceRes filterList opt = do
stat <- ask
(str::[String]) <- liftIO $ flip runReaderT stat $ do
keys <- execZookeeper $ \zk -> do
Z.getChildren zk (filter2path filterList) Nothing
selectOptParser keys opt
return $ return $ loop stat str
where
loop _ [] = return ()
loop stat (x:xs) = do
let key = txtToKey x
va <- liftIO $ flip runReaderT stat $ get key
case va of
Nothing -> return ()
Just v -> do
let (chk,_,_) = filterClause v filterList
if chk
then yield $ Entity key v
else return ()
loop stat xs
selectFirst filterList opt = do
srcRes <- selectSourceRes filterList opt
liftIO $ with srcRes ( $$ CL.head)
selectKeysRes filterList opt = do
stat <- ask
(str::[String]) <- liftIO $ flip runReaderT stat $ do
keys <- execZookeeper $ \zk -> do
Z.getChildren zk (filter2path filterList) Nothing
selectOptParser keys opt
return $ return (loop stat str)
where
loop _ [] = return ()
loop stat (x:xs) = do
let key = txtToKey x
va <- liftIO $ flip runReaderT stat $ get key
case va of
Nothing -> return ()
Just v -> do
let (chk,_,_) = filterClause v filterList
if chk
then yield key
else return ()
loop stat xs
count filterList = do
v <- selectList filterList []
return $ length v
dummyFromFilts :: [Filter v] -> Maybe v
dummyFromFilts _ = Nothing
data OrNull = OrNullYes | OrNullNo
filterClauseHelper :: PersistEntity val
=> Bool
-> OrNull
-> val
-> [Filter val]
-> (Bool, T.Text, [PersistValue])
filterClauseHelper includeWhere orNull val filters =
(bool, if not (T.null sql) && includeWhere
then " WHERE " <> sql
else sql, vals)
where
(bool, sql, vals) = combineAND filters
combineAND = combine " AND " (&&)
combineOR = combine " OR " (||)
combine s op fs =
(foldr1 op c ,T.intercalate s $ map wrapP a, mconcat b)
where
(c, a, b) = unzip3 $ map go fs
wrapP x = T.concat ["(", x, ")"]
go (BackendFilter _) = error "BackendFilter not expected"
go (FilterAnd []) = (True,"1=1", [])
go (FilterAnd fs) = combineAND fs
go (FilterOr []) = (False,"1=0", [])
go (FilterOr fs) = combineOR fs
go (Filter field value pfilter) =
(showSqlFilter' pfilter (fieldval field val) allVals,
name <> ":"
<> T.pack (show (fieldval field val)) <> ":"
<> showSqlFilter pfilter
<> T.pack (show (showSqlFilter' pfilter (fieldval field val) allVals))
<> "?5:" <> T.pack (show allVals) <> orNullSuffix, allVals)
where
filterValueToPersistValues :: forall a. PersistField a => Either a [a] -> [PersistValue]
filterValueToPersistValues v = map toPersistValue $ either return id v
orNullSuffix =
case orNull of
OrNullYes -> mconcat [" OR ", name, " IS NULL"]
OrNullNo -> ""
allVals = filterValueToPersistValues value
name = unDBName $ fieldDB $ persistFieldDef field
showSqlFilter Eq = "="
showSqlFilter Ne = "<>"
showSqlFilter Gt = ">"
showSqlFilter Lt = "<"
showSqlFilter Ge = ">="
showSqlFilter Le = "<="
showSqlFilter In = " IN "
showSqlFilter NotIn = " NOT IN "
showSqlFilter (BackendSpecificFilter s) = s
showSqlFilter' :: PersistFilter -> PersistValue -> [PersistValue] -> Bool
showSqlFilter' Eq a b = (==) a (head b)
showSqlFilter' Ne a b = (/=) a (head b)
showSqlFilter' Gt a b = (>) a (head b)
showSqlFilter' Lt a b = (<) a (head b)
showSqlFilter' Ge a b = (>=) a (head b)
showSqlFilter' Le a b = (<=) a (head b)
showSqlFilter' In _ [] = False
showSqlFilter' In a (x:xs) = if a==x then True else showSqlFilter' In a xs
showSqlFilter' NotIn _ [] = True
showSqlFilter' NotIn a (x:xs) = if a==x then False else showSqlFilter' NotIn a xs
showSqlFilter' (BackendSpecificFilter _s) _ _ = error "not supported"
filterClause :: PersistEntity val
=> val
-> [Filter val]
-> (Bool, T.Text, [PersistValue])
filterClause _val [] = (True,"",[])
filterClause val filter' = filterClauseHelper True OrNullNo val filter'
addIdx :: [[String]] -> [(String,Int)]
addIdx keys = concat $ map (\(i,ks) -> map (\k -> (k,i)) ks) $ zip [0..] keys
delIdx :: [(String,Int)] -> [[String]]
delIdx keys = fstIdx $ L.groupBy cmp keys
where
cmp :: (String,Int) -> (String,Int) -> Bool
cmp (_k0,i0) (_k1,i1) = i0==i1
dropIdx :: Int -> [[String]] -> [[String]]
dropIdx num keys = delIdx $ drop num $ addIdx keys
takeIdx :: Int -> [[String]] -> [[String]]
takeIdx num keys = delIdx $ take num $ addIdx keys
sortIdx' :: Ord a => Bool -> [(String,a)] -> [[(String,a)]]
sortIdx' asc keys = L.groupBy (\(_k0,i0) (_k1,i1)-> i0==i1) $ L.sortBy (cmp' asc) keys
where
cmp' True (_k0,v0) (_k1,v1) = compare v0 v1
cmp' False (_k0,v0) (_k1,v1) = compare v1 v0
sortIdx :: Ord a => Bool -> [[(String,a)]] -> [[(String,a)]]
sortIdx asc keys = concat $ map (sortIdx' asc) keys
fstIdx :: Ord a => [[(String,a)]] -> [[String]]
fstIdx keys = flip map keys $ \ks -> flip map ks $ \k -> fst k
selectOptParser' :: (PersistStore backend, MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
=> [[String]]
-> [SelectOpt val]
-> ReaderT backend m [[String]]
selectOptParser' keys [] = do
return keys
selectOptParser' keys (OffsetBy i:xs) = do
selectOptParser' (dropIdx i keys) xs
selectOptParser' keys (LimitTo i:xs) = do
selectOptParser' (takeIdx i keys) xs
selectOptParser' keys (Asc field:xs) = do
keysWithVal <- forM keys $ \ks -> do
forM ks $ \k -> do
let key = txtToKey k
val <- get key
case val of
Nothing -> fail "can not get value"
Just v -> return $ (k,fieldval field v)
selectOptParser' (fstIdx $ sortIdx True keysWithVal) xs
selectOptParser' keys (Desc field:xs) = do
keysWithVal <- forM keys $ \ks -> do
forM ks $ \k -> do
let key = txtToKey k
val <- get key
case val of
Nothing -> fail "can not get value"
Just v -> return $ (k,fieldval field v)
selectOptParser' (fstIdx $ sortIdx False keysWithVal) xs
selectOptParser :: (PersistStore backend, MonadIO m, PersistEntity val, backend ~ PersistEntityBackend val)
=> [String]
-> [SelectOpt val]
-> ReaderT backend m [String]
selectOptParser keys opt' = do
keys' <- selectOptParser' [keys] $ selectOpt opt' [] Nothing Nothing
return $ concat keys'
where
selectOpt (opt@(Asc _):opts) sortOpt offset limit = selectOpt opts (sortOpt++[opt]) offset limit
selectOpt (opt@(Desc _):opts) sortOpt offset limit = selectOpt opts (sortOpt++[opt]) offset limit
selectOpt (opt@(LimitTo _):opts) sortOpt offset Nothing = selectOpt opts sortOpt offset (Just opt)
selectOpt (opt@(OffsetBy _):opts) sortOpt Nothing limit = selectOpt opts sortOpt (Just opt) limit
selectOpt (_opt:opts) sortOpt offset limit = selectOpt opts sortOpt offset limit
selectOpt [] sortOpt offset limit = sortOpt ++ maybe [] (\v -> [v]) offset ++ maybe [] (\v -> [v]) limit