{-# LANGUAGE OverloadedStrings #-} 
{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-} 

-- | Higher-level functions to interact with CouchDB views.
--   To manipulate views in design documents see 
--   "Database.CouchDB.Conduit.Design"

module Database.CouchDB.Conduit.View 
(   
    -- * Acccessing views #run#
    -- $run
    couchView,
    couchView',
    couchViewPost,
    couchViewPost',
    rowValue,

    -- * View query parameters
    -- $view_query #view_query#
    mkParam 
)
 where

import Control.Monad.Trans.Class (lift)
import Control.Applicative ((<|>))

import Data.Monoid (mconcat)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Char8 as BC8
import qualified Data.HashMap.Lazy as M
import qualified Data.Aeson as A
import Data.Attoparsec

import Data.Conduit (ResourceIO, ResourceT, 
                        Source, Conduit, Sink, ($$), ($=), 
                        sequenceSink, SequencedSinkResponse(..),
                        resourceThrow )
import qualified Data.Conduit.List as CL
import qualified Data.Conduit.Attoparsec as CA

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

import Database.CouchDB.Conduit.Internal.Connection
import Database.CouchDB.Conduit.LowLevel (couch, protect')

-----------------------------------------------------------------------------
-- View query parameters
-----------------------------------------------------------------------------

-- $view_query
-- For details see 
-- <http://wiki.apache.org/couchdb/HTTP_view_API#Querying_Options>. Note, 
-- because all options must be a proper URL encoded JSON, construction of 
-- complex parameters can be very tedious. To simplify this, use 'mkParam'. 

-- | Encode query parameter to 'B.ByteString'.  
--
-- > mkParam (["a", "b"] :: [String])
-- > "[\"a\",\"b\"]"
--
-- It't just convert lazy 'BL.ByteString' from 'A.encode' to strict 
-- 'B.ByteString'
mkParam :: A.ToJSON a =>
       a                -- ^ Parameter
    -> B.ByteString
mkParam = mconcat . BL.toChunks . A.encode

-----------------------------------------------------------------------------
-- Running
-----------------------------------------------------------------------------

-- $run
-- In contrast to the functions of access to documents that are loaded into 
-- memory entirely. 'couchView' and 'couchView'' combines the incredible power 
-- of /http-conduit/ and /attoparsec/ to allow you to process objects in 
-- constant space.  
--
-- As data is read from the network, it is fed into attoparsec. When 
-- attoparsec completes parsing row, it sent to 'Sink'. 'Sink' can be composed 
-- from many conduits with sink at the end, such as 'rowValue', view conduits 
-- from "Database.CouchDB.Conduit.Explicit#view" and 
-- "Database.CouchDB.Conduit.Generic#view", and many others. See 
-- "Data.Conduit" for details and documentation.

-- | Run CouchDB view in manner like 'H.http'.
--
-- > runCouch def $ do
-- >
-- >     -- Print all upon receipt.
-- >     src <- couchView "mydb" "mydesign" "myview" [] 
-- >     src $$ CL.mapM_ (liftIO . print)
-- >
-- >     -- ... Or extract row value and consume
-- >     src' <- couchView "mydb" "mydesign" "myview" [] 
-- >     res <- src' $= rowValue $$ CL.consume
couchView :: MonadCouch m =>
       Path                 -- ^ Database
    -> Path                 -- ^ Design document
    -> Path                 -- ^ View name
    -> HT.Query             -- ^ Query parameters
    -> ResourceT m (Source m A.Object)
couchView db design view q = do
    H.Response _ _ bsrc <- couch HT.methodGet 
            (viewPath db design view)
            [] q 
            (H.RequestBodyBS B.empty) protect'
    return $ bsrc $= conduitCouchView

-- | Brain-free version of 'couchView'. Takes 'Sink' to consume response.
--
-- > runCouch def $ do
-- >
-- >     -- Print all upon receipt.
-- >     couchView' "mydb" "mydesign" "myview" [] $ CL.mapM_ (liftIO . print)
-- >
-- >     -- ... Or extract row value and consume
-- >     res <- couchView' "mydb" "mydesign" "myview" [] $ 
-- >                        rowValue =$ CL.consume
couchView' :: MonadCouch m =>
       Path                 -- ^ Database
    -> Path                 -- ^ Design document
    -> Path                 -- ^ View name
    -> HT.Query             -- ^ Query parameters
    -> Sink A.Object m a    -- ^ Sink for handle view rows.
    -> ResourceT m a
couchView' db design view q sink = do
    raw <- couchView db design view q
    raw $$ sink

-- | Run CouchDB view in manner like 'H.http' using @POST@ (since CouchDB 0.9).
--   It's convenient in case that @keys@ paremeter too big for @GET@ query 
--   string. Other query parameters used as usual.
-- 
-- > runCouch def $ do
-- >     src <- couchViewPost "mydb" "mydesign" "myview" 
-- >             [("group", Just "true")]
-- >             ["key1", "key2", "key3"] 
-- >     src $$ CL.mapM_ (liftIO . print)
couchViewPost :: (MonadCouch m, A.ToJSON a) =>
       Path                 -- ^ Database
    -> Path                 -- ^ Design document
    -> Path                 -- ^ View name
    -> HT.Query             -- ^ Query parameters
    -> a                    -- ^ View @keys@. Must be list or cortege.
    -> ResourceT m (Source m A.Object)    
couchViewPost db design view q ks = do
    H.Response _ _ bsrc <- couch HT.methodPost 
            (viewPath db design view)  
            [] 
            q 
            (H.RequestBodyLBS mkPost) protect'
    return $ bsrc $= conduitCouchView
  where
    mkPost = A.encode $ A.object ["keys" A..= ks]

-- | Brain-free version of 'couchViewPost'. Takes 'Sink' to consume response.
couchViewPost' :: (MonadCouch m, A.ToJSON a) =>
       Path                 -- ^ Database
    -> Path                 -- ^ Design document
    -> Path                 -- ^ View name
    -> HT.Query             -- ^ Query parameters
    -> a                    -- ^ View @keys@. Must be list or cortege.
    -> Sink A.Object m a    -- ^ Sink for handle view rows.
    -> ResourceT m a
couchViewPost' db design view q ks sink = do
    raw <- couchViewPost db design view q ks
    raw $$ sink

-- | Conduit for extract \"value\" field from CouchDB view row.
rowValue :: ResourceIO m => Conduit A.Object m A.Value
rowValue = CL.mapM (\v -> case M.lookup "value" v of
            (Just o) -> return o
            _ -> resourceThrow $ CouchInternalError $ BC8.pack
                    ("View row does not contain value: " ++ show v))

-----------------------------------------------------------------------------
-- Internal
-----------------------------------------------------------------------------

-- | Make full view path
viewPath :: Path -> Path -> Path -> Path
viewPath db design view = mkPath [db, "_design", design, "_view", view]

-----------------------------------------------------------------------------
-- Internal view parser
-----------------------------------------------------------------------------

conduitCouchView :: ResourceIO m => Conduit B.ByteString m A.Object
conduitCouchView = sequenceSink () $ \() -> do
    b <- CA.sinkParser viewStart
    if b then return $ StartConduit viewLoop
         else return Stop

viewLoop :: ResourceIO m => Conduit B.ByteString m A.Object   
viewLoop = sequenceSink False $ \isLast -> 
    if isLast then return Stop
    else do 
        v <- CA.sinkParser (A.json <?> "json object")
        vobj <- case v of
            (A.Object o) -> return o
            _ -> lift $ resourceThrow $ 
                 CouchInternalError "view entry is not an object"
        res <- CA.sinkParser (commaOrClose <?> "comma or close")
        case res of
            Comma -> return $ Emit False [vobj]
            CloseBracket -> return $ Emit True [vobj]

data CommaOrCloseBracket = Comma | CloseBracket

commaOrClose :: Parser CommaOrCloseBracket
commaOrClose = do
    skipWhile (\c -> c /= 44 && c /= 93) <?> 
            "Checking for next comma"
    w <- anyWord8
    if w == 44 then return Comma else return CloseBracket

-- determine view
viewStart :: Parser Bool
viewStart = do
    _ <- string "{" 
    _ <- option "" $ string "\"total_rows\":" 
    option () $ skipWhile (\x -> x >= 48 && x <= 57)
    _ <- option "" $ string ",\"update_seq\":" 
    option () $ skipWhile (\x -> x >= 48 && x <= 57)
    _ <- option "" $ string ",\"offset\":"
    option () $ skipWhile (\x -> x >= 48 && x <= 57)
    _ <- option "" $ string ","
    _ <- string "\"rows\":["
    (string "]}" <|> (do
        r <- string "]"
        _ <- option "" $ string ",\"update_seq\":"
        option () $ skipWhile (\x -> x >= 48 && x <= 57)
        _ <- option "" $ string "}"
        return r) 
        >> return False) <|> return True