{-# LANGUAGE GeneralizedNewtypeDeriving #-}{-# LANGUAGE DeriveDataTypeable #-}{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE FlexibleInstances #-}{-# LANGUAGE FlexibleContexts #-}{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables #-}{- |
With the advent of conduits, you are strongly encouraged to use couchdb-conduit
<http://hackage.haskell.org/package/couchdb-conduit> instead of this package.
It exports almost the same interface but uses conduits instead of enumerator.
This module is a very thin wrapper around "Network.HTTP.Enumerator" using
the aeson package to parse and encode JSON. The Couch DB HTTP API is the
best place to learn about how to use this library.
<http://wiki.apache.org/couchdb/Complete_HTTP_API_Reference>
> {-# LANGUAGE OverloadedStrings #-}
> import Control.Monad.IO.Class (liftIO)
> import Data.Aeson
> import qualified Data.ByteString.Lazy as BL
> import Data.ByteString.UTF8 (fromString)
> import Data.Enumerator (($$), run_)
> import qualified Data.Enumerator.List as EL
> import Database.CouchDB.Enumerator
>
> testCouch :: IO ()
> testCouch = runCouch "localhost" 5984 "test" $ do
> -- Make database if not present
> couchPutDb ""
>
> -- Insert some documents. Note that the dbname passed to
> -- withCouchConnection is prepended to the given path, so this is a put
> -- to http://localhost:5984/test/doc1> rev1 <- couchPut "doc1" [] $ object [ "foo" .= (3 :: Int),
> "bar" .= ("abc" :: String) ]
> rev2 <- couchPut "doc2" [] $ object [ "foo" .= (7 :: Int),
> "baz" .= (145 :: Int) ]
>
> -- Load the document and print it out
> couchGet "doc1" [] >>= liftIO . BL.putStrLn . encode . Object
>
> -- Overwite the document. We supply the revision, otherwise Couch DB
> -- would give an error. (The revision could also have been passed
> -- in the query arguments.)
> rev3 <- couchPut "doc1" [] $ object [ "foo" .= (10 :: Int)
> , "bar" .= ("def" :: String)
> , "_rev" .= rev1 ]
>
> -- Create a view
> couchPut_ "_design/testdesign" [] $
> object [ "language" .= ("javascript" :: String)
> , "views" .= object [ "myview" .= object [ "map" .=
> ("function(doc) { emit(doc.foo, doc); }" :: String)
> ]]
> ]
>
> -- Read from the view using couchGet and print it out.
> couchGet "_design/testdesign/_view/myview" [] >>=
> liftIO . BL.putStrLn . encode . Object
> couchGet "_design/testdesign/_view/myview"
> [(fromString "key", Just $ fromString "10")]
> >>= liftIO . BL.putStrLn . encode . Object
>
> -- Read the view using couchView and print it out.
> run_ $ couchView "testdesign/_view/myview" [] $$
> EL.foldM (\_ o -> liftIO $ BL.putStrLn $ encode $ Object o) ()
>
> -- .. with restrictions and extracting view value
> run_ $ couchView "testdesign/_view/myview"
> [(fromString "key", Just $ fromString "10")] $= extractViewValue $$
> EL.foldM (\_ o -> liftIO $ BL.putStrLn $ encode $ Object o) ()
>
> -- .. and in strict manner
> v1 <- couchView "testdesign/_view/myview" [] $= extractViewValue
> EL.consume
> print v1
>
> -- Delete the objects
> couchDelete "doc1" rev3
> couchDelete "doc2" rev2
>
> -- Delete test database
> couchDeleteDb ""
-}moduleDatabase.CouchDB.Enumerator(-- * Couch DB ConnectionCouchConnection(..),runCouch,withCouchConnection,CouchError(..),MonadCouch(..)-- * Couch DB database API,couchPutDb,couchDeleteDb-- * Couch DB documents API,Path,Revision,couchRev,couchGet,couchPut,couchPutRev,couchPut_,couchDelete-- * Couch DB views API,couchView,extractViewValue-- * Low-level API,couch,couch'-- * Connection Pooling-- $pool-- * Yesod Integration-- $yesod)whereimportPreludehiding(catch)importControl.ApplicativeimportControl.Exception(Exception,throw,bracket)importControl.Exception.Lifted(catch)importControl.Monad.IO.Class(MonadIO,liftIO)importControl.Monad.Trans.Class(MonadTrans,lift)importControl.Monad.Trans.Control(MonadBaseControl,liftBaseOp)importControl.Monad.Trans.Reader(ReaderT,ask,runReaderT)importData.Maybe(fromJust)importqualifiedData.AesonasA--import qualified Data.Aeson.Encode as AEimportData.AttoparsecimportData.Attoparsec.Enumerator(iterParser)importqualifiedData.ByteStringasBimportqualifiedData.ByteString.UTF8asBU8importData.Enumeratorhiding(map)importqualifiedData.HashMap.LazyasMimportqualifiedData.TextasTimportqualifiedData.Text.EncodingasTEimportData.Typeable(Typeable)importqualifiedNetwork.HTTP.EnumeratorasHimportqualifiedNetwork.HTTP.TypesasHT-- | Represents a connection to a single Couch DB Database. ---- A connection contains a 'H.Manager' and reuses it for multiple requests, -- which means a single open HTTP connection to CouchDB will be kept around -- until the manager is closed (http-enumerator will create more connections -- if needed, it just keeps only one and closes the rest.) See the Pool -- section for more information.---- To access more than one database, the dbname entry can be set to the-- empty string.dataCouchConnection=CouchConnection{host::B.ByteString,port::Int,manager::H.Manager,dbname::String}-- | Connect to a CouchDB database, call the supplied function, and then close -- the connection.-- -- If you create your own instance of 'MonadCouch' instead of using -- 'runCouch', this function will help you create the 'CouchConnection'. On -- the other hand, if you want to implement connection pooling, you will not -- be able to use withCouchConnection and must create the connection yourself.withCouchConnection::(MonadBaseControlIOm)=>String-- ^ Host->Int-- ^ Port->String-- ^ Database name. Just set empty if you -- need access to many DBs->(CouchConnection->ma)-- ^ Function to run->mawithCouchConnectionhpdbf=liftBaseOp(bracketH.newManagerH.closeManager)gowheregom=f$CouchConnection(BU8.fromStringh)pmdb-- | A Couch DB Error. If the error comes from http, the http status code -- is also given. Non-http errors include things like errors -- parsing the response.dataCouchError=CouchError(MaybeInt)Stringderiving(Show,Typeable)instanceExceptionCouchError-- | A monad which allows access to the connection.class(MonadIOm,MonadBaseControlIOm)=>MonadCouchmwherecouchConnection::mCouchConnectioninstance(MonadIOm,MonadBaseControlIOm)=>MonadCouch(ReaderTCouchConnectionm)wherecouchConnection=ask-- | Run a sequence of CouchDB actions.---- The functions below to access CouchDB require a 'MonadCouch' instance to -- access the connection information. 'ReaderT' is an instance of -- 'MonadCouch', and /runCouch/ runs a sequence of database actions using -- 'ReaderT'. See the top of this page for an example using /runCouch/.---- The main reason to not use /runCouch/ is to obtain more control over -- connection pooling. Also, if your db code is part of a larger monad, it -- makes sense to just make the larger monad an instance of 'MonadCouch' and -- skip the intermediate ReaderT, since then performance is improved by -- eliminating one monad from the final transformer stack.---- This function is a combination of 'withCouchConnection' and 'runReaderT'runCouch::(MonadIOm,MonadBaseControlIOm)=>String-- ^ Host->Int-- ^ Port->String-- ^ Database name. Just set empty if you -- need access to many DBs->ReaderTCouchConnectionma-- ^ CouchDB actions->marunCouchhpd=withCouchConnectionhpd.runReaderT-- | A path to a Couch DB Object.typePath=String-- | Represents a revision of a Couch DB Document.typeRevision=T.Text-- | Simplified version of 'couch''. ---- Response headers are ignored, and the response status is only used to-- detect for an error, in which case a 'CouchError' is sent down the-- 'Iteratee'.couch::MonadCouchm=>HT.Method-- ^ Method->Path-- ^ The dbname from the connection is -- prepended to this path. Just set empty -- if you need access to many DBs.->HT.Query-- ^ Query arguments->IterateeB.ByteStringma-- ^ Iteratee to process the response if no -- error occurs.->H.RequestBodym-- ^ Body->IterateeB.ByteStringmacouchmpqi=couch'mp[]q(consti)-- | The most general method of accessing CouchDB. This is a very thin wrapper -- around 'H.http'. Most of the time you should use one of the other access -- functions, but this function is needed for example to write and read -- attachments that are not in JSON format.-- -- If CouchDB returns an error, the iteratee passed to this function is not-- called and instead a 'CouchError' is sent out the Iteratee returned from-- this function.couch'::MonadCouchm=>HT.Method-- ^ Method->Path-- ^ The dbname from the connection is -- prepended to this path. Just set empty -- if you need access to many DBs.->HT.RequestHeaders-- ^ Headers->HT.Query-- ^ Query arguments->(HT.ResponseHeaders->IterateeB.ByteStringma)-- ^ Function what returns Iteratee to -- process the response if no error occurs.->H.RequestBodym-- ^ Body->IterateeB.ByteStringmacouch'mphqib=Iteratee$doconn<-couchConnectionletreq=H.def{H.method=m,H.host=hostconn,H.requestHeaders=h,H.port=portconn,H.path=BU8.fromString("/"++dbnameconn++"/"++p),H.queryString=q,H.requestBody=b}runIteratee$H.httpreq(\sh1->tryAcceptsh1i)(managerconn)-- | Create CouchDB database regardless of presence. Roughly equivalent to-- -- > couchPut_ "" [] $ object []-- -- but catches 'CouchError' /412/.couchPutDb::MonadCouchm=>Path-- ^ If you passed a database name to 'withCouchConnection',-- 'runCouch', or 'CouchConnection', the path should be-- the empty string. If you passed the empty string to-- 'CouchConnection', then the dbname should be used here.->m()couchPutDbp=catch(couchPut_p[]$A.object[])handlerwherehandler(CouchError(Just412)_)=return()handlere=throwe-- | Delete a database.couchDeleteDb::MonadCouchm=>Path-- ^ If you passed a database name to 'withCouchConnection',-- 'runCouch', or 'CouchConnection', the path should be-- the empty string. If you passed the empty string to-- 'CouchConnection', then the dbname should be used here.->m()couchDeleteDbp=run_$couchHT.methodDeletep[](yield()EOF)(H.RequestBodyBSB.empty)-- | Get Revision of a document. couchRev::MonadCouchm=>Path->mRevisioncouchRevp=dov<-run_$couch'HT.methodHeadp[][]getEtag(H.RequestBodyBSB.empty)return$T.dropAround(=='"')$TE.decodeUtf8vwheregetEtagh=yield(fromJust$lookup"Etag"h)EOF-- | Load a single object from couch DB.couchGet::MonadCouchm=>Path-- ^ the dbname is prepended to this string to -- form the full path.->HT.Query-- ^ Query arguments.->mA.ObjectcouchGetpq=dov<-run_$couchHT.methodGetpq(iterParserA.json)(H.RequestBodyBSB.empty)eitherthrowreturn$valToObjv-- | Put an object in Couch DB, returning the new Revision.couchPut::(MonadCouchm,A.ToJSONa)=>Path-- ^ the dbname is prepended to this string to -- form the full path.->HT.Query-- ^ Query arguments.->a-- ^ The object to store.->mRevisioncouchPutpqval=dov<-run_$couchHT.methodPutpq(iterParserA.json)bodyeither(liftIO.throw)return(valToObjv>>=objToRev)wherebody=jsonToReqBodyval-- | Put an object in Couch DB with revision, returning the new Revision.couchPutRev::(MonadCouchm,A.ToJSONa)=>Path-- ^ the dbname is prepended to this string to -- form the full path.->Revision-- ^ Document revision. For new docs provide empty string.->HT.Query-- ^ Query arguments.->a-- ^ The object to store.->mRevisioncouchPutRevprqval=dov<-run_$couch'HT.methodPutp(ifMatchr)q(\_->iterParserA.json)bodyeither(liftIO.throw)return(valToObjv>>=objToRev)wherebody=jsonToReqBodyvalifMatch""=[]ifMatchrv=[("If-Match",TE.encodeUtf8rv)]-- | A version of 'couchPut' which ignores the return value. This is slightly -- faster than / _ <- couchPut .../ since the JSON parser is not run.couchPut_::(MonadCouchm,A.ToJSONa)=>Path-- ^ the dbname is prepended to this string to -- form the full path.->HT.Query-- ^ Query arguments.->a-- ^ The object to store.->m()couchPut_pqval=run_$couchHT.methodPutpq(yield()EOF)bodywherebody=jsonToReqBodyval-- | Delete the given revision of the object.couchDelete::MonadCouchm=>Path-- ^ the dbname is prepended to this string to -- form the full path. ->Revision-- ^ Document revision.->m()couchDeletepr=run_$couchHT.methodDeletep[("rev",Just$TE.encodeUtf8r)](yield()EOF)(H.RequestBodyBSB.empty)-- | Load from a Couch DB View.---- While you can use 'couchGet' on a view object, this function combines the-- incredible power of http-enumerator 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 an object it is sent out -- the enumerator.---- The objects enumerated are the entries in the \"rows\" property of the -- view result, which means they are not directly the objects you put into -- the database. See <http://wiki.apache.org/couchdb/HTTP_view_API> for more -- information. The objects inserted into the database are available in the -- \"value\" entry, and can be extracted with the 'extractViewValue' -- enumeratee, for example:---- > couchView "mydesigndoc/_view/myview" -- > [(fromString "key", Just $ fromString "3")] -- > $= extractViewValuecouchView::MonadCouchm=>Path-- ^ \/dbname\/_design\/ is prepended to the given path.->HT.Query-- ^ Query arguments.->EnumeratorA.ObjectmacouchViewpqstep=dos<-lift$run$couchHT.methodGet("_design/"++p)q(parseViewstep)(H.RequestBodyBSB.empty)eitherthrowErrorreturnIs-- | An enumeratee to extract the \"value\" member of JSON objects.---- This is useful to extract the object from the data returned from a view. -- For example, Couch DB will return objects that look like the following:---- > { "id":"64ACF01B05F53...", "key":null, "value": { some object } }---- and this enumeratee will extract /{some object}/extractViewValue::Monadm=>EnumerateeA.ObjectA.ObjectmaextractViewValue=mapEitherfwherefv=caseM.lookup"value"vof(Just(A.Objecto))->Righto_->Left$CouchErrorNothing"view does not contain value"---------------------------------------------------------------------------------- Helper Code--------------------------------------------------------------------------------- | Internal try accept tryAccept::Monadm=>HT.Status->HT.ResponseHeaders->(HT.ResponseHeaders->IterateeB.ByteStringmb)->IterateeB.ByteStringmbtryAccept(HT.Status200_)hit=ithtryAccept(HT.Status201_)hit=ithtryAccept(HT.Status202_)hit=ithtryAccept(HT.Status304_)hit=ithtryAccept(HT.Statuscms)__=dov<-catchError(iterParserA.json)(\_->yield""EOF)throwError$CouchError(Justc)$msgvwheremsgv=BU8.toStringms++reasonvreason(A.Objectv)=caseM.lookup"reason"vofJust(A.Stringt)->": "++T.unpackt_->""reason_=[]-- | Converts a json object into a 'H.RequestBodyLBS'jsonToReqBody::(A.ToJSONa,Monadm)=>a->H.RequestBodymjsonToReqBodyval=H.RequestBodyLBS$A.encodeval-- where -- jbuilder = AE.fromValue $ A.toJSON val-- enum (Continue k) = k (Chunks [jbuilder])-- enum step = returnI step-- trans = BLB.fromLazyByteString . TLE.encodeUtf8-- untrans = TLE.decodeUtf8 . BL.toLazyByteString-- | Convers a value to an objectvalToObj::A.Value->EitherCouchErrorA.ObjectvalToObj(A.Objecto)=RightovalToObj_=Left$CouchErrorNothing"Couch DB did not return an object"-- | Converts an object to a revisionobjToRev::A.Object->EitherCouchErrorRevisionobjToRevo=caseM.lookup"rev"oof(Just(A.Stringr))->Rightr_->Left$CouchErrorNothing"unable to find revision"dataCommaOrCloseBracket=Comma|CloseBracketcommaOrClose::ParserCommaOrCloseBracketcommaOrClose=doskipWhile(\c->c/=44&&c/=93)<?>"Checking for next comma"w<-anyWord8ifw==44thenreturnCommaelsereturnCloseBracket-- | The main loop of processing the view rows.viewLoop::MonadIOm=>EnumerateeB.ByteStringA.ObjectmaviewLoop(Yielda_)=return$YieldaEOFviewLoop(Errorerr)=return$ErrorerrviewLoop(Continuek)=dov<-iterParser(A.json<?>"json object")vobj<-casevof(A.Objecto)->returno_->throwError$CouchErrorNothing"view entry is not an object"step'<-lift$runIteratee$k$Chunks[vobj]res<-iterParser(commaOrClose<?>"comma or close")caseresofComma->viewLoopstep'CloseBracket->casestep'of(Continuek')->lift$runIteratee$k'EOF_->returnstep'viewStart::ParserBoolviewStart=do_<-string"{\"total_rows\":"skipWhile(\x->x>=48&&x<=57)_<-string",\"offset\":"skipWhile(\x->x>=48&&x<=57)_<-string",\"rows\":["(string"]}">>returnFalse)<|>returnTrue-- | Enumeratee to parse the data returned by a view.parseView::MonadIOm=>EnumerateeB.ByteStringA.ObjectmaparseView(Yielda_)=return$YieldaEOFparseView(Errorerr)=return$ErrorerrparseView(Continuek)=dob<-iterParser(viewStart<?>"start of view")ifbthenviewLoop$Continuekelselift$runIteratee$kEOFmapEither::(Exceptione,Monadm)=>(a->Eithereb)->EnumerateeabmcmapEitherf=checkDone(continue.step)wherestepkEOF=yield(Continuek)EOFstepk(Chunksxs)=casePrelude.mapMfxsofLefterr->throwErrorerrRightxs'->k(Chunksxs')>>==mapEitherf-- $pool-- The 'H.Manager' stored in the CouchConnection maintains a pool of open -- connections in an IORef, but keeps a maximum of one open connection per -- (host,port) pair. Also, each time 'runCouch' or 'withCouchConnection' is -- called, a new manager (and thus new connections) is created and destroyed.---- For more precise control over pooling, use the -- <http://hackage.haskell.org/package/resource-pool> or-- <http://hackage.haskell.org/package/pool> packages combined with the-- 'H.newManager' and 'H.closeManager' functions.---- For example, the following code using the resource-pool package runs a -- /ReaderT CouchConnection m/ action using a HTTP connection from a pool.-- -- > runPooledCouch :: MonadCatchIO m => -- > Pool Manager -- > -> String -- > -> Int -- > -> String -- > -> ReaderT CouchConnection m a -> m a-- > runPooledCouch p host port dbname c = withResource p $ \m -> do-- > runReaderT c $ CouchConnection (BU8.fromString host) port m dbname-- $yesod-- Integrating couchdb-enumerator with yesod looks something the way the -- scaffold sets up the YesodPersist instance.---- > data MyFoundation = MyFoundation -- > { ... (normal yesod stuff in the foundation type)-- > , connPool :: Data.Pool.Pool H.Manager-- > , dbLocation :: B.ByteString-- > , databaseName :: String }-- >-- > newtype CouchDBPersist m a = CouchDBPersist { -- > unCouchDBPersist :: ReaderT CouchConnection m a }-- > deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, -- > MonadTransControl, MonadBaseControl, MonadPlus, MonadCouch)-- >-- > instance YesodPersist MyFoundation where-- > type YesodPersistBackend = CouchDBPersist-- > runDB r = do -- > pool <- connPool <$> getYesod-- > loc <- dbLocation <$> getYesod-- > db <- databaseName <$> getYesod-- > Data.Pool.withPool' pool $ \m ->-- > runReaderT (unCouchDBPersist r) $ -- > CouchConnection loc 5984 m db---- Then you can write handler code as follows:---- > getFooR :: PersonID -> Handler RepPlain-- > getFooR p = do-- > person <- runDB $ couchGet p []-- > return $ RepPlain $ toContent $ Aeson.encode $ maybe Aeson.null person---- Alternatively, you don't need to make your Foundation an instance of -- YesodPersist, you could supply your own runCouchDB function which is just -- a version of runDB specialized to your foundation and just use that -- from the handlers.-- vim: set expandtab:set tabstop=4: