DB.hs

{-# LANGUAGE DeriveDataTypeable #-} 
{-# LANGUAGE OverloadedStrings #-} 

{- | CouchDB database methods.

> runCouch def $ couchPutDb "my_new_db"
> runCouch def {couchDB="my_new_db"} $ couchPutDb "another_new_db"

/Note./ All database methods ignores database settings in connection.
-}

module Database.CouchDB.Conduit.DB (
    -- * Methods
    couchPutDB,
    couchPutDB_,
    couchDeleteDB,
    -- * Replication
    couchReplicateDB,
    -- * Security
    couchSecureDB
) where

--import Control.Applicative ((<$>), (<*>), empty)

import qualified Data.ByteString as B
import qualified Data.Aeson as A
--import Data.Generics (Data, Typeable)
--import Data.Default (Default (def))

import Data.Conduit (ResourceT)

import qualified Network.HTTP.Conduit as H
import qualified Network.HTTP.Types as HT

import Database.CouchDB.Conduit (MonadCouch(..), Path)
import Database.CouchDB.Conduit.LowLevel (couch, protect, protect')


-- | Create CouchDB database. 
couchPutDB :: MonadCouch m =>
       Path     -- ^ CouchDB Database name.
    -> ResourceT m ()
couchPutDB p = couch HT.methodPut (const p) [] []
                    (H.RequestBodyBS B.empty) protect' 
                    >> return ()

-- | \"Don't care\" version of couchPutDb. Create CouchDB database only in its 
--   absence. For this it handles @412@ responses.
couchPutDB_ :: MonadCouch m =>
       Path     -- ^ CouchDB Database name.
    -> ResourceT m ()
couchPutDB_ p = 
    couch HT.methodPut (const p) [] []
                    (H.RequestBodyBS B.empty) 
                    (protect [200, 201, 202, 304, 412] return) 
                    >> return ()

-- | Delete a database.
couchDeleteDB :: MonadCouch m => 
       Path     -- ^ CouchDB Database name.
    -> ResourceT m ()
couchDeleteDB p = couch HT.methodDelete (const p) [] []
                    (H.RequestBodyBS B.empty) protect' 
                    >> return ()

-- | Database replication. 
--
--   See <http://guide.couchdb.org/editions/1/en/api.html#replication> for 
--   details.
couchReplicateDB :: MonadCouch m => 
       B.ByteString     -- ^ Source database. Path or URL 
    -> B.ByteString     -- ^ Target database. Path or URL 
    -> Bool             -- ^ Target creation flag
    -> Bool             -- ^ Continuous flag
    -> Bool             -- ^ Cancel flag
    -> ResourceT m ()
couchReplicateDB source target createTarget continuous cancel = 
    couch HT.methodPost (const "_replicate") [] []
            reqBody protect' 
            >> return ()
  where
    reqBody = H.RequestBodyLBS $ A.encode $ A.object [
            "source" A..= source,
            "target" A..= target,
            "create_target" A..= createTarget,
            "continuous" A..= continuous,
            "cancel" A..= cancel ]

couchSecureDB :: MonadCouch m => 
       Path             -- ^ Database
    -> [B.ByteString]   -- ^ Admin roles 
    -> [B.ByteString]   -- ^ Admin names
    -> [B.ByteString]   -- ^ Readers roles 
    -> [B.ByteString]   -- ^ Readers names
    -> ResourceT m ()       
couchSecureDB p adminRoles adminNames readersRoles readersNames = 
    couch HT.methodPut (`B.append` B.append "/" p) [] []
            reqBody protect' 
            >> return ()
  where
    reqBody = H.RequestBodyLBS $ A.encode $ A.object [
            "admins" A..= A.object [ "roles" A..= adminRoles,
                                     "names" A..= adminNames ],
            "readers" A..= A.object [ "roles" A..= readersRoles,
                                     "names" A..= readersNames ] ]