From 83a90895a5b6f1267ad272bfe23a6b604068d3c0 Mon Sep 17 00:00:00 2001 From: defanor Date: Sun, 3 Feb 2019 21:42:35 +0300 Subject: 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. --- Main.hs | 136 +++++++++++++++++++++++++++++++++++------------------ example/bugs.sql | 2 +- example/common.xsl | 1 + example/list.xsl | 21 +++++---- example/view.xsl | 13 ++--- pgxhtml.cabal | 20 ++++---- 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, ""] -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 $ - "\n" : "\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 @@ + <!DOCTYPE html> Bugs 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 @@ @@ -11,10 +14,10 @@ - +

Report

-
+
@@ -70,18 +73,18 @@ Project Summary - + - - + + - - + + - - + + 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 @@ - + back to listing
ID
-
+
Reported
-
+
Reporter
-
+
Project
-
+
Description
-
+
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 -- cgit v1.2.3