From bb511f0df2cda475cb76745dad336c1073a44958 Mon Sep 17 00:00:00 2001
From: Joe Nelson <cred+github@begriffs.com>
Date: Sat, 18 Jul 2015 15:38:46 -0700
Subject: [PATCH] WIP: call stored pprocedures that emit plain text

The beginning of #114
---
 src/PostgREST/App.hs         | 19 ++++++++++++++++++-
 src/PostgREST/PgQuery.hs     |  8 ++++++++
 src/PostgREST/PgStructure.hs | 13 ++++++++++++-
 3 files changed, 38 insertions(+), 2 deletions(-)

diff --git a/src/PostgREST/App.hs b/src/PostgREST/App.hs
index 69fbc7e4b..d8f625c30 100644
--- a/src/PostgREST/App.hs
+++ b/src/PostgREST/App.hs
@@ -163,6 +163,21 @@ app conf reqBody req =
                   ] $ if echoRequested then encode obj else ""
           return $ multipart status201 responses
 
+    (["rpc", proc], "POST") -> do
+      let qi = QualifiedIdentifier schema (cs proc)
+      exists <- doesProcExist schema proc
+      if exists
+        then do
+          row :: Maybe (Identity Text) <- H.maybeEx $ callProc qi $
+                      fromMaybe M.empty (decode reqBody)
+          return $ responseLBS status200 [textH]
+            (cs $ fromMaybe "" $ runIdentity <$> row)
+        else return $ responseLBS status404 [] ""
+
+      -- check that proc exists
+      -- check that arg names are all specified
+      -- select * from "1".proc(a := "foo"::undefined) where whereT limit limitT
+
     ([table], "PUT") ->
       handleJsonObj reqBody $ \obj -> do
         let qt = qualify table
@@ -279,6 +294,9 @@ csvMT = "text/csv"
 jsonH :: Header
 jsonH = (hContentType, jsonMT)
 
+textH :: Header
+textH = (hContentType, "text/plain")
+
 contentTypeForAccept :: Maybe BS.ByteString -> Maybe BS.ByteString
 contentTypeForAccept accept
   | isNothing accept || hasJson = Just jsonMT
@@ -295,7 +313,6 @@ bodyForAccept contentType table
   | contentType == csvMT = asCsvWithCount table
   | otherwise = asJsonWithCount -- defaults to JSON
 
-
 handleJsonObj :: BL.ByteString -> (Object -> H.Tx P.Postgres s Response)
               -> H.Tx P.Postgres s Response
 handleJsonObj reqBody handler = do
diff --git a/src/PostgREST/PgQuery.hs b/src/PostgREST/PgQuery.hs
index 180e51500..c03d6b92c 100644
--- a/src/PostgREST/PgQuery.hs
+++ b/src/PostgREST/PgQuery.hs
@@ -10,6 +10,7 @@ import qualified Hasql.Postgres as P
 import qualified Hasql.Backend as B
 
 import qualified Data.Text as T
+import qualified Data.HashMap.Strict as H
 import Text.Regex.TDFA ( (=~) )
 import qualified Network.HTTP.Types.URI as Net
 import qualified Data.ByteString.Char8 as BS
@@ -172,6 +173,13 @@ update t cols vals = B.Stmt
     <> ")")
   empty True
 
+callProc :: QualifiedIdentifier -> JSON.Object -> PStmt
+callProc qi params = do
+  let args = T.intercalate "," $ map assignment (H.toList params)
+  B.Stmt ("select " <> fromQi qi <> "(" <> args <> ")") empty True
+  where
+    assignment (n,v) = pgFmtIdent n <> ":=" <> insertableValue v
+
 wherePred :: QualifiedIdentifier -> Net.QueryItem -> PStmt
 wherePred table (col, predicate) =
   B.Stmt (" " <> pgFmtJsonbPath table (cs col) <> " " <> op <> " " <>
diff --git a/src/PostgREST/PgStructure.hs b/src/PostgREST/PgStructure.hs
index 1d58ba5cd..4e3a724e7 100644
--- a/src/PostgREST/PgStructure.hs
+++ b/src/PostgREST/PgStructure.hs
@@ -8,7 +8,7 @@ import Data.Text hiding (foldl, map, zipWith, concat)
 import Data.Aeson
 import Data.Functor.Identity
 import Data.String.Conversions (cs)
-import Data.Maybe (fromMaybe)
+import Data.Maybe (fromMaybe, isJust)
 import Control.Applicative
 
 import qualified Data.Map as Map
@@ -121,6 +121,17 @@ primaryKeyColumns table = do
       and kc.table_name  = ? |] (qiSchema table) (qiName table)
   return $ map runIdentity r
 
+doesProcExist :: Text -> Text -> H.Tx P.Postgres s Bool
+doesProcExist schema proc = do
+  row :: Maybe (Identity Int) <- H.maybeEx $ [H.stmt|
+      SELECT 1
+      FROM   pg_catalog.pg_namespace n
+      JOIN   pg_catalog.pg_proc p
+      ON     pronamespace = n.oid
+      WHERE  nspname = ?
+      AND    proname = ?
+    |] schema proc
+  return $ isJust row
 
 data Table = Table {
   tableSchema :: Text