diff options
-rw-r--r-- | Main.hs | 136 | ||||
-rw-r--r-- | example/bugs.sql | 2 | ||||
-rw-r--r-- | example/common.xsl | 1 | ||||
-rw-r--r-- | example/list.xsl | 21 | ||||
-rw-r--r-- | example/view.xsl | 13 | ||||
-rw-r--r-- | pgxhtml.cabal | 20 |
6 files changed, 121 insertions, 72 deletions
@@ -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'><!DOCTYPE html></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})&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 |