Remove the postgresql-simple dependency

It pulls Aeson, which is a rather large dependency (as does wai-extra,
but it's to be removed too), and its functionality was barely used
anyway.

3 files changed, 121 insertions, 144 deletions

diff --git a/Main.hs b/Main.hs
index e85eed3..2540c8b 100644
--- a/Main.hs
+++ b/Main.hs
@@ -34,17 +34,14 @@ import qualified Data.ByteString.Char8 as BS
 import qualified Data.ByteString.Lazy as BL
 import qualified Data.HashMap.Lazy as HM
 import qualified Data.Text as T
-import qualified Database.PostgreSQL.Simple.Types as PT
-import Database.PostgreSQL.Simple
 import Network.Wai
 import Network.HTTP.Types as HT
-import Database.PostgreSQL.Simple.FromField
-  (FromField, fromField, returnError, typename)
 import Web.FormUrlEncoded (Form(..), urlDecodeForm)
-import Database.PostgreSQL.Simple.ToField (Action (..))
-import Database.PostgreSQL.Simple.Internal (withConnection)
-import Database.PostgreSQL.LibPQ (getCancel, cancel)
-import Data.Maybe (mapMaybe, fromMaybe)
+import Database.PostgreSQL.LibPQ
+  (getCancel, cancel, connectdb, finish, execParams, getvalue, invalidOid,
+   escapeIdentifier, resultStatus, errorMessage, Connection, Format(..),
+   ExecStatus(..))
+import Data.Maybe (mapMaybe, fromMaybe, catMaybes)
 import Data.Text.Encoding (encodeUtf8)
 import Network.Wai.Middleware.HttpAuth (extractBasicAuth)
 import Network.HTTP.Types.Header (hWWWAuthenticate)
@@ -52,7 +49,7 @@ import System.Timeout (timeout)
 import Network.Wai.Handler.FastCGI (run)
 import Control.Monad (join)
 import Control.Arrow ((***))
-import Control.Exception (bracket, finally, catches, Handler(..))
+import Control.Exception (bracket, finally)
 import System.FilePath (replaceExtension, takeFileName, (</>))
 import System.Environment (lookupEnv)
 import Data.List (nubBy)
@@ -60,8 +57,9 @@ import Foreign
 import Foreign.C
 
 
+-- * libxml bindings and functions
+
 data XmlDoc
-data XmlSaveCtxt
 data XsltStylesheet
 data XsltTransformContext
 
@@ -100,20 +98,25 @@ transform docBS baseStr pathStr stringParams =
   withCString pathStr $ \pathCStr ->
   alloca $ \bufPtr ->
   alloca $ \lenPtr ->
-  bracket (notNull $ xmlReadMemory docCStr (fromIntegral docCStrLen) baseCStr nullPtr 0)
+  bracket
+  (notNull $ xmlReadMemory docCStr (fromIntegral docCStrLen) baseCStr nullPtr 0)
   xmlFreeDoc $ \doc ->
   bracket (mapM newCString (concatMap (\(x, y) -> [x, y]) $
                             nubBy (\x y -> fst x == fst y) stringParams))
   (mapM free) $ \params ->
   withArray0 nullPtr params $ \paramsArr ->
   withArray0 nullPtr [] $ \emptyArr ->
-  bracket (notNull $ xsltParseStylesheetFile pathCStr) xsltFreeStylesheet $ \stylesheet ->
-  bracket (notNull $ xsltNewTransformContext stylesheet doc) xsltFreeTransformContext $
+  bracket (notNull $ xsltParseStylesheetFile pathCStr) xsltFreeStylesheet $
+  \stylesheet ->
+  bracket (notNull $ xsltNewTransformContext stylesheet doc)
+  xsltFreeTransformContext $
   \tc -> xsltQuoteUserParams tc paramsArr >>
-  bracket (notNull $ xsltApplyStylesheetUser stylesheet doc emptyArr nullPtr nullPtr tc)
-  xmlFreeDoc (\res ->
-                xsltSaveResultToString bufPtr lenPtr res stylesheet >>
-                bracket (peek bufPtr) free BS.packCString)
+  bracket
+  (notNull $ xsltApplyStylesheetUser stylesheet doc emptyArr nullPtr nullPtr tc)
+  xmlFreeDoc
+  (\res ->
+      xsltSaveResultToString bufPtr lenPtr res stylesheet >>
+      bracket (peek bufPtr) free BS.packCString)
   where
     notNull :: IO (Ptr a) -> IO (Ptr a)
     notNull a = a >>= \p -> if p == nullPtr
@@ -121,22 +124,64 @@ transform docBS baseStr pathStr stringParams =
                             else pure p
   -- TODO: improve error handling
 
-newtype PgXmlString = PgXmlString { unPgXmlString :: BS.ByteString }
 
-instance FromField PgXmlString where
-  fromField f Nothing = returnError UnexpectedNull f ""
-  fromField f (Just mdata) = do
-    tName <- typename f
-    if tName /= "xml"
-      then returnError ConversionFailed f $
-           "Expected xml type, got " ++ BS.unpack tName
-      else pure $ PgXmlString mdata
+-- * PostgreSQL-related functions
+
+connString :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString
+connString [] = BS.empty
+connString ((k,v):xs) =
+  BS.concat [k, "='", BS.pack (val $ BS.unpack v), "' ", connString xs]
+  where val [] = []
+        val ('\\':cs) = '\\' : '\\' : val cs
+        val ('\'':cs) = '\\' : '\'' : val cs
+        val (c:cs) = c : val cs
+
+-- https://www.postgresql.org/docs/11/libpq-exec.html
+-- https://hackage.haskell.org/package/postgresql-libpq-0.9.4.2/docs/Database-PostgreSQL-LibPQ.html
+prepareQuery :: Connection
+             -> [(BS.ByteString, BS.ByteString)]
+             -- ^ Form data
+             -> [(BS.ByteString, Maybe BS.ByteString)]
+             -- ^ URL query
+             -> BS.ByteString
+             -- ^ SQL query template
+             -> IO (BS.ByteString, [BS.ByteString])
+             -- ^ SQL query template and parameters
+prepareQuery c f gq q = substWords [] [] $ BS.words q
+  where
+    placeholder :: Int -> BS.ByteString
+    placeholder n = BS.cons '$' $ BS.pack $ show $ n + 1
+    placeholders :: Int -> BS.ByteString
+    placeholders cnt = BS.intercalate " , "
+      [placeholder (cnt + n) | n <- [0 .. length f - 1]]
+    substWords :: [BS.ByteString]
+               -- ^ query bits
+               -> [BS.ByteString]
+               -- ^ parameters
+               -> [BS.ByteString]
+               -- ^ remaining words
+               -> IO (BS.ByteString, [BS.ByteString])
+               -- ^ query and parameters
+    substWords qs ps [] = pure (BS.unwords qs, ps)
+    substWords qs ps (":fields":rest) = do
+      identifiers <- BS.intercalate ", " . catMaybes
+                     <$> mapM (escapeIdentifier c . fst) f
+      substWords (qs ++ [identifiers]) ps rest
+    substWords qs ps (":values":rest) =
+      substWords (qs ++ [placeholders $ length ps]) (ps ++ map snd f) rest
+    substWords qs ps (other:rest) = case BS.splitAt 2 other of
+      -- POST (form) parameter
+      ("f:", fieldName) -> case lookup fieldName f of
+        Nothing -> substWords (qs ++ [other]) ps rest
+        Just v -> substWords (qs ++ [placeholder $ length ps]) (ps ++ [v]) rest
+      -- GET (query/link or form) parameter
+      ("q:", fieldName) -> case join (lookup fieldName gq) of
+        Nothing -> substWords (qs ++ [other]) ps rest
+        Just v -> substWords (qs ++ [placeholder $ length ps]) (ps ++ [v]) rest
+      _ -> substWords (qs ++ [other]) ps rest
+
 
-data Error = ESQL SqlError
-           | EFormat FormatError
-           | EQuery QueryError
-           | EResult ResultError
-           | EOther String
+-- * Web interface
 
 formToFields :: Form -> [(T.Text, T.Text)]
 formToFields = mapMaybe toField . HM.toList . unForm
@@ -144,85 +189,57 @@ formToFields = mapMaybe toField . HM.toList . unForm
         toField _ = Nothing
 
 cancelAndClose :: Connection -> IO (Maybe BS.ByteString)
-cancelAndClose c = cancelConn `finally` close c
-  where cancelConn = withConnection c $ \conn -> do
-          cl <- getCancel conn
+cancelAndClose c = cancelConn `finally` finish c
+  where cancelConn = do
+          cl <- getCancel c
           case cl of
             Nothing -> pure $ Just "Failed to get a Cancel structure"
             Just cl' -> either Just (const Nothing) <$> cancel cl'
 
-prepareQuery :: Form
-             -- ^ Form data
-             -> HT.Query
-             -- ^ URL query
-             -> BS.ByteString
-             -- ^ SQL query template
-             -> (PT.Query, [Action])
-             -- ^ SQL query template and parameters
-prepareQuery f gq q = let sub = map substWord $ BS.words q
-  in (PT.Query $ BS.unwords (map fst sub), concat $ mapMaybe snd sub)
-  where
-    fields = formToFields f
-    bsFields = map (encodeUtf8 *** encodeUtf8) fields
-    keys = map fst bsFields
-    vals = map snd bsFields
-    placeholders = BS.intercalate "," (map (const "?") fields)
-    substWord ":fields" = (placeholders, Just (map EscapeIdentifier keys))
-    substWord ":values" = (placeholders, Just (map Escape vals))
-    substWord other = case BS.splitAt 2 other of
-      -- POST (form) parameter
-      ("f:", fieldName) -> ("?", pure . Escape <$> lookup fieldName bsFields)
-      -- GET (query/link or form) parameter
-      ("q:", fieldName) -> ("?", pure . Escape <$> join (lookup fieldName gq))
-      _ -> (other, Nothing)
-
 makeParams :: HT.Query -> [(String, String)]
 makeParams = mapMaybe makeParam
   where makeParam (k, Just v) = Just (BS.unpack k, BS.unpack v)
         makeParam _ = Nothing
 
-mkError :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] -> BS.ByteString
-mkError t kv = xmlElem t " xmlns=\"urn:x-pgxhtml\"" $
+errorXML :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString
+errorXML kv = xmlElem "error" " xmlns=\"urn:x-pgxhtml\"" $
   BS.concat $ map (\(k,v) -> xmlElem k "" v) kv
   where
     xmlElem n a s = BS.concat ["<", n, a, ">", s, "</", n, ">"]
 
-errorXML :: Error -> BS.ByteString
-errorXML (EOther m) = mkError "error" [("message", BS.pack m)]
-errorXML (EQuery (QueryError m (PT.Query q))) =
-  mkError "query_error" [("message", BS.pack m), ("query", q)]
-errorXML (EFormat (FormatError m (PT.Query q) p)) =
-  mkError "format_error" $ [("message", BS.pack m), ("query", q)]
-  ++ map ((,) "param") p
-errorXML (ESQL e) = mkError "sql_error"
-  [ ("state", sqlState e)
-  , ("status", BS.pack $ show $ sqlExecStatus e)
-  , ("message", sqlErrorMsg e)
-  , ("detail", sqlErrorDetail e)
-  , ("hint", sqlErrorHint e) ]
-errorXML (EResult e) = mkError "result_error" [("message", BS.pack $ errMessage e)]
-
 serve :: FilePath -> IO Connection -> Application
 serve xsltDirectory ioc req respond = do
   form' <- urlDecodeForm <$> strictRequestBody req
   case form' of
-    Left err -> respError notAcceptable406 $ EOther $
-      "Failed to read form data:" ++ T.unpack err
-    Right form -> case lookup "q" (queryString req) of
-      Just (Just q) -> do
-        let (q', params) = prepareQuery form qs q
-        flip catches [ Handler $ respError badRequest400 . ESQL
-                     , Handler $ respError badRequest400 . EFormat
-                     , Handler $ respError badRequest400 . EQuery
-                     , Handler $ respError badRequest400 . EResult
-                     ]
-          $ bracket ioc cancelAndClose $ \c -> do
-          r <- query c q' params
-          case r of
-            [Only xmlDoc] -> resp ok200 (unPgXmlString xmlDoc)
-            _ -> respError status500
-              (EOther "Expected a single result, got 0 or more")
-      _ -> respError imATeapot418 (EOther "No query is provided")
+    Left err -> respError notAcceptable406
+      [("message", BS.pack $ "Failed to read form data:" ++ T.unpack err)]
+    Right form -> case join $ lookup "q" $ queryString req of
+      Just q -> bracket ioc cancelAndClose $ \c -> do
+        (q', params) <- prepareQuery c
+          (map (encodeUtf8 *** encodeUtf8) $ formToFields form) qs q
+        r <- execParams c q'
+          (map (\p -> Just (invalidOid, p, Text)) params) Text
+        case r of
+          Just r' -> do
+            rs <- resultStatus r'
+            case rs of
+              TuplesOk -> do
+                -- TODO: add more checks and error messages
+                val <- getvalue r' 0 0
+                case val of
+                  Nothing -> respError status500
+                    [("message", "Failed to read query result")]
+                  Just val' -> resp ok200 val'
+              CommandOk ->
+                respError status500
+                  [("message", "The command didn't return XML")]
+              _ -> do
+                errMsg <- maybe [] (\m -> [("message", m)]) <$> errorMessage c
+                respError status500 $
+                  ("exec_status", BS.pack (show rs)) : errMsg
+          Nothing -> respError status500
+            [("message", "Failed to execute the query")]
+      _ -> respError imATeapot418 [("message", "No query is provided")]
   where
     qs = queryString req
     xsltPath = xsltDirectory
@@ -247,10 +264,10 @@ main = do
             =<< lookup hAuthorization (requestHeaders req)) of
         (True, Just (l, p)) ->
           serve xsltDir
-          (connect $ ConnectInfo "" 0 (BS.unpack l) (BS.unpack p) "")
+          (connectdb (connString [("user", l), ("password", p)]))
           req respond
         (True, Nothing) ->
           respond $ responseLBS unauthorized401
           [( hWWWAuthenticate
            , "Basic realm=\"Protected area\", charset=\"UTF-8\"")] ""
-        _ -> serve xsltDir (connectPostgreSQL "") req respond)
+        _ -> serve xsltDir (connectdb "") req respond)
diff --git a/example/common.xsl b/example/common.xsl
index 3a89d46..cc10c40 100644
--- a/example/common.xsl
+++ b/example/common.xsl
@@ -19,60 +19,21 @@
     </html>
   </xsl:template>
 
-  <xsl:template match="pgx:sql_error">
-    <h1>SQL error</h1>
-    <dl>
-      <dt>State</dt>
-      <dd><xsl:copy-of select="pgx:state/text()" /></dd>
-      <dt>Status</dt>
-      <dd><xsl:copy-of select="pgx:status/text()" /></dd>
-      <dt>Message</dt>
-      <dd><xsl:copy-of select="pgx:message/text()" /></dd>
-      <dt>Detail</dt>
-      <dd><xsl:copy-of select="pgx:detail/text()" /></dd>
-      <dt>Hint</dt>
-      <dd><xsl:copy-of select="pgx:hint/text()" /></dd>
-    </dl>
-  </xsl:template>
-
-  <xsl:template match="pgx:result_error">
-    <h1>Result error</h1>
-    <dl>
-      <dt>Message</dt>
-      <dd><xsl:copy-of select="pgx:message/text()" /></dd>
-    </dl>
-  </xsl:template>
-
-  <xsl:template match="pgx:query_error">
-    <h1>Query error</h1>
+  <xsl:template match="pgx:error">
+    <h1>Error</h1>
     <dl>
-      <dt>Message</dt>
-      <dd><xsl:copy-of select="pgx:message/text()" /></dd>
-      <dt>Query</dt>
-      <dd><xsl:copy-of select="pgx:query/text()" /></dd>
+      <xsl:apply-templates select="*" />
     </dl>
   </xsl:template>
 
-  <xsl:template match="pgx:format_error">
-    <h1>Format error</h1>
-    <dl>
-      <dt>Message</dt>
-      <dd><xsl:copy-of select="pgx:message/text()" /></dd>
-      <dt>Query</dt>
-      <dd><xsl:copy-of select="pgx:query/text()" /></dd>
-      <dt>Parameters</dt>
-      <xsl:for-each select="pgx:param">
-        <dd><xsl:copy-of select="text()" /></dd>
-      </xsl:for-each>
-    </dl>
+  <xsl:template match="pgx:message">
+    <dt>Message</dt>
+    <dd><pre><xsl:copy-of select="text()" /></pre></dd>
   </xsl:template>
 
-  <xsl:template match="pgx:error">
-    <h1>Error</h1>
-    <dl>
-      <dt>Message</dt>
-      <dd><xsl:copy-of select="pgx:message/text()" /></dd>
-    </dl>
+  <xsl:template match="pgx:exec_status">
+    <dt>ExecStatus</dt>
+    <dd><xsl:copy-of select="text()" /></dd>
   </xsl:template>
 
 </xsl:stylesheet>
diff --git a/pgxhtml.cabal b/pgxhtml.cabal
index 9f8adcc..0af9c36 100644
--- a/pgxhtml.cabal
+++ b/pgxhtml.cabal
@@ -23,7 +23,6 @@ executable pgxhtml
                      , http-types >=0.12 && <0.13
                      , network-uri >= 2.6.1.0
                      , postgresql-libpq >=0.9 && <0.10
-                     , postgresql-simple >=0.5 && <0.6
                      , text >=1.2 && <1.3
                      , unordered-containers >=0.2 && <0.3
                      , wai >=3.2 && <3.3