packages feed

couch-simple (empty) → 0.0.1.0

raw patch · 76 files changed

+4952/−0 lines, 76 filesdep +aesondep +attoparsecdep +basebuild-type:Customsetup-changed

Dependencies added: aeson, attoparsec, base, bifunctors, bytestring, bytestring-builder, couch-simple, data-default, directory, exceptions, filepath, hjsonschema, hlint, http-client, http-types, integer-gmp, mtl, random, tasty, tasty-hunit, text, transformers, unordered-containers, uuid, vector

Files

+ CHANGELOG.txt view
@@ -0,0 +1,33 @@+              ____________________________________________++                               CHANGELOG+               A log of what's going on in `couch-simple'+              ____________________________________________++++++Stuff to do+===========++Better examples+~~~~~~~~~~~~~~~+++Implicit interface+~~~~~~~~~~~~~~~~~~+++Stuff that's been done+======================++v0.0.1.0+~~~~~~~~++Intial release on an unsuspecting world+---------------------------------------+++Not yet complete, but what is here should be solid+--------------------------------------------------
+ LICENSE view
@@ -0,0 +1,20 @@+Copyright (c) 2015 Michael Alan Dorman++Permission is hereby granted, free of charge, to any person obtaining+a copy of this software and associated documentation files (the+"Software"), to deal in the Software without restriction, including+without limitation the rights to use, copy, modify, merge, publish,+distribute, sublicense, and/or sell copies of the Software, and to+permit persons to whom the Software is furnished to do so, subject to+the following conditions:++The above copyright notice and this permission notice shall be included+in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.+IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY+CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,+TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE+SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+ README.txt view
@@ -0,0 +1,14 @@+           __________________________________________________++                              COUCH-SIMPLE+               A modern, lightweight, complete client for+                                CouchDB+           __________________________________________________+++`Database.Couch' is intended to be a modern, lightweight, complete+client for [CouchDB].  So far, it is modern and lightweight, but not yet+complete.+++[CouchDB] http://couchdb.apache.org
+ Setup.hs view
@@ -0,0 +1,6 @@+import           Distribution.Simple+import           Distribution.Simple.Program++main :: IO ()+main = defaultMainWithHooks simpleUserHooks+       { hookedPrograms = [ simpleProgram "couchdb" ]}
+ couch-simple.cabal view
@@ -0,0 +1,97 @@+author:              Michael Alan Dorman+bug-reports:         https://github.com/mdorman/couch-simple/issues+build-type:          Custom+cabal-version:       >= 1.10+category:            Database+copyright:           Copyright (c) 2015, Michael Alan Dorman+description:         Based on http-client, with intended extensions for streaming through Conduit and other libraries.+extra-source-files:  test/schema/schema/*.json+                     *.txt+homepage:            https://github.com/mdorman/couch-simple+license-file:        LICENSE+license:             MIT+maintainer:          mdorman@jaunder.io+name:                couch-simple+synopsis:            A modern, lightweight, complete client for CouchDB+tested-with:         GHC == 7.6.3, GHC == 7.8.4, GHC == 7.10.2+version:             0.0.1.0++source-repository head+  type:     git+  location: https://github.com/mdorman/couch-simple.git++library+  build-depends: base >= 4.6 && < 4.10+               , aeson >= 0.9+               , attoparsec+               , bifunctors+               , bytestring+               , data-default+               , exceptions+               , http-client+               , http-types+               , integer-gmp+               , mtl+               , text+               , transformers >= 0.4+               , unordered-containers+               , uuid+               , vector+  default-language: Haskell2010+  exposed-modules: Database.Couch+                   Database.Couch.Explicit+                   Database.Couch.Explicit.Configuration+                   Database.Couch.Explicit.Database+                   Database.Couch.Explicit.Design+                   Database.Couch.Explicit.DocBase+                   Database.Couch.Explicit.Doc+                   Database.Couch.Explicit.Local+                   Database.Couch.Explicit.Server+                   Database.Couch.Internal+                   Database.Couch.RequestBuilder+                   Database.Couch.Response+                   Database.Couch.ResponseParser+                   Database.Couch.Types+  ghc-options: -Wall+  hs-source-dirs: src/lib+  if impl(ghc < 7.8)+    build-depends: bytestring-builder++test-suite test+  build-depends: aeson+               , base >= 4.6 && < 4.10+               , bytestring+               , couch-simple+               , data-default+               , directory+               , exceptions+               , filepath+               , hjsonschema >= 0.6+               , hlint == 1.*+               , http-client >= 0.4.18+               , http-types+               , random+               , tasty+               , tasty >= 0.10.1.2+               , tasty-hunit+               , text+               , transformers >= 0.4+               , unordered-containers+               , uuid+  build-tools: couchdb+  default-language: Haskell2010+  ghc-options: -Wall+  hs-source-dirs: test+  main-is: Main.hs+  other-modules: Functionality+                 Functionality.Explicit.Configuration+                 Functionality.Explicit.Database+                 Functionality.Explicit.Design+                 Functionality.Explicit.Doc+                 Functionality.Explicit.Local+                 Functionality.Explicit.Server+                 Functionality.Internal+                 Functionality.Util+                 Quality+                 Quality.HLint+  type: exitcode-stdio-1.0
+ src/lib/Database/Couch.hs view
@@ -0,0 +1,21 @@+{- |++Module      : Database.Couch+Description : An overview of the package+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++Database.Couch is intended to be a modern, lightweight, complete client for <http://couchdb.apache.org/ CouchDB>.  So far, it is modern and lightweight, but not yet complete.++All of the modules in this package are intended to be @import qualified@.  No attempt has been made to keep names of functions from clashing with obvious or otherwise commonly-used names---or even with other modules in the package.  Types are often unique, but again, no guarantees.++At the moment the only available interface is the "Database.Couch.Explicit" interface, where all aspects of the interface are directly exposed.  Please see that module for an overview.++All types are located in "Database.Couch.Types".++-}++module Database.Couch where
+ src/lib/Database/Couch/Explicit.hs view
@@ -0,0 +1,43 @@+{- |++Module      : Database.Couch.Explicit+Description : An overview of the /Explicit/ interface+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This is a mid-layer interface to <http://couchdb.apache.org/ CouchDB>.  All information necessary for each operation has to be provided directly for each function, and similarly all necessary data is returned explicitly.++All of the modules of the /Explicit/ interface are intended to be @import qualified@.  No attempt has been made to keep names of functions from clashing with obvious or otherwise commonly-used names---or even with other modules in this package.++The /Explicit/ interface consists of:++* "Database.Couch.Explicit.Server"++    Server functionality, like getting a list of databases or starting replication.++* "Database.Couch.Explicit.Configuration"++    Server configuration handling.++* "Database.Couch.Explicit.Database"++    Database functionality, like creation, or cleaning and compacting.++* "Database.Couch.Explicit.Design"++    Design document handling, like creation and querying.++* "Database.Couch.Explicit.Doc"++    Document handling.++* "Database.Couch.Explicit.Local"++    Local (unreplicated) document handling.++-}++module Database.Couch.Explicit where
+ src/lib/Database/Couch/Explicit/Configuration.hs view
@@ -0,0 +1,137 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++{- |++Module      : Database.Couch.Explicit.Configuration+Description : Requests for handling configuration of CouchDB, with explicit parameters+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is intended to be @import qualified@.  /No attempt/ has been made to keep names of types or functions from clashing with obvious or otherwise commonly-used names, or even other modules within this package.++The functions here are derived from (and presented in the same order as) the <http://docs.couchdb.org/en/1.6.1/api/server/configuration.html Server Configuration API documentation>.  For each function, we attempt to link back to the original documentation, as well as make a notation as to how complete and correct we feel our implementation is.++Each function takes a 'Database.Couch.Types.Context' as its final parameter, and returns a 'Database.Couch.Types.Result'.++-}++module Database.Couch.Explicit.Configuration where++import           Control.Monad.IO.Class        (MonadIO)+import           Data.Aeson                    (FromJSON, ToJSON)+import           Data.Function                 (($), (.))+import           Database.Couch.Internal       (standardRequest)+import           Database.Couch.RequestBuilder (RequestBuilder, addPath,+                                                selectDoc, setJsonBody,+                                                setMethod)+import           Database.Couch.Types          (Context, DocId, Result)++{- | <http://docs.couchdb.org/en/1.6.1/api/server/configuration.html#get--_config Get the overall server configuration>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Configuration.server ctx++Status: __Complete__ -}+server :: (FromJSON a, MonadIO m)+       => Context+       -> m (Result a)+server =+  standardRequest configPath++{- | <http://docs.couchdb.org/en/1.6.1/api/server/configuration.html#get--_config-section Get the configuration for one section>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Configuration.section "auth" ctx++Status: __Complete__ -}+section :: (FromJSON a, MonadIO m)+        => DocId -- ^ Section name+        -> Context -> m (Result a)+section =+  standardRequest . sectionPath++{- | <http://docs.couchdb.org/en/1.6.1/api/server/configuration.html#get--_config-section Get the configuration for one item>++The return value is a JSON Value whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Configuration.getValue "auth" "ssl" ctx++Status: __Complete__-}+getValue :: (FromJSON a, MonadIO m)+         => DocId -- ^ Section name+         -> DocId -- ^ Key name+         -> Context -> m (Result a)+getValue s k =+  standardRequest $ itemPath s k++{- | <http://docs.couchdb.org/en/1.6.1/api/server/configuration.html#get--_config-section Set the configuration value for one item>++The value to set must be something that can be translated to JSON.++The return value is a JSON Value whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Configuration.setValue "auth" "ssl" Bool ctx++Status: __Complete__ -}+setValue :: (ToJSON a, FromJSON b, MonadIO m)+         => DocId -- ^ Section name+         -> DocId -- ^ Key name+         -> a -- ^ Value+         -> Context+         -> m (Result b)+setValue s k v =+  standardRequest request+  where+    request = do+      setMethod "PUT"+      itemPath s k+      setJsonBody v++{- | <http://docs.couchdb.org/en/1.6.1/api/server/configuration.html#get--_config-section Remove the configuration value for one item>++Returns the previous JSON Value.++The return value is a JSON Value whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Configuration.delValue "auth" "ssl" ctx++Status: __Complete__ -}+delValue :: (FromJSON a, MonadIO m)+         => DocId -- ^ Section name+         -> DocId -- ^ Key name+         -> Context+         -> m (Result a)+delValue s k =+  standardRequest request+  where+    request = do+      setMethod "DELETE"+      itemPath s k++-- * Internal combinators++-- | Base path for all config requests+configPath :: RequestBuilder ()+configPath =+  addPath "_config"++-- | Base path for all section requests+sectionPath :: DocId -- ^ Section name+            -> RequestBuilder ()+sectionPath s = do+  configPath+  selectDoc s++-- | Base path for all item requests+itemPath :: DocId -- ^ Section name+         -> DocId -- ^ Key name+         -> RequestBuilder ()+itemPath s k = do+  sectionPath s+  selectDoc k
+ src/lib/Database/Couch/Explicit/Database.hs view
@@ -0,0 +1,498 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{- |++Module      : Database.Couch.Explicit.Database+Description : Database-oriented requests to CouchDB, with explicit parameters+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is intended to be @import qualified@.  /No attempt/ has been made to keep names of types or functions from clashing with obvious or otherwise commonly-used names, or even other modules within this package.++The functions here are derived from (and presented in the same order as) the <http://docs.couchdb.org/en/1.6.1/api/database/index.html Database API documentation>.  For each function, we attempt to link back to the original documentation, as well as make a notation as to how complete and correct we feel our implementation is.++Each function takes a 'Database.Couch.Types.Context'---which, among other things, holds the name of the database---as its final parameter, and returns a 'Database.Couch.Types.Result'.++-}++module Database.Couch.Explicit.Database where++import           Control.Monad                 (return, when)+import           Control.Monad.IO.Class        (MonadIO)+import           Control.Monad.Trans.Except    (throwE)+import           Data.Aeson                    (FromJSON, ToJSON,+                                                Value (Object), object, toJSON)+import           Data.Bool                     (Bool (True))+import           Data.Function                 (($), (.))+import           Data.Functor                  (fmap)+import           Data.HashMap.Strict           (fromList)+import           Data.Int                      (Int)+import           Data.Maybe                    (Maybe (Just), catMaybes,+                                                fromJust, isJust)+import           Data.Text                     (Text)+import           Data.Text.Encoding            (encodeUtf8)+import           Database.Couch.Internal       (standardRequest,+                                                structureRequest)+import           Database.Couch.RequestBuilder (RequestBuilder, addPath,+                                                selectDb, selectDoc, setHeaders,+                                                setJsonBody, setMethod,+                                                setQueryParam)+import           Database.Couch.ResponseParser (responseStatus, toOutputType)+import           Database.Couch.Types          (Context, DbAllDocs, DbBulkDocs,+                                                DbChanges, DocId, DocRevMap,+                                                Error (NotFound, Unknown),+                                                Result, ToQueryParameters,+                                                bdAllOrNothing, bdFullCommit,+                                                bdNewEdits, cLastEvent,+                                                toQueryParameters)+import           Network.HTTP.Types            (statusCode)++{- | <http://docs.couchdb.org/en/1.6.1/api/database/common.html#head--db Check that the requested database exists>++The return value is an object that should only contain a single key "ok", so it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Database.exists ctx >>= asBool++Status: __Complete__ -}+exists :: (FromJSON a, MonadIO m)+       => Context+       -> m (Result a)+exists =+  structureRequest request parse+  where+    request = do+      selectDb+      setMethod "HEAD"+    parse = do+      -- Check status codes by hand because we don't want 404 to be an error, just False+      s <- responseStatus+      case statusCode s of+        200 -> toOutputType $ object [("ok", toJSON True)]+        404 -> throwE NotFound+        _   -> throwE Unknown++{- | <http://docs.couchdb.org/en/1.6.1/api/database/common.html#get--db Get most basic meta-information>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.meta ctx++Status: __Complete__ -}+meta :: (FromJSON a, MonadIO m)+     => Context+     -> m (Result a)+meta =+  standardRequest request+  where+    request =+      selectDb++{- | <http://docs.couchdb.org/en/1.6.1/api/database/common.html#put--db Create a database>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.meta ctx++Status: __Complete__ -}+create :: (FromJSON a, MonadIO m)+       => Context+       -> m (Result a)+create =+  standardRequest request+  where+    request = do+      selectDb+      setMethod "PUT"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/common.html#delete--db Delete a database>++The return value is an object that should only contain a single key "ok", so it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Database.delete ctx >>= asBool++Status: __Complete__ -}+delete :: (FromJSON a, MonadIO m)+       => Context+       -> m (Result a)+delete =+  standardRequest request+  where+    request = do+      selectDb+      setMethod "DELETE"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/common.html#post--db Create a new document in a database>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Database.createDoc True someObject ctx >>= asBool++Status: __Complete__ -}+createDoc :: (FromJSON a, MonadIO m, ToJSON b)+          => Bool -- ^ Whether to create the document in batch mode+          -> b -- ^ The document to create+          -> Context+          -> m (Result a)+createDoc batch doc =+  standardRequest request+  where+    request = do+      selectDb+      setMethod "POST"+      when batch (setQueryParam [("batch", Just "ok")])+      setJsonBody doc++{- | <http://docs.couchdb.org/en/1.6.1/api/database/bulk-api.html#get--db-_all_docs Get a list of all database documents>++The return value is a list of objects whose fields often vary, so it is easily decoded as a 'Data.List.List' of 'Data.Aeson.Value':++>>> value :: Result [Value] <- Database.allDocs dbAllDocs ctx++Status: __Complete__ -}+allDocs :: (FromJSON a, MonadIO m)+        => DbAllDocs -- ^ Parameters governing retrieval ('Database.Couch.Types.dbAllDocs' is an empty default)+        -> Context+        -> m (Result a)+allDocs =+  standardRequest . allDocsBase++{- | <http://docs.couchdb.org/en/1.6.1/api/database/bulk-api.html#post--db-_all_docs Get a list of some database documents>++The return value is a list of objects whose fields often vary, so it is easily decoded as a 'Data.List.List' of 'Data.Aeson.Value':++>>> value :: Result [Value] <- Database.someDocs ["a", "b", "c"] ctx++Status: __Complete__ -}+someDocs :: (FromJSON a, MonadIO m)+         => DbAllDocs -- ^ Parameters governing retrieval ('Database.Couch.Types.dbAllDocs' is an empty default)+         -> [DocId] -- ^ List of ids documents to retrieve+         -> Context+         -> m (Result a)+someDocs param ids =+  standardRequest request+  where+    request = do+      setMethod "POST"+      allDocsBase param+      let parameters = Object (fromList [("keys", toJSON ids)])+      setJsonBody parameters++{- | <http://docs.couchdb.org/en/1.6.1/api/database/bulk-api.html#post--db-_bulk_docs Create or update a list of documents>++The return value is a list of objects whose fields often vary, so it is easily decoded as a 'Data.List.List' of 'Data.Aeson.Value':++>>> value :: Result [Value] <- Database.bulkDocs dbBulkDocs ["a", "b", "c"] ctx++Status: __Complete__ -}+bulkDocs :: (FromJSON a, MonadIO m, ToJSON a)+         => DbBulkDocs -- ^ Parameters coverning retrieval ('Database.Couch.Types.dbBulkDocs' is an empty default)+         -> [a] -- ^ List of documents to add or update+         -> Context+         -> m (Result a)+bulkDocs param docs =+  standardRequest request+  where+    request = do+      setMethod "POST"+      -- TODO: We need a way to set a header when we have a value for it [refactor]+      when (isJust $ bdFullCommit param)+        (setHeaders+           [("X-Couch-Full-Commit", if fromJust $ bdFullCommit param+                                      then "true"+                                      else "false")])+      selectDb+      addPath "_bulk_docs"+      -- TODO: We need a way to construct a json body from parameters [refactor]+      let parameters = Object+                         ((fromList . catMaybes)+                            [ Just ("docs", toJSON docs)+                            , boolToParam "all_or_nothing" bdAllOrNothing+                            , boolToParam "new_edits" bdNewEdits+                            ])+      setJsonBody parameters+    boolToParam k s = do+      v <- s param+      return+        (k, if v+              then "true"+              else "false")++{- | <http://docs.couchdb.org/en/1.6.1/api/database/changes.html#get--db-_changes Get a list of all document modifications>++This call does not stream out results; so while it allows you to specify parameters for streaming, it's a dirty, dirty lie.++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.changes ctx++Status: __Limited__ -}+changes :: (FromJSON a, MonadIO m)+        => DbChanges -- ^ Arguments governing changes contents ('Database.Couch.Types.dbChanges' is an empty default)+        -> Context+        -> m (Result a)+changes param =+  standardRequest request+  where+    request = do+      -- TODO: We need a way to set a header when we have a value for it [refactor]+      when (isJust $ cLastEvent param)+        (setHeaders [("Last-Event-Id", encodeUtf8 . fromJust $ cLastEvent param)])+      selectDb+      addPath "_changes"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/compact.html#post--db-_compact Compact a database>++The return value is an object that should only contain a single key "ok", so it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Database.compact ctx >>= asBool++Status: __Complete__ -}+compact :: (FromJSON a, MonadIO m)+        => Context+        -> m (Result a)+compact =+  standardRequest compactBase++{- | <http://docs.couchdb.org/en/1.6.1/api/database/compact.html#post--db-_compact-ddoc Compact the views attached to a particular design document>++The return value is an object that should only contain a single key "ok", so it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Database.compactDesignDoc "ddoc" ctx >>= asBool++Status: __Complete__ -}+compactDesignDoc :: (FromJSON a, MonadIO m)+                 => DocId -- ^ The 'DocId' of the design document to compact+                 -> Context+                 -> m (Result a)+compactDesignDoc doc =+  standardRequest request+  where+    request = do+      compactBase+      selectDoc doc++{- | <http://docs.couchdb.org/en/1.6.1/api/database/compact.html#post--db-_ensure_full_commit Ensure that all changes to the database have made it to disk>++The return value is an object that can hold an "instance_start_time" key, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Database.sync ctx >>= asBool++Status: __Complete__ -}+sync :: (FromJSON a, MonadIO m)+     => Context+     -> m (Result a)+sync =+  standardRequest request+  where+    request = do+      setMethod "POST"+      selectDb+      addPath "_ensure_full_commit"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/compact.html#post--db-_view_cleanup Cleanup any stray view definitions>++The return value is an object that should only contain a single key "ok", so it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Database.cleanup ctx >>= asBool++Status: __Complete__ -}+cleanup :: (FromJSON a, MonadIO m)+        => Context+        -> m (Result a)+cleanup =+  standardRequest request+  where+    request = do+      setMethod "POST"+      selectDb+      addPath "_view_cleanup"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/security.html#get--db-_security Get security information for database>++The return value is an object that has with a standard set of fields ("admin" and "members" keys, which each contain "users" and "roles"), the system does not prevent you from adding (and even using in validation functions) additional fields, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.getSecurity ctx++Status: __Complete__ -}+getSecurity :: (FromJSON a, MonadIO m)+            => Context+            -> m (Result a)+getSecurity =+  standardRequest securityBase++{- | <http://docs.couchdb.org/en/1.6.1/api/database/security.html#post--db-_security Set security information for database>++The input value is an object that has with a standard set of fields ("admin" and "members" keys, which each contain "users" and "roles"), but the system does not prevent you from adding (and even using in validation functions) additional fields, so we don't specify a specific type, and you can roll your own:++The return value is an object that should only contain a single key "ok", so it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Value <- Database.setSecurity (object [("users", object [("harry")])]) ctx >>= asBool++Status: __Complete__ -}+setSecurity :: (FromJSON b, MonadIO m, ToJSON a)+            => a -- ^ The security document content+            -> Context+            -> m (Result b)+setSecurity doc =+  standardRequest request+  where+    request = do+      setMethod "PUT"+      securityBase+      setJsonBody doc++{- | <http://docs.couchdb.org/en/1.6.1/api/database/temp-views.html#post--db-_temp_view Create a temporary view>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.tempView "function (doc) { emit (1); }" (Just "_count") Nothing ctx++Status: __Complete__ -}+tempView :: (FromJSON a, MonadIO m)+         => Text -- ^ The text of your map function+         -> Maybe Text -- ^ The text of your optional reduce function+         -> Context+         -> m (Result a)+tempView map reduce =+  standardRequest request+  where+    request = do+      setMethod "POST"+      selectDb+      -- TODO: We need a way to construct a json body from parameters [refactor]+      let parameters = Object+                         (fromList $ catMaybes+                                       [ Just ("map", toJSON map)+                                       , fmap (("reduce",) . toJSON) reduce+                                       ])+      addPath "_temp_view"+      setJsonBody parameters++{- | <http://docs.couchdb.org/en/1.6.1/api/database/misc.html#post--db-_purge Purge document revisions from the database>++The return value is an object with two fields "purge_seq" and "purged", which contains an object with no fixed keys, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.purge $ DocRevMap [(DocId "junebug", [DocRev "1-1"])] Nothing ctx++However, the content of "purged" is effectively a 'Database.Couch.Types.DocRevMap', so the output can be parsed into an (Int, DocRevMap) pair using:++>>> (,) <$> (getKey "purge_seq" >>= toOutputType) <*> (getKey "purged" >>= toOutputType)++Status: __Complete__ -}+purge :: (FromJSON a, MonadIO m)+      => DocRevMap -- ^ A 'Database.Couch.Types.DocRevMap' of documents and versions to purge+      -> Context+      -> m (Result a)+purge docRevs =+  standardRequest request+  where+    request = do+      docRevBase docRevs+      addPath "_purge"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/misc.html#post--db-_missing_revs Find document revisions not present in the database>++The return value is an object with one field "missed_revs", which contains an object with no fixed keys, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.missingRevs $ DocRevMap [(DocId "junebug", [DocRev "1-1"])] ctx++However, the content of "missed_revs" is effectively a 'Database.Couch.Types.DocRevMap', so it can be parsed into a 'Database.Couch.Types.DocRevMap' using:++>>> getKey "missed_revs" >>= toOutputType++Status: __Complete__ -}+missingRevs :: (FromJSON a, MonadIO m)+            => DocRevMap -- ^ A 'Database.Couch.Types.DocRevMap' of documents and versions available+            -> Context+            -> m (Result a)+missingRevs docRevs =+  standardRequest request+  where+    request = do+      docRevBase docRevs+      addPath "_missing_revs"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/misc.html#post--db-_revs_diff Find document revisions not present in the database>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Database.revsDiff $ DocRevMap [(DocId "junebug", [DocRev "1-1"])] ctx++Status: __Complete__ -}+revsDiff :: (FromJSON a, MonadIO m)+         => DocRevMap -- ^ A 'Database.Couch.Types.DocRevMap' of documents and versions available+         -> Context+         -> m (Result a)+revsDiff docRevs =+  standardRequest request+  where+    request = do+      docRevBase docRevs+      addPath "_revs_diff"++{- | <http://docs.couchdb.org/en/1.6.1/api/database/misc.html#get--db-_revs_limit Get the revision limit setting>++The return value is a JSON numeric value that can easily be decoded to an 'Int':++>>> value :: Result Integer <- Database.getRevsLimit ctx++Status: __Complete__ -}+getRevsLimit :: (FromJSON a, MonadIO m) => Context -> m (Result a)+getRevsLimit =+  standardRequest revsLimitBase++{- | <http://docs.couchdb.org/en/1.6.1/api/database/misc.html#put--db-_revs_limit Set the revision limit>++Status: __Complete__ -}+setRevsLimit :: (FromJSON a, MonadIO m)+             => Int -- ^ The value at which to set the limit+             -> Context+             -> m (Result a)+setRevsLimit limit =+  standardRequest request+  where+    request = do+      setMethod "PUT"+      revsLimitBase+      setJsonBody limit++-- * Internal combinators++-- | Base bits for all _all_docs requests+allDocsBase :: ToQueryParameters a => a -> RequestBuilder ()+allDocsBase param = do+  selectDb+  addPath "_all_docs"+  setQueryParam $ toQueryParameters param++-- | Base bits for all our _compact requests+compactBase :: RequestBuilder ()+compactBase = do+  setMethod "POST"+  selectDb+  addPath "_compact"++-- | Base bits for our revision examination functions+docRevBase :: ToJSON a => a -> RequestBuilder ()+docRevBase docRevs = do+  setMethod "POST"+  selectDb+  let parameters = toJSON docRevs+  setJsonBody parameters++-- | Base bits for our revisions limit functions+revsLimitBase :: RequestBuilder ()+revsLimitBase = do+  selectDb+  addPath "_revs_limit"++-- | Base bits for our security functions+securityBase :: RequestBuilder ()+securityBase = do+  selectDb+  addPath "_security"
+ src/lib/Database/Couch/Explicit/Design.hs view
@@ -0,0 +1,188 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{- |++Module      : Database.Couch.Explicit.Design+Description : Design Document-oriented requests to CouchDB, with explicit parameters+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is intended to be @import qualified@.  /No attempt/ has been made to keep names of types or functions from clashing with obvious or otherwise commonly-used names, or even other modules within this package.++The functions here are derived from (and presented in the same order as) the <http://docs.couchdb.org/en/1.6.1/api/ddoc/common.html Design Document API documentation>.  For each function, we attempt to link back to the original documentation, as well as make a notation as to how complete and correct we feel our implementation is.++Each function takes a 'Database.Couch.Types.Context'---which, among other things, holds the name of the database---as its final parameter, and returns a 'Database.Couch.Types.Result'.++-}++module Database.Couch.Explicit.Design where++import           Control.Monad.IO.Class          (MonadIO)+import           Data.Aeson                      (FromJSON, ToJSON, object,+                                                  toJSON)+import           Data.Function                   (($))+import           Data.Maybe                      (Maybe (Nothing))+import qualified Database.Couch.Explicit.DocBase as Base (accessBase, copy,+                                                          delete, get, meta,+                                                          put)+import           Database.Couch.Internal         (standardRequest)+import           Database.Couch.RequestBuilder   (RequestBuilder, addPath,+                                                  selectDoc, setJsonBody,+                                                  setMethod, setQueryParam)+import           Database.Couch.Types            (Context, DocId, DocRev,+                                                  ModifyDoc, Result,+                                                  RetrieveDoc, ViewParams,+                                                  toQueryParameters)++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#head--db-_design-ddoc Get the size and revision of the specified design document>++The return value is an object that should only contain the keys "rev" and "size", that can be easily parsed into a pair of (DocRev, Int):++>>> (,) <$> (getKey "rev" >>= toOutputType) <*> (getKey "size" >>= toOutputType)++If the specified DocRev matches, returns a JSON Null, otherwise a JSON value for the document.++Status: __Complete__ -}+meta :: (FromJSON a, MonadIO m)+     => RetrieveDoc -- ^ Parameters for the HEAD request+     -> DocId -- ^ The ID of the design document+     -> Maybe DocRev -- ^ A desired revision+     -> Context+     -> m (Result a)+meta = Base.meta "_design"++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#get--db-_design-ddoc Get the specified design document>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Design.get "pandas" Nothing ctx++If the specified DocRev matches, returns a JSON Null, otherwise a JSON value for the document.++Status: __Complete__ -}+get :: (FromJSON a, MonadIO m)+    => RetrieveDoc -- ^ Parameters for the HEAD request+    -> DocId -- ^ The ID of the design document+    -> Maybe DocRev -- ^ A desired revision+    -> Context+    -> m (Result a)+get = Base.get "_design"++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#put--db-_design-ddoc Create or replace the specified design document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Design.put modifyDoc "pandas" Nothing SomeValue ctx >>= asBool++Status: __Complete__ -}+put :: (FromJSON a, MonadIO m, ToJSON b)+    => ModifyDoc -- ^ Parameters for the request+    -> DocId -- ^ The ID of the design document+    -> Maybe DocRev -- ^ A desired revision+    -> b+    -> Context+    -> m (Result a)+put = Base.put "_design"++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#delete--db-_design-ddoc Delete the specified design document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Design.delete modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+delete :: (FromJSON a, MonadIO m)+       => ModifyDoc -- ^ Parameters for the request+       -> DocId -- ^ The ID of the design document+       -> Maybe DocRev -- ^ A desired revision+       -> Context+       -> m (Result a)+delete = Base.delete "_design"++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#copy--db-_design-ddoc Copy the specified design document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Design.delete modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+copy :: (FromJSON a, MonadIO m)+     => ModifyDoc -- ^ Parameters for the request+     -> DocId -- ^ The ID of the design document+     -> Maybe DocRev -- ^ A desired revision+     -> DocId+     -> Context+     -> m (Result a)+copy = Base.copy "_design"++{- | <http://docs.couchdb.org/en/1.6.1/api/ddoc/common.html#get--db-_design-ddoc-_info Get information on a design document>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Design.info "pandas" ctx++Status: __Complete__ -}+info :: (FromJSON a, MonadIO m)+     => DocId -- ^ The ID of the design document+     -> Context+     -> m (Result a)+info doc =+  standardRequest request+  where+    request = do+      Base.accessBase "_design" doc Nothing+      addPath "_info"++{- | <http://docs.couchdb.org/en/1.6.1/api/ddoc/views.html#get--db-_design-ddoc-_view-view Get a list of all database documents>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Design.allDocs viewParams "pandas" "counter" ctx++Status: __Complete__ -}+allDocs :: (FromJSON a, MonadIO m)+        => ViewParams -- ^ Parameters for the request+        -> DocId -- ^ The ID of the design document+        -> DocId -- ^ The ID of the view+        -> Context+        -> m (Result a)+allDocs params doc view =+  standardRequest $ viewBase params doc view++{- | <http://docs.couchdb.org/en/1.6.1/api/ddoc/views.html#post--db-_design-ddoc-_view-view Get a list of some database documents>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Design.someDocs viewParams "pandas" "counter" ["a", "b"] ctx++Status: __Complete__ -}+someDocs :: (FromJSON a, MonadIO m)+         => ViewParams -- ^ Parameters for the request+         -> DocId -- ^ The ID of the design document+         -> DocId -- ^ The ID of the view+         -> [DocId] -- ^ The IDs of the documents of interest+         -> Context+         -> m (Result a)+someDocs params doc view ids =+  standardRequest request+  where+    request = do+      setMethod "POST"+      viewBase params doc view+      let docs = object [("keys", toJSON ids)]+      setJsonBody docs++-- * Internal combinators++-- | Base bits for all view queries+viewBase :: ViewParams -> DocId -> DocId -> RequestBuilder ()+viewBase params doc view = do+      Base.accessBase "_design" doc Nothing+      addPath "_view"+      selectDoc view+      setQueryParam $ toQueryParameters params
+ src/lib/Database/Couch/Explicit/Doc.hs view
@@ -0,0 +1,114 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{- |++Module      : Database.Couch.Explicit.Doc+Description : Document-oriented requests to CouchDB, with explicit parameters+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is intended to be @import qualified@.  /No attempt/ has been made to keep names of types or functions from clashing with obvious or otherwise commonly-used names, or even other modules within this package.++The functions here are derived from (and presented in the same order as) the <http://docs.couchdb.org/en/1.6.1/api/document/common.html Document API documentation>.  For each function, we attempt to link back to the original documentation, as well as make a notation as to how complete and correct we feel our implementation is.++Each function takes a 'Database.Couch.Types.Context'---which, among other things, holds the name of the database---as its final parameter, and returns a 'Database.Couch.Types.Result'.++-}++module Database.Couch.Explicit.Doc where++import           Control.Monad.IO.Class          (MonadIO)+import           Data.Aeson                      (FromJSON, ToJSON)+import           Data.Maybe                      (Maybe)+import           Data.Monoid                     (mempty)+import qualified Database.Couch.Explicit.DocBase as Base (copy, delete, get,+                                                          put)+import           Database.Couch.Types            (Context, DocId, DocRev,+                                                  ModifyDoc, Result,+                                                  RetrieveDoc)++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#head--db-docid Get the size and revision of the specified document>++The return value is an object that should only contain the keys "rev" and "size", that can be easily parsed into a pair of (DocRev, Int):++>>> (,) <$> (getKey "rev" >>= toOutputType) <*> (getKey "size" >>= toOutputType)++If the specified DocRev matches, returns a JSON Null, otherwise a JSON value for the document.++Status: __Complete__ -}+meta :: (FromJSON a, MonadIO m)+     => RetrieveDoc -- ^ Parameters for document retrieval+     -> DocId -- ^ The document ID+     -> Maybe DocRev -- ^ An optional document revision+     -> Context+     -> m (Result a)+meta = Base.get mempty++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#get--db-docid Get the specified document>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Doc.get "pandas" Nothing ctx++If the specified DocRev matches, returns a JSON Null, otherwise a JSON value for the document.++Status: __Complete__ -}+get :: (FromJSON a, MonadIO m)+    => RetrieveDoc -- ^ Parameters for document retrieval+    -> DocId -- ^ The document ID+    -> Maybe DocRev -- ^ An optional document revision+    -> Context+    -> m (Result a)+get = Base.get mempty++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#put--db-docid Create or replace the specified document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.put modifyDoc "pandas" Nothing SomeValue ctx >>= asBool++Status: __Complete__ -}+put :: (FromJSON a, MonadIO m, ToJSON b)+    => ModifyDoc -- ^ Parameters for modifying document+    -> DocId -- ^ The document ID+    -> Maybe DocRev -- ^ An optional document revision+    -> b -- ^ The document+    -> Context+    -> m (Result a)+put = Base.put mempty++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#delete--db-docid Delete the specified document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.delete "prefix" modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+delete :: (FromJSON a, MonadIO m)+       => ModifyDoc -- ^ Parameters for modifying document+       -> DocId -- ^ The document ID+       -> Maybe DocRev -- ^ An optional document revision+       -> Context+       -> m (Result a)+delete = Base.delete mempty++{- | <http://docs.couchdb.org/en/1.6.1/api/document/common.html#copy--db-docid Copy the specified document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.delete "prefix" modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+copy :: (FromJSON a, MonadIO m)+     => ModifyDoc -- ^ Parameters for modifying document+     -> DocId -- ^ The document ID+     -> Maybe DocRev -- ^ An optional document revision+     -> DocId -- ^ The destination document Id+     -> Context+     -> m (Result a)+copy = Base.copy mempty
+ src/lib/Database/Couch/Explicit/DocBase.hs view
@@ -0,0 +1,223 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{- |++Module      : Database.Couch.Explicit.Internal+Description : Parameterized document-oriented requests to CouchDB+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is not intended to be used directly---it is used to construct a number of otherwise-similar modules, where the modules are primarily concerned with the existence (or not) of a path prefix for documents.++The functions here are effectively derived from (and presented in the same order as) the <http://docs.couchdb.org/en/1.6.1/api/document/common.html Document API documentation>, though we don't link back to the specific functions here, since they're not meant for direct use.++Each function takes a 'Database.Couch.Types.Context'---which, among other things, holds the name of the database---as its final parameter, and returns a 'Database.Couch.Types.Result'.++-}++module Database.Couch.Explicit.DocBase where++import           Control.Monad                 (return, unless)+import           Control.Monad.IO.Class        (MonadIO)+import           Control.Monad.Trans.Except    (throwE)+import           Data.Aeson                    (FromJSON, ToJSON,+                                                Value (Null, Number, String),+                                                object)+import           Data.ByteString               (ByteString, null)+import           Data.Function                 (($), (.))+import           Data.Maybe                    (Maybe, maybe)+import           Data.Monoid                   ((<>))+import           Database.Couch.Internal       (standardRequest,+                                                structureRequest)+import           Database.Couch.RequestBuilder (RequestBuilder, addPath,+                                                selectDb, selectDoc, setHeaders,+                                                setJsonBody, setMethod,+                                                setQueryParam)+import           Database.Couch.ResponseParser (checkStatusCode,+                                                getContentLength, getDocRev,+                                                responseStatus, responseValue,+                                                toOutputType)+import           Database.Couch.Types          (Context, DocId, DocRev,+                                                Error (Unknown), ModifyDoc,+                                                Result, RetrieveDoc, reqDocId,+                                                reqDocRev, toHTTPHeaders,+                                                toQueryParameters, unwrapDocRev)+import           GHC.Num                       (fromInteger)+import           Network.HTTP.Types            (statusCode)++{- | Get the size and revision of the specified document++The return value is an object that should only contain the keys "rev" and "size", that can be easily parsed into a pair of (DocRev, Int):++>>> (,) <$> (getKey "rev" >>= toOutputType) <*> (getKey "size" >>= toOutputType)++If the specified DocRev matches, returns a JSON Null, otherwise a JSON value for the document.++Status: __Complete__ -}+meta :: (FromJSON a, MonadIO m)+     => ByteString -- ^ The prefix to use for the document+     -> RetrieveDoc -- ^ Parameters for document retrieval+     -> DocId -- ^ The document ID+     -> Maybe DocRev -- ^ An optional document revision+     -> Context+     -> m (Result a)+meta prefix param doc rev =+  structureRequest request parse+  where+    request = do+      setMethod "HEAD"+      accessBase prefix doc rev+      setQueryParam $ toQueryParameters param+    parse = do+      -- Do our standard status code checks+      checkStatusCode+      -- And then handle 304 appropriately+      s <- responseStatus+      docRev <- getDocRev+      contentLength <- getContentLength+      case statusCode s of+        200 -> toOutputType $ object [("rev", String $ unwrapDocRev docRev), ("size", Number $ fromInteger contentLength)]+        304 -> toOutputType Null+        _   -> throwE Unknown++{- | Get the specified document++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- DocBase.get "prefix" "pandas" Nothing ctx++If the specified DocRev matches, returns a JSON Null, otherwise a JSON value for the document.++Status: __Complete__ -}+get :: (FromJSON a, MonadIO m)+    => ByteString -- ^ A prefix for the document ID+    -> RetrieveDoc -- ^ Parameters for document retrieval+    -> DocId -- ^ The document ID+    -> Maybe DocRev -- ^ An optional document revision+    -> Context+    -> m (Result a)+get prefix param doc rev =+  structureRequest request parse+  where+    request = do+      accessBase prefix doc rev+      setQueryParam $ toQueryParameters param+    parse = do+      -- Do our standard status code checks+      checkStatusCode+      -- And then handle 304 appropriately+      s <- responseStatus+      v <- responseValue+      case statusCode s of+        200 -> toOutputType v+        304 -> toOutputType Null+        _   -> throwE Unknown++{- | Create or replace the specified document++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.put "prefix" modifyDoc "pandas" Nothing SomeValue ctx >>= asBool++Status: __Complete__ -}+put :: (FromJSON a, MonadIO m, ToJSON b)+    => ByteString -- ^ A prefix for the document ID+    -> ModifyDoc -- ^ The parameters for modifying the document+    -> DocId -- ^ The document ID+    -> Maybe DocRev -- ^ An optional document revision+    -> b -- ^ The document+    -> Context+    -> m (Result a)+put prefix param docid rev doc =+  standardRequest request+  where+    request = do+      setMethod "PUT"+      modBase prefix param docid rev+      setJsonBody doc++{- | Delete the specified document++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.delete "prefix" modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+delete :: (FromJSON a, MonadIO m)+       => ByteString -- ^ A prefix for the document ID+       -> ModifyDoc -- ^ The parameters for modifying the document+       -> DocId -- ^ The document ID+       -> Maybe DocRev -- ^ An optional document revision+       -> Context+       -> m (Result a)+delete prefix param docid rev =+  standardRequest request+  where+    request = do+      setMethod "DELETE"+      modBase prefix param docid rev++{- | Copy the specified document++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.delete "prefix" modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+copy :: (FromJSON a, MonadIO m)+     => ByteString -- ^ A prefix for the document ID+     -> ModifyDoc -- ^ The parameters for modifying the document+     -> DocId -- ^ The document ID+     -> Maybe DocRev -- ^ An optional document revision+     -> DocId -- ^ The destination document ID+     -> Context+     -> m (Result a)+copy prefix param source rev dest =+  standardRequest request+  where+    request = do+      setMethod "COPY"+      modBase prefix param source rev+      setHeaders [("Destination", destination)]+    destination =+      if null prefix+      then reqDocId dest+      else prefix <> "/" <> reqDocId dest++-- * Internal combinators++-- | Construct a path in a consistent fashion+docPath :: ByteString -- ^ A prefix for the document ID+        -> DocId -- ^ The document ID+        -> RequestBuilder ()+docPath prefix docid = do+  selectDb+  unless (null prefix) $+    addPath prefix+  selectDoc docid++-- | All retrievals want to allow 304s+accessBase :: ByteString -- ^ A prefix for the document ID+           -> DocId -- ^ The document ID+           -> Maybe DocRev -- ^ An optional document revision+           -> RequestBuilder ()+accessBase prefix docid rev = do+  docPath prefix docid+  maybe (return ()) (setHeaders . return . ("If-None-Match" ,) . reqDocRev) rev++-- | All modifications want to allow conflict recognition and parameters+modBase :: ByteString -- ^ A prefix for the document ID+        -> ModifyDoc -- ^ The parameters for modifying the document+        -> DocId -- ^ The document ID+        -> Maybe DocRev -- ^ An optional document revision+        -> RequestBuilder ()+modBase prefix param docid rev = do+  docPath prefix docid+  maybe (return ()) (setHeaders . return . ("If-Match" ,) . reqDocRev) rev+  setHeaders $ toHTTPHeaders param+  setQueryParam $ toQueryParameters param
+ src/lib/Database/Couch/Explicit/Local.hs view
@@ -0,0 +1,95 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{- |++Module      : Database.Couch.Explicit.Local+Description : Local document-oriented requests to CouchDB+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is intended to be @import qualified@.  /No attempt/ has+been made to keep names of types or functions from clashing with+obvious or otherwise commonly-used names.++The functions here are derived from (and presented in the same order+as) http://docs.couchdb.org/en/1.6.1/api/local/index.html.++-}++module Database.Couch.Explicit.Local where++import           Control.Monad.IO.Class          (MonadIO)+import           Data.Aeson                      (FromJSON, ToJSON)+import           Data.Maybe                      (Maybe)+import qualified Database.Couch.Explicit.DocBase as Base (copy, delete, get,+                                                          put)+import           Database.Couch.Types            (Context, DocId, DocRev,+                                                  ModifyDoc, Result,+                                                  RetrieveDoc)++{- | <http://docs.couchdb.org/en/1.6.1/api/local.html#get--db-_local-docid Get the specified local document>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Doc.get "pandas" Nothing ctx++If the specified DocRev matches, returns a JSON Null, otherwise a JSON value for the document.++Status: __Complete__ -}+get :: (FromJSON a, MonadIO m)+    => RetrieveDoc -- ^ Parameters for document retrieval+    -> DocId -- ^ The document ID+    -> Maybe DocRev -- ^ An optional document revision+    -> Context+    -> m (Result a)+get = Base.get "_local"++{- | <http://docs.couchdb.org/en/1.6.1/api/local.html#put--db-_local-docid Create or replace the specified local document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.put modifyDoc "pandas" Nothing SomeValue ctx >>= asBool++Status: __Complete__ -}+put :: (FromJSON a, MonadIO m, ToJSON b)+    => ModifyDoc -- ^ Parameters for document modification+    -> DocId -- ^ The document ID+    -> Maybe DocRev -- ^ An optional document revision+    -> b -- ^ The document+    -> Context -> m (Result a)+put = Base.put "_local"++{- | <http://docs.couchdb.org/en/1.6.1/api/local.html#delete--db-_local-docid Delete the specified local document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.delete "prefix" modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+delete :: (FromJSON a, MonadIO m)+       => ModifyDoc -- ^ Parameters for document modification+       -> DocId -- ^ The document ID+       -> Maybe DocRev -- ^ An optional document revision+       -> Context+       -> m (Result a)+delete = Base.delete "_local"++{- | <http://docs.couchdb.org/en/1.6.1/api/local.html#copy--db-_local-docid Copy the specified local document>++The return value is an object that can hold "id" and "rev" keys, but if you don't need those values, it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- DocBase.delete "prefix" modifyDoc "pandas" Nothing ctx >>= asBool++Status: __Complete__ -}+copy :: (FromJSON a, MonadIO m)+     => ModifyDoc -- ^ Parameters for document modification+     -> DocId -- ^ The document ID+     -> Maybe DocRev -- ^ An optional document revision+     -> DocId -- ^ The destination document ID+     -> Context -> m (Result a)+copy = Base.copy "_local"
+ src/lib/Database/Couch/Explicit/Server.hs view
@@ -0,0 +1,178 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++{- |++Module      : Database.Couch.Explicit.Server+Description : Server-oriented requests to CouchDB, with explicit parameters+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is intended to be @import qualified@.  /No attempt/ has been made to keep names of types or functions from clashing with obvious or otherwise commonly-used names, or even other modules within this package.++The functions here are derived from (and presented in the same order as) the <http://docs.couchdb.org/en/1.6.1/api/server/index.html Server API documentation>.  For each function, we attempt to link back to the original documentation, as well as make a notation as to how complete and correct we feel our implementation is.++Each function takes a 'Database.Couch.Types.Context' as its final parameter, and returns a 'Database.Couch.Types.Result'.++-}++module Database.Couch.Explicit.Server where++import           Control.Monad                 (return)+import           Control.Monad.IO.Class        (MonadIO)+import           Data.Aeson                    (FromJSON)+import           Data.Function                 (($))+import           Data.Int                      (Int)+import           Data.Maybe                    (Maybe (Just))+import           Data.String                   (fromString)+import           Data.Text                     (Text)+import           Database.Couch.Internal       (standardRequest)+import           Database.Couch.RequestBuilder (addPath, addQueryParam,+                                                setMethod, setQueryParam)+import           Database.Couch.Types          (Context, DbUpdates, Result,+                                                toQueryParameters)+import           GHC.Err                       (undefined)+import           Text.Show                     (show)++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#get-- Get most basic meta-information>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Server.meta ctx++Status: __Complete__ -}+meta :: (FromJSON a, MonadIO m)+     => Context+     -> m (Result a)+meta =+  standardRequest request+  where+    -- This is actually the default request+    request =+      return ()++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#get--_active_tasks Get a list of active tasks>++The return value is a list of objects whose fields often vary, so it is easily decoded as a 'Data.List.List' of 'Data.Aeson.Value':++>>> value :: Result [Value] <- Server.activeTasks ctx++Status: __Complete__ -}+activeTasks :: (FromJSON a, MonadIO m)+            => Context+            -> m (Result a)+activeTasks =+  standardRequest request+  where+    request =+      addPath "_active_tasks"++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#get--_all_dbs Get a list of all databases>++The return value is a list of database names, so it is easily decoded into a 'Data.List.List' of 'Text':++>>> value :: Result [Text] <- Server.allDbs ctx++Status: __Complete__ -}+allDbs :: (FromJSON a, MonadIO m)+       => Context+       -> m (Result a)+allDbs =+  standardRequest request+  where+    request =+      addPath "_all_dbs"++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#get--_db_updates Get a list of all database events>++This call does not yet stream out results, so it's functionality is limited.++The return value is a list of database update events, so it is easily decoded into a 'Data.List.List' of 'Data.Aeson.Value':++>>> value :: Result [Value] <- Server.dbUpdates ctx++Status: __Limited__ -}+dbUpdates :: (FromJSON a, MonadIO m) => DbUpdates -> Context -> m (Result a)+dbUpdates param =+  standardRequest request+  where+    request = do+      addPath "_db_updates"+      setQueryParam $ toQueryParameters param++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#get--_log Get the log output of the server>++This call doesn't return a JSON result, so we're deferring support for the moment.++Status: __Unimplemented__ -}+log :: MonadIO m => Context -> m (Result Text)+log = undefined++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#post--_replicate Administer replication for databases on the server>++We do not yet have a structure for specifying parameters to this call, so we're deferring support for the moment++Status: __Unimplemented__ -}+replicate :: (FromJSON a, MonadIO m)+          => Context+          -> m (Result a)+replicate =+  standardRequest request+  where+    request = do+      setMethod "POST"+      addPath "_replicate"++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#post--_restart Restart the server>++The return value is an object that should only contain a single key "ok", so it is easily decoded into a 'Data.Bool.Bool' with our 'asBool' combinator:++>>> value :: Result Bool <- Server.restart ctx >>= asBool++Status: __Complete__ -}+restart :: (FromJSON a, MonadIO m)+        => Context+        -> m (Result a)+restart =+  standardRequest request+  where+    request = do+      setMethod "POST"+      addPath "_restart"++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#get--_stats Get server statistics>++The return value is an object whose fields often vary, so it is most easily decoded as a 'Data.Aeson.Value':++>>> value :: Result Value <- Server.stats ctx++Status: __Complete__ -}+stats :: (FromJSON a, MonadIO m)+      => Context+      -> m (Result a)+stats =+  standardRequest request+  where+    request =+      addPath "_stats"++{- | <http://docs.couchdb.org/en/1.6.1/api/server/common.html#get--_uuids Get a batch of UUIDs>++The return value is a list of strings representing UUIDs, so it is easily decoded as a 'Data.List.List' of 'Data.UUID.UUID' with our 'asUUID' combinator:++>>> value :: Result [UUID] <- Server.stats ctx >>= asUUID++Status: __Complete__ -}+uuids :: (FromJSON a, MonadIO m)+      => Int -- ^ How many 'UUID's to retrieve+      -> Context+      -> m (Result a)+uuids count =+  standardRequest request+  where+    request = do+      addPath "_uuids"+      addQueryParam [("count", Just $ fromString $ show count)]
+ src/lib/Database/Couch/Internal.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE NoImplicitPrelude #-}++{- |++Module      : Database.Couch.Internal+Description : The lowest low-level code for Database.Couch+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++This module is about things that are at such a low level, they're not+even necessarily really CouchDB-specific.++-}++module Database.Couch.Internal where++import           Control.Monad                 (return, (>>=))+import           Control.Monad.Catch           (handle)+import           Control.Monad.IO.Class        (MonadIO, liftIO)+import           Data.Aeson                    (FromJSON, Value (Null))+import           Data.Aeson.Parser             (json)+import           Data.Attoparsec.ByteString    (IResult (Done, Fail, Partial),+                                                parseWith)+import           Data.Either                   (Either (Right, Left), either)+import           Data.Eq                       ((==))+import           Data.Function                 (const, flip, ($), (.))+import           Data.Maybe                    (Maybe (Just, Nothing))+import           Data.Monoid                   (mempty)+import           Data.Text                     (pack)+import           Database.Couch.RequestBuilder (RequestBuilder, runBuilder)+import           Database.Couch.ResponseParser (ResponseParser, runParse,+                                                standardParse)+import           Database.Couch.Types          (Context, Error (HttpError, ParseFail, ParseIncomplete),+                                                Result, ctxCookies, ctxManager)+import           Network.HTTP.Client           (CookieJar, Manager, Request,+                                                brRead, checkStatus, method,+                                                responseBody, responseCookieJar,+                                                responseHeaders, responseStatus,+                                                withResponse)+import           Network.HTTP.Types            (ResponseHeaders, Status,+                                                methodHead)++{- | Make an HTTP request returning a JSON value++This is our lowest-level non-streaming routine.  It only handles+performing the request and parsing the result into a JSON value.++It presumes:++ * we will be receiving a deserializable JSON value++ * we do not need to stream out the result (though the input is parsed+incrementally)++The results of parsing the stream will be handed to a routine that+take the output and return the value the user ultimately desires.  We+use "Data.Either" to handle indicating failure and such.++Basing the rest of our library on a function where all dependencies+are explicit should help make sure that other bits remain portable to,+say, streaming interfaces.++-}++rawJsonRequest :: MonadIO m+               => Manager -- ^ The "Network.HTTP.Client.Manager" to use for the request+               -> Request -- ^ The actual request itself+               -> m (Either Error (ResponseHeaders, Status, CookieJar, Value))+rawJsonRequest manager request =+  liftIO (handle errorHandler $ withResponse request { checkStatus = const . const . const Nothing } manager responseHandler)+  where+    -- Simply convert any exception into an HttpError+    errorHandler =+       return . Left . HttpError+    -- Incrementally parse the body, reporting failures.+    responseHandler res = do+      result <- if method request == methodHead+                then return (Done mempty Null)+                else parseParts res+      return $ case result of+        (Done _ ret) -> return (responseHeaders res, responseStatus res, responseCookieJar res, ret)+        (Partial _) -> Left ParseIncomplete+        (Fail _ _ err) -> Left $ ParseFail $ pack err+    parseParts res = do+      let input = brRead (responseBody res)+      initial <- input+      parseWith input json initial++{- | Higher-level wrapper around 'rawJsonRequest'++Building on top of 'rawJsonRequest, this routine is designed to take a+builder for the request and a parser for the result, and use them to+request our transaction.  This makes for a very declarative style when+defining individual endpoints for CouchDB.++In order to support more sophisticated forms of authentication than+'Basic', we do have to examine the cookie jar returned from the+server, and perhaps tell the user that they should replace the cookie+jar in their context with it.++-}++structureRequest :: MonadIO m+                 => RequestBuilder () -- ^ The builder for the HTTP request+                 -> ResponseParser a -- ^ A parser for the data type the requester seeks+                 -> Context -- ^ A context for holding the HTTP manager and the cookie jar+                 -> m (Result a)+structureRequest builder parse context =+  rawJsonRequest manager request >>= parser+  where+    manager =+      ctxManager context+    request =+      runBuilder builder context+    parser =+      return . either Left parseContext+    parseContext (h, s, c, v) =+      runParse parse (Right (h, s, v)) >>= checkContextUpdate c+    checkContextUpdate c a =+      Right (a, if c == ctxCookies context then Nothing else Just c)++{- | Make a HTTP request with standard CouchDB semantics++This builds on 'structureRequest', with a standard parser for the+response.++-}++standardRequest :: (FromJSON a, MonadIO m) => RequestBuilder () -> Context -> m (Result a)+standardRequest =+  flip structureRequest standardParse
+ src/lib/Database/Couch/RequestBuilder.hs view
@@ -0,0 +1,211 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++{- |++Module      : Database.Couch.RequestBuilder+Description : Routines for creating the Request to send to CouchDB+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++-}++module Database.Couch.RequestBuilder where++import           Control.Monad        (return, (>>))+import           Control.Monad.Reader (Reader, ask, runReader)+import           Control.Monad.State  (StateT, execStateT, get, put)+import           Data.Aeson           (ToJSON, encode)+import           Data.ByteString      (ByteString, intercalate, null)+import           Data.Default         (def)+import           Data.Eq              ((==))+import           Data.Function        (on, ($), (.))+import           Data.List            (unionBy)+import           Data.Maybe           (Maybe (Just), maybe)+import           Data.Monoid          (mempty, (<>))+import           Data.Tuple           (fst)+import           Database.Couch.Types (Context, Credentials (Basic), DocId,+                                       DocRev, ctxCookies, ctxCred, reqDb,+                                       reqDocId, reqDocRev, reqHost,+                                       reqPassword, reqPort, reqUser)+import           Network.HTTP.Client  (Request, RequestBody (RequestBodyLBS),+                                       applyBasicAuth, cookieJar, host, method,+                                       path, port, requestBody, requestHeaders,+                                       setQueryString)+import           Network.HTTP.Types   (RequestHeaders, hAccept, hContentType)++-- | The state of our request as it's being built+data BuilderState =+  BuilderState {+    -- FIXME: Does it make more sense to hold all the individual+    -- pieces explicitly, and then just have a BuilderState -> Request+    -- function?+    -- | The base request being built+    bsRequest      :: Request,+    -- | The request itself only stores the 'queryString', so we accumulate pairs during construction, and use them to set the query string at the end.+    bsQueryParam   :: [(ByteString, Maybe ByteString)],+    -- | If this is set, it will be prepended to the path.+    bsDb           :: ByteString,+    -- | Again, stored this way for ease of manipulation, then properly assembled at the end.+    bsPathSegments :: [ByteString]+    }++-- | A type synonym for our builder monad+type RequestBuilder = StateT BuilderState (Reader Context)++-- | Given a 'Context', run our monadic builder function to produce a 'Request'.+runBuilder :: RequestBuilder () -> Context -> Request+runBuilder builder context =+  finalize (runReader (execStateT (defaultRequest >> builder) (BuilderState def [] mempty [])) context)++-- | This actually takes the 'BuilderState' and does the assembly of the various state bits into a single 'Request'.+finalize :: BuilderState -> Request+finalize (BuilderState r q d p) =+  setQueryString q r { path = calculatedPath }+  where+    calculatedPath =  "/" <> intercalate "/" ((if null d then [] else [d]) <> p)++{- | The default set of modifications applied to the request.++* The host/port connection information is set++* The 'Accept' header is set to 'application/json'++* The 'Content-Type' headers is set to 'application/json'++* Any authentication session in the cookie jar is set++* Any Basic Authentication information is applied++Any or all of these may be overridden, but probably shouldn't be.++-}+defaultRequest :: RequestBuilder ()+defaultRequest = do+  defaultHeaders [(hAccept, "application/json"), (hContentType, "application/json")]+  setAuth+  setConnection+  setCookieJar+  setMethod "GET"+++-- * Applying 'Context' to the 'Request'++-- | Choose the database for the 'Request', based on what's in the 'Context'.  This is the one thing that could arguably throw an error.+selectDb :: RequestBuilder ()+selectDb = do+  c <- ask+  (BuilderState r q _ p) <- get+  put $ BuilderState r q (reqDb c) p++-- | Set the appropriate authentication markers on the 'Request', based on what's in the 'Context'.+setAuth :: RequestBuilder ()+setAuth = do+  c <- ask+  maybe (return ()) doApply (ctxCred c)+  where+    doApply cred = do+      (BuilderState r q d p) <- get+      put $ BuilderState (applyCred cred r) q d p+    applyCred (Basic u p) = applyBasicAuth (reqUser u) (reqPassword p)++-- | Set the host and port for the 'Request', based on what's in the 'Context'.+setConnection :: RequestBuilder ()+setConnection = do+  c <- ask+  (BuilderState r q d p) <- get+  put $ BuilderState r { host = reqHost c, port = reqPort c } q d p++-- | Set the 'CookieJar' for the 'Request', based on what's in the 'Context'.+setCookieJar :: RequestBuilder ()+setCookieJar = do+  c <- ask+  (BuilderState r q d p) <- get+  put $ BuilderState r { cookieJar = Just $ ctxCookies c } q d p++-- * Setting Headers++-- | Add headers to a 'Request', leaving existing instances undisturbed.+addHeaders :: RequestHeaders -> RequestBuilder ()+addHeaders new = do+  (BuilderState r q d p) <- get+  let headers = requestHeaders r+  put $ BuilderState r { requestHeaders = headers <> new } q d p++-- | Add headers to a 'Request', if they aren't already present.+defaultHeaders :: RequestHeaders -> RequestBuilder ()+defaultHeaders new = do+  (BuilderState r q d p) <- get+  let headers = requestHeaders r+  put $ BuilderState r { requestHeaders = unionBy ((==) `on` fst) headers new } q d p++-- | Set headers on the 'Request', overriding any existing instances.+setHeaders :: RequestHeaders -> RequestBuilder ()+setHeaders new = do+  (BuilderState r q d p) <- get+  let headers = requestHeaders r+  put $ BuilderState r { requestHeaders = unionBy ((==) `on` fst) new headers } q d p++-- * Setting Query Parameters++-- | Add query parameters to a 'Request', leaving existing parameters undisturbed.+addQueryParam :: [(ByteString, Maybe ByteString)] -> RequestBuilder ()+addQueryParam new = do+  (BuilderState r q d p) <- get+  put $ BuilderState r (q <> new) d p++-- | Add query parameters to a 'Request', if they aren't already present+defaultQueryParam :: [(ByteString, Maybe ByteString)] -> RequestBuilder ()+defaultQueryParam new = do+  (BuilderState r q d p) <- get+  put $ BuilderState r (unionBy ((==) `on` fst) q new) d p++-- | Set query parameters on the 'Request', overriding any existing instances.+setQueryParam :: [(ByteString, Maybe ByteString)] -> RequestBuilder ()+setQueryParam new = do+  (BuilderState r q d p) <- get+  put $ BuilderState r (unionBy ((==) `on` fst) new q) d p++-- * Setting the document path++-- | Add a path segment to the 'Request'.  This is only appropriate for static paths.+addPath :: ByteString -> RequestBuilder ()+addPath new = do+  (BuilderState r q d p) <- get+  put $ BuilderState r q d (p <> [new])++-- | Add a path segment to the 'Request', given a 'DocId'.+selectDoc :: DocId -> RequestBuilder ()+selectDoc = addPath . reqDocId++-- * Handling optional revision information++-- | Set the rev for the 'Request'.+addRev :: DocRev -> RequestBuilder ()+addRev rev =+  setHeaders [("ETag", reqDocRev rev)]++-- | Set the rev for the 'Request' if you have it.+maybeAddRev :: Maybe DocRev -> RequestBuilder ()+maybeAddRev =+  maybe (return ()) addRev++-- * Miscellaneous request options++-- | Set the body of the request to the encoded JSON value+setJsonBody :: ToJSON a+            => a -- ^ The document content+            -> RequestBuilder ()+setJsonBody new = do+  (BuilderState r q d p) <- get+  put $ BuilderState r { requestBody = RequestBodyLBS $ encode new } q d p++-- | Set the method for the 'Request'.+setMethod :: ByteString -> RequestBuilder ()+setMethod m = do+  (BuilderState r q d p) <- get+  put $ BuilderState r { method = m } q d p
+ src/lib/Database/Couch/Response.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{- |++Module      : Database.Couch.Response+Description : Utilities for extracting specific types from Database.Couch JSON values+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++Calls to CouchDB can return values that have well-defined structure beyond their simple JSON content, but that don't necessarily warrant full-blown data types with 'FromJSON' instances and the like.  We want to provide convenient conversions when that is the case.++> result <- Database.compact cxt `ap` asBool+> if result+>   then ...+>   else ...++-}++module Database.Couch.Response where++import           Control.Monad        ((>>=))+import           Data.Aeson           (FromJSON, Value (Object), fromJSON)+import qualified Data.Aeson           as Aeson (Result (Error, Success))+import           Data.Bool            (Bool)+import           Data.Either          (Either (Left, Right))+import           Data.Function        (($), (.))+import           Data.Functor         (fmap)+import           Data.HashMap.Strict  (lookup)+import           Data.Maybe           (Maybe (Just, Nothing), catMaybes, maybe)+import           Data.String          (fromString)+import           Data.Text            (Text, intercalate, splitAt)+import           Data.Text.Encoding   (encodeUtf8)+import           Data.UUID            (UUID, fromASCIIBytes)+import           Database.Couch.Types (Error (NotFound, ParseFail), Result)++{- | Attempt to decode the value into anything with a FromJSON constraint.++This is really about translating 'Data.Aeson.Result' values into our 'Database.Couch.Types.Result' values. -}++asAnything :: FromJSON a => Result Value -> Result a+asAnything v =+  case v of+    Left x             -> Left x+    Right (a, b) -> case fromJSON a of+      Aeson.Error e   -> (Left . ParseFail . fromString) e+      Aeson.Success s -> Right (s, b)++{- | Attempt to construct a 'Data.Bool.Bool' value.++This assumes the routine conforms to CouchDB's @{"ok": true}@ return convention. -}+asBool :: Result Value -> Result Bool+asBool = getKey "ok"++{- | Attempt to construct a list of 'Data.UUID.UUID' values.++CouchDB returns uuids as string values in a form that "Data.UUID" cannot consume directly, so we provide this standard conversion. -}+asUUID :: Result Value -> Result [UUID]+asUUID v =+  case v of+    Left x              -> Left x+    Right (Object o, b) -> maybe (Left (ParseFail "Couldn't convert to UUID type"))+                             (Right . (,b) . catMaybes . reformat) $ lookup "uuids" o+    _                   -> Left NotFound+  where+    reformat i =+      case fromJSON i of+        Aeson.Error _   -> []+        Aeson.Success a -> fmap (fromASCIIBytes . encodeUtf8 . reformatUuid) a+    reformatUuid s =+      let (first, second') = splitAt 8 s+          (second, third') = splitAt 4 second'+          (third, fourth') = splitAt 4 third'+          (fourth, fifth) = splitAt 4 fourth'+      in intercalate "-" [first, second, third, fourth, fifth]++{- | Attempt to extract the value of a particular key. -}+getKey :: FromJSON a => Text -> Result Value -> Result a+getKey k v  =+  case v of+    Left x              -> Left x+    Right (Object o, b) -> maybe (Left NotFound) (Right . (, b)) $ lookup k o >>= reformat+    _                   -> Left NotFound+  where+    reformat i =+      case fromJSON i of+      Aeson.Error _   -> Nothing+      Aeson.Success a -> Just a
+ src/lib/Database/Couch/ResponseParser.hs view
@@ -0,0 +1,141 @@+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TupleSections     #-}++{- |++Module      : Database.Couch.ResponseParser+Description : Code for parsing responses from Database.Couch.External+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++These relatively simple combinators can do simple extractions of data from the data returned by "Database.Couch.External" routines, as well as checking certain information about the actual response values.++-}++module Database.Couch.ResponseParser where++import           Control.Monad              (return, (>>=))+import           Control.Monad.Reader       (Reader, asks, runReader)+import           Control.Monad.Trans.Except (ExceptT, runExceptT, throwE)+import           Data.Aeson                 (FromJSON, Result (Error, Success),+                                             Value (Object), fromJSON)+import           Data.ByteString            (ByteString)+import           Data.Either                (Either (Left, Right), either)+import           Data.Eq                    ((==))+import           Data.Foldable              (find)+import           Data.Function              (($), (.))+import           Data.Functor               (fmap)+import           Data.HashMap.Strict        (lookup)+import           Data.Maybe                 (Maybe, maybe)+import           Data.Monoid                (mempty)+import           Data.Text                  (Text, pack)+import           Data.Text.Encoding         (decodeUtf8)+import           Data.Text.Read             (decimal)+import           Data.Tuple                 (fst, snd)+import           Database.Couch.Types       (DocRev (DocRev), Error (AlreadyExists, Conflict, HttpError, ImplementationError, InvalidName, NotFound, ParseFail, Unauthorized))+import           GHC.Integer                (Integer)+import           Network.HTTP.Client        (HttpException (StatusCodeException))+import           Network.HTTP.Types         (HeaderName, ResponseHeaders,+                                             Status, statusCode)++-- * Our primary interface++-- | Check the status code for a successful value and tries to decode to the user's desired type if so+standardParse :: FromJSON a => ResponseParser a+standardParse = do+  checkStatusCode+  responseValue >>= toOutputType++-- * Lower-level interfaces++-- | A type synonym for the Monad we're operating in+type ResponseParser = ExceptT Error (Reader (ResponseHeaders, Status, Value))++-- | Run a given parser over an initial value+runParse :: ResponseParser a -> Either Error (ResponseHeaders, Status, Value) -> Either Error a+runParse p (Right v) = (runReader . runExceptT) p v+runParse _ (Left v) = Left v++-- | Extract the response status from the Monad+responseStatus :: ResponseParser Status+responseStatus =+  asks status+  where+    status (_, s, _) = s++-- | Extract the response headers from the Monad+responseHeaders :: ResponseParser ResponseHeaders+responseHeaders =+  asks headers+  where+    headers (h, _, _) = h++-- | Extract the response value from the Monad+responseValue :: ResponseParser Value+responseValue =+  asks value+  where+    value (_, _, v) = v++-- | Check the status code for the response+checkStatusCode :: ResponseParser ()+checkStatusCode = do+  h <- responseHeaders+  s <- responseStatus+  case statusCode s of+    200 -> return ()+    201 -> return ()+    202 -> return ()+    304 -> return ()+    400 -> do+      error <- getKey "reason" >>= toOutputType+      throwE $ InvalidName error+    401 -> throwE Unauthorized+    404 -> throwE NotFound+    409 -> throwE Conflict+    412 -> throwE AlreadyExists+    415 -> throwE $ ImplementationError "The server says we sent a bad content type, which shouldn't happen.  Please open an issue at https://github.com/mdorman/couch-simple/issues with a test case if possible."+    _   -> throwE $ HttpError (StatusCodeException s h mempty)++-- | Try to retrieve a header from the response+maybeGetHeader :: HeaderName -> ResponseParser (Maybe ByteString)+maybeGetHeader header = do+  h <- responseHeaders+  return $ fmap snd (find ((== header) . fst) h)++-- | Retrieve a header from the response, or return an error if it's not present+getHeader :: HeaderName -> ResponseParser ByteString+getHeader header =+  maybeGetHeader header >>= maybe (throwE NotFound) return++-- | Decode the Content-Length header from the response, or return an error if it's not present+getContentLength :: ResponseParser Integer+getContentLength = do+  h <- getHeader "Content-Length"+  either (throwE . ParseFail . pack) (return . fst) $ decimal (decodeUtf8 h)++-- | Get the document revision (ETag header), or return an error if it's not present+getDocRev :: ResponseParser DocRev+getDocRev = do+  h <- getHeader "ETag"+  return $ DocRev $ decodeUtf8 h++-- | Get the value of a particular key from the response value, or return an error if it's not found+getKey :: Text -> ResponseParser Value+getKey key = do+  v <- responseValue+  case v of+    Object o -> maybe (throwE NotFound) return $ lookup key o+    _        -> throwE NotFound++-- | Decode the response value to a particular type, or return an error if it can't be decoded+toOutputType :: (FromJSON a) => Value -> ResponseParser a+toOutputType v =+  case fromJSON v of+    Error e -> throwE $ ParseFail $ pack e+    Success a -> return a
+ src/lib/Database/Couch/Types.hs view
@@ -0,0 +1,648 @@+{-# LANGUAGE DeriveGeneric              #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE NoImplicitPrelude          #-}+{-# LANGUAGE OverloadedStrings          #-}+{-# LANGUAGE RecordWildCards            #-}+{-# LANGUAGE ScopedTypeVariables        #-}+{-# LANGUAGE TupleSections              #-}++{- |++Module      : Database.Couch.Types+Description : Types for interacting with CouchDB+Copyright   : Copyright (c) 2015, Michael Alan Dorman+License     : MIT+Maintainer  : mdorman@jaunder.io+Stability   : experimental+Portability : POSIX++These types are intended for interacting with a CouchDB database.  We generally favor giving things distinct types for different uses, though this is not a hard and fast rule.++-}++module Database.Couch.Types where++import           Control.Applicative     ((<$>), (<*>))+import           Control.Monad           (mapM, mzero, return)+import           Data.Aeson              (FromJSON, ToJSON,+                                          Value (Array, Object, String), object,+                                          parseJSON, toJSON, (.:), (.:?), (.=))+import           Data.Aeson.Types        (typeMismatch)+import           Data.Biapplicative      ((<<*>>))+import           Data.Bool               (Bool)+import           Data.ByteString         (ByteString)+import           Data.ByteString.Builder (intDec, toLazyByteString)+import           Data.ByteString.Lazy    (toStrict)+import           Data.Either             (Either)+import           Data.Eq                 (Eq)+import           Data.Function           (($), (.))+import           Data.Functor            (fmap)+import           Data.HashMap.Strict     (HashMap)+import qualified Data.HashMap.Strict     as HashMap (fromList, toList)+import           Data.Int                (Int)+import           Data.List               ((++))+import           Data.Maybe              (Maybe (Just, Nothing), catMaybes,+                                          maybe)+import           Data.Monoid             (mempty)+import           Data.String             (IsString)+import           Data.Text               (Text, null)+import           Data.Text.Encoding      (encodeUtf8)+import qualified Data.Vector             as Vector (fromList)+import           GHC.Generics            (Generic)+import           Network.HTTP.Client     (CookieJar, HttpException, Manager)+import           Network.HTTP.Types      (Header, HeaderName)+import           Text.Show               (Show)++-- * Basic types to distinguish CouchDB information++-- | The name of a database+newtype Db = Db { unwrapDb :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)++-- | The id of a document+newtype DocId = DocId { unwrapDocId :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)++-- | The revision of a document+newtype DocRev = DocRev { unwrapDocRev :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)++-- | The name of a host+newtype Host = Host { unwrapHost :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)++-- | The password of a user+newtype Password = Password { unwrapPassword :: Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)++-- | A TCP port number+newtype Port = Port { unwrapPort :: Int } deriving (Eq, Show)++-- | The name of a user+newtype User = User { unwrapUser ::  Text } deriving (Eq, FromJSON, IsString, Show, ToJSON)++-- ** Handling encoding++-- | Convert a 'DocId' directly into a 'ByteString'+reqDocId :: DocId -> ByteString+reqDocId = encodeUtf8 . unwrapDocId++-- | Convert a 'DocRev' directly into a 'ByteString'+reqDocRev :: DocRev -> ByteString+reqDocRev = encodeUtf8 . unwrapDocRev++-- | Convert a 'Password' directly into a 'ByteString'+reqPassword :: Password -> ByteString+reqPassword = encodeUtf8 . unwrapPassword++-- | Convert a 'User' directly into a 'ByteString'+reqUser :: User -> ByteString+reqUser = encodeUtf8 . unwrapUser++-- * Request Context++{- | This represents the context for each CouchDB request.++This contains all the bits that are unlikely to vary between requests.++Eventually, we should have routines that are smart enough to pull this+out of a suitably-set-up Monad, so you could just stash it there and+forget about it. -}+data Context+ = Context {+   -- | The Manager that "Network.HTTP.Client" requests require.  We store it here for easy access.+   ctxManager :: Manager,+   -- | The host to connect to+   ctxHost    :: Host,+   -- | The port to connect to+   ctxPort    :: Port,+   -- | Any credentials that should be used in making requests+   ctxCred    :: Maybe Credentials,+   -- | We can trade credentials for a session cookie that is more efficient, this is where it can be stored.+   ctxCookies :: CookieJar,+   -- | The database that should be used for database-specific requests.+   ctxDb      :: Maybe Db+   }++-- | Pull the appropriately encoded database out of the context+reqDb :: Context -> ByteString+reqDb c = maybe mempty (encodeUtf8 . unwrapDb) (ctxDb c)++-- | Pull the appropriately encoded host out of the context+reqHost :: Context -> ByteString+reqHost = encodeUtf8 . unwrapHost . ctxHost++-- | Pull the appropriately encoded port out of the context+reqPort :: Context -> Int+reqPort = unwrapPort . ctxPort++{- | The credentials for each CouchDB request.++Many operations in CouchDB require some sort of authentication.  We will store the credentials in their various forms here (though we're sticking to HTTP Basic Authentication for now).++There are operations on the request that know how to modify the request appropriately depending on which credential type is in play. -}+data Credentials+  = Basic {+    credUser :: User,+    credPass :: Password+    }++-- * Building requests++-- ** Handling Query Parameters++-- | A quick type alias for query parameters.+type QueryParameters = [(ByteString, Maybe ByteString)]++-- | A typeclass for types that can be converted to query parameters.+class ToQueryParameters a where+  -- | Performs the actual conversion+  toQueryParameters :: a -> QueryParameters++-- *** Helpers for converting values to Query Parameters++-- | Convert a value to a query parameter+toQP :: ByteString -- ^ The name of the query parameter+     -> (a -> ByteString) -- ^ A function from the raw value to a 'ByteString'+     -> Maybe a -- ^ The raw value+     -> Maybe (ByteString, Maybe ByteString)+toQP name fun = fmap ((name,) . Just . fun)++-- | Handle converting 'Bool' values+boolToQP :: ByteString -> Maybe Bool -> Maybe (ByteString, Maybe ByteString)+boolToQP name = toQP name (\bool -> if bool then "true" else "false")++-- | Handle converting 'DocId' values+docIdToQP :: ByteString -> Maybe DocId -> Maybe (ByteString, Maybe ByteString)+docIdToQP name = toQP name reqDocId++-- | Handle converting 'DocRev' values+docRevToQP :: ByteString -> Maybe DocRev -> Maybe (ByteString, Maybe ByteString)+docRevToQP name = toQP name reqDocRev++-- | Handle converting 'Int' values+intToQP :: ByteString -> Maybe Int -> Maybe (ByteString, Maybe ByteString)+intToQP name = toQP name (toStrict . toLazyByteString . intDec)++-- | Handle converting 'Text' values+textToQP :: ByteString -> Maybe Text -> Maybe (ByteString, Maybe ByteString)+textToQP name = toQP name encodeUtf8++-- ** Handling Header values++-- | A typeclass for types that can be converted to headers.+class ToHTTPHeaders a where+  -- | Performs the actual conversion+  toHTTPHeaders :: a -> [Header]++-- *** Helpers for converting values to Headers++-- | Convert a value to a 'Header'+toHH :: HeaderName -- ^ The name of the header+     -> (a -> ByteString) -- ^ A function from the raw value to a 'ByteString'+     -> Maybe a -- ^ The raw value+     -> Maybe Header+toHH name fun = fmap ((name,) . fun)++-- | Handle converting 'Bool' values+boolToHH :: HeaderName -> Maybe Bool -> Maybe Header+boolToHH name = toHH name (\bool -> if bool then "true" else "false")++-- * Parameters for different requests.++-- ** Parameters for monitoring server database creation++-- | The basic structure+data DbUpdates+  = DbUpdates {+    feed      :: Maybe FeedType,+    timeOut   :: Maybe Int,+    heartBeat :: Maybe Bool+    }++-- | Convert to query parameters+instance ToQueryParameters DbUpdates where+  toQueryParameters DbUpdates {..} = catMaybes [+    feedTypeToQP feed,+    intToQP "timeout" timeOut,+    boolToQP "heartbeat" heartBeat+    ]++-- | The default (empty) parameters+dbUpdatesParam :: DbUpdates+dbUpdatesParam = DbUpdates Nothing Nothing Nothing++-- ** Parameters for monitoring database changes++-- | The basic structure+data DbChanges+  = DbChanges {+    cDocIds          :: Maybe [DocId],+    cConflicts       :: Maybe Bool,+    cDescending      :: Maybe Bool,+    cFeed            :: Maybe FeedType,+    cFilter          :: Maybe Text,+    cHeartBeat       :: Maybe Int,+    cIncludeDocs     :: Maybe Bool,+    cAttachments     :: Maybe Bool,+    cAttEncodingInfo :: Maybe Bool,+    cLastEvent       :: Maybe Text,+    cSince           :: Maybe SinceType,+    cStyle           :: Maybe StyleType,+    cTimeout         :: Maybe Int,+    cView            :: Maybe Text+    }++-- | Convert to query parameters+instance ToQueryParameters DbChanges where+  toQueryParameters DbChanges {..} = catMaybes [+    boolToQP "conflicts" cConflicts,+    boolToQP "descending" cDescending,+    feedTypeToQP cFeed,+    textToQP "filter" cFilter,+    intToQP "heartbeat" cHeartBeat,+    boolToQP "include_docs" cIncludeDocs,+    boolToQP "attachments" cAttachments,+    boolToQP "att_encoding_info" cAttEncodingInfo,+    sinceTypeToQP cSince,+    styleTypeToQP cStyle,+    intToQP "timeout" cTimeout,+    textToQP "view" cView+    ]++-- | The default (empty) parameters+dbChangesParam :: DbChanges+dbChangesParam = DbChanges Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++-- ** Parameters for bulk retrieval of documents.++-- | The basic structure+data DbAllDocs+  = DbAllDocs {+    adConflicts     :: Maybe Bool,+    adDescending    :: Maybe Bool,+    adEndKey        :: Maybe Text,+    adEndKeyDocId   :: Maybe DocId,+    adIncludeDocs   :: Maybe Bool,+    adInclusiveEnd  :: Maybe Bool,+    adKey           :: Maybe Text,+    adLimit         :: Maybe Int,+    adSkip          :: Maybe Int,+    adStale         :: Maybe Bool,+    adStartKey      :: Maybe Text,+    adStartKeyDocId :: Maybe DocId,+    adUpdateSeq     :: Maybe Bool+    }++-- | Convert to query parameters+instance ToQueryParameters DbAllDocs where+  toQueryParameters DbAllDocs {..} = catMaybes [+    boolToQP "conflicts" adConflicts,+    boolToQP "descending" adDescending,+    textToQP "end_key" adEndKey,+    docIdToQP "end_key_doc_id" adEndKeyDocId,+    boolToQP "include_docs" adIncludeDocs,+    boolToQP "inclusive_end" adInclusiveEnd,+    textToQP "key" adKey,+    intToQP "limit" adLimit,+    intToQP "skip" adSkip,+    boolToQP "stale" adStale,+    textToQP "start_key" adStartKey,+    docIdToQP "start_key_doc_id" adStartKeyDocId,+    boolToQP "update_seq" adUpdateSeq+    ]++-- | The default (empty) parameters for bulk retrieval of documents+dbAllDocs :: DbAllDocs+dbAllDocs = DbAllDocs Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++-- ** Paramters for bulk creation and updating parameters++-- | The basic structure+data DbBulkDocs+  = DbBulkDocs {+    bdAllOrNothing :: Maybe Bool,+    bdFullCommit   :: Maybe Bool,+    bdNewEdits     :: Maybe Bool+    }++-- | The default (empty) parameters for bulk creation and update of documents+dbBulkDocs :: DbBulkDocs+dbBulkDocs = DbBulkDocs Nothing Nothing Nothing++-- ** Parameters for modifying documents++-- | The basic structure+data ModifyDoc+  = ModifyDoc {+    dpFullCommit :: Maybe Bool,+    dpBatch      :: Maybe Bool+    }++-- | Convert to HTTP Headers (partial)+instance ToHTTPHeaders ModifyDoc where+  toHTTPHeaders ModifyDoc {..} = catMaybes [+    boolToHH "X-Couch-Full-Commit" dpFullCommit+    ]++-- | Convert to query parameters (partial)+instance ToQueryParameters ModifyDoc where+  toQueryParameters ModifyDoc {..} = catMaybes [+    boolToQP "batch" dpBatch+    ]++-- | The default (empty) parameters+modifyDoc :: ModifyDoc+modifyDoc = ModifyDoc Nothing Nothing++-- ** Parameters for retrieving documents++-- | The basic structure+data RetrieveDoc+  = RetrieveDoc {+    dgdAttachments      :: Maybe Bool,+    dgdAttEncodingInfo  :: Maybe Bool,+    dgdAttsSince        :: [DocRev],+    dgdConflicts        :: Maybe Bool,+    dgdDeletedConflicts :: Maybe Bool,+    dgdLatest           :: Maybe Bool,+    dgdLocalSeq         :: Maybe Bool,+    dgdMeta             :: Maybe Bool,+    dgdOpenRevs         :: [DocRev],+    dgdRev              :: Maybe DocId,+    dgdRevs             :: Maybe Bool,+    dgdRevsInfo         :: Maybe Bool+    }++-- | Convert to query parameters+instance ToQueryParameters RetrieveDoc where+  toQueryParameters RetrieveDoc {..} = catMaybes $ [+    boolToQP "attachments" dgdAttachments,+    boolToQP "att_encoding_info" dgdAttEncodingInfo+    ] +++    fmap (docRevToQP "atts_since" . Just) dgdAttsSince+--    boolToQP "atts_since" dgdAttsSince,+    ++ [+    boolToQP "conflicts" dgdConflicts,+    boolToQP "deleted_conflicts" dgdDeletedConflicts,+    boolToQP "latest" dgdLatest,+    boolToQP "local_seq" dgdLocalSeq,+    boolToQP "meta" dgdMeta+    ] +++    fmap (docRevToQP "open_revs" . Just) dgdOpenRevs+    ++ [+    docIdToQP "rev" dgdRev,+    boolToQP "revs" dgdRevs,+    boolToQP "revs_info" dgdRevsInfo+    ]++-- | The default (empty) parameters+retrieveDoc :: RetrieveDoc+retrieveDoc = RetrieveDoc Nothing Nothing [] Nothing Nothing Nothing Nothing Nothing [] Nothing Nothing Nothing++-- * Specifying how to monitor updates++-- | Types of feeds available.+data FeedType+  = Continuous+  | EventSource+  | Longpoll++-- | Convert feed to Query Parameter+feedTypeToQP :: Maybe FeedType -> Maybe (ByteString, Maybe ByteString)+feedTypeToQP = fmap (("feed",) . Just . go)+    where+      go Continuous = "continuous"+      go EventSource = "eventsource"+      go Longpoll = "longpoll"++-- | Possible values of since+data SinceType+  = Now+  | Since Int++-- | Convert since to Query Parameter+sinceTypeToQP :: Maybe SinceType -> Maybe (ByteString, Maybe ByteString)+sinceTypeToQP = fmap (("since",) . Just . go)+    where+      go Now = "now"+      go (Since i) = (toStrict . toLazyByteString . intDec) i++-- | Possible values for style+data StyleType+  = StyleAll+  | StyleMain++-- | Convert style to Query Parameter+styleTypeToQP :: Maybe StyleType -> Maybe (ByteString, Maybe ByteString)+styleTypeToQP = fmap (("style",) . Just . go)+    where+      go StyleAll = "all_docs"+      go StyleMain = "main_docs"++-- * Document revision map++-- | The basic data type+data DocRevMap+  = DocRevMap [(DocId, [DocRev])]+  deriving (Generic, Eq, Show)++-- | decode from JSON+instance FromJSON DocRevMap where+  parseJSON (Object o) = DocRevMap <$> mapM (\(k, v) -> (,) <$> (return . DocId $ k) <*> parseJSON v) (HashMap.toList o)+  parseJSON _ = mzero++-- | encode to JSON+instance ToJSON DocRevMap where+  -- The lack of symmetry in the outer and inner conversions annoys me, but I don't see how to make the outer point-free+  toJSON (DocRevMap d) = Object . HashMap.fromList $ fmap ((unwrapDocId, Array . Vector.fromList . fmap (String . unwrapDocRev)) <<*>>) d++-- * View specification type++-- | The basic type+data ViewSpec+  = ViewSpec {+    vsMap    :: Text,+    vsReduce :: Maybe Text+    } deriving (Generic, Eq, Show)++-- | decode from JSON+instance FromJSON ViewSpec where+  parseJSON (Object o) = ViewSpec <$> o .: "map" <*> o .:? "reduce"+  parseJSON v = typeMismatch "Couldn't extract ViewSpec: " v++-- | encode to JSON+instance ToJSON ViewSpec where+  toJSON ViewSpec {..} = object $ "map" .= vsMap : maybe [] (\v -> ["reduce" .= v]) vsReduce++-- * Design document type++-- | The basic type+data DesignDoc+  = DesignDoc {+    ddocId         :: DocId,+    ddocRev        :: DocRev,+    ddocLanguage   :: Maybe Text,+    ddocOptions    :: Maybe (HashMap Text Text),+    ddocFilters    :: Maybe (HashMap Text Text),+    ddocLists      :: Maybe (HashMap Text Text),+    ddocShows      :: Maybe (HashMap Text Text),+    ddocUpdates    :: Maybe (HashMap Text Text),+    ddocValidation :: Maybe Text,+    ddocViews      :: Maybe (HashMap Text ViewSpec)+    } deriving (Generic, Eq, Show)++-- | decode from JSON+instance FromJSON DesignDoc where+  parseJSON (Object o) = DesignDoc+                         <$> o .: "_id"+                         <*> o .: "_rev"+                         <*> o .:? "language"+                         <*> o .:? "options"+                         <*> o .:? "filters"+                         <*> o .:? "lists"+                         <*> o .:? "shows"+                         <*> o .:? "updates"+                         <*> o .:? "validate_doc_update"+                         <*> o .:? "views"+  parseJSON v = typeMismatch "Couldn't extract DesignDoc: " v++-- | encode to JSON+instance ToJSON DesignDoc where+  toJSON DesignDoc {..} = object $ catMaybes [+    if (null . unwrapDocId) ddocId+    then Nothing+    else Just ("_id" .= ddocId),+    if (null . unwrapDocRev) ddocRev+    then Nothing+    else Just ("_rev" .= ddocRev),+    fmap ("language" .=) ddocLanguage,+    fmap ("options" .=) ddocOptions,+    fmap ("filters" .=) ddocFilters,+    fmap ("lists" .=) ddocLists,+    fmap ("shows" .=) ddocShows,+    fmap ("updates" .=) ddocUpdates,+    fmap ("validate_doc_update" .=) ddocValidation,+    fmap ("views" .=) ddocViews+    ]++-- * A type for view information++-- | The basic type+data ViewIndexInfo+  = ViewIndexInfo {+    viCompactRunning :: Bool,+    viDataSize       :: Int,+    viDiskSize       :: Int,+    viLanguage       :: Text,+    viPurgeSeq       :: Int,+    viSignature      :: Text,+    viUpdateSeq      :: Int,+    viUpdaterRunning :: Bool,+    viWaitingClients :: Int,+    viWaitingCommit  :: Bool+} deriving (Generic, Eq, Show)++-- | decode from JSON+instance FromJSON ViewIndexInfo where+  parseJSON (Object o) = ViewIndexInfo+                         <$> o .: "compact_running"+                         <*> o .: "data_size"+                         <*> o .: "disk_size"+                         <*> o .: "language"+                         <*> o .: "purge_seq"+                         <*> o .: "signature"+                         <*> o .: "update_seq"+                         <*> o .: "updater_running"+                         <*> o .: "waiting_clients"+                         <*> o .: "waiting_commit"+  parseJSON v = typeMismatch "Couldn't extract ViewIndexInfo: " v++-- * Parameters for view retrieval.++-- | The basic type+data ViewParams+  = ViewParams {+    vpAttachments     :: Maybe Bool,+    vpAttEncodingInfo :: Maybe Bool,+    vpConflicts       :: Maybe Bool,+    vpDescending      :: Maybe Bool,+    vpEndKey          :: Maybe Text,+    vpEndKeyDocId     :: Maybe DocId,+    vpGroup           :: Maybe Bool,+    vpGroupLevel      :: Maybe Int,+    vpIncludeDocs     :: Maybe Bool,+    vpInclusiveEnd    :: Maybe Bool,+    vpKey             :: Maybe Text,+    vpLimit           :: Maybe Int,+    vpReduce          :: Maybe Bool,+    vpSkip            :: Maybe Int,+    vpStale           :: Maybe Bool,+    vpStartKey        :: Maybe Text,+    vpStartKeyDocId   :: Maybe DocId,+    vpUpdateSeq       :: Maybe Bool+    }++-- | Convert to query parameters+instance ToQueryParameters ViewParams where+  toQueryParameters ViewParams {..} = catMaybes [+    boolToQP "attachments" vpAttachments,+    boolToQP "att_encoding_info" vpAttEncodingInfo,+    boolToQP "conflicts" vpConflicts,+    boolToQP "descending" vpDescending,+    textToQP "end_key" vpEndKey,+    docIdToQP "end_key_doc_id" vpEndKeyDocId,+    boolToQP "group" vpGroup,+    intToQP "group_level" vpGroupLevel,+    boolToQP "include_docs" vpIncludeDocs,+    boolToQP "inclusive_end" vpInclusiveEnd,+    textToQP "key" vpKey,+    intToQP "limit" vpLimit,+    boolToQP "reduce" vpReduce,+    intToQP "skip" vpSkip,+    boolToQP "stale" vpStale,+    textToQP "start_key" vpStartKey,+    docIdToQP "start_key_doc_id" vpStartKeyDocId,+    boolToQP "update_seq" vpUpdateSeq+    ]++-- | The default (empty) parameters+viewParams :: ViewParams+viewParams = ViewParams Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++-- * Results of a request++-- | Calls in the /Explicit/ interface will always return a 'Result', so we make it easy to type here.+type Result a = Either Error (a, Maybe CookieJar)++-- ** Some success values++-- | Result type for creating a new document in a database.+data CreateResult+  -- | In batch mode, you don't get a rev back+  = NoRev DocId+  -- | Otherwise, you do get the rev back for your doc+  | WithRev DocId DocRev++{- ** Error values++These will come to cover the gamut from failure to parse a particular JSON value to document conflicts.  We try to differentiate in useful ways without being slavish about it. -}++-- | These represent Failure modes for making CouchDB requests.+data Error+  -- | The database already exists+  = AlreadyExists+  -- | The document already exists, and without the appropriate rev+  | Conflict+  -- | The server complained about the content of our request.  Sounds like the library is broken. :(+  | HttpError HttpException+  -- | The server complained about the content of our request.  Sounds like the library is broken. :(+  | ImplementationError Text+  -- | The name you tried to give for the DB is invalid+  | InvalidName Text+  -- | The thing you were looking for was not found+  | NotFound+  -- | We ran out of input before we succeeded in parsing a JSON 'Data.Aeson.Value'.+  | ParseIncomplete+  -- | There was some sort of syntactic issue with the text we were attempting to parse.+  | ParseFail Text+  -- | The credentials you used do not have access to this resource+  | Unauthorized+  -- | Don't understand the failure+  | Unknown+  deriving (Show)
+ test/Functionality.hs view
@@ -0,0 +1,31 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Functionality where++import           Control.Applicative                  ((<$>))+import           Control.Monad                        (return)+import           Data.Function                        (const, ($))+import qualified Functionality.Explicit.Configuration as Configuration (tests)+import qualified Functionality.Explicit.Database      as Database (tests)+import qualified Functionality.Explicit.Design        as Design (tests)+import qualified Functionality.Explicit.Doc           as Doc (tests)+import qualified Functionality.Explicit.Local         as Local (tests)+import qualified Functionality.Explicit.Server        as Server (tests)+import qualified Functionality.Internal               as Internal (tests)+import           Network.HTTP.Client                  (defaultManagerSettings,+                                                       newManager)+import           System.IO                            (IO)+import           Test.Tasty                           (TestTree, defaultMain,+                                                       testGroup, withResource)++-- For interactive testing+_main :: IO ()+_main = defaultMain tests++-- Tests for functionality+tests :: TestTree+tests = withResource+        (newManager defaultManagerSettings)+        (const $ return ()) $ \manager -> testGroup "Functional Tests" $+                                          ($ manager) <$> [Internal.tests, Server.tests, Configuration.tests, Database.tests, Doc.tests, Design.tests, Local.tests]
+ test/Functionality/Explicit/Configuration.hs view
@@ -0,0 +1,44 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Functionality.Explicit.Configuration where++import           Control.Applicative                   ((<$>))+import           Data.Aeson                            (Value (String))+import           Data.Function                         (($))+import qualified Database.Couch.Explicit.Configuration as Configuration (delValue, getValue, section,+                                                                         server, setValue)+import           Database.Couch.Types                  (Context, Result)+import           Functionality.Util                    (runTests, serverContext,+                                                        testAgainstSchema)+import           Network.HTTP.Client                   (Manager)+import           System.IO                             (IO)+import           Test.Tasty                            (TestTree, testGroup)++_main :: IO ()+_main = runTests tests++-- We specifically don't use makeTests here because we want no-databas-selected context+tests :: IO Manager -> TestTree+tests manager =+  testGroup "Tests of the config interface" $+  ($ serverContext manager) <$> [server, section, getValue, setValue, delValue]++-- Server-oriented functions+server :: IO Context -> TestTree+server = testAgainstSchema "Get server config" Configuration.server "get--_config.json"++section :: IO Context -> TestTree+section = testAgainstSchema "Get section config" (Configuration.section "couchdb") "get--_config-section.json"++getValue :: IO Context -> TestTree+getValue = testAgainstSchema "Get config item" (Configuration.getValue "couchdb" "max_document_size") "get--_config-section-key.json"++setValue :: IO Context -> TestTree+setValue = testAgainstSchema "Set config item" (Configuration.setValue "testsection" "testkey" $ String "foo") "put--_config-section-key.json"++delValue :: IO Context -> TestTree+delValue = testAgainstSchema "Delete config item" (\c -> do+                                                       _ :: Result Value <- Configuration.setValue "testsection" "testkey" (String "foo") c+                                                       Configuration.delValue "testsection" "testkey" c) "delete--_config-section-key.json"
+ test/Functionality/Explicit/Database.hs view
@@ -0,0 +1,270 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Functionality.Explicit.Database where++import           Control.Applicative              ((<$>))+import           Control.Monad                    (return, (>>))+import           Data.Aeson                       (Object, Value (Bool, Number),+                                                   object)+import           Data.Bool                        (Bool (False, True))+import           Data.Function                    (($))+import           Data.HashMap.Strict              (lookup)+import           Data.Maybe                       (Maybe (Just))+import qualified Database.Couch.Explicit.Database as Database (allDocs,+                                                               bulkDocs,+                                                               changes, cleanup,+                                                               compact,+                                                               compactDesignDoc,+                                                               create,+                                                               createDoc,+                                                               delete, exists,+                                                               getRevsLimit,+                                                               getSecurity,+                                                               meta,+                                                               missingRevs,+                                                               purge, revsDiff,+                                                               setRevsLimit,+                                                               setSecurity,+                                                               someDocs, sync,+                                                               tempView)+import qualified Database.Couch.Response          as Response (asAnything,+                                                               asBool)+import           Database.Couch.Types             (Context (ctxDb),+                                                   DocId (DocId),+                                                   DocRev (DocRev),+                                                   DocRevMap (DocRevMap), Error (Conflict, NotFound, InvalidName, AlreadyExists),+                                                   Result, dbAllDocs,+                                                   dbBulkDocs, dbChangesParam)+import           Functionality.Util               (makeTests, runTests,+                                                   testAgainstFailure,+                                                   testAgainstSchema,+                                                   testAgainstSchemaAndValue,+                                                   withDb)+import           Network.HTTP.Client              (Manager)+import           System.IO                        (IO)+import           Test.Tasty                       (TestTree)+import           Test.Tasty.HUnit                 ((@=?))++_main :: IO ()+_main = runTests tests++tests :: IO Manager -> TestTree+tests = makeTests "Tests of the database interface"+          [ databaseExists+          , databaseMeta+          , databaseCreate+          , databaseDelete+          , databaseCreateDoc+          , databaseAllDocs+          , databaseSomeDocs+          , databaseBulkDocs+          , databaseChanges+          , databaseCompact+          , databaseCompactDesignDoc+          , databaseSync+          , databaseCleanup+          , databaseGetSecurity+          , databaseSetSecurity+          , databaseTempView+          , databasePurge+          , databaseMissingRevs+          , databaseRevsDiff+          , databaseGetRevsLimit+          , databaseSetRevsLimit+          ]++-- Database-oriented functions+databaseExists :: IO Context -> TestTree+databaseExists = makeTests "Database existence"+                   [ testAgainstFailure "Randomly named database should not exist" Database.exists+                       NotFound+                   , withDb $ testAgainstSchema "Check for an existing database" Database.exists+                                "head--db.json"+                   ]++databaseMeta :: IO Context -> TestTree+databaseMeta =+  makeTests "Database metadata"+    [ testAgainstFailure "No metadata on non-existent database" Database.meta NotFound+    , withDb $ testAgainstSchema "Metadata for an existing database" Database.meta "get--db.json"+    ]++databaseCreate :: IO Context -> TestTree+databaseCreate =+  makeTests "Database creation"+    [ testAgainstFailure+        "Invalid name is not accepted"+        (\c -> Database.create c { ctxDb = Just "1111" })+        (InvalidName+           "Name: '1111'. Only lowercase characters (a-z), digits (0-9), and any of the characters _, $, (, ), +, -, and / are allowed. Must begin with a letter.")+    , withDb $ testAgainstFailure "Invalid name is not accepted" Database.create AlreadyExists+    , testAgainstSchema "Result of creating a new database" (\c -> do+                                                                 createResp <- Database.create c+                                                                 _ :: Result Value <- Database.delete c+                                                                 return createResp) "put--db.json"+    ]++databaseDelete :: IO Context -> TestTree+databaseDelete =+  makeTests "Database deletion"+    [ testAgainstFailure+        "Invalid name is not accepted"+        (\c -> Database.delete c { ctxDb = Just "1111" })+        (InvalidName+           "Name: '1111'. Only lowercase characters (a-z), digits (0-9), and any of the characters _, $, (, ), +, -, and / are allowed. Must begin with a letter.")+    , testAgainstFailure "Missing name is not accepted" Database.delete NotFound+    , testAgainstSchema+        "Result of deleting a new database"+        (\c -> Response.asBool <$> Database.create c >> Database.delete c)+        "delete--db.json"+    ]++databaseCreateDoc :: IO Context -> TestTree+databaseCreateDoc =+  makeTests "Database create document"+    [ withDb $ testAgainstSchema+                 "Create a document without _id, immediate mode"+                 (Database.createDoc False (object [("llamas", Bool True)]))+                 "post--db.json"+    , withDb $ testAgainstSchema+                 "Create a document without _id, batch mode"+                 (Database.createDoc True (object [("llamas", Bool True)]))+                 "post--db.json"+    , withDb $ testAgainstSchema+                 "Create a document with _id, immediate mode"+                 (Database.createDoc False (object [("_id", "foo"), ("llamas", Bool True)]))+                 "post--db.json"+    , withDb $ testAgainstSchema+                 "Create a document with _id, batch mode"+                 (Database.createDoc True (object [("_id", "foo"), ("llamas", Bool True)]))+                 "post--db.json"+    , withDb $ testAgainstFailure+                 "Try to create a document with an invalid name"+                 (Database.createDoc False (object [("_id", "_111111%%%"), ("llamas", Bool True)]))+                 (InvalidName "Only reserved document ids may start with underscore.")+    , withDb $ testAgainstFailure+                 "Try to create a document twice"+                 (\c -> do+                    _ :: Result Value <- Database.createDoc False (object [("_id", "foo"), ("llamas", Bool True)]) c+                    Database.createDoc False (object [("_id", "foo"), ("llamas", Bool True)]) c)+                 Conflict+    ]++databaseAllDocs :: IO Context -> TestTree+databaseAllDocs =+  makeTests "Database retrieve all document"+    [ withDb $ testAgainstSchema "Result of completely fresh database" (Database.allDocs dbAllDocs)+                 "get--db-_all_docs.json"+    , withDb $ testAgainstSchema+                 "Add a record and get all docs"+                 (\c -> do+                    _ :: Result Value <- Database.createDoc False (object [("_id", "foo"), ("llamas", Bool True)]) c+                    Database.allDocs dbAllDocs c)+                 "get--db-_all_docs.json"+    ]++databaseSomeDocs :: IO Context -> TestTree+databaseSomeDocs =+  makeTests "Database retrieve some documents"+    [withDb $ testAgainstSchemaAndValue "Result of completely fresh database" (Database.someDocs dbAllDocs ["llama", "tron"]) "get--db-_all_docs.json" Response.asAnything $ \step (val :: Object) -> do+      step "Check number of items in database"+      lookup "total_rows" val @=? Just (Number 0), withDb $ testAgainstSchemaAndValue+                                                              "Add a record and get all docs"+                                                              (\c -> do+                                                                 _ :: Result Value <- Database.createDoc False (object [("_id", "foo"), ("llamas", Bool True)]) c+                                                                 _ :: Result Value <- Database.createDoc False (object [("_id", "bar"), ("llamas", Bool True)]) c+                                                                 Database.someDocs dbAllDocs ["foo"] c)+                                                              "get--db-_all_docs.json"+                                                              Response.asAnything $ \step (val :: Object) -> do+                                                     step "Check number of items in database"+                                                     lookup "total_rows" val @=? Just (Number 2)]++databaseBulkDocs :: IO Context -> TestTree+databaseBulkDocs =+  makeTests "Database update documents in bulk"+    [ withDb $ testAgainstSchema "Empty list of documents" (Database.bulkDocs dbBulkDocs [])+      "post--db-_bulk_docs.json"+    ]++databaseChanges :: IO Context -> TestTree+databaseChanges =+  makeTests "Database update documents in bulk"+  [ withDb $ testAgainstSchema "Empty list of documents" (Database.changes dbChangesParam)+    "get--db-_changes.json"+  ]++databaseCleanup :: IO Context -> TestTree+databaseCleanup =+  makeTests "Database view cleanup"+  [ testAgainstSchema "_users database" (\c -> Database.cleanup c { ctxDb = Just "_users" }) "post--db-_view_cleanup.json"+  ]++databaseCompact :: IO Context -> TestTree+databaseCompact =+  makeTests "Database compact database"+  [ withDb $ testAgainstSchema "Empty list of documents" Database.compact "post--db-_compact.json"+  ]++databaseCompactDesignDoc :: IO Context -> TestTree+databaseCompactDesignDoc =+  makeTests "Database compact database design document"+  [ testAgainstSchema "Empty list of documents" (\c -> Database.compactDesignDoc "_auth" c { ctxDb = Just "_users" }) "post--db-_compact-ddoc.json"+  ]++databaseSync :: IO Context -> TestTree+databaseSync =+  makeTests "Database sync commit"+  [ testAgainstSchema "_users database" (\c -> Database.sync c { ctxDb = Just "_users" }) "post--db-_ensure_full_commit.json"+  ]++databaseGetSecurity :: IO Context -> TestTree+databaseGetSecurity =+  makeTests "Database get security"+  [ testAgainstSchema "_users database" (\c -> Database.getSecurity c { ctxDb = Just "_users" }) "get--db-_security.json"+  ]++databaseSetSecurity :: IO Context -> TestTree+databaseSetSecurity =+  makeTests "Database set security"+  [ withDb $ testAgainstSchema "Random database" (Database.setSecurity $ object []) "put--db-_security.json"+  ]++databaseTempView :: IO Context -> TestTree+databaseTempView =+  makeTests "Database temporary view"+  [ withDb $ testAgainstSchema "Random database" (\c -> do+                                                      _ :: Result Value <- Database.createDoc False (object [("_id", "foo"), ("llamas", Bool True)]) c+                                                      Database.tempView "function (doc) { emit (1); }" (Just "_count") c) "post--db-_temp_view.json"+  ]++databasePurge :: IO Context -> TestTree+databasePurge =+  makeTests "Database purge"+  [ withDb $ testAgainstSchema "Random database" (Database.purge $ DocRevMap [(DocId "junebug", [DocRev "1-1"])]) "post--db-_purge.json"+  ]++databaseMissingRevs :: IO Context -> TestTree+databaseMissingRevs =+  makeTests "Database missing revs"+  [ withDb $ testAgainstSchema "Random database" (Database.missingRevs $ DocRevMap [(DocId "junebug", [DocRev "1-1"])]) "post--db-_missing_revs.json"+  ]++databaseRevsDiff :: IO Context -> TestTree+databaseRevsDiff =+  makeTests "Database revs diff"+  [ withDb $ testAgainstSchema "Random database" (Database.revsDiff $ DocRevMap [(DocId "junebug", [DocRev "1-1"])]) "post--db-_revs_diff.json"+  ]++databaseGetRevsLimit :: IO Context -> TestTree+databaseGetRevsLimit =+  makeTests "Database revs limit"+  [ withDb $ testAgainstSchema "Random database" Database.getRevsLimit "get--db-_revs_limit.json"+  ]++databaseSetRevsLimit :: IO Context -> TestTree+databaseSetRevsLimit =+  makeTests "Set database revs limit"+  [ withDb $ testAgainstSchema "Random database" (Database.setRevsLimit 17) "put--db-_revs_limit.json"+  ]
+ test/Functionality/Explicit/Design.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Functionality.Explicit.Design where++import           Control.Monad                  (mapM_, return)+import           Data.Aeson                     (Value, object)+import           Data.Either                    (Either (Right))+import           Data.Function                  (($))+import           Data.HashMap.Strict            (fromList)+import           Data.Maybe                     (Maybe (Just, Nothing))+import qualified Database.Couch.Explicit.Design as Design (allDocs, copy,+                                                           delete, get, info,+                                                           meta, put, someDocs)+import           Database.Couch.Explicit.Doc    as Doc (put)+import           Database.Couch.Response        (getKey)+import           Database.Couch.Types           (Context, DesignDoc (..),+                                                 DocRev (..),+                                                 Error (NotFound, Conflict),+                                                 Result, ViewSpec (ViewSpec),+                                                 ctxDb, modifyDoc, retrieveDoc,+                                                 viewParams)+import           Functionality.Util             (makeTests, runTests,+                                                 testAgainstFailure,+                                                 testAgainstSchema, withDb)+import           Network.HTTP.Client            (Manager)+import           System.IO                      (IO)+import           Test.Tasty                     (TestTree)++_main :: IO ()+_main = runTests tests++tests :: IO Manager -> TestTree+tests = makeTests "Tests of the design doc interface"+          [ ddocMeta+          , ddocGet+          , ddocPut+          , ddocDelete+          , ddocCopy+          , ddocInfo+          , viewAllDocs+          , viewSomeDocs+          ]++-- Doc-oriented functions+ddocMeta :: IO Context -> TestTree+ddocMeta =+  makeTests "Get design document size and revision"+    [ testAgainstFailure "No size information for non-existent doc" (Design.meta retrieveDoc "llamas" Nothing) NotFound+    , testAgainstSchema "Get standard _auth ddoc in _users"  (\c -> Design.meta retrieveDoc "_auth" Nothing c { ctxDb = Just "_users" })++                 "head--db-_design-ddoc.json"+    ]++ddocGet :: IO Context -> TestTree+ddocGet =+  makeTests "Get design document content"+    [ testAgainstSchema "Get standard _auth ddoc in _users"  (\c -> Design.get retrieveDoc "_auth" Nothing c { ctxDb = Just "_users" })+                 "get--db-_design-ddoc.json"+    ]++ddocPut :: IO Context -> TestTree+ddocPut =+  makeTests "Create and update a design document"+    [ withDb $ testAgainstSchema "Simple add of document" (Design.put modifyDoc "foo" Nothing initialDdoc) "put--db-_design-ddoc.json"+    , withDb $ testAgainstFailure "Failure to update document" (\c -> do+                                                                    _ :: Result Value <- Design.put modifyDoc "foo" Nothing initialDdoc c+                                                                    Design.put modifyDoc "foo" Nothing initialDdoc c) Conflict+    , withDb $ testAgainstSchema+                 "Add, then update a doc"+                 (\c -> do+                    res <- Design.put modifyDoc "foo" Nothing initialDdoc c+                    let (Right (id, _)) = getKey "id" res+                    let (Right (rev, _)) = getKey "rev" res+                    Design.put modifyDoc "foo" (Just rev) initialDdoc {ddocId = id, ddocRev = rev} c)+                 "put--db-_design-ddoc.json"+    ]+  where+    initialDdoc = DesignDoc "" "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++ddocDelete :: IO Context -> TestTree+ddocDelete =+  makeTests "Create and update a design document"+    [ withDb $ testAgainstFailure "Delete non-existent design document" (Design.delete modifyDoc "foo" Nothing) NotFound+    , withDb $ testAgainstFailure "Delete design document with conflict" (\c -> do+                                                                   _ :: Result Value <- Design.put modifyDoc "foo" Nothing initialDdoc c+                                                                   Design.delete modifyDoc "foo" Nothing c) Conflict+    , withDb $ testAgainstSchema+                 "Add, then delete design doc"+                 (\c -> do+                    res <- Design.put modifyDoc "foo" Nothing initialDdoc c+                    let (Right (rev, _)) = getKey "rev" res+                    Design.delete modifyDoc "foo" rev c)+                 "delete--db-_design-ddoc.json"+    ]+  where+    initialDdoc = DesignDoc "" "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++ddocCopy :: IO Context -> TestTree+ddocCopy =+  makeTests "Copy a document"+    [ withDb $ testAgainstFailure "Copy a non-existent document" (Design.copy modifyDoc "foo" Nothing "bar") NotFound+    , withDb $ testAgainstFailure "Copy a document with conflict" (\c -> do+                                                                   _ :: Result Value <- Design.put modifyDoc "foo" Nothing initialDdoc c+                                                                   _ :: Result Value <- Design.put modifyDoc "bar" Nothing initialDdoc c+                                                                   Design.copy modifyDoc "foo" Nothing "bar" c) Conflict+    , withDb $ testAgainstFailure+                 "Copy a document with a non-existent revision"+                 (\c -> do+                    _ :: Result Value <- Design.put modifyDoc "foo" Nothing initialDdoc c+                    Design.copy modifyDoc "foo" (Just $ DocRev "1-000000000") "bar" c)+                 NotFound+    , withDb $ testAgainstSchema+                 "Copy a document"+                 (\c -> do+                    _ :: Result Value <- Design.put modifyDoc "foo" Nothing initialDdoc c+                    Design.copy modifyDoc "foo" Nothing "bar" c)+                 "copy--db-_design-ddoc.json"+    ]+  where+    initialDdoc = DesignDoc "" "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing Nothing++ddocInfo :: IO Context -> TestTree+ddocInfo =+  makeTests "Get design document info"+    [ testAgainstSchema "Get standard _auth ddoc in _users"  (\c -> Design.info "_auth" c { ctxDb = Just "_users" })+                 "get--db-_design-ddoc-_info.json"+    ]++viewAllDocs :: IO Context -> TestTree+viewAllDocs =+  makeTests "Get results from a view" [+    withDb $ testAgainstSchema "Simple view" checkView "get--db-_design-ddoc-_view-view.json"+    ]+  where+    checkView c = do+      _ :: Result Value <- Design.put modifyDoc "foo" Nothing initialDdoc c+      _ :: Result Value <- Doc.put modifyDoc "foo" Nothing testDoc c+      Design.allDocs viewParams "foo" "test" c+    initialDdoc = DesignDoc "" "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just $ fromList [("test", simpleView)])+    simpleView = ViewSpec "function(doc) {\n  if(doc.date && doc.title) {\n    emit(doc.date, doc.title);\n  }\n}\n" Nothing+    testDoc = object [("_id", "the-silence-of-the-lambs"), ("title", "The Silence of the Lambs"), ("date", "1991-02-14")]++viewSomeDocs :: IO Context -> TestTree+viewSomeDocs =+  makeTests "Get results from a view" [+    withDb $ testAgainstSchema "Simple view" checkView "post--db-_design-ddoc-_view-view.json"+    ]+  where+    checkView c = do+      _ :: Result Value <- Design.put modifyDoc "foo" Nothing initialDdoc c+      mapM_ (\testDoc -> do+                 _ :: Result Value <- Doc.put modifyDoc "foo" Nothing testDoc c+                 return ()) testDocs+      Design.someDocs viewParams "foo" "test" ["red-dragon"] c+    initialDdoc = DesignDoc "" "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing (Just $ fromList [("test", simpleView)])+    simpleView = ViewSpec "function(doc) {\n  if(doc.date && doc.title) {\n    emit(doc.date, doc.title);\n  }\n}\n" Nothing+    testDocs = [object [("_id", "the-silence-of-the-lambs"), ("title", "The Silence of the Lambs"), ("date", "1991-02-14")]+               ,object [("_id", "red-dragon"), ("title", "Red Dragon"), ("date", "2002-10-04")]]
+ test/Functionality/Explicit/Doc.hs view
@@ -0,0 +1,119 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Functionality.Explicit.Doc where++import           Data.Aeson                       (Value (Bool), object)+import           Data.Bool                        (Bool (False, True))+import           Data.Either                      (Either (Right))+import           Data.Function                    (($))+import           Data.Maybe                       (Maybe (Just, Nothing))+import qualified Database.Couch.Explicit.Database as Database (createDoc)+import qualified Database.Couch.Explicit.Doc      as Doc (copy, delete, get,+                                                          meta, put)+import           Database.Couch.Response          (getKey)+import           Database.Couch.Types             (Context, DocRev (DocRev),+                                                   Error (Conflict, NotFound),+                                                   Result, modifyDoc,+                                                   retrieveDoc)+import           Functionality.Util               (makeTests, runTests,+                                                   testAgainstFailure,+                                                   testAgainstSchema, withDb)+import           Network.HTTP.Client              (Manager)+import           System.IO                        (IO)+import           Test.Tasty                       (TestTree)++_main :: IO ()+_main = runTests tests++tests :: IO Manager -> TestTree+tests = makeTests "Tests of the doc interface"+          [ docMeta+          , docGet+          , docPut+          , docDelete+          , docCopy+          ]++testDoc :: Value+testDoc = object [("_id", "foo"), ("llamas", Bool True)]++-- Doc-oriented functions+docMeta :: IO Context -> TestTree+docMeta =+  makeTests "Get document size and revision"+    [ withDb $ testAgainstFailure "No size information for non-existent doc" (Doc.meta retrieveDoc "foo" Nothing) NotFound+    , withDb $ testAgainstSchema+                 "Add a record and get all docs"+                 (\c -> do+                    _ :: Result Value <- Database.createDoc False testDoc c+                    Doc.meta retrieveDoc "foo" Nothing c)+                 "head--db-docid.json"+    ]++docGet :: IO Context -> TestTree+docGet =+  makeTests "Get document"+    [ withDb $ testAgainstFailure "No information for non-existent doc" (Doc.get retrieveDoc "foo" Nothing) NotFound+    , withDb $ testAgainstSchema+                 "Add a doc and get the docs"+                 (\c -> do+                    _ :: Result Value <- Database.createDoc False testDoc c+                    Doc.get retrieveDoc "foo" Nothing c)+                 "get--db-docid.json"+    ]++docPut :: IO Context -> TestTree+docPut =+  makeTests "Create and update a document"+    [ withDb $ testAgainstSchema "Simple add of document" (Doc.put modifyDoc "foo" Nothing testDoc) "put--db-docid.json"+    , withDb $ testAgainstFailure "Failure to re-add document" (\c -> do+                                                                   _ :: Result Value <- Doc.put modifyDoc "foo" Nothing testDoc c+                                                                   Doc.put modifyDoc "foo" Nothing testDoc c) Conflict+    , withDb $ testAgainstSchema+                 "Add, then update a doc"+                 (\c -> do+                    res <- Doc.put modifyDoc "foo" Nothing testDoc c+                    let (Right (rev, _)) = getKey "rev" res+                    Doc.put modifyDoc "foo" rev testDoc c)+                 "put--db-docid.json"+    ]++docDelete :: IO Context -> TestTree+docDelete =+  makeTests "Create and update a document"+    [ withDb $ testAgainstFailure "Delete non-existent document" (Doc.delete modifyDoc "foo" Nothing) NotFound+    , withDb $ testAgainstFailure "Delete document with conflict" (\c -> do+                                                                   _ :: Result Value <- Doc.put modifyDoc "foo" Nothing testDoc c+                                                                   Doc.delete modifyDoc "foo" Nothing c) Conflict+    , withDb $ testAgainstSchema+                 "Add, then delete doc"+                 (\c -> do+                    res <- Doc.put modifyDoc "foo" Nothing testDoc c+                    let (Right (rev, _)) = getKey "rev" res+                    Doc.delete modifyDoc "foo" rev c)+                 "delete--db-docid.json"+    ]++docCopy :: IO Context -> TestTree+docCopy =+  makeTests "Copy a document"+    [ withDb $ testAgainstFailure "Copy a non-existent document" (Doc.copy modifyDoc "foo" Nothing "bar") NotFound+    , withDb $ testAgainstFailure "Copy a document with conflict" (\c -> do+                                                                   _ :: Result Value <- Doc.put modifyDoc "foo" Nothing testDoc c+                                                                   _ :: Result Value <- Doc.put modifyDoc "bar" Nothing testDoc c+                                                                   Doc.copy modifyDoc "foo" Nothing "bar" c) Conflict+    , withDb $ testAgainstFailure+                 "Copy a document with a non-existent revision"+                 (\c -> do+                    _ :: Result Value <- Doc.put modifyDoc "foo" Nothing testDoc c+                    Doc.copy modifyDoc "foo" (Just $ DocRev "1-000000000") "bar" c)+                 NotFound+    , withDb $ testAgainstSchema+                 "Copy a document"+                 (\c -> do+                    _ :: Result Value <- Doc.put modifyDoc "foo" Nothing testDoc c+                    Doc.copy modifyDoc "foo" Nothing "bar" c)+                 "copy--db-docid.json"+    ]
+ test/Functionality/Explicit/Local.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Functionality.Explicit.Local where++import           Data.Aeson                    (Value (Bool), object)+import           Data.Bool                     (Bool (True))+import           Data.Either                   (Either (Right))+import           Data.Function                 (($))+import           Data.Maybe                    (Maybe (Just, Nothing))+import qualified Database.Couch.Explicit.Local as Local (copy, delete, get, put)+import           Database.Couch.Response       (getKey)+import           Database.Couch.Types          (Context, DocRev (DocRev),+                                                Error (Conflict, NotFound),+                                                Result, modifyDoc, retrieveDoc)+import           Functionality.Util            (makeTests, runTests,+                                                testAgainstFailure,+                                                testAgainstSchema, withDb)+import           Network.HTTP.Client           (Manager)+import           System.IO                     (IO)+import           Test.Tasty                    (TestTree)++_main :: IO ()+_main = runTests tests++tests :: IO Manager -> TestTree+tests = makeTests "Tests of the local interface"+          [ docGet+          , docPut+          , docDelete+          , docCopy+          ]++testDoc :: Value+testDoc = object [("_id", "foo"), ("llamas", Bool True)]++docGet :: IO Context -> TestTree+docGet =+  makeTests "Get local document size and revision"+    [ withDb $ testAgainstFailure "No information for non-existent doc" (Local.get retrieveDoc "foo" Nothing) NotFound+    , withDb $ testAgainstSchema+                 "Add a doc and get the docs"+                 (\c -> do+                    _ :: Result Value <- Local.put modifyDoc "foo" Nothing testDoc c+                    Local.get retrieveDoc "foo" Nothing c)+                 "get--db-docid.json"+    ]++docPut :: IO Context -> TestTree+docPut =+  makeTests "Create and update a local document"+    [ withDb $ testAgainstSchema "Simple add of local document" (Local.put modifyDoc "foo" Nothing testDoc) "put--db-docid.json"+    , withDb $ testAgainstFailure "Failure to re-add local document" (\c -> do+                                                                   _ :: Result Value <- Local.put modifyDoc "foo" Nothing testDoc c+                                                                   Local.put modifyDoc "foo" Nothing testDoc c) Conflict+    , withDb $ testAgainstSchema+                 "Add, then update a doc"+                 (\c -> do+                    res <- Local.put modifyDoc "foo" Nothing testDoc c+                    let (Right (rev, _)) = getKey "rev" res+                    Local.put modifyDoc "foo" rev testDoc c)+                 "put--db-docid.json"+    ]++docDelete :: IO Context -> TestTree+docDelete =+  makeTests "Delete a local document"+    [ withDb $ testAgainstFailure "Delete non-existent local document" (Local.delete modifyDoc "foo" Nothing) NotFound+    , withDb $ testAgainstFailure "Delete local document with conflict" (\c -> do+                                                                   _ :: Result Value <- Local.put modifyDoc "foo" Nothing testDoc c+                                                                   Local.delete modifyDoc "foo" Nothing c) Conflict+    , withDb $ testAgainstSchema+                 "Add, then delete doc"+                 (\c -> do+                    res <- Local.put modifyDoc "foo" Nothing testDoc c+                    let (Right (rev, _)) = getKey "rev" res+                    Local.delete modifyDoc "foo" rev c)+                 "delete--db-docid.json"+    ]++docCopy :: IO Context -> TestTree+docCopy =+  makeTests "Copy a document"+    [ withDb $ testAgainstFailure "Copy a non-existent document" (Local.copy modifyDoc "foo" Nothing "bar") NotFound+    , withDb $ testAgainstFailure "Copy a document with conflict" (\c -> do+                                                                   _ :: Result Value <- Local.put modifyDoc "foo" Nothing testDoc c+                                                                   _ :: Result Value <- Local.put modifyDoc "bar" Nothing testDoc c+                                                                   Local.copy modifyDoc "foo" Nothing "bar" c) Conflict+    , withDb $ testAgainstFailure+                 "Copy a document with a non-existent revision"+                 (\c -> do+                    _ :: Result Value <- Local.put modifyDoc "foo" Nothing testDoc c+                    Local.copy modifyDoc "foo" (Just $ DocRev "1-000000000") "bar" c)+                 NotFound+    , withDb $ testAgainstSchema+                 "Copy a document"+                 (\c -> do+                    _ :: Result Value <- Local.put modifyDoc "foo" Nothing testDoc c+                    Local.copy modifyDoc "foo" Nothing "bar" c)+                 "copy--db-docid.json"+    ]
+ test/Functionality/Explicit/Server.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Functionality.Explicit.Server where++import           Control.Applicative            ((<$>))+import           Data.Foldable                  (for_)+import           Data.Function                  (($), (.))+import           Data.List                      (length)+import           Data.UUID                      (toString)+import qualified Database.Couch.Explicit.Server as Server (activeTasks, allDbs,+                                                           meta, restart, stats,+                                                           uuids)+import           Database.Couch.Response        as Response (asUUID)+import           Database.Couch.Types           (Context)+import           Functionality.Util             (runTests, serverContext,+                                                 testAgainstSchema,+                                                 testAgainstSchemaAndValue)+import           Network.HTTP.Client            (Manager)+import           System.IO                      (IO)+import           Test.Tasty                     (TestTree, testGroup)+import           Test.Tasty.HUnit               ((@=?))++_main :: IO ()+_main = runTests tests+++-- We specifically don't use makeTests here because we want no-databas-selected context+tests :: IO Manager -> TestTree+tests manager = testGroup "Tests of the server interface" $+  ($ serverContext manager) <$> [serverMeta, activeTasks, allDbs, stats, uuids]++-- Server-oriented functions+serverMeta :: IO Context -> TestTree+serverMeta = testAgainstSchema "Get server meta information" Server.meta "get--.json"++activeTasks :: IO Context -> TestTree+activeTasks = testAgainstSchema "Get list of active tasks" Server.activeTasks "get--_active_tasks.json"++allDbs :: IO Context -> TestTree+allDbs = testAgainstSchema "Retrieve list of all dbs (should be empty)" Server.allDbs "get--_all_dbs.json"++-- This fails when run alone, so it's commented out; I need to have it+-- able to run some other thing concurrently to provoke some actual+-- content+-- dbUpdates :: IO Context -> TestTree+-- dbUpdates getContext = testCaseSteps "Retrieve list of database updates" $ do+--   res <- getContext >>= Server.dbUpdates+--   checkRequestSuccess res+--   assertBool "should have an array of objects" $ allOf (_Right._1.each) (has _Object) res+--   assertBool "should have pids for all tasks" $ allOf (_Right._1.each) (has (key "pid")) res+--   checkEmptyCookieJar res++restart :: IO Context -> TestTree+restart = testAgainstSchema "Restart server" Server.restart "post--_restart.json"++stats :: IO Context -> TestTree+stats = testAgainstSchema "Retrieve statistics" Server.stats "get--_stats.json"++uuids :: IO Context -> TestTree+uuids = testAgainstSchemaAndValue "Retrieve UUIDs" (Server.uuids 1) "get--_stats.json" Response.asUUID $ \step val -> do+  step "Check length of list"+  length val @=? 1+  step "Check lengths of items"+  for_ val $ \u -> (length . toString) u @=? 36
+ test/Functionality/Internal.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Functionality.Internal where++import           Data.Default            (def)+import           Data.Either             (Either (Left, Right))+import           Data.Eq                 ((==))+import           Data.Foldable           (find)+import           Data.Function           (($), (.))+import           Data.Functor            (fmap)+import           Data.Maybe              (Maybe (Just))+import           Data.Tuple              (fst, snd)+import           Database.Couch.Internal (rawJsonRequest)+import           Functionality.Util      (checkSchema, runTests)+import           Network.HTTP.Client     (Manager, RequestBody (RequestBodyLBS),+                                          host, method, path, port, requestBody,+                                          requestHeaders)+import           Network.HTTP.Types      (status200)+import           System.IO               (IO)+import           Test.Tasty              (TestTree, testGroup)+import           Test.Tasty.HUnit        (assertFailure, testCaseSteps, (@=?))+import           Text.Show               (show)++-- For interactive testing+_main :: IO ()+_main = runTests tests++tests :: IO Manager -> TestTree+tests manager = testGroup "Raw JSON interface" [requestRoot manager]++-- The root of the couchdb server provides predictable content+requestRoot :: IO Manager -> TestTree+requestRoot getManager = testCaseSteps "Check rawJsonRequest" $ \step -> do+  manager <- getManager+  step "Request root"+  res <- rawJsonRequest manager def { requestHeaders = [], host = "localhost", method = "GET", path = "/", port = 5984, requestBody = RequestBodyLBS "" }+  step "No exception"+  case res of+    Left error -> assertFailure (show error)+    Right (headers, status, cookieJar, value) -> do+      step "Cache-Control header"+      Just "must-revalidate" @=? fmap snd (find ((== "cache-control") . fst) headers)+      step "200 status code"+      status200 @=? status+      step "Empty cookie jar"+      def @=? cookieJar+      checkSchema step value "get--.json"
+ test/Functionality/Util.hs view
@@ -0,0 +1,183 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}+{-# LANGUAGE OverloadedStrings #-}++module Functionality.Util where++import           Control.Monad                    (liftM, return, (>=>), (>>=))+import           Control.Monad.IO.Class           (MonadIO, liftIO)+import           Data.Aeson                       (FromJSON, Value (Object),+                                                   decode)+import           Data.ByteString.Lazy             (readFile)+import           Data.Default                     (def)+import           Data.Either                      (Either (Left, Right))+import           Data.Eq                          ((==))+import           Data.Function                    (const, id, ($), (.))+import           Data.Functor                     (fmap, (<$>))+import           Data.JsonSchema                  (RawSchema (..), compile,+                                                   draft4, validate)+import           Data.Maybe                       (Maybe (Just, Nothing))+import           Data.Monoid                      (mempty, (<>))+import           Data.String                      (IsString, String, fromString,+                                                   unwords)+import           Data.UUID                        (toString)+import qualified Database.Couch.Explicit.Database as Database (create, delete)+import qualified Database.Couch.Response          as Response (asBool)+import           Database.Couch.Types             (Context (Context), Error,+                                                   Port (Port), Result)+import           GHC.Err                          (error)+import           Network.HTTP.Client              (Manager,+                                                   defaultManagerSettings,+                                                   newManager)+import           System.Directory                 (doesFileExist,+                                                   getCurrentDirectory)+import           System.FilePath                  (takeDirectory, (</>))+import           System.IO                        (FilePath, IO)+import           System.Random                    (randomIO)+import           Test.Tasty                       (TestName, TestTree,+                                                   defaultMain, testGroup,+                                                   withResource)+import           Test.Tasty.HUnit                 (assertFailure, testCaseSteps,+                                                   (@=?))+import           Text.Show                        (show)++dbContext :: MonadIO m => IO Manager -> m Context+dbContext getManager = do+  manager <- liftIO getManager+  uuid <- liftM (fromString . ("test-" <>) . toString) (liftIO randomIO)+  return $ Context manager "localhost" (Port 5984) Nothing def (Just uuid)++serverContext :: MonadIO m => IO Manager -> m Context+serverContext getManager = do+  manager <- liftIO getManager+  return $ Context manager "localhost" (Port 5984) Nothing def Nothing++releaseContext :: Context -> IO ()+releaseContext = const $ return ()++runTests :: (IO Manager -> TestTree) -> IO ()+runTests testTree = do+  let manager = newManager defaultManagerSettings+  defaultMain $ testTree manager++testAgainstFailure :: String+                   -> (Context -> IO (Result Value))+                   -> Error+                   -> IO Context+                   -> TestTree+testAgainstFailure desc function exception getContext = testCaseSteps desc $ \step -> do+  step "Make request"+  getContext >>= function >>= checkException step exception++checkException :: (String -> IO ())+               -> Error+               -> Result Value+               -> IO ()+checkException step exception res = do+  step "Got an exception"+  case res of+    -- HttpException isn't Eqable, so we simply coerce with show+    Left err -> show exception @=? show err+    Right val -> assertFailure $ unwords+                                   [ "Didn't get expected exception"+                                   , show exception+                                   , "instead"+                                   , show val+                                   ]++throwOnError :: FromJSON a => Result a -> IO ()+throwOnError res =+  case res of+    Left err -> error $ show err+    Right _  -> return ()++withDb :: (IO Context -> TestTree) -> IO Context -> TestTree+withDb test getContext =+  withResource+    (getContext >>= createTempDb)+    (fmap Response.asBool . Database.delete >=> throwOnError)+    test+  where+    createTempDb ctx = do+      Response.asBool <$> Database.create ctx >>= throwOnError+      return ctx++testAgainstSchema :: String+                  -> (Context -> IO (Result Value))+                  -> FilePath+                  -> IO Context+                  -> TestTree+testAgainstSchema desc function schema =+  testAgainstSchemaAndValue desc function schema id (const . const (return ()))++testAgainstSchemaAndValue :: String+                          -> (Context -> IO (Result Value))+                          -> FilePath+                          -> (Result Value -> Result a)+                          -> ((String -> IO ()) -> a -> IO ())+                          -> IO Context+                          -> TestTree+testAgainstSchemaAndValue desc function schema decoder checker getContext = testCaseSteps desc $ \step -> do+  step "Make request"+  getContext >>= function >>= checkCookiesAndSchema step schema decoder checker++checkCookiesAndSchema :: (String -> IO ())+                      -> FilePath+                      -> (Result Value -> Result a)+                      -> ((String -> IO ()) -> a -> IO ())+                      -> Result Value+                      -> IO ()+checkCookiesAndSchema step schemaFile decoder checker res = do+  step "No exception"+  case res of+    Left err -> assertFailure (show err)+    Right (json, cookieJar) -> do+      step "Empty cookie jar"+      def @=? cookieJar+      checkSchema step json schemaFile+      step $ "Decoding json: " <> show json+      case decoder res of+        Left err -> assertFailure (show err)+        Right (val, _) -> do+          step "Checking value"+          checker step val++checkSchema :: IsString s => (s -> IO ()) -> Value -> FilePath -> IO ()+checkSchema step value schemaName = do+  step "Checking result against schema"+  schema <- loadSchema ("test/schema/schema" </> schemaName)+  case validate (compile draft4 mempty schema) value of+    Left err -> assertFailure $ unwords ["Failed to validate", show value, ":", show err]+    Right _  -> return ()++loadSchema :: FilePath -> IO RawSchema+loadSchema file = do+  (_, content) <- findRequestedFile+  case decode content of+    Just (Object o) -> return RawSchema { _rsURI = "", _rsObject = o }+    _               -> error "Couldn't extract object from file"++  where+    findRequestedFile = do+      start <- getCurrentDirectory+      checkDir start+    checkDir dir =+      let path = dir </> file+      in doesFileExist path >>= \exists -> if exists+                                             then readFile path >>= \c -> return (path, c)+                                             else let upOne = takeDirectory dir+                                                  in if upOne == dir+                                                       then error "Cannot find file to embed as resource"+                                                       else checkDir upOne++class TestInput a where+  makeTests :: TestInput a => TestName -> [IO Context -> TestTree] -> a -> TestTree+  makeTests desc tests input = testGroup desc $ fmap (applyInput input) tests++  applyInput :: a -> (IO Context -> TestTree) -> TestTree++instance TestInput (IO Manager) where+  applyInput input = ($ dbContext input)++instance TestInput (IO Context) where+  applyInput input = ($ input)
+ test/Main.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE NoImplicitPrelude   #-}+{-# LANGUAGE ScopedTypeVariables #-}++module Main where++import           Control.Monad             (liftM, return, (=<<))+import           Control.Monad.Catch       (SomeException, handle)+import           Data.Bool                 (Bool (False))+import           Data.Function             (($), (.))+import           Data.Monoid               ((<>))+import qualified Functionality             (tests)+import           Network.HTTP.Client       (defaultManagerSettings, httpNoBody,+                                            newManager, parseUrl,+                                            responseStatus)+import           Network.HTTP.Types.Status (statusIsSuccessful)+import qualified Quality                   (tests)+import           System.IO                 (IO)+import           Test.Tasty                (TestTree, defaultMain, testGroup)++-- Run all teests by default+main :: IO ()+main = defaultMain . tests =<< do+  manager <- newManager defaultManagerSettings+  request <- parseUrl "http://localhost:5984/"+  handle (\(_ :: SomeException) -> return False) $ liftM (statusIsSuccessful . responseStatus) (httpNoBody request manager)++-- Everything we can throw at it+tests :: Bool -> TestTree+tests haveCouch = testGroup "All tests" $+  [Quality.tests] <> [Functionality.tests | haveCouch]
+ test/Quality.hs view
@@ -0,0 +1,17 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Quality where++import qualified Quality.HLint as HLint (tests)+import           System.IO     (IO)+import           Test.Tasty    (TestTree, defaultMain, testGroup)++-- For interactive testing+_main :: IO ()+_main = defaultMain tests++-- Tests for code quality rather than functionality+tests :: TestTree+tests = testGroup "Code Quality Tests" [+  HLint.tests+  ]
+ test/Quality/HLint.hs view
@@ -0,0 +1,19 @@+{-# LANGUAGE NoImplicitPrelude #-}++module Quality.HLint where++import           Data.Function          (($))+import           Language.Haskell.HLint (hlint)+import           System.IO              (IO)+import           Test.Tasty             (TestTree, defaultMain)+import           Test.Tasty.HUnit       (testCase, (@=?))++-- For interactive testing+_main :: IO ()+_main = defaultMain tests++-- Run hlint over source and tests alike+tests :: TestTree+tests = testCase "HLint" $ do+  hints <- hlint ["--quiet", "src", "test"]+  [] @=? hints
+ test/schema/schema/copy--db-_design-ddoc.json view
@@ -0,0 +1,18 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by COPY /{db}/_design/{ddoc}",+    "properties": {+        "id": {+            "type": "string"+        },+        "ok": {+            "type": "boolean"+        },+        "rev": {+            "type": "string"+        }+    },+    "required": ["id", "ok"],+    "title": "CouchDB copy design doc",+    "type": "object"+}
+ test/schema/schema/copy--db-docid.json view
@@ -0,0 +1,18 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by COPY /{db}/{docid}",+    "properties": {+        "id": {+            "type": "string"+        },+        "ok": {+            "type": "boolean"+        },+        "rev": {+            "type": "string"+        }+    },+    "required": ["id", "ok"],+    "title": "CouchDB copy doc",+    "type": "object"+}
+ test/schema/schema/delete--_config-section-key.json view
@@ -0,0 +1,19 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by DELETE /{db}/{section}/{key}",+    "oneOf": [+        {+            "type": "array"+        },+        {+            "type": "number"+        },+        {+            "type": "object"+        },+        {+            "type": "string"+        }+    ],+    "title": "CouchDB configuration value"+}
+ test/schema/schema/delete--db-_design-ddoc.json view
@@ -0,0 +1,18 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by DELETE /{db}/_design/{ddoc}",+    "properties": {+        "id": {+            "type": "string"+        },+        "ok": {+            "type": "boolean"+        },+        "rev": {+            "type": "string"+        }+    },+    "required": ["id", "ok"],+    "title": "CouchDB delete design doc",+    "type": "object"+}
+ test/schema/schema/delete--db-docid.json view
@@ -0,0 +1,18 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by DELETE /{db}/{docid}",+    "properties": {+        "id": {+            "type": "string"+        },+        "ok": {+            "type": "boolean"+        },+        "rev": {+            "type": "string"+        }+    },+    "required": ["id", "ok"],+    "title": "CouchDB delete doc",+    "type": "object"+}
+ test/schema/schema/delete--db.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by DELETE /{db}",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "Delete database",+    "type": "object"+}
+ test/schema/schema/get--.json view
@@ -0,0 +1,31 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /",+    "properties": {+        "couchdb": {+            "pattern": "^Welcome$",+            "type": "string"+        },+        "uuid": {+            "type": "string"+        },+        "vendor": {+            "type": "object",+            "properties": {+                "name": {+                    "type": "string"+                },+                "version": {+                    "type": "string"+                }+            },+            "required": ["name", "version"]+        },+        "version": {+            "type": "string"+        }+    },+    "required": ["couchdb", "uuid", "vendor", "version"],+    "title": "CouchDB root",+    "type": "object"+}
+ test/schema/schema/get--_active_tasks.json view
@@ -0,0 +1,42 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /_active_tasks",+    "items": {+        "properties": {+            "changes_done": {+                "type": "number"+            },+            "database": {+                "type": "string"+            },+            "pid": {+                "type": "string"+            },+            "progress": {+                "type": "number"+            },+            "started_on": {+                "type": "number"+            },+            "status": {+                "type": "string"+            },+            "task": {+                "type": "string"+            },+            "total_changes": {+                "type": "number"+            },+            "type": {+                "type": "string"+            },+            "updated_on": {+                "type": "number"+            }+        },+        "required": ["changes_done", "database", "pid", "progress", "started_on", "status", "task", "total_changes", "type", "updated_on"],+        "type": "object"+    },+    "title": "CouchDB _active_tasks",+    "type": "array"+}
+ test/schema/schema/get--_all_dbs.json view
@@ -0,0 +1,9 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /_all_dbs",+    "items": {+        "type": "string"+    },+    "title": "CouchDB _all_dbs",+    "type": "array"+}
+ test/schema/schema/get--_config-section-key.json view
@@ -0,0 +1,19 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}/{section}/{key}",+    "oneOf": [+        {+            "type": "array"+        },+        {+            "type": "number"+        },+        {+            "type": "object"+        },+        {+            "type": "string"+        }+    ],+    "title": "CouchDB configuration value"+}
+ test/schema/schema/get--_config-section.json view
@@ -0,0 +1,6 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /_config/{section}",+    "title": "CouchDB server _config/{section}",+    "type": "object"+}
+ test/schema/schema/get--_config.json view
@@ -0,0 +1,6 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /_config",+    "title": "CouchDB server _config",+    "type": "object"+}
+ test/schema/schema/get--_db_updates.json view
@@ -0,0 +1,19 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /_db_updates",+    "properties": {+        "db_name": {+            "type": "string"+        },+        "ok": {+            "type": "bool"+        },+        "type": {+            "enum": ["created", "updated", "deleted"],+            "type": "string"+        }+    },+    "required": ["db_name", "ok", "type"],+    "title": "CouchDB _db_updates",+    "type": "object"+}
+ test/schema/schema/get--_stats.json view
@@ -0,0 +1,24 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /_stats",+    "items": {+        "properties": {+            "couchdb": {+                "type": "object"+            },+            "httpd": {+                "type": "object"+            },+            "httpd_request_methods": {+                "type": "object"+            },+            "httpd_status_codes": {+                "type": "object"+            }+        },+        "required": ["couchdb", "httpd", "httpd_request_methods", "httpd_status_codes"],+        "type": "object"+    },+    "title": "CouchDB _stats",+    "type": "object"+}
+ test/schema/schema/get--_uuids.json view
@@ -0,0 +1,13 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /_uuids",+    "items": {+        "properties": {+            "uuids": {+                "type": "array"+            }+        }+    },+    "title": "CouchDB _uuids",+    "type": "object"+}
+ test/schema/schema/get--db-_all_docs.json view
@@ -0,0 +1,40 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}/_all_docs",+    "properties": {+        "offset": {+            "type": "number"+        },+        "rows": {+            "items": {+                "properties": {+                    "id": {+                        "type": "string"+                    },+                    "key": {+                        "type": "string"+                    },+                    "value": {+                        "properties": {+                            "rev": {+                                "type": "string"+                            }+                        },+                        "type": "object"+                    }+                },+                "type": "object"+            },+            "type": "array"+        },+        "total_rows": {+            "type": "number"+        },+        "update_seq": {+            "type": "number"+        }+    },+    "required": ["offset", "rows", "total_rows"],+    "title": "CouchDB get all docs from database",+    "type": "object"+}
+ test/schema/schema/get--db-_changes.json view
@@ -0,0 +1,37 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}/_changes",+    "properties": {+        "last_seq": {+            "type": "number"+        },+        "results": {+            "items": {+                "properties": {+                    "changes": {+                        "items": {+                            "rev": {+                                "type": "string"+                            },+                            "required": ["rev"],+                            "type": "object"+                        },+                        "type": "array"+                    },+                    "id": {+                        "type": "string"+                    },+                    "seq": {+                        "type": "string"+                    }+                },+                "required": ["changes", "id", "seq"],+                "type": "object"+            },+            "type": "array"+        }+    },+    "required": ["last_seq", "results"],+    "title": "CouchDB _changes",+    "type": "object"+}
+ test/schema/schema/get--db-_design-ddoc-_info.json view
@@ -0,0 +1,48 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}/_design/{ddoc}/_info",+    "properties": {+        "name": {+            "type": "string"+        },+        "view_index": {+            "properties": {+                "compact_running": {+                    "type": "boolean"+                },+                "data_size": {+                    "type": "number"+                },+                "disk_size": {+                    "type": "number"+                },+                "language": {+                    "type": "string"+                },+                "purge_seq": {+                    "type": "number"+                },+                "signature": {+                    "type": "string"+                },+                "update_seq": {+                    "type": "number"+                },+                "updater_running": {+                    "type": "boolean"+                },+                "waiting_clients": {+                    "type": "number"+                },+                "waiting_commit": {+                    "type": "boolean"+                }+            },+            "required": ["compact_running", "data_size", "disk_size", "language", "purge_seq", "signature", "update_seq", "updater_running", "waiting_clients", "waiting_commit"],+            "type": "object"+        }+    },+    "required": ["name", "view_index"],+    "title": "CouchDB /{db}/_design/{ddoc}/_info",+    "type": "object"+}
+ test/schema/schema/get--db-_design-ddoc-_view-view.json view
@@ -0,0 +1,32 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}/_design/{ddoc}/_view/{view}",+    "properties": {+        "offset": {+            "type": "number"+        },+        "rows": {+            "items": {+                "properties": {+                    "id": {+                        "type": "string"+                    },+                    "key": {+                        "type": "string"+                    }+                },+                "type": "object"+            },+            "type": "array"+        },+        "total_rows": {+            "type": "number"+        },+        "update_seq": {+            "type": "number"+        }+    },+    "required": ["offset", "rows", "total_rows"],+    "title": "CouchDB get all docs from database",+    "type": "object"+}
+ test/schema/schema/get--db-_design-ddoc.json view
@@ -0,0 +1,45 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "A document returned by GET /{db}/_design/{ddoc}",+    "properties": {+        "_id": {+            "type": "string"+        },+        "_rev": {+            "type": "string"+        },+        "language": {+            "type": "string"+        },+        "options": {+            "type": "object"+        },+        "filters": {+            "type": "object"+        },+        "lists": {+            "type": "object"+        },+        "rewrites": {+            "items": {+                "type": "object"+            },+            "type": "array"+        },+        "shows": {+            "type": "object"+        },+        "updates": {+            "type": "object"+        },+        "validate_doc_update": {+            "type": "string"+        },+        "views": {+            "type": "object"+        }+    },+    "required": ["_id", "_rev"],+    "title": "CouchDB GET of design document",+    "type": "object"+}
+ test/schema/schema/get--db-_revs_limit.json view
@@ -0,0 +1,6 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by PUT /{db}/_revs_limit",+    "title": "CouchDB database revision limit",+    "type": "number"+}
+ test/schema/schema/get--db-_security.json view
@@ -0,0 +1,44 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}/_security",+    "properties": {+        "admins": {+            "properties": {+                "names": {+                    "items": {+                        "type": "string"+                    },+                    "type": "array"+                },+                "roles": {+                    "items": {+                        "type": "string"+                    },+                    "type": "array"+                }+            },+            "required": ["names", "roles"],+            "type": "object"+        },+        "members": {+            "properties": {+                "names": {+                    "items": {+                        "type": "string"+                    },+                    "type": "array"+                },+                "roles": {+                    "items": {+                        "type": "string"+                    },+                    "type": "array"+                }+            },+            "required": ["names", "roles"],+            "type": "object"+        }+    },+    "title": "CouchDB get _security",+    "type": "object"+}
+ test/schema/schema/get--db-docid.json view
@@ -0,0 +1,36 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}/{docid}",+    "properties": {+        "_id": {+            "type": "string"+        },+        "_rev": {+            "type": "string"+        },+        "_deleted": {+            "type": "boolean"+        },+        "_attachments": {+            "type": "object"+        },+        "_conflicts": {+            "type": "array"+        },+        "_deleted_conflicts": {+            "type": "array"+        },+        "_local_seq": {+            "type": "number"+        },+        "_revs_info": {+            "type": "array"+        },+        "_revisions": {+            "type": "object"+        }+    },+    "required": ["_id", "_rev"],+    "title": "CouchDB document",+    "type": "object"+}
+ test/schema/schema/get--db.json view
@@ -0,0 +1,42 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by GET /{db}",+    "properties": {+        "committed_update_seq": {+            "type": "number"+        },+        "compact_running": {+            "type": "boolean"+        },+        "db_name": {+            "type": "string"+        },+        "disk_format_version": {+            "type": "number"+        },+        "data_size": {+            "type": "number"+        },+        "disk_size": {+            "type": "number"+        },+        "doc_count": {+            "type": "number"+        },+        "doc_del_count": {+            "type": "number"+        },+        "instance_start_time": {+            "type": "string"+        },+        "purge_seq": {+            "type": "number"+        },+        "update_seq": {+            "type": "number"+        }+    },+    "required": ["committed_update_seq", "compact_running", "db_name", "disk_format_version", "data_size", "disk_size", "doc_count", "doc_del_count", "instance_start_time", "purge_seq", "update_seq"],+    "title": "CouchDB database root",+    "type": "object"+}
+ test/schema/schema/head--db-_design-ddoc.json view
@@ -0,0 +1,6 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "A fake schema returned by HEAD /{db}/_design/{ddoc}",+    "title": "CouchDB HEAD of design document",+    "type": "object"+}
+ test/schema/schema/head--db-docid.json view
@@ -0,0 +1,7 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "A fake schema returned by HEAD /{db}/{docid}",+    "title": "CouchDB HEAD of document",+    "type": "object"+}+
+ test/schema/schema/head--db.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by HEAD /{db}",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "Check whether database exists",+    "type": "object"+}
+ test/schema/schema/post--_restart.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /_restart",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "CouchDB _restart",+    "type": "object"+}
+ test/schema/schema/post--db-_bulk_docs.json view
@@ -0,0 +1,33 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_bulk_docs",+    "items": {+        "oneOf": [+            {+                "properties": {+                    "error": {+                        "type": "string"+                    },+                    "reason": {+                        "type": "string"+                    }+                },+                "required": ["error", "reason"]+            },+            {+                "properties": {+                    "ok": {+                        "type": "boolean"+                    },+                    "rev": {+                        "type": "string"+                    }+                },+                "required": ["ok"]+            }+        ],+        "type": "object"+    },+    "title": "CouchDB _bulk_docs",+    "type": "array"+}
+ test/schema/schema/post--db-_compact-ddoc.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_compact/{ddoc}",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "CouchDB db _compact design document",+    "type": "object"+}
+ test/schema/schema/post--db-_compact.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_compact",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "CouchDB db _compact",+    "type": "object"+}
+ test/schema/schema/post--db-_design-ddoc-_view-view.json view
@@ -0,0 +1,32 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_design/{ddoc}/_view/{view}",+    "properties": {+        "offset": {+            "type": "number"+        },+        "rows": {+            "items": {+                "properties": {+                    "id": {+                        "type": "string"+                    },+                    "key": {+                        "type": "string"+                    }+                },+                "type": "object"+            },+            "type": "array"+        },+        "total_rows": {+            "type": "number"+        },+        "update_seq": {+            "type": "number"+        }+    },+    "required": ["offset", "rows", "total_rows"],+    "title": "CouchDB get all docs from database",+    "type": "object"+}
+ test/schema/schema/post--db-_ensure_full_commit.json view
@@ -0,0 +1,15 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_ensure_full_commit",+    "properties": {+        "instance_start_time": {+            "type": "string"+        },+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["instance_start_time", "ok"],+    "title": "CouchDB db/_ensure_full_commit",+    "type": "object"+}
+ test/schema/schema/post--db-_missing_revs.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_missing_revs",+    "properties": {+        "missing_revs": {+            "type": "object"+        }+    },+    "required": ["missing_revs"],+    "title": "CouchDB db _missing_revs",+    "type": "object"+}
+ test/schema/schema/post--db-_purge.json view
@@ -0,0 +1,15 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_purge",+    "properties": {+        "purge_seq": {+            "type": "number"+        },+        "purged": {+            "type": "object"+        }+    },+    "required": ["purge_seq", "purged"],+    "title": "CouchDB db _purge",+    "type": "object"+}
+ test/schema/schema/post--db-_revs_diff.json view
@@ -0,0 +1,6 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_revs_diff.  Nothing much we can validate.",+    "title": "CouchDB db _revs_diff",+    "type": "object"+}
+ test/schema/schema/post--db-_temp_view.json view
@@ -0,0 +1,14 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_temp_view",+    "properties": {+        "rows": {+            "items": {+                "type": "object"+            },+            "type": "array"+        }+    },+    "title": "CouchDB database _temp_view",+    "type": "object"+}
+ test/schema/schema/post--db-_view_cleanup.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}/_view_cleanup",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "CouchDB db _compact",+    "type": "object"+}
+ test/schema/schema/post--db.json view
@@ -0,0 +1,33 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by POST /{db}",+    "oneOf": [+        {+            "properties": {+                "error": {+                    "type": "string"+                },+                "reason": {+                    "type": "string"+                }+            },+            "required": ["error", "reason"]+        },+        {+            "properties": {+                "id": {+                    "type": "string"+                },+                "ok": {+                    "type": "boolean"+                },+                "rev": {+                    "type": "string"+                }+            },+            "required": ["id", "ok"]+        }+    ],+    "title": "CouchDB create doc",+    "type": "object"+}
+ test/schema/schema/put--_config-section-key.json view
@@ -0,0 +1,19 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by PUT /{db}/{section}/{key}",+    "oneOf": [+        {+            "type": "array"+        },+        {+            "type": "number"+        },+        {+            "type": "object"+        },+        {+            "type": "string"+        }+    ],+    "title": "CouchDB configuration value"+}
+ test/schema/schema/put--db-_design-ddoc.json view
@@ -0,0 +1,33 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by PUT /{db}/{docid}",+    "oneOf": [+        {+            "properties": {+                "error": {+                    "type": "string"+                },+                "reason": {+                    "type": "string"+                }+            },+            "required": ["error", "reason"]+        },+        {+            "properties": {+                "id": {+                    "type": "string"+                },+                "ok": {+                    "type": "boolean"+                },+                "rev": {+                    "type": "string"+                }+            },+            "required": ["id", "ok"]+        }+    ],+    "title": "CouchDB create doc",+    "type": "object"+}
+ test/schema/schema/put--db-_revs_limit.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by PUT /{db}/_revs_limit",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "CouchDB /{db}/_revs_limit",+    "type": "object"+}
+ test/schema/schema/put--db-_security.json view
@@ -0,0 +1,12 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by PUT /{db}/_security",+    "properties": {+        "ok": {+            "type": "boolean"+        }+    },+    "required": ["ok"],+    "title": "CouchDB database security",+    "type": "object"+}
+ test/schema/schema/put--db-docid.json view
@@ -0,0 +1,33 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by PUT /{db}/{docid}",+    "oneOf": [+        {+            "properties": {+                "error": {+                    "type": "string"+                },+                "reason": {+                    "type": "string"+                }+            },+            "required": ["error", "reason"]+        },+        {+            "properties": {+                "id": {+                    "type": "string"+                },+                "ok": {+                    "type": "boolean"+                },+                "rev": {+                    "type": "string"+                }+            },+            "required": ["id", "ok"]+        }+    ],+    "title": "CouchDB create doc",+    "type": "object"+}
+ test/schema/schema/put--db.json view
@@ -0,0 +1,27 @@+{+    "$schema": "http://json-schema.org/draft-04/schema#",+    "description": "The value returned by PUT /{db}",+    "oneOf": [+        {+            "properties": {+                "error": {+                    "type": "string"+                },+                "reason": {+                    "type": "string"+                }+            },+            "required": ["error", "reason"]+        },+        {+            "properties": {+                "ok": {+                    "type": "boolean"+                }+            },+            "required": ["ok"]+        }+    ],+    "title": "CouchDB database creation",+    "type": "object"+}