{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} -- | Higher-level functions to interact with CouchDB views. -- To manipulate views in design documents see -- "Database.CouchDB.Conduit.Design" module Database.CouchDB.Conduit.View ( -- * Acccessing views #run# -- $run couchView, couchView', couchViewPost, couchViewPost', rowValue, -- * View query parameters -- $view_query #view_query# mkParam ) where import Control.Monad.Trans.Class (lift) import Control.Applicative ((<|>)) import Data.Monoid (mconcat) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Char8 as BC8 import qualified Data.HashMap.Lazy as M import qualified Data.Aeson as A import Data.Attoparsec import Data.Conduit (ResourceIO, ResourceT, Source, Conduit, Sink, ($$), ($=), sequenceSink, SequencedSinkResponse(..), resourceThrow ) import qualified Data.Conduit.List as CL import qualified Data.Conduit.Attoparsec as CA import qualified Network.HTTP.Conduit as H import qualified Network.HTTP.Types as HT import Database.CouchDB.Conduit.Internal.Connection import Database.CouchDB.Conduit.LowLevel (couch, protect') ----------------------------------------------------------------------------- -- View query parameters ----------------------------------------------------------------------------- -- $view_query -- For details see -- <http://wiki.apache.org/couchdb/HTTP_view_API#Querying_Options>. Note, -- because all options must be a proper URL encoded JSON, construction of -- complex parameters can be very tedious. To simplify this, use 'mkParam'. -- | Encode query parameter to 'B.ByteString'. -- -- > mkParam (["a", "b"] :: [String]) -- > "[\"a\",\"b\"]" -- -- It't just convert lazy 'BL.ByteString' from 'A.encode' to strict -- 'B.ByteString' mkParam :: A.ToJSON a => a -- ^ Parameter -> B.ByteString mkParam = mconcat . BL.toChunks . A.encode ----------------------------------------------------------------------------- -- Running ----------------------------------------------------------------------------- -- $run -- In contrast to the functions of access to documents that are loaded into -- memory entirely. 'couchView' and 'couchView'' combines the incredible power -- of /http-conduit/ and /attoparsec/ to allow you to process objects in -- constant space. -- -- As data is read from the network, it is fed into attoparsec. When -- attoparsec completes parsing row, it sent to 'Sink'. 'Sink' can be composed -- from many conduits with sink at the end, such as 'rowValue', view conduits -- from "Database.CouchDB.Conduit.Explicit#view" and -- "Database.CouchDB.Conduit.Generic#view", and many others. See -- "Data.Conduit" for details and documentation. -- | Run CouchDB view in manner like 'H.http'. -- -- > runCouch def $ do -- > -- > -- Print all upon receipt. -- > src <- couchView "mydb" "mydesign" "myview" [] -- > src $$ CL.mapM_ (liftIO . print) -- > -- > -- ... Or extract row value and consume -- > src' <- couchView "mydb" "mydesign" "myview" [] -- > res <- src' $= rowValue $$ CL.consume couchView :: MonadCouch m => Path -- ^ Database -> Path -- ^ Design document -> Path -- ^ View name -> HT.Query -- ^ Query parameters -> ResourceT m (Source m A.Object) couchView db design view q = do H.Response _ _ bsrc <- couch HT.methodGet (viewPath db design view) [] q (H.RequestBodyBS B.empty) protect' return $ bsrc $= conduitCouchView -- | Brain-free version of 'couchView'. Takes 'Sink' to consume response. -- -- > runCouch def $ do -- > -- > -- Print all upon receipt. -- > couchView' "mydb" "mydesign" "myview" [] $ CL.mapM_ (liftIO . print) -- > -- > -- ... Or extract row value and consume -- > res <- couchView' "mydb" "mydesign" "myview" [] $ -- > rowValue =$ CL.consume couchView' :: MonadCouch m => Path -- ^ Database -> Path -- ^ Design document -> Path -- ^ View name -> HT.Query -- ^ Query parameters -> Sink A.Object m a -- ^ Sink for handle view rows. -> ResourceT m a couchView' db design view q sink = do raw <- couchView db design view q raw $$ sink -- | Run CouchDB view in manner like 'H.http' using @POST@ (since CouchDB 0.9). -- It's convenient in case that @keys@ paremeter too big for @GET@ query -- string. Other query parameters used as usual. -- -- > runCouch def $ do -- > src <- couchViewPost "mydb" "mydesign" "myview" -- > [("group", Just "true")] -- > ["key1", "key2", "key3"] -- > src $$ CL.mapM_ (liftIO . print) couchViewPost :: (MonadCouch m, A.ToJSON a) => Path -- ^ Database -> Path -- ^ Design document -> Path -- ^ View name -> HT.Query -- ^ Query parameters -> a -- ^ View @keys@. Must be list or cortege. -> ResourceT m (Source m A.Object) couchViewPost db design view q ks = do H.Response _ _ bsrc <- couch HT.methodPost (viewPath db design view) [] q (H.RequestBodyLBS mkPost) protect' return $ bsrc $= conduitCouchView where mkPost = A.encode $ A.object ["keys" A..= ks] -- | Brain-free version of 'couchViewPost'. Takes 'Sink' to consume response. couchViewPost' :: (MonadCouch m, A.ToJSON a) => Path -- ^ Database -> Path -- ^ Design document -> Path -- ^ View name -> HT.Query -- ^ Query parameters -> a -- ^ View @keys@. Must be list or cortege. -> Sink A.Object m a -- ^ Sink for handle view rows. -> ResourceT m a couchViewPost' db design view q ks sink = do raw <- couchViewPost db design view q ks raw $$ sink -- | Conduit for extract \"value\" field from CouchDB view row. rowValue :: ResourceIO m => Conduit A.Object m A.Value rowValue = CL.mapM (\v -> case M.lookup "value" v of (Just o) -> return o _ -> resourceThrow $ CouchInternalError $ BC8.pack ("View row does not contain value: " ++ show v)) ----------------------------------------------------------------------------- -- Internal ----------------------------------------------------------------------------- -- | Make full view path viewPath :: Path -> Path -> Path -> Path viewPath db design view = mkPath [db, "_design", design, "_view", view] ----------------------------------------------------------------------------- -- Internal view parser ----------------------------------------------------------------------------- conduitCouchView :: ResourceIO m => Conduit B.ByteString m A.Object conduitCouchView = sequenceSink () $ \() -> do b <- CA.sinkParser viewStart if b then return $ StartConduit viewLoop else return Stop viewLoop :: ResourceIO m => Conduit B.ByteString m A.Object viewLoop = sequenceSink False $ \isLast -> if isLast then return Stop else do v <- CA.sinkParser (A.json <?> "json object") vobj <- case v of (A.Object o) -> return o _ -> lift $ resourceThrow $ CouchInternalError "view entry is not an object" res <- CA.sinkParser (commaOrClose <?> "comma or close") case res of Comma -> return $ Emit False [vobj] CloseBracket -> return $ Emit True [vobj] data CommaOrCloseBracket = Comma | CloseBracket commaOrClose :: Parser CommaOrCloseBracket commaOrClose = do skipWhile (\c -> c /= 44 && c /= 93) <?> "Checking for next comma" w <- anyWord8 if w == 44 then return Comma else return CloseBracket -- determine view viewStart :: Parser Bool viewStart = do _ <- string "{" _ <- option "" $ string "\"total_rows\":" option () $ skipWhile (\x -> x >= 48 && x <= 57) _ <- option "" $ string ",\"update_seq\":" option () $ skipWhile (\x -> x >= 48 && x <= 57) _ <- option "" $ string ",\"offset\":" option () $ skipWhile (\x -> x >= 48 && x <= 57) _ <- option "" $ string "," _ <- string "\"rows\":[" (string "]}" <|> (do r <- string "]" _ <- option "" $ string ",\"update_seq\":" option () $ skipWhile (\x -> x >= 48 && x <= 57) _ <- option "" $ string "}" return r) >> return False) <|> return True