summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2019-01-15 16:03:31 +0300
committerdefanor <defanor@uberspace.net>2019-01-15 16:03:31 +0300
commit7bc223ad6408a36072b5196fbf0dcc7de15b0984 (patch)
tree6dd7815ddb270428a756c09656576ec63e0d303d
parent8cf0dd8156e4f51dc731650caf12366e3b736b76 (diff)
downloadpgxhtml-7bc223ad6408a36072b5196fbf0dcc7de15b0984.zip
pgxhtml-7bc223ad6408a36072b5196fbf0dcc7de15b0984.tar.gz
pgxhtml-7bc223ad6408a36072b5196fbf0dcc7de15b0984.tar.bz2
Improve error messages
- ResultError gets handled now - No plain textual messages anymore - An XML namespace is set, though an experimental one Maybe the serialization should be changed to simplify templating. It would also be nice to specify the schema (e.g., with relax ng), host it, and use its URI for the namespace.
-rw-r--r--Main.hs112
-rw-r--r--example/common.xsl57
2 files changed, 100 insertions, 69 deletions
diff --git a/Main.hs b/Main.hs
index 25126ed..979a960 100644
--- a/Main.hs
+++ b/Main.hs
@@ -45,14 +45,12 @@ import Database.PostgreSQL.Simple.Internal (withConnection)
import Database.PostgreSQL.LibPQ (getCancel, cancel)
import Text.XML.HXT.Core
(IOSArrow, replaceChildren, arrL, ($<), constA, runX,
- writeDocumentToString, withOutputXHTML, withIndent, stringTrim,
- XNode(..), mkName)
-import Text.XML.HXT.DOM.XmlNode (mkRoot)
+ writeDocumentToString, withOutputXHTML, withIndent, stringTrim, mkQName)
+import Text.XML.HXT.DOM.XmlNode (mkRoot, mkElement, mkText)
import Text.XML.HXT.Parser.XmlParsec (xreadDoc)
import Text.XML.HXT.XSLT.Application (XPathParams, applyStylesheetWParams)
import Text.XML.HXT.XSLT.XsltArrows (xsltCompileStylesheetFromURI)
import Text.XML.HXT.XSLT.Common (XmlTree, ExName(..), Expr(..), (>>>))
-import Data.Tree.Class (mkTree)
import Data.String (fromString)
import Data.Maybe (mapMaybe)
import Data.Text.Encoding (encodeUtf8)
@@ -89,6 +87,12 @@ instance FromEnv EnvConfig where
fromEnv =
EnvConfig <$> envMaybe "TIMEOUT" .!= 10 <*> envMaybe "XSLT_DIR" .!= ""
+data Error = ESQL SqlError
+ | EFormat FormatError
+ | EQuery QueryError
+ | EResult ResultError
+ | EOther String
+
formToFields :: Form -> [(T.Text, T.Text)]
formToFields = mapMaybe toField . HM.toList . unForm
where toField (f, [v]) = Just (f, v)
@@ -139,73 +143,63 @@ makeParams = M.fromList . mapMaybe makeParam
, LiteralExpr (BS.unpack v))
makeParam _ = Nothing
-mkAttr :: String -> String -> XmlTree
-mkAttr k v = mkTree (XAttr $ mkName k) [mkTree (XText v) []]
-
-sqlErrorXML :: PT.Query -> [Action] -> SqlError -> XmlTree
-sqlErrorXML q p e = mkRoot []
- [mkTree (XTag (mkName "sql_error")
- [ mkAttr "template" (show q)
- , mkAttr "parameters" (show p)
- , mkAttr "state" (BS.unpack $ sqlState e)
- , mkAttr "status" (show $ sqlExecStatus e)
- , mkAttr "message" (BS.unpack $ sqlErrorMsg e)
- , mkAttr "detail" (BS.unpack $ sqlErrorDetail e)
- , mkAttr "hint" (BS.unpack $ sqlErrorHint e)
- ])
- []]
-
--- todo: perhaps encode parameters separately, as an array
-formatErrorXML :: FormatError -> XmlTree
-formatErrorXML (FormatError m (PT.Query q) p) = mkRoot []
- [mkTree (XTag (mkName "format_error")
- [ mkAttr "message" m
- , mkAttr "query" (BS.unpack q)
- , mkAttr "params" (show p)
- ])
- []]
-
-queryErrorXML :: QueryError -> XmlTree
-queryErrorXML (QueryError m (PT.Query q)) = mkRoot []
- [mkTree (XTag (mkName "query_error")
- [ mkAttr "message" m
- , mkAttr "query" (BS.unpack q)
- ])
- []]
+mkError :: String -> [(String, String)] -> XmlTree
+mkError t kv = mkRoot [] . pure $
+ mkElement (mkQName "px" t nsURI) [] $
+ map (\(k,v) -> mkElement (mkQName "px" k nsURI) [] [mkText v]) kv
+ where
+ nsURI = "urn:x-pgxhtml"
+
+errorXML :: Error -> XmlTree
+errorXML (EOther m) = mkError "error" [("message", m)]
+errorXML (EQuery (QueryError m (PT.Query q))) =
+ mkError "query_error" [("message", m), ("query", BS.unpack q)]
+errorXML (EFormat (FormatError m (PT.Query q) p)) =
+ mkError "format_error" $ [("message", m), ("query", BS.unpack q)]
+ ++ map ((,) "param" . BS.unpack) p
+errorXML (ESQL e) = mkError "sql_error" $
+ [ ("state", BS.unpack $ sqlState e)
+ , ("status", show $ sqlExecStatus e)
+ , ("message", BS.unpack $ sqlErrorMsg e)
+ , ("detail", BS.unpack $ sqlErrorDetail e)
+ , ("hint", BS.unpack $ sqlErrorHint e) ]
+errorXML (EResult e) = mkError "result_error" [("message", errMessage e)]
serve :: EnvConfig -> IO Connection -> Application
serve conf ioc req respond = do
form' <- urlDecodeForm <$> strictRequestBody req
case form' of
- Left _err -> respond $ responseLBS notAcceptable406 []
- "Failed to read form data"
+ 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 qs = queryString req
- (q', params) = prepareQuery form qs q
- xsltPath = xsltDirectory conf
- </> replaceExtension
- (takeFileName (BS.unpack $ rawPathInfo req)) "xsl"
- resp st xml = do
- rc <- runX $ constA xml
- >>> xsltApplyStylesheetWParamsFromURI (makeParams qs) xsltPath
- >>> writeDocumentToString [withOutputXHTML, withIndent True]
- respond $ responseLBS st
- [(hContentType, "application/xhtml+xml")]
- (fromString $ concat $
- "<?xml version=\"1.0\"?>\n" : "<!DOCTYPE html>\n" : rc)
- flip catches [ Handler $ resp badRequest400 . sqlErrorXML q' params
- , Handler $ resp badRequest400 . formatErrorXML
- , Handler $ resp badRequest400 . queryErrorXML
- -- todo: handle ResultError as well
+ 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 (unPgXmlTree xmlDoc)
- _ -> respond $ responseLBS status500 []
- "Expected a single result, got 0 or more"
- _ -> respond $ responseLBS imATeapot418 [] "No query is provided"
+ _ -> respError status500
+ (EOther "Expected a single result, got 0 or more")
+ _ -> respError imATeapot418 (EOther "No query is provided")
+ where
+ qs = queryString req
+ xsltPath = xsltDirectory conf
+ </> replaceExtension
+ (takeFileName (BS.unpack $ rawPathInfo req)) "xsl"
+ resp st xml = do
+ rc <- runX $ constA xml
+ >>> xsltApplyStylesheetWParamsFromURI (makeParams qs) xsltPath
+ >>> writeDocumentToString [withOutputXHTML, withIndent True]
+ respond $ responseLBS st
+ [(hContentType, "application/xhtml+xml")]
+ (fromString $ concat $
+ "<?xml version=\"1.0\"?>\n" : "<!DOCTYPE html>\n" : rc)
+ respError st e = resp st (errorXML e)
main :: IO ()
main = do
diff --git a/example/common.xsl b/example/common.xsl
index 1db0229..ff456a3 100644
--- a/example/common.xsl
+++ b/example/common.xsl
@@ -2,6 +2,7 @@
<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
xmlns:xhtml="http://www.w3.org/1999/xhtml"
+ xmlns:pgx="urn:x-pgxhtml"
xmlns="http://www.w3.org/1999/xhtml"
version="1.0">
<xsl:output method="xml" indent="yes"/>
@@ -17,23 +18,59 @@
</html>
</xsl:template>
- <xsl:template match="sql_error">
+ <xsl:template match="pgx:sql_error">
<h1>SQL error</h1>
<dl>
<dt>State</dt>
- <dd><xsl:copy-of select="@state/text()" /></dd>
+ <dd><xsl:copy-of select="pgx:state/text()" /></dd>
<dt>Status</dt>
- <dd><xsl:copy-of select="@status/text()" /></dd>
+ <dd><xsl:copy-of select="pgx:status/text()" /></dd>
<dt>Message</dt>
- <dd><xsl:copy-of select="@message/text()" /></dd>
+ <dd><xsl:copy-of select="pgx:message/text()" /></dd>
<dt>Detail</dt>
- <dd><xsl:copy-of select="@detail/text()" /></dd>
+ <dd><xsl:copy-of select="pgx:detail/text()" /></dd>
<dt>Hint</dt>
- <dd><xsl:copy-of select="@hint/text()" /></dd>
- <dt>Query template</dt>
- <dd><xsl:copy-of select="@template/text()" /></dd>
- <dt>Query parameters</dt>
- <dd><xsl:copy-of select="@parameters/text()" /></dd>
+ <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>
+ <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>
+ </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>
+
+ <xsl:template match="pgx:error">
+ <h1>Error</h1>
+ <dl>
+ <dt>Message</dt>
+ <dd><xsl:copy-of select="pgx:message/text()" /></dd>
</dl>
</xsl:template>