module Database.CouchDB.HTTP
( request
, RequestMethod (..)
, CouchMonad
, Response (..)
, runCouchDB
, runCouchDB'
) where
import Data.IORef
import Control.Concurrent
import System.Log.Logger (errorM,debugM,infoM)
import Network.TCP
import Network.Stream
import Network.HTTP
import Network.URI
import Control.Exception (finally)
import Control.Monad.Trans (MonadIO (..))
data CouchConn = CouchConn
{ ccConn :: IORef Connection
, ccURI :: URI
, ccHostname :: String
, ccPort :: Int
}
data CouchMonad a = CouchMonad (CouchConn -> IO (a,CouchConn))
instance Monad CouchMonad where
return a = CouchMonad $ \conn -> return (a,conn)
(CouchMonad m) >>= k = CouchMonad $ \conn -> do
(a,conn') <- m conn
let (CouchMonad m') = k a
m' conn'
fail msg = CouchMonad $ \conn -> do
errorM "couchdb" msg
fail "internal error"
instance MonadIO CouchMonad where
liftIO m = CouchMonad $ \conn -> m >>= \a -> return (a,conn)
makeURL :: String
-> [(String,String)]
-> CouchMonad URI
makeURL path query = CouchMonad $ \conn -> do
return ( (ccURI conn) { uriPath = '/':path
, uriQuery = '?':(urlEncodeVars query)
}
,conn )
getConn :: CouchMonad Connection
getConn = CouchMonad $ \conn -> do
r <- readIORef (ccConn conn)
return (r,conn)
reopenConnection :: CouchMonad ()
reopenConnection = CouchMonad $ \conn -> do
c <- liftIO $ readIORef (ccConn conn) >>= close
connection <- liftIO $ openTCPPort (ccHostname conn) (ccPort conn)
writeIORef (ccConn conn) connection
return ((), conn)
makeHeaders bodyLen =
[ Header HdrContentType "application/json"
, Header HdrConnection "keep-alive"
, Header HdrContentLength (show bodyLen)
]
request :: String
-> [(String,String)]
-> RequestMethod
-> [Header]
-> String
-> CouchMonad Response
request path query method headers body = do
url <- makeURL path query
let allHeaders = (makeHeaders (length body)) ++ headers
conn <- getConn
let req = Request url method allHeaders body
liftIO $ debugM "couchdb.http" $ "Starting " ++ show req
let retry 0 = do
liftIO $ errorM "couchdb.http" $ "request failed: " ++ show req
fail "server error"
retry n = do
response <- liftIO $ sendHTTP conn req
case response of
Left err -> do
liftIO $ infoM "couchdb.http" $ "request failed; " ++ show n ++
" more tries left. Error code: " ++ show err ++ ", request: " ++
show req
reopenConnection
retry (n1)
Right val -> return val
retry 2
runCouchDB :: String
-> Int
-> CouchMonad a
-> IO a
runCouchDB hostname port (CouchMonad m) = do
let uriAuth = URIAuth "" hostname (':':(show port))
let baseURI = URI "http:" (Just uriAuth) "" "" ""
c <- openTCPPort hostname port
conn <- newIORef c
(a,_) <- m (CouchConn conn baseURI hostname port)
`finally` (do c <- readIORef conn
close c)
return a
runCouchDB' :: CouchMonad a -> IO a
runCouchDB' = runCouchDB "127.0.0.1" 5984