From 61174cfa172ea806869259e6dd8b1ba0fb2de582 Mon Sep 17 00:00:00 2001 From: Joe Nelson Date: Wed, 12 Nov 2014 09:55:25 -0800 Subject: [PATCH] Add user creation route --- src/App.hs | 92 +++++++++++++------------------------------------- src/PgQuery.hs | 4 +-- 2 files changed, 26 insertions(+), 70 deletions(-) diff --git a/src/App.hs b/src/App.hs index b1199e1f3..3fa152349 100644 --- a/src/App.hs +++ b/src/App.hs @@ -12,6 +12,7 @@ import Data.Text hiding (map) import Data.Maybe (listToMaybe, fromMaybe) import Text.Regex.TDFA ((=~)) import Data.Ord (comparing) +import Data.Ranged.Ranges (emptyRange) import Data.HashMap.Strict (keys, elems, filterWithKey, toList) -- import Data.Map (intersection, fromList, toList, Map) import Data.List (sortBy) @@ -39,7 +40,7 @@ import Database.PostgreSQL.Simple import PgQuery import RangeQuery import PgStructure -import Data.Ranged.Ranges (emptyRange) +import Auth app :: Connection -> Application app conn req respond = @@ -86,12 +87,28 @@ app conn req respond = return $ responseLBS status [jsonH, contentRange, ("Content-Location", - "/" <> cs table <> if Prelude.null canonical then "" else "?" <> cs canonical + "/" <> cs table <> + if Prelude.null canonical then "" else "?" <> cs canonical ) ] (cs body) + (["dbapi", "users"], "POST") -> do + body <- strictRequestBody req + let user = decode body :: Maybe AuthUser + + case user of + Nothing -> return $ responseLBS status400 [jsonH] $ + encode . object $ [("error", String "Failed to parse user.")] + Just u -> do + _ <- addUser conn (cs $ userId u) + (cs $ userPass u) (cs $ userRole u) + return $ responseLBS status201 + [ jsonH + , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) + ] "" + ([table], "POST") -> - handleJsonObj req (\obj -> do + handleJsonObj req $ \obj -> do let qt = QualifiedTable schema (cs table) _ <- uncurry (execute conn) $ insertInto qt (map cs $ keys obj) (elems obj) @@ -104,10 +121,9 @@ app conn req respond = [ jsonH , (hLocation, "/" <> cs table <> "?" <> cs params) ] "" - ) ([table], "PUT") -> - handleJsonObj req (\obj -> do + handleJsonObj req $ \obj -> do let qt = QualifiedTable schema (cs table) primaryKeys <- primaryKeyColumns conn qt let specifiedKeys = map (cs . fst) qq @@ -119,26 +135,23 @@ app conn req respond = let cols = map cs $ keys obj if S.fromList tableCols == S.fromList cols then do let vals = elems obj - let upsert = - aIffNotBT (whereT qq $ update qt cols vals) + _ <- uncurry (execute conn) $ iffNotT + (whereT qq $ update qt cols vals) (insertInto qt cols vals) - _ <- uncurry (execute conn) upsert return $ responseLBS status204 [ jsonH ] "" else return $ if Prelude.null tableCols then responseLBS status404 [] "" else responseLBS status400 [] "You must specify all columns in PUT request" - ) ([table], "PATCH") -> - handleJsonObj req (\obj -> do + handleJsonObj req $ \obj -> do let qt = QualifiedTable schema (cs table) _ <- uncurry (execute conn) $ whereT qq $ update qt (map cs $ keys obj) (elems obj) return $ responseLBS status204 [ jsonH ] "" - ) (_, _) -> return $ responseLBS status404 [] "" @@ -209,40 +222,6 @@ instance ToJSON TableOptions where , "pkey" .= tblOptpkey t ] --- app :: Connection -> Application --- app conn req respond = --- respond =<< case (path, verb) of --- ([], _) -> --- responseLBS status200 [jsonContentType] <$> printTables ver conn - --- (["dbapi", "users"], "POST") -> do --- body <- strictRequestBody req --- let parse = JSON.eitherDecode body - --- case parse of --- Left err -> return $ responseLBS status400 [jsonContentType] json --- where json = JSON.encode . JSON.object $ [("error", JSON.String $ "Failed to parse JSON payload. " <> cs err) ] --- Right u -> do --- addUser (cs $ userId u) (cs $ userPass u) (cs $ userRole u) conn --- return $ responseLBS status201 --- [ jsonContentType --- , (hLocation, "/dbapi/users?id=eq." <> cs (userId u)) --- ] "" - - --- (_, _) -> --- return $ responseLBS status404 [] "" - --- where --- path = pathInfo req --- verb = requestMethod req --- qq = queryString req --- hdrs = requestHeaders req --- ver = fromMaybe "1" $ requestedVersion hdrs --- range = requestedRange hdrs --- cRange = requestedContentRange hdrs --- allOrigins = ("Access-Control-Allow-Origin", "*") :: Header - -- defaultCorsPolicy :: CorsResourcePolicy -- defaultCorsPolicy = CorsResourcePolicy Nothing -- ["GET", "POST", "PUT", "PATCH", "DELETE", "OPTIONS"] ["Authorization"] Nothing @@ -262,29 +241,6 @@ instance ToJSON TableOptions where -- Nothing -> [] --- respondWithRangedResult :: RangedResult -> Response --- respondWithRangedResult rr = --- responseLBS status [ --- jsonContentType, --- ("Content-Range", --- if total == 0 || from > total --- then "*/" <> cs (show total) --- else cs (show from) <> "-" --- <> cs (show to) <> "/" --- <> cs (show total) --- ) --- ] (rrBody rr) - --- where --- from = rrFrom rr --- to = rrTo rr --- total = rrTotal rr --- status --- | from > total = status416 --- | (1 + to - from) < total = status206 --- | otherwise = status200 - - -- addHeaders :: ResponseHeaders -> Response -> Response -- addHeaders hdrs (ResponseFile s headers fp m) = -- ResponseFile s (headers ++ hdrs) fp m diff --git a/src/PgQuery.hs b/src/PgQuery.hs index 1e0de2d66..1ac961b60 100644 --- a/src/PgQuery.hs +++ b/src/PgQuery.hs @@ -61,8 +61,8 @@ parentheticT :: CompleteQueryT parentheticT (sql, params) = (" (" <> sql <> ") ", params) -aIffNotBT :: CompleteQuery -> CompleteQueryT -aIffNotBT (aq, ap) (bq, bp) = +iffNotT :: CompleteQuery -> CompleteQueryT +iffNotT (aq, ap) (bq, bp) = ("WITH aaa AS (" <> aq <> " returning *) " <> bq <> "WHERE NOT EXISTS (SELECT * FROM aaa)" , ap ++ bp