Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Proper UTF-8 encoding, with headers

  • Loading branch information...
commit b6458299b6b09d5dfeff9c08d56c21ca70a3f374 1 parent 3b977df
@haasn haasn authored
View
4 CouchDB.cabal
@@ -20,7 +20,7 @@ Test-Suite test-couchdb
Type: exitcode-stdio-1.0
Main-Is: Tests.hs
Build-Depends:
- base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7, HUnit
+ base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7, HUnit, bytestring
Extensions:
FlexibleInstances
ghc-options:
@@ -29,7 +29,7 @@ Test-Suite test-couchdb
Library
Hs-Source-Dirs: src
Build-Depends:
- base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7
+ base >= 4 && < 5, mtl, containers, network, HTTP>=4000.0.4, json>=0.4.3, utf8-string >= 0.3.6 && <= 0.3.7, bytestring
ghc-options:
-fwarn-incomplete-patterns
Extensions:
View
17 src/Database/CouchDB/HTTP.hs
@@ -25,13 +25,15 @@ import Network.URI
import Control.Exception (bracket)
import Control.Monad.Trans (MonadIO (..))
import Data.Maybe (fromJust)
+import qualified Data.ByteString as BS (ByteString, length)
+import qualified Data.ByteString.UTF8 as UTF8 (fromString, toString)
import Network.HTTP.Auth
import Control.Monad (ap)
-- |Describes a connection to a CouchDB database. This type is
-- encapsulated by 'CouchMonad'.
data CouchConn = CouchConn
- { ccConn :: IORef (HandleStream String)
+ { ccConn :: IORef (HandleStream BS.ByteString)
, ccURI :: URI
, ccHostname :: String
, ccPort :: Int
@@ -69,7 +71,7 @@ makeURL path query = CouchMonad $ \conn -> do
}
,conn )
-getConn :: CouchMonad (HandleStream String)
+getConn :: CouchMonad (HandleStream BS.ByteString)
getConn = CouchMonad $ \conn -> do
r <- readIORef (ccConn conn)
return (r,conn)
@@ -86,6 +88,7 @@ reopenConnection = CouchMonad $ \conn -> do
makeHeaders bodyLen =
[ Header HdrContentType "application/json"
+ , Header HdrContentEncoding "UTF-8"
, Header HdrConnection "keep-alive"
, Header HdrContentLength (show bodyLen)
]
@@ -100,11 +103,12 @@ request :: String -- ^path of the request
-> String -- ^body of the request
-> CouchMonad (Response String)
request path query method headers body = do
+ let body' = UTF8.fromString body
url <- makeURL path query
- let allHeaders = (makeHeaders (length body)) ++ headers
+ let allHeaders = (makeHeaders (BS.length body')) ++ headers
conn <- getConn
auth <- getConnAuth
- let req' = Request url method allHeaders body
+ let req' = Request url method allHeaders body'
let req = maybe req' (fillAuth req') auth
let retry 0 = do
fail $ "server error: " ++ show req
@@ -114,8 +118,11 @@ request path query method headers body = do
Left err -> do
reopenConnection
retry (n-1)
- Right val -> return val
+ Right val -> return (unUTF8 val)
retry 2
+ where
+ unUTF8 :: Response BS.ByteString -> Response String
+ unUTF8 (Response c r h b) = Response c r h (UTF8.toString b)
fillAuth :: Request a -> Authority -> Request a
fillAuth req auth = req { rqHeaders = new : rqHeaders req }
View
21 src/Database/CouchDB/Unsafe.hs
@@ -28,7 +28,6 @@ module Database.CouchDB.Unsafe
) where
import Database.CouchDB.HTTP
-import Codec.Binary.UTF8.String (encodeString, decodeString)
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.Maybe (fromJust, mapMaybe, isNothing)
@@ -40,7 +39,7 @@ assertJSObject v@(JSObject _) = return v
assertJSObject o = fail $ "expected a JSON object; received: " ++ encode o
couchResponse :: String -> [(String,JSValue)]
-couchResponse respBody = case dec respBody of
+couchResponse respBody = case decode respBody of
Error s -> error $ "couchResponse: s"
Ok r -> fromJSObject r
@@ -68,7 +67,7 @@ getAllDBs = do
response <- request' "_all_dbs" GET
case rspCode response of
(2,0,0) ->
- case dec (rspBody response) of
+ case decode (rspBody response) of
Ok (JSArray dbs) -> return [db | JSString db <- dbs]
otherwise -> error "Unexpected couch response"
otherwise -> error (show response)
@@ -82,7 +81,7 @@ newNamedDoc :: (JSON a)
-- revision number on success.
newNamedDoc dbName docName body = do
obj <- assertJSObject (showJSON body)
- r <- request (dbName ++ "/" ++ docName) [] PUT [] (enc obj)
+ r <- request (dbName ++ "/" ++ docName) [] PUT [] (encode obj)
case rspCode r of
(2,0,1) -> do
let result = couchResponse (rspBody r)
@@ -106,7 +105,7 @@ updateDoc db (doc,rev) val = do
let (JSObject obj) = showJSON val
let doc' = fromJSString doc
let obj' = ("_id",JSString doc):("_rev",JSString rev):(fromJSObject obj)
- r <- request (db ++ "/" ++ doc') [] PUT [] (enc $ toJSObject obj')
+ r <- request (db ++ "/" ++ doc') [] PUT [] (encode $ toJSObject obj')
case rspCode r of
(2,0,1) -> do
let result = couchResponse (rspBody r)
@@ -122,10 +121,10 @@ bulkUpdateDocs :: (JSON a)
-> CouchMonad (Maybe [Either JSString (JSString, JSString)]) -- ^ error or (id,rev)
bulkUpdateDocs db docs = do
let obj = [("docs", docs)]
- r <- request (db ++ "/_bulk_docs") [] POST [] (enc $ toJSObject obj)
+ r <- request (db ++ "/_bulk_docs") [] POST [] (encode $ toJSObject obj)
case rspCode r of
(2,0,1) -> do
- let Ok results = dec (rspBody r)
+ let Ok results = decode (rspBody r)
return $ Just $
map (\result ->
case (lookup "id" result,
@@ -168,7 +167,7 @@ newDoc :: (JSON a)
-> CouchMonad (JSString,JSString) -- ^ id and rev of new document
newDoc db doc = do
obj <- assertJSObject (showJSON doc)
- r <- request db [] POST [] (enc obj)
+ r <- request db [] POST [] (encode obj)
case rspCode r of
(2,0,1) -> do
let result = couchResponse (rspBody r)
@@ -400,9 +399,3 @@ rowKey (JSObject obj) = do
Just (JSString s) -> return (fromJSString s)
v -> fail "expected id"
rowKey v = fail "expected id"
-
-enc :: (JSON a) => a -> String
-enc = encodeString . encode
-
-dec :: (JSON a) => String -> Result a
-dec = decode . decodeString
Please sign in to comment.
Something went wrong with that request. Please try again.