Database.hs

{-# 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"