summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2019-02-03 21:42:35 +0300
committerdefanor <defanor@uberspace.net>2019-02-03 21:42:35 +0300
commit83a90895a5b6f1267ad272bfe23a6b604068d3c0 (patch)
tree8e9e59ac917c53a7c1921e6fcee14c35a7d0cae4
parent7bc223ad6408a36072b5196fbf0dcc7de15b0984 (diff)
Replace HXT with libxml
The primary issue is that str:encode-uri function from EXSLT is not available with HXT (but available with libxml's friends: libxslt and libexslt, which are generally more complete). This function is important for HTML documents. Another reason is libxml being better documented and somewhat easier to work with. Yet another reason to switch is the intent to avoid dependencies that reimplement common functionality, and/or normally get statically linked.
-rw-r--r--Main.hs136
-rw-r--r--example/bugs.sql2
-rw-r--r--example/common.xsl1
-rw-r--r--example/list.xsl21
-rw-r--r--example/view.xsl13
-rw-r--r--pgxhtml.cabal20
6 files changed, 121 insertions, 72 deletions
diff --git a/Main.hs b/Main.hs
index 979a960..e26cac6 100644
--- a/Main.hs
+++ b/Main.hs
@@ -28,11 +28,12 @@ HTTP basic authentication and PostgreSQL roles for authentication.
-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE ForeignFunctionInterface #-}
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 Data.Map.Lazy as M
import qualified Database.PostgreSQL.Simple.Types as PT
import Database.PostgreSQL.Simple
import Network.Wai
@@ -43,15 +44,6 @@ import Web.FormUrlEncoded (Form(..), urlDecodeForm)
import Database.PostgreSQL.Simple.ToField (Action (..))
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, 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.String (fromString)
import Data.Maybe (mapMaybe)
import Data.Text.Encoding (encodeUtf8)
import Network.Wai.Middleware.HttpAuth (extractBasicAuth)
@@ -63,18 +55,80 @@ import Control.Arrow ((***))
import Control.Exception (bracket, finally, catches, Handler(..))
import System.FilePath (replaceExtension, takeFileName, (</>))
import System.Envy (decodeEnv, FromEnv(..), envMaybe, (.!=))
+import Foreign
+import Foreign.C
-newtype PgXmlTree = PgXmlTree { unPgXmlTree :: XmlTree }
-instance FromField PgXmlTree where
+data XmlDoc
+data XmlSaveCtxt
+data XsltStylesheet
+data XsltTransformContext
+
+foreign import ccall "xmlReadMemory" xmlReadMemory ::
+ CString -> CInt -> CString -> CString -> CInt -> IO (Ptr XmlDoc)
+foreign import ccall "xmlFreeDoc" xmlFreeDoc :: Ptr XmlDoc -> IO ()
+foreign import ccall "xsltParseStylesheetFile" xsltParseStylesheetFile ::
+ CString -> IO (Ptr XsltStylesheet)
+foreign import ccall "xsltFreeStylesheet" xsltFreeStylesheet ::
+ Ptr XsltStylesheet -> IO ()
+foreign import ccall "xsltNewTransformContext" xsltNewTransformContext ::
+ Ptr XsltStylesheet -> Ptr XmlDoc -> IO (Ptr XsltTransformContext)
+foreign import ccall "xsltFreeTransformContext" xsltFreeTransformContext ::
+ Ptr XsltTransformContext -> IO ()
+foreign import ccall "xsltQuoteUserParams" xsltQuoteUserParams ::
+ Ptr XsltTransformContext -> Ptr CString -> IO CInt
+foreign import ccall "xsltApplyStylesheetUser" xsltApplyStylesheetUser ::
+ Ptr XsltStylesheet -> Ptr XmlDoc -> Ptr CString -> CString -> Ptr () ->
+ Ptr XsltTransformContext -> IO (Ptr XmlDoc)
+foreign import ccall "xsltSaveResultToString" xsltSaveResultToString ::
+ Ptr CString -> Ptr CInt -> Ptr XmlDoc -> Ptr XsltStylesheet -> IO CInt
+foreign import ccall "exsltRegisterAll" exsltRegisterAll :: IO ()
+
+transform :: BS.ByteString
+ -- ^ document
+ -> String
+ -- ^ base URI
+ -> FilePath
+ -- ^ path to stylesheet
+ -> [(String, String)]
+ -- ^ string params
+ -> IO BS.ByteString
+transform docBS baseStr pathStr stringParams =
+ BS.useAsCStringLen docBS $ \(docCStr, docCStrLen) ->
+ withCString baseStr $ \baseCStr ->
+ withCString pathStr $ \pathCStr ->
+ alloca $ \bufPtr ->
+ alloca $ \lenPtr ->
+ bracket (notNull $ xmlReadMemory docCStr (fromIntegral docCStrLen) baseCStr nullPtr 0)
+ xmlFreeDoc $ \doc ->
+ bracket (mapM newCString (concatMap (\(x, y) -> [x, y]) stringParams))
+ (mapM free) $ \params ->
+ withArray0 nullPtr params $ \paramsArr ->
+ withArray0 nullPtr [] $ \emptyArr ->
+ 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)
+ where
+ notNull :: IO (Ptr a) -> IO (Ptr a)
+ notNull a = a >>= \p -> if p == nullPtr
+ then error "Unexpected NULL pointer"
+ 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 $ PgXmlTree $
- mkRoot [] $ xreadDoc (stringTrim $ BS.unpack mdata)
+ else pure $ PgXmlString mdata
data EnvConfig = EnvConfig
{ connectionTimeout :: Int
@@ -98,12 +152,6 @@ formToFields = mapMaybe toField . HM.toList . unForm
where toField (f, [v]) = Just (f, v)
toField _ = Nothing
-xsltApplyStylesheetWParamsFromURI :: XPathParams -> String
- -> IOSArrow XmlTree XmlTree
-xsltApplyStylesheetWParamsFromURI par uri = replaceChildren
- $ arrL . applyStylesheetWParams par
- $< (constA uri >>> xsltCompileStylesheetFromURI)
-
cancelAndClose :: Connection -> IO (Maybe BS.ByteString)
cancelAndClose c = cancelConn `finally` close c
where cancelConn = withConnection c $ \conn -> do
@@ -137,33 +185,31 @@ prepareQuery f gq q = let sub = map substWord $ BS.words q
("q:", fieldName) -> ("?", pure . Escape <$> join (lookup fieldName gq))
_ -> (other, Nothing)
-makeParams :: HT.Query -> XPathParams
-makeParams = M.fromList . mapMaybe makeParam
- where makeParam (k, Just v) = Just ( ExName (BS.unpack k) ""
- , LiteralExpr (BS.unpack v))
+makeParams :: HT.Query -> [(String, String)]
+makeParams = mapMaybe makeParam
+ where makeParam (k, Just v) = Just (BS.unpack k, BS.unpack v)
makeParam _ = Nothing
-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
+mkError :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] -> BS.ByteString
+mkError t kv = xmlElem t " xmlns=\"urn:x-pgxhtml\"" $
+ BS.concat $ map (\(k,v) -> xmlElem k "" v) kv
where
- nsURI = "urn:x-pgxhtml"
+ xmlElem n a s = BS.concat ["<", n, a, ">", s, "</", n, ">"]
-errorXML :: Error -> XmlTree
-errorXML (EOther m) = mkError "error" [("message", m)]
+errorXML :: Error -> BS.ByteString
+errorXML (EOther m) = mkError "error" [("message", BS.pack m)]
errorXML (EQuery (QueryError m (PT.Query q))) =
- mkError "query_error" [("message", m), ("query", BS.unpack q)]
+ mkError "query_error" [("message", BS.pack m), ("query", q)]
errorXML (EFormat (FormatError m (PT.Query q) p)) =
- mkError "format_error" $ [("message", m), ("query", BS.unpack q)]
- ++ map ((,) "param" . BS.unpack) p
+ mkError "format_error" $ [("message", BS.pack m), ("query", q)]
+ ++ map ((,) "param") 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)]
+ [ ("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 :: EnvConfig -> IO Connection -> Application
serve conf ioc req respond = do
@@ -182,7 +228,7 @@ serve conf ioc req respond = do
$ bracket ioc cancelAndClose $ \c -> do
r <- query c q' params
case r of
- [Only xmlDoc] -> resp ok200 (unPgXmlTree xmlDoc)
+ [Only xmlDoc] -> resp ok200 (unPgXmlString xmlDoc)
_ -> respError status500
(EOther "Expected a single result, got 0 or more")
_ -> respError imATeapot418 (EOther "No query is provided")
@@ -192,17 +238,15 @@ serve conf ioc req respond = do
</> replaceExtension
(takeFileName (BS.unpack $ rawPathInfo req)) "xsl"
resp st xml = do
- rc <- runX $ constA xml
- >>> xsltApplyStylesheetWParamsFromURI (makeParams qs) xsltPath
- >>> writeDocumentToString [withOutputXHTML, withIndent True]
+ doc <- transform xml "" xsltPath (makeParams qs)
respond $ responseLBS st
[(hContentType, "application/xhtml+xml")]
- (fromString $ concat $
- "<?xml version=\"1.0\"?>\n" : "<!DOCTYPE html>\n" : rc)
+ (BL.fromStrict doc)
respError st e = resp st (errorXML e)
main :: IO ()
main = do
+ exsltRegisterAll
conf <- decodeEnv
case conf of
Left err -> putStrLn err
diff --git a/example/bugs.sql b/example/bugs.sql
index 033a1f7..eadb89a 100644
--- a/example/bugs.sql
+++ b/example/bugs.sql
@@ -30,7 +30,7 @@ as $$
|| 'where (project like ' || quote_literal('%' || proj || '%')
|| ') and (description like ' || quote_literal('%' || descr || '%')
|| ') order by reported desc limit ' || lim || ' offset ' || offs,
- false, false, 'bugs')
+ false, false, 'urn:x-bugs')
$$ language sql;
-- Now users can be added with select and/or insert privileges,
diff --git a/example/common.xsl b/example/common.xsl
index ff456a3..3a89d46 100644
--- a/example/common.xsl
+++ b/example/common.xsl
@@ -8,6 +8,7 @@
<xsl:output method="xml" indent="yes"/>
<xsl:template match="/">
+ <xsl:text disable-output-escaping='yes'>&lt;!DOCTYPE html&gt;</xsl:text>
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<title>Bugs</title>
diff --git a/example/list.xsl b/example/list.xsl
index 86c3150..f229e3e 100644
--- a/example/list.xsl
+++ b/example/list.xsl
@@ -2,7 +2,10 @@
<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
xmlns:xhtml="http://www.w3.org/1999/xhtml"
+ xmlns:bugs="urn:x-bugs"
+ xmlns:str="http://exslt.org/strings"
xmlns="http://www.w3.org/1999/xhtml"
+ extension-element-prefixes="str"
version="1.0">
<xsl:output method="xml" indent="yes"/>
<xsl:include href="common.xsl"/>
@@ -11,10 +14,10 @@
<xsl:param name="limit" select="10" />
<xsl:param name="offset" select="0" />
- <xsl:template match="table">
+ <xsl:template match="bugs:table">
<!-- Report form -->
<h2>Report</h2>
- <form method="post" action="view.xhtml?q=insert%20into%20bugs%20(%20:fields%20)%20values%20(%20:values%20)%20returning%20xmlelement(name%20table,xmlelement(name%20row,xmlelement(name%20id,id),xmlelement(name%20reported,reported),xmlelement(name%20reporter,reporter),xmlelement(name%20project,project),xmlelement(name%20description,description)))">
+ <form method="post" action="view.xhtml?q=insert%20into%20bugs%20(%20:fields%20)%20values%20(%20:values%20)%20returning%20xmlelement(name%20table,xmlattributes('urn:x-bugs'%20as%20xmlns),xmlelement(name%20row,xmlelement(name%20id,id),xmlelement(name%20reported,reported),xmlelement(name%20reporter,reporter),xmlelement(name%20project,project),xmlelement(name%20description,description)))">
<dl>
<dt><label for="report_project">Project</label></dt>
<dd>
@@ -70,18 +73,18 @@
<th>Project</th>
<th>Summary</th>
</tr>
- <xsl:for-each select="row">
+ <xsl:for-each select="bugs:row">
<tr>
- <td><xsl:copy-of select="reported/text()" /></td>
- <td><xsl:copy-of select="reporter/text()" /></td>
+ <td><xsl:copy-of select="bugs:reported/text()" /></td>
+ <td><xsl:copy-of select="bugs:reporter/text()" /></td>
<td>
- <a href="list.xhtml?q=select%20bug_search('{project/text()}','',{$limit},{$offset})">
- <xsl:copy-of select="project/text()" />
+ <a href="list.xhtml?q=select%20bug_search(%20q:project%20,'',{$limit},{$offset})&amp;project={str:encode-uri(bugs:project/text(), true())}">
+ <xsl:copy-of select="bugs:project/text()" />
</a>
</td>
<td>
- <a href="view.xhtml?q=select%20query_to_xml('select%20*%20from%20bugs%20where%20id=''{id}''',false,false,'foo')">
- <xsl:copy-of select="summary/text()" />
+ <a href="view.xhtml?q=select%20query_to_xml('select%20*%20from%20bugs%20where%20id=''{bugs:id}''',false,false,'urn:x-bugs')">
+ <xsl:copy-of select="bugs:summary/text()" />
</a>
</td>
</tr>
diff --git a/example/view.xsl b/example/view.xsl
index af0e090..84a9d5a 100644
--- a/example/view.xsl
+++ b/example/view.xsl
@@ -2,24 +2,25 @@
<xsl:stylesheet xmlns:xsl="http://www.w3.org/1999/XSL/Transform"
xmlns:xhtml="http://www.w3.org/1999/xhtml"
+ xmlns:bugs="urn:x-bugs"
xmlns="http://www.w3.org/1999/xhtml"
version="1.0">
<xsl:output method="xml" indent="yes"/>
<xsl:include href="common.xsl"/>
- <xsl:template match="table/row">
+ <xsl:template match="bugs:table/bugs:row">
<a href="list.xhtml?q=select%20bug_search(%27%27,%20%27%27,%2010,%200)">back to listing</a>
<dl>
<dt>ID</dt>
- <dd><xsl:copy-of select="id/text()" /></dd>
+ <dd><xsl:copy-of select="bugs:id/text()" /></dd>
<dt>Reported</dt>
- <dd><xsl:copy-of select="reported/text()" /></dd>
+ <dd><xsl:copy-of select="bugs:reported/text()" /></dd>
<dt>Reporter</dt>
- <dd><xsl:copy-of select="reporter/text()" /></dd>
+ <dd><xsl:copy-of select="bugs:reporter/text()" /></dd>
<dt>Project</dt>
- <dd><xsl:copy-of select="project/text()" /></dd>
+ <dd><xsl:copy-of select="bugs:project/text()" /></dd>
<dt>Description</dt>
- <dd><pre><xsl:copy-of select="description/text()" /></pre></dd>
+ <dd><pre><xsl:copy-of select="bugs:description/text()" /></pre></dd>
</dl>
</xsl:template>
diff --git a/pgxhtml.cabal b/pgxhtml.cabal
index 6430b31..78de784 100644
--- a/pgxhtml.cabal
+++ b/pgxhtml.cabal
@@ -18,20 +18,20 @@ executable pgxhtml
other-extensions: OverloadedStrings
build-depends: base >=4.9 && <5
, bytestring >=0.10 && <0.11
- , unordered-containers >=0.2 && <0.3
- , text >=1.2 && <1.3
, containers >=0.5 && <0.6
- , postgresql-simple >=0.5 && <0.6
- , postgresql-libpq >=0.9 && <0.10
- , http-types >=0.12 && <0.13
- , hxt >=9.3 && <9.4
- , hxt-xslt >=9.1 && <9.2
+ , envy >=1.5 && <1.6
+ , filepath >=1.4 && <1.5
, http-api-data >=0.3 && <0.4
+ , 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
- , wai-extra >=3.0 && <3.1
, wai-cli >=0.1 && <0.2
+ , wai-extra >=3.0 && <3.1
, warp >=3.2 && <3.3
- , filepath >=1.4 && <1.5
- , envy >=1.5 && <1.6
default-language: Haskell2010
+ pkgconfig-depends: libxml-2.0, libxslt, libexslt
ghc-options: -Wall