module EZCouch.ReadAction where
import Prelude ()
import ClassyPrelude.Conduit
import EZCouch.Action
import EZCouch.Entity
import EZCouch.Types
import EZCouch.Parsing
import EZCouch.View
import EZCouch.Logging
import EZCouch.Crash
import qualified EZCouch.Encoding as Encoding
import qualified Database.CouchDB.Conduit.View.Query as CC
import qualified System.Random as Random
import qualified EZCouch.Base62 as Base62
import qualified Network.HTTP.Conduit as HTTP
import qualified Network.HTTP.Types as HTTP
import Data.Aeson.Types
data KeysSelection k
= KeysSelectionAll
| KeysSelectionRange k k
| KeysSelectionRangeStart k
| KeysSelectionRangeEnd k
| KeysSelectionList [k]
deriving (Show, Eq)
readAction :: (MonadAction m, Entity a, ToJSON k)
=> Bool
-> Int
-> Maybe Int
-> Bool
-> KeysSelection k
-> View a k
-> m Value
readAction includeDocs skip limit desc mode view = do
result <- action path qps body
case result of
ResponseNotFound -> do
logLn 2 $ "View "
++ fromMaybe undefined (viewGeneratedName view)
++ " does not exist. Generating."
createOrUpdateView view
action path qps body >>= \r -> case r of
ResponseNotFound -> crash "readAction keeps getting a ResponseNotFound"
ResponseOk json -> return json
ResponseOk json -> return json
where
action = case mode of
KeysSelectionList {} -> postAction
_ -> getAction
path = viewPath view
qps = catMaybes [
includeDocsQP includeDocs,
startKeyQP view mode,
endKeyQP view mode,
descQP desc,
limitQP limit,
skipQP skip
]
body = case mode of
KeysSelectionList keys -> Encoding.keysBody keys
_ -> ""
startKeyQP _ (KeysSelectionRange start end) = Just $ CC.QPStartKey start
startKeyQP _ (KeysSelectionRangeStart start) = Just $ CC.QPStartKey start
startKeyQP _ (KeysSelectionList {}) = Nothing
startKeyQP view@ViewById _ = Just $ CC.QPStartKey $ viewDocType view ++ "-"
startKeyQP _ _ = Nothing
endKeyQP _ (KeysSelectionRange start end) = Just $ CC.QPEndKey end
endKeyQP _ (KeysSelectionRangeEnd end) = Just $ CC.QPEndKey end
endKeyQP _ (KeysSelectionList {}) = Nothing
endKeyQP view@ViewById _ = Just $ CC.QPEndKey $ viewDocType view ++ "."
endKeyQP _ _ = Nothing
limitQP limit = CC.QPLimit <$> limit
skipQP skip = if skip /= 0 then Just $ CC.QPSkip skip else Nothing
descQP desc = if desc then Just CC.QPDescending else Nothing
includeDocsQP True = Just CC.QPIncludeDocs
includeDocsQP False = Nothing
readKeys :: (MonadAction m, Entity a, ToJSON k, FromJSON k)
=> KeysSelection k
-> View a k
-> m [k]
readKeys mode view = fmap (map fst . filter snd) $ readKeysExist mode view
readCount :: (MonadAction m, Entity a, ToJSON k, FromJSON k)
=> KeysSelection k
-> View a k
-> m Int
readCount mode view = fmap length $ readKeys mode view
readKeysExist :: (MonadAction m, Entity a, ToJSON k, FromJSON k)
=> KeysSelection k
-> View a k
-> m [(k, Bool)]
readKeysExist mode view =
readAction False 0 Nothing False mode view
>>= runParser (rowsParser1 >=> mapM keyExistsParser . toList)
readEntities :: (MonadAction m, Entity a, ToJSON k)
=> Int
-> Maybe Int
-> Bool
-> KeysSelection k
-> View a k
-> m [Persisted a]
readEntities skip limit desc mode view =
readAction True skip limit desc mode view
>>= runParser (rowsParser1 >=> mapM persistedParser . toList)
>>= return . catMaybes
readEntity :: (MonadAction m, Entity a, ToJSON k)
=> Int
-> Bool
-> KeysSelection k
-> View a k
-> m (Maybe (Persisted a))
readEntity skip desc mode view =
listToMaybe <$> readEntities skip (Just 1) desc mode view
readRandomEntities :: (MonadAction m, Entity a)
=> Maybe Int
-> m [Persisted a]
readRandomEntities limit = do
startKey :: Double <- liftIO $ Random.randomRIO (0.0, 1.0)
readEntities
0
limit
False
(KeysSelectionRangeStart startKey)
(ViewByKeys1 ViewKeyFloatRevHash)
readKeys' = readKeys KeysSelectionAll
readCount' = readCount KeysSelectionAll
readKeysExist' = readKeysExist KeysSelectionAll
readEntities' = readEntities 0
readEntities'' = readEntities 0 Nothing
readEntities''' = readEntities 0 Nothing False
readEntities'''' = readEntities 0 Nothing False KeysSelectionAll
readEntities''''' = readEntities 0 Nothing False KeysSelectionAll ViewById
readEntity' = readEntity 0
readEntity'' = readEntity 0 False
readEntity''' = readEntity 0 False KeysSelectionAll
readEntity'''' = readEntity 0 False KeysSelectionAll ViewById