diff options
author | defanor <defanor@uberspace.net> | 2019-01-15 16:03:31 +0300 |
---|---|---|
committer | defanor <defanor@uberspace.net> | 2019-01-15 16:03:31 +0300 |
commit | 7bc223ad6408a36072b5196fbf0dcc7de15b0984 (patch) | |
tree | 6dd7815ddb270428a756c09656576ec63e0d303d | |
parent | 8cf0dd8156e4f51dc731650caf12366e3b736b76 (diff) |
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.hs | 112 | ||||
-rw-r--r-- | example/common.xsl | 57 |
2 files changed, 100 insertions, 69 deletions
@@ -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> |