diff --git a/Main.hs b/Main.hs index 999d17ca0..32a5334c7 100644 --- a/Main.hs +++ b/Main.hs @@ -23,11 +23,13 @@ import qualified Data.ByteString.Char8 as BS import PgStructure (printTables, printColumns) import PgQuery import RangeQuery +import Types (SqlRow) import Data.Maybe (fromMaybe) import Text.Regex.TDFA ((=~)) import Text.Read (readMaybe) -import Data.Text (unpack) +import Data.Text (pack, unpack) +import qualified Data.Aeson as JSON import Data.Ranged.Ranges (emptyRange) @@ -59,19 +61,39 @@ main = do traceThis :: (Show a) => a -> a traceThis x = trace (show x) x +jsonContentType :: (HeaderName, BS.ByteString) +jsonContentType = (hContentType, "application/json") + +jsonBodyAction :: Request -> (SqlRow -> IO Response) -> IO Response +jsonBodyAction req handler = do + parse <- jsonBody req + case parse of + Left err -> return $ responseLBS status400 [jsonContentType] json + where json = JSON.encode . JSON.object $ [("error", JSON.String $ pack err)] + Right body -> handler body + +jsonBody :: Request -> IO (Either String SqlRow) +jsonBody = (fmap JSON.eitherDecode) . strictRequestBody + app :: AppConfig -> Application app config req respond = do + conn <- connectPostgreSQL $ configDbUri config r <- try $ case (path, verb) of ([], _) -> - responseLBS status200 [json] <$> (printTables ver =<< conn) + responseLBS status200 [jsonContentType] <$> (printTables ver conn) ([table], "OPTIONS") -> - responseLBS status200 [json] <$> (printColumns ver (unpack table) =<< conn) + responseLBS status200 [jsonContentType] <$> ( + printColumns ver (unpack table) conn) ([table], "GET") -> if range == Just emptyRange then return $ responseLBS status416 [] "HTTP Range error" else respondWithRangedResult <$> - (getRows (show ver) (unpack table) qq range =<< conn) + (getRows (show ver) (unpack table) qq range conn) + ([table], "POST") -> + jsonBodyAction req (\row -> + responseLBS status200 [jsonContentType] <$> ( + insert (pack $ show ver) table row conn)) (_, _) -> return $ responseLBS status404 [] "" @@ -80,8 +102,6 @@ app config req respond = do where path = pathInfo req verb = requestMethod req - json = (hContentType, "application/json") - conn = connectPostgreSQL $ configDbUri config qq = queryString req ver = fromMaybe 1 $ requestedVersion (requestHeaders req) range = requestedRange (requestHeaders req) @@ -89,7 +109,7 @@ app config req respond = do respondWithRangedResult :: RangedResult -> Response respondWithRangedResult rr = responseLBS status206 [ - json, + jsonContentType, ("Content-Range", if rrTotal rr == 0 then "*/0" @@ -99,9 +119,6 @@ respondWithRangedResult rr = ) ] (rrBody rr) - where - json = (hContentType, "application/json") - requestedVersion :: RequestHeaders -> Maybe Int requestedVersion hdrs = case verStr of diff --git a/PgQuery.hs b/PgQuery.hs index 94b2efe2a..65f4d91bc 100644 --- a/PgQuery.hs +++ b/PgQuery.hs @@ -4,10 +4,13 @@ module PgQuery where +import Data.Text (Text) import Data.Functor ( (<$>) ) import Data.Maybe (fromMaybe) import Data.List (intersperse, intercalate) import Data.Monoid ((<>), mconcat) +import Data.HashMap.Strict (fromList) +import qualified Data.Aeson as JSON import qualified RangeQuery as R import qualified Data.ByteString.Char8 as BS @@ -18,6 +21,8 @@ import Database.HDBC.PostgreSQL import qualified Network.HTTP.Types.URI as Net +import Types (SqlRow, getRow) + -- }}} data RangedResult = RangedResult { @@ -56,7 +61,6 @@ whereClause qs = where conjunction = mconcat $ intersperse (" and ", []) (map wherePred qs) - wherePred :: Net.QueryItem -> QuotedSql wherePred (column, predicate) = ("%I " <> op <> "%L", map toSql [column, value]) @@ -73,7 +77,6 @@ wherePred (column, predicate) = "neq" -> "<>" _ -> "=" - limitClause :: Maybe R.NonnegRange -> QuotedSql limitClause range = (" LIMIT %s OFFSET %s ", [toSql limit, toSql offset]) @@ -101,6 +104,20 @@ jsonArrayRows :: QuotedSql -> QuotedSql jsonArrayRows q = ("array_to_json(array_agg(row_to_json(t))) from (", []) <> q <> (") t", []) +insert :: Text -> Text -> SqlRow -> Connection -> IO BL.ByteString +insert schema table row conn = do + query <- populateSql conn ("insert into %I.%I ("++colIds++")", map toSql $ schema:table:cols) + stmt <- prepare conn (query ++ " values ("++phs++") returning *") + _ <- execute stmt values + keys <- getColumnNames stmt + Just vals <- fetchRow stmt + let rowMap = fromList $ zip keys vals + return $ JSON.encode rowMap + where + (cols, values) = unzip . getRow $ row + colIds = intercalate ", " $ map (const "%I") cols + phs = intercalate ", " $ map (const "?") values + populateSql :: Connection -> QuotedSql -> IO String populateSql conn sql = do [[escaped]] <- quickQuery conn q (snd sql)