POST to insert row.

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

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)