diff options
-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> |