summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordefanor <defanor@uberspace.net>2019-02-09 10:50:08 +0300
committerdefanor <defanor@uberspace.net>2019-02-09 10:50:08 +0300
commit330f68012df0aa5c215a99924bd9b5a343512499 (patch)
tree4813987a72811d5c7ed70755098a43e34356b08e
parenta5ffe01c8806b720a99569dd407a4b14a67693e3 (diff)
downloadpgxhtml-330f68012df0aa5c215a99924bd9b5a343512499.zip
pgxhtml-330f68012df0aa5c215a99924bd9b5a343512499.tar.gz
pgxhtml-330f68012df0aa5c215a99924bd9b5a343512499.tar.bz2
Handle media-type
Defaulting to application/xhtml+xml, but the xsl:output media-type attribute can now be set to change that.
-rw-r--r--Main.hsc (renamed from Main.hs)24
-rw-r--r--pgxhtml.cabal1
2 files changed, 19 insertions, 6 deletions
diff --git a/Main.hs b/Main.hsc
index 5128c3a..c8cf99b 100644
--- a/Main.hs
+++ b/Main.hsc
@@ -30,6 +30,8 @@ HTTP basic authentication and PostgreSQL roles for authentication.
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ForeignFunctionInterface #-}
+#include <libxslt/xsltInternals.h>
+
import qualified Data.ByteString.Char8 as BS
import Database.PostgreSQL.LibPQ
(getCancel, cancel, connectdb, finish, execParams, getvalue, invalidOid,
@@ -84,7 +86,7 @@ transform :: BS.ByteString
-- ^ path to stylesheet
-> [(BS.ByteString, BS.ByteString)]
-- ^ string params
- -> IO BS.ByteString
+ -> IO (BS.ByteString, Maybe BS.ByteString)
transform docBS baseStr pathStr stringParams =
BS.useAsCStringLen docBS $ \(docCStr, docCStrLen) ->
withCString baseStr $ \baseCStr ->
@@ -106,9 +108,12 @@ transform docBS baseStr pathStr stringParams =
bracket
(notNull $ xsltApplyStylesheetUser stylesheet doc emptyArr nullPtr nullPtr tc)
xmlFreeDoc
- (\res ->
- xsltSaveResultToString bufPtr lenPtr res stylesheet >>
- bracket (peek bufPtr) free BS.packCString)
+ (\res -> do
+ xsltSaveResultToString bufPtr lenPtr res stylesheet
+ bracket (peek bufPtr) free $ \resultCStr -> do
+ resultBS <- BS.packCString resultCStr
+ mt <- mediaType stylesheet
+ pure (resultBS, mt))
where
useAsCStrings :: [BS.ByteString] -> [CString] -> ([CString] -> IO a) -> IO a
useAsCStrings [] a f = f a
@@ -118,6 +123,12 @@ transform docBS baseStr pathStr stringParams =
notNull a = a >>= \p -> if p == nullPtr
then error "Unexpected NULL pointer"
else pure p
+ mediaType :: Ptr XsltStylesheet -> IO (Maybe BS.ByteString)
+ mediaType pXslt = do
+ mt <- (#peek xsltStylesheet, mediaType) pXslt
+ if mt == nullPtr
+ then pure Nothing
+ else Just <$> BS.packCString mt
-- TODO: improve error handling
@@ -231,7 +242,6 @@ baCredentials cred = do
respond' :: Int -> [String] -> BS.ByteString -> IO ()
respond' code headers content = do
- putStrLn "Content-Type:application/xhtml+xml"
mapM_ putStrLn headers
putStrLn $ concat ["Status:", show code, " ", reason, "\n"]
BS.putStr content
@@ -285,7 +295,9 @@ serve xsltDirectory ioc ps = case lookup "q" ps of
takeFileName (BS.unpack $ fromMaybe "default" $ lookup "t" ps)
<.> "xsl"
resp st xml = do
- doc <- transform xml "" xsltPath ps
+ (doc, mt) <- transform xml "" xsltPath ps
+ BS.putStrLn $ BS.append "Content-Type:" $
+ fromMaybe "application/xhtml+xml" mt
respond st doc
respError st e = resp st (errorXML e)
diff --git a/pgxhtml.cabal b/pgxhtml.cabal
index 204d4e0..9697382 100644
--- a/pgxhtml.cabal
+++ b/pgxhtml.cabal
@@ -24,3 +24,4 @@ executable pgxhtml
default-language: Haskell2010
pkgconfig-depends: libxml-2.0, libxslt, libexslt
ghc-options: -Wall
+ build-tools: hsc2hs