Fix original tests
This commit is contained in:
+7
-3
@@ -104,16 +104,16 @@ app v1schema reqBody req =
|
|||||||
([table], "POST") -> do
|
([table], "POST") -> do
|
||||||
let qt = QualifiedTable schema (cs table)
|
let qt = QualifiedTable schema (cs table)
|
||||||
echoRequested = lookup "Prefer" hdrs == Just "return=representation"
|
echoRequested = lookup "Prefer" hdrs == Just "return=representation"
|
||||||
parsed :: Either String (V.Vector Text, V.Vector (V.Vector Text))
|
parsed :: Either String (V.Vector Text, V.Vector (V.Vector Value))
|
||||||
parsed = if lookup "Content-Type" hdrs == Just "text/csv"
|
parsed = if lookup "Content-Type" hdrs == Just "text/csv"
|
||||||
then do
|
then do
|
||||||
rows <- CSV.decode CSV.NoHeader reqBody
|
rows <- CSV.decode CSV.NoHeader reqBody
|
||||||
if V.null rows then Left "CSV requires header"
|
if V.null rows then Left "CSV requires header"
|
||||||
else Right (V.head rows, V.tail rows)
|
else Right (V.head rows, (V.map $ V.map $ parseCsvCell . cs) (V.tail rows))
|
||||||
else eitherDecode reqBody >>= \val ->
|
else eitherDecode reqBody >>= \val ->
|
||||||
case val of
|
case val of
|
||||||
Object obj -> Right . second V.singleton . V.unzip . V.fromList $
|
Object obj -> Right . second V.singleton . V.unzip . V.fromList $
|
||||||
M.toList (M.map unquoted obj)
|
M.toList 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 [] $
|
Left err -> return $ responseLBS status400 [] $
|
||||||
@@ -244,6 +244,10 @@ handleJsonObj reqBody handler = do
|
|||||||
jErr = encode . object $
|
jErr = encode . object $
|
||||||
[("message", String "Expecting a JSON object")]
|
[("message", String "Expecting a JSON object")]
|
||||||
|
|
||||||
|
parseCsvCell :: BL.ByteString -> Value
|
||||||
|
parseCsvCell s =
|
||||||
|
either (const $ String "") id (eitherDecode s)
|
||||||
|
|
||||||
multipart :: Status -> [Response] -> Response
|
multipart :: Status -> [Response] -> Response
|
||||||
multipart _ [] = responseLBS status204 [] ""
|
multipart _ [] = responseLBS status204 [] ""
|
||||||
multipart _ [r] = r
|
multipart _ [r] = r
|
||||||
|
|||||||
+4
-4
@@ -111,7 +111,7 @@ deleteFrom t = B.Stmt ("delete from " <> fromQt t) empty True
|
|||||||
|
|
||||||
insertInto :: QualifiedTable
|
insertInto :: QualifiedTable
|
||||||
-> V.Vector T.Text
|
-> V.Vector T.Text
|
||||||
-> V.Vector (V.Vector T.Text)
|
-> V.Vector (V.Vector JSON.Value)
|
||||||
-> PStmt
|
-> PStmt
|
||||||
insertInto t cols vals
|
insertInto t cols vals
|
||||||
| V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True
|
| V.null cols = B.Stmt ("insert into " <> fromQt t <> " default values returning *") empty True
|
||||||
@@ -121,7 +121,7 @@ insertInto t cols vals
|
|||||||
") values "
|
") values "
|
||||||
<> T.intercalate ", "
|
<> T.intercalate ", "
|
||||||
(V.toList $ V.map (\v -> "("
|
(V.toList $ V.map (\v -> "("
|
||||||
<> T.intercalate ", " (V.toList $ V.map insertableText v)
|
<> T.intercalate ", " (V.toList $ V.map insertableValue v)
|
||||||
<> ")"
|
<> ")"
|
||||||
) vals
|
) vals
|
||||||
)
|
)
|
||||||
@@ -268,14 +268,14 @@ unquoted (JSON.String t) = t
|
|||||||
unquoted (JSON.Number n) =
|
unquoted (JSON.Number n) =
|
||||||
cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
|
cs $ formatScientific Fixed (if isInteger n then Just 0 else Nothing) n
|
||||||
unquoted (JSON.Bool b) = cs . show $ b
|
unquoted (JSON.Bool b) = cs . show $ b
|
||||||
unquoted JSON.Null = "null"
|
|
||||||
unquoted _ = ""
|
unquoted _ = ""
|
||||||
|
|
||||||
insertableText :: T.Text -> T.Text
|
insertableText :: T.Text -> T.Text
|
||||||
insertableText = (<> "::unknown") . pgFmtLit
|
insertableText = (<> "::unknown") . pgFmtLit
|
||||||
|
|
||||||
insertableValue :: JSON.Value -> T.Text
|
insertableValue :: JSON.Value -> T.Text
|
||||||
insertableValue = insertableText . unquoted
|
insertableValue JSON.Null = "null"
|
||||||
|
insertableValue v = insertableText $ unquoted v
|
||||||
|
|
||||||
paramFilter :: JSON.Value -> T.Text
|
paramFilter :: JSON.Value -> T.Text
|
||||||
paramFilter JSON.Null = "is.null"
|
paramFilter JSON.Null = "is.null"
|
||||||
|
|||||||
Reference in New Issue
Block a user