module Database.CouchDB.Enumerator(
CouchConnection(..)
, withCouchConnection
, CouchError(..)
, CouchMonad(..)
, Path
, Revision
, couchGet
, couchPut
, couchPut_
, couchDelete
, couchView
, extractViewValue
, couch
, CouchT(..)
, runCouchT
) where
import Control.Applicative
import Control.Exception (Exception, throw, bracket)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.IO.Control (MonadControlIO, liftIOOp)
import Control.Monad.Trans.Class (MonadTrans, lift)
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
import qualified Data.Aeson as A
import Data.Attoparsec
import Data.Attoparsec.Enumerator (iterParser)
import qualified Data.ByteString as B
import qualified Data.ByteString.UTF8 as BU8
import Data.Enumerator hiding (map)
import qualified Data.Map as M
import qualified Data.Text as T
import qualified Data.Text.Encoding as TE
import Data.Typeable (Typeable)
import qualified Network.HTTP.Enumerator as H
import qualified Network.HTTP.Types as HT
data CouchConnection = CouchConnection {
host :: B.ByteString
, port :: Int
, manager :: H.Manager
, dbname :: String
}
withCouchConnection :: (MonadControlIO m) => String
-> Int
-> String
-> (CouchConnection -> m a)
-> m a
withCouchConnection h p db f = liftIOOp (bracket H.newManager H.closeManager) go
where go m = f $ CouchConnection (BU8.fromString h) p m db
data CouchError = CouchError (Maybe Int) String
deriving (Show,Typeable)
instance Exception CouchError
class (MonadIO m) => CouchMonad m where
couchConnection :: m CouchConnection
type Path = String
type Revision = T.Text
couch :: (CouchMonad m) => HT.Method
-> Path
-> HT.Query
-> Iteratee B.ByteString m a
-> H.RequestBody m
-> Iteratee B.ByteString m a
couch m p q i b = Iteratee $ do
conn <- couchConnection
let req = H.Request { H.method = m
, H.secure = False
, H.checkCerts = const $ return False
, H.host = host conn
, H.port = port conn
, H.path = BU8.fromString ("/" ++ dbname conn ++ "/" ++ p)
, H.queryString = q
, H.requestHeaders = []
, H.requestBody = b
, H.proxy = Nothing
, H.rawBody = False
}
runIteratee $ H.http req (\s _ -> checkStatus s i) (manager conn)
couchGet :: (CouchMonad m) => Path
-> HT.Query
-> m A.Object
couchGet p q = do v <- run_ $ couch HT.methodGet p q (iterParser A.json) (H.RequestBodyBS B.empty)
either throw return $ valToObj v
couchPut :: (CouchMonad m, A.ToJSON a)
=> Path
-> HT.Query
-> a
-> m Revision
couchPut p q val = do v <- run_ $ couch HT.methodPut p q (iterParser A.json) body
either (liftIO . throw) return (valToObj v >>= objToRev)
where body = H.RequestBodyLBS $ A.encode $ A.toJSON val
couchPut_ :: (CouchMonad m, A.ToJSON a)
=> Path
-> HT.Query
-> a
-> m ()
couchPut_ p q val = run_ $ couch HT.methodPut p q (yield () EOF) body
where body = H.RequestBodyLBS $ A.encode $ A.toJSON val
couchDelete :: (CouchMonad m) => Path
-> Revision
-> m ()
couchDelete p r = run_ $ couch HT.methodDelete p [("rev", Just $ TE.encodeUtf8 r)]
(yield () EOF) (H.RequestBodyBS B.empty)
couchView :: (CouchMonad m) => Path
-> HT.Query
-> Enumerator A.Object m a
couchView p q step = do s <- lift $ run $ couch HT.methodGet ("_design/" ++ p) q (parseView step) (H.RequestBodyBS B.empty)
either throwError returnI s
extractViewValue :: (Monad m) => Enumeratee A.Object A.Object m a
extractViewValue = mapEither f
where f v = case M.lookup "value" v of
(Just (A.Object o)) -> Right o
_ -> Left $ CouchError Nothing "view does not contain value"
newtype CouchT m a = CouchT (ReaderT CouchConnection m a)
deriving (Monad, MonadIO, MonadTrans, Functor, Applicative, MonadControlIO)
instance (MonadIO m) => CouchMonad (CouchT m) where
couchConnection = CouchT ask
runCouchT :: (Monad m) => CouchT m a -> CouchConnection -> m a
runCouchT (CouchT r) = runReaderT r
checkStatus :: (Monad m) => HT.Status -> Iteratee B.ByteString m b
-> Iteratee B.ByteString m b
checkStatus (HT.Status 200 _) i = i
checkStatus (HT.Status 201 _) i = i
checkStatus (HT.Status 202 _) i = i
checkStatus (HT.Status 304 _) i = i
checkStatus (HT.Status c m) _ = iterParser A.json >>= \v -> throwError $ CouchError (Just c) $ msg v
where msg v = BU8.toString m ++ reason v
reason (A.Object v) = case M.lookup "reason" v of
Just (A.String t) -> ": " ++ T.unpack t
_ -> ""
reason _ = []
valToObj :: A.Value -> Either CouchError A.Object
valToObj (A.Object o) = Right o
valToObj _ = Left $ CouchError Nothing "Couch DB did not return an object"
objToRev :: A.Object -> Either CouchError Revision
objToRev o = case M.lookup "rev" o of
(Just (A.String r)) -> Right r
_ -> Left $ CouchError Nothing "unable to find revision"
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
viewLoop :: (MonadIO m) => Enumeratee B.ByteString A.Object m a
viewLoop (Yield a _) = return $ Yield a EOF
viewLoop (Error err) = return $ Error err
viewLoop (Continue k) = do
v <- iterParser (A.json <?> "json object")
vobj <- case v of
(A.Object o) -> return o
_ -> throwError $ CouchError Nothing "view entry is not an object"
step' <- lift $ runIteratee $ k $ Chunks [vobj]
res <- iterParser (commaOrClose <?> "comma or close")
case res of
Comma -> viewLoop step'
CloseBracket -> case step' of
(Continue k') -> lift $ runIteratee $ k' EOF
_ -> return step'
viewStart :: Parser Bool
viewStart = do _ <- string "{\"total_rows\":"
skipWhile (\x -> x >= 48 && x <= 57)
_ <- string ",\"offset\":"
skipWhile (\x -> x >= 48 && x <= 57)
_ <- string ",\"rows\":["
(string "]}" >> return False) <|> return True
parseView :: (MonadIO m) => Enumeratee B.ByteString A.Object m a
parseView (Yield a _) = return $ Yield a EOF
parseView (Error err) = return $ Error err
parseView (Continue k) = do b <- iterParser (viewStart <?> "start of view")
if b
then viewLoop $ Continue k
else lift $ runIteratee $ k EOF
mapEither :: (Exception e, Monad m) => (a -> Either e b) -> Enumeratee a b m c
mapEither f = checkDone (continue . step) where
step k EOF = yield (Continue k) EOF
step k (Chunks xs) = case Prelude.mapM f xs of
Left err -> throwError err
Right xs' -> k (Chunks xs') >>== mapEither f