module Happstack.Server.XSLT
(xsltFile, xsltString, xsltFPS, xsltFPSIO, XSLPath,
xslt, doXslt, xsltproc,saxon,procFPSIO,procLBSIO,XSLTCommand,XSLTCmd
) where
import System.Log.Logger
import Control.Concurrent (forkIO)
import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
import Control.Monad
import Control.Monad.Trans
import qualified Data.ByteString.Char8 as B
import Happstack.Server.SimpleHTTP
import Happstack.Server.Types
import Control.Exception.Extensible(bracket,try,SomeException)
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import System.Directory(removeFile)
import System.Environment(getEnv)
import System.Exit (ExitCode(..))
import System.IO
import System.IO.Unsafe(unsafePerformIO)
import System.Process (runInteractiveProcess, waitForProcess)
import Happstack.Data hiding (Element)
logMX :: Priority -> String -> IO ()
logMX = logM "Happstack.Server.XSLT"
type XSLPath = FilePath
$(deriveAll [''Show,''Read,''Default, ''Eq, ''Ord]
[d|
data XSLTCmd = XSLTProc | Saxon
|]
)
xsltCmd :: XSLTCmd
-> XSLPath
-> FilePath
-> FilePath
-> (FilePath, [String])
xsltCmd XSLTProc = xsltproc'
xsltCmd Saxon = saxon'
procLBSIO :: XSLTCmd -> XSLPath -> L.ByteString -> IO L.ByteString
procLBSIO xsltp' xsl inp =
withTempFile "happs-src.xml" $ \sfp sh -> do
withTempFile "happs-dst.xml" $ \dfp dh -> do
let xsltp = xsltCmd xsltp'
L.hPut sh inp
hClose sh
hClose dh
xsltFileEx xsltp xsl sfp dfp
s <- L.readFile dfp
logMX DEBUG (">>> XSLT: result: "++ show s)
return s
procFPSIO :: XSLTCommand
-> XSLPath
-> [P.ByteString]
-> IO [P.ByteString]
procFPSIO xsltp xsl inp =
withTempFile "happs-src.xml" $ \sfp sh -> do
withTempFile "happs-dst.xml" $ \dfp dh -> do
mapM_ (P.hPut sh) inp
hClose sh
hClose dh
xsltFileEx xsltp xsl sfp dfp
s <- P.readFile dfp
logMX DEBUG (">>> XSLT: result: "++ show s)
return [s]
xsltFPS :: XSLPath -> [P.ByteString] -> [P.ByteString]
xsltFPS xsl = unsafePerformIO . xsltFPSIO xsl
xsltFPSIO :: XSLPath -> [P.ByteString] -> IO [P.ByteString]
xsltFPSIO xsl inp =
withTempFile "happs-src.xml" $ \sfp sh -> do
withTempFile "happs-dst.xml" $ \dfp dh -> do
mapM_ (P.hPut sh) inp
hClose sh
hClose dh
xsltFile xsl sfp dfp
s <- P.readFile dfp
logMX DEBUG (">>> XSLT: result: "++ show s)
return [s]
xsltString :: XSLPath -> String -> String
xsltString xsl inp = unsafePerformIO $
withTempFile "happs-src.xml" $ \sfp sh -> do
withTempFile "happs-dst.xml" $ \dfp dh -> do
hPutStr sh inp
hClose sh
hClose dh
xsltFile xsl sfp dfp
s <- readFileStrict dfp
logMX DEBUG (">>> XSLT: result: "++ show s)
return s
xsltFile :: XSLPath -> FilePath -> FilePath -> IO ()
xsltFile = xsltFileEx xsltproc'
xsltproc :: XSLTCmd
xsltproc = XSLTProc
xsltproc' :: XSLTCommand
xsltproc' dst xsl src = ("xsltproc",["-o",dst,xsl,src])
saxon :: XSLTCmd
saxon = Saxon
saxon' :: XSLTCommand
saxon' dst xsl src = ("java -classpath /usr/share/java/saxon.jar",
["com.icl.saxon.StyleSheet"
,"-o",dst,src,xsl])
type XSLTCommand = XSLPath -> FilePath -> FilePath -> (FilePath,[String])
xsltFileEx :: XSLTCommand -> XSLPath -> FilePath -> FilePath -> IO ()
xsltFileEx xsltp xsl src dst = do
let msg = (">>> XSLT: Starting xsltproc " ++ unwords ["-o",dst,xsl,src])
logMX DEBUG msg
uncurry runCommand $ xsltp dst xsl src
logMX DEBUG (">>> XSLT: xsltproc done")
withTempFile :: String -> (FilePath -> Handle -> IO a) -> IO a
withTempFile str hand = bracket (openTempFile tempDir str) (removeFile . fst) (uncurry hand)
readFileStrict :: FilePath -> IO String
readFileStrict fp = do
let fseqM [] = return []
fseqM xs = last xs `seq` return xs
fseqM =<< readFile fp
tempDir :: FilePath
tempDir = unsafePerformIO $ tryAny [getEnv "TEMP",getEnv "TMP"] err
where err = return "/tmp"
tryAny :: [IO a] -> IO a -> IO a
tryAny [] c = c
tryAny (x:xs) c = either (\(_::SomeException) -> tryAny xs c) return =<< try x
xslt :: (MonadIO m, MonadPlus m, ToMessage r) =>
XSLTCmd
-> XSLPath
-> m r
-> m Response
xslt cmd xslPath parts = do
res <- parts
if toContentType res == B.pack "application/xml"
then doXslt cmd xslPath (toResponse res)
else return (toResponse res)
doXslt :: (MonadIO m) =>
XSLTCmd -> XSLPath -> Response -> m Response
doXslt cmd xslPath res =
do new <- liftIO $ procLBSIO cmd xslPath $ rsBody res
return $ setHeader "Content-Type" "text/html" $
setHeader "Content-Length" (show $ L.length new) $
res { rsBody = new }
runCommand :: String -> [String] -> IO ()
runCommand cmd args = do
(_, outP, errP, pid) <- runInteractiveProcess cmd args Nothing Nothing
let pGetContents h = do mv <- newEmptyMVar
let put [] = putMVar mv []
put xs = last xs `seq` putMVar mv xs
forkIO (hGetContents h >>= put)
takeMVar mv
os <- pGetContents outP
es <- pGetContents errP
ec <- waitForProcess pid
case ec of
ExitSuccess -> return ()
ExitFailure e ->
do hPutStrLn stderr ("Running process "++unwords (cmd:args)++" FAILED ("++show e++")")
hPutStrLn stderr os
hPutStrLn stderr es
hPutStrLn stderr "Raising error..."
fail "Running external command failed"