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

WIP: typechecking but not yet sending back links

Browse Source 
Rather amazing how well this actually works given
it only type checked
This commit is contained in:
Joe Nelson
2015-04-11 21:41:32 -07:00
parent 87acee924e
commit 4dbcf45555
1 changed files with 19 additions and 33 deletions
Download Patch File Download Diff File Expand all files Collapse all files
src/App.hs
+19 -33
View File
@@ -2,7 +2,7 @@
module App (app, sqlError, isSqlError) where module App (app, sqlError, isSqlError) where
import Control.Monad (join) import Control.Monad (join)
import Control.Arrow ((***)) import Control.Arrow ((***), second)
import Control.Applicative import Control.Applicative
import Data.Text hiding (map) import Data.Text hiding (map)
@@ -10,13 +10,12 @@ import Data.Maybe (fromMaybe)
import Text.Regex.TDFA ((=~)) import Text.Regex.TDFA ((=~))
import Data.Ord (comparing) import Data.Ord (comparing)
import Data.Ranged.Ranges (emptyRange) import Data.Ranged.Ranges (emptyRange)
import Data.HashMap.Strict (HashMap, keys, elems, filterWithKey, toList, fromList) import qualified Data.HashMap.Strict as M
import Data.String.Conversions (cs) import Data.String.Conversions (cs)
import Data.List (sortBy) 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 as BS
import qualified Data.Csv as CSV import qualified Data.Csv as CSV
import Network.HTTP.Types.Status import Network.HTTP.Types.Status
@@ -102,36 +101,23 @@ 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"
records :: Either String (CSV.Header, V.Vector (HashMap BS.ByteString BS.ByteString)) parsed :: Either String (V.Vector Text, V.Vector (V.Vector Text))
records = if lookup "Content-Type" hdrs == Just "text/csv" parsed = if lookup "Content-Type" hdrs == Just "text/csv"
then CSV.decodeByName reqBody then do
rows <- CSV.decode CSV.NoHeader reqBody
if V.null rows then Left "CSV requires header"
else Right (V.head rows, V.tail rows)
else eitherDecode reqBody >>= \val -> else eitherDecode reqBody >>= \val ->
case val of case val of
Object obj -> Right ( Object obj -> Right . second V.singleton . V.unzip . V.fromList $
V.fromList $ map cs $ keys obj M.toList (M.map unquoted obj)
, V.singleton . fromList . map (\(k,v) -> (cs k, cs $ unquoted v)) $ toList obj
)
_ -> Left "Expecting single JSON object or CSV rows" _ -> Left "Expecting single JSON object or CSV rows"
rows = insertInto qt records case parsed of
undefined Left err -> return $ responseLBS status400 [] (cs err)
-- else do Right records -> do
-- query = insertInto qt (map cs $ keys obj) [(elems obj)] H.unitEx $ uncurry (insertInto qt) records
-- row <- H.maybeEx query return $ responseLBS status201 [] ""
-- let (Identity insertedJson) = fromMaybe (Identity "{}" :: Identity Text) row
-- Just inserted = decode (cs insertedJson) :: Maybe Object
-- primaryKeys <- map cs <$> primaryKeyColumns qt
-- let primaries = if Prelude.null primaryKeys
-- then inserted
-- else filterWithKey (const . (`elem` primaryKeys)) inserted
-- let params = urlEncodeVars
-- $ map (\t -> (cs $ fst t, cs (paramFilter $ snd t)))
-- $ sortBy (comparing fst) $ toList primaries
-- return $ responseLBS status201
-- [ jsonH
-- , (hLocation, "/" <> cs table <> "?" <> cs params)
-- ] $ if echoRequested then cs insertedJson else ""
([table], "PUT") -> ([table], "PUT") ->
handleJsonObj reqBody $ \obj -> do handleJsonObj reqBody $ \obj -> do
@@ -143,10 +129,10 @@ app v1schema reqBody req =
"You must speficy all and only primary keys as params" "You must speficy all and only primary keys as params"
else do else do
tableCols <- map (cs . colName) <$> columns qt tableCols <- map (cs . colName) <$> columns qt
let cols = map cs $ keys obj let cols = map cs $ M.keys obj
if S.fromList tableCols == S.fromList cols if S.fromList tableCols == S.fromList cols
then do then do
let vals = elems obj let vals = M.elems obj
H.unitEx $ iffNotT H.unitEx $ iffNotT
(whereT qq $ update qt cols vals) (whereT qq $ update qt cols vals)
(insertSelect qt cols vals) (insertSelect qt cols vals)
@@ -162,7 +148,7 @@ app v1schema reqBody req =
let qt = QualifiedTable schema (cs table) let qt = QualifiedTable schema (cs table)
H.unitEx H.unitEx
$ whereT qq $ whereT qq
$ update qt (map cs $ keys obj) (elems obj) $ update qt (map cs $ M.keys obj) (M.elems obj)
return $ responseLBS status204 [ jsonH ] "" return $ responseLBS status204 [ jsonH ] ""
([table], "DELETE") -> do ([table], "DELETE") -> do