jimmy/postgrest
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

All tests but one are passing

Browse Source
This commit is contained in:
Joe Nelson
2015-04-12 19:56:33 -07:00
parent 70d33445db
commit 7d03a71fed
1 changed files with 18 additions and 10 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/App.hs
+18 -10
View File
@@ -16,7 +16,7 @@ import Data.List (sortBy)
import Data.Functor.Identity import Data.Functor.Identity
import qualified Data.Set as S import qualified Data.Set as S
import qualified Data.ByteString.Lazy as BL import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Builder as BB import qualified Blaze.ByteString.Builder as BB
import qualified Data.Csv as CSV import qualified Data.Csv as CSV
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
@@ -24,6 +24,7 @@ import Network.HTTP.Types.Header
import Network.HTTP.Types.URI (parseSimpleQuery) import Network.HTTP.Types.URI (parseSimpleQuery)
import Network.HTTP.Base (urlEncodeVars) import Network.HTTP.Base (urlEncodeVars)
import Network.Wai import Network.Wai
import Network.Wai.Internal (Response(..))
import Data.Aeson import Data.Aeson
import Data.Monoid import Data.Monoid
@@ -115,7 +116,8 @@ app v1schema reqBody req =
M.toList (M.map unquoted obj) M.toList (M.map unquoted obj)
_ -> Left "Expecting single JSON object or CSV rows" _ -> Left "Expecting single JSON object or CSV rows"
case parsed of case parsed of
Left err -> return $ responseLBS status400 [] (cs err) Left err -> return $ responseLBS status400 [] $
encode . object $ [("message", String $ "Failed to parse JSON payload. " <> cs err)]
Right toBeInserted -> do Right toBeInserted -> do
rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted rows :: [Identity Text] <- H.listEx $ uncurry (insertInto qt) toBeInserted
let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows let inserted :: [Object] = mapMaybe (decode . cs . runIdentity) rows
@@ -132,7 +134,7 @@ app v1schema reqBody req =
[ jsonH [ jsonH
, (hLocation, "/" <> cs table <> "?" <> cs params) , (hLocation, "/" <> cs table <> "?" <> cs params)
] $ if echoRequested then encode obj else "" ] $ if echoRequested then encode obj else ""
return $ multipart responses return $ multipart status201 responses
([table], "PUT") -> ([table], "PUT") ->
handleJsonObj reqBody $ \obj -> do handleJsonObj reqBody $ \obj -> do
@@ -242,17 +244,23 @@ handleJsonObj reqBody handler = do
jErr = encode . object $ jErr = encode . object $
[("message", String "Expecting a JSON object")] [("message", String "Expecting a JSON object")]
multipart :: [Response] -> Response multipart :: Status -> [Response] -> Response
multipart rs = multipart _ [] = responseLBS status204 [] ""
undefined multipart _ [r] = r
multipart s rs =
responseLBS s [(hContentType, "Multipart/mixed; boundary=postgrest_boundary")] $
BL.intercalate "\n\n--postgrest_boundary\n" (map renderResponseBody rs)
where where
renderHeader :: Header -> BL.ByteString renderHeader :: Header -> BL.ByteString
renderHeader (k, v) = k <> ": " <> v renderHeader (k, v) = cs (show k) <> ": " <> cs v
renderResponse (ResponseBuilder _ headers b) = renderResponseBody :: Response -> BL.ByteString
BL.intercalate "\n" $ map renderHeader headers renderResponseBody (ResponseBuilder _ headers b) =
<> BB.toLazyByteString b BL.intercalate "\n" (map renderHeader headers)
<> "\n\n" <> BB.toLazyByteString b
renderResponseBody _ = error
"Unable to create multipart response from non-ResponseBuilder"
data TableOptions = TableOptions { data TableOptions = TableOptions {
tblOptcolumns :: [Column] tblOptcolumns :: [Column]