From 330f68012df0aa5c215a99924bd9b5a343512499 Mon Sep 17 00:00:00 2001 From: defanor Date: Sat, 9 Feb 2019 10:50:08 +0300 Subject: Handle media-type Defaulting to application/xhtml+xml, but the xsl:output media-type attribute can now be set to change that. --- Main.hsc | 321 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 321 insertions(+) create mode 100644 Main.hsc (limited to 'Main.hsc') diff --git a/Main.hsc b/Main.hsc new file mode 100644 index 0000000..c8cf99b --- /dev/null +++ b/Main.hsc @@ -0,0 +1,321 @@ +{- +pgxhtml, an XSLT-based PostgreSQL web interface. +Copyright (C) 2018-2019 defanor + +This program is free software: you can redistribute it and/or modify +it under the terms of the GNU Affero General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU Affero General Public License for more details. + +You should have received a copy of the GNU Affero General Public License +along with this program. If not, see . +-} + +{- | +Description : XSLT-based PostgreSQL web interface +Maintainer : defanor +Stability : unstable +Portability : non-portable (uses GHC extensions) + +This is a tool to make custom web (HTTP with XHTML) interfaces to +PostgreSQL databases, using XSLT for templating and SQL for querying, +HTTP basic authentication and PostgreSQL roles for authentication. +-} + +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +#include + +import qualified Data.ByteString.Char8 as BS +import Database.PostgreSQL.LibPQ + (getCancel, cancel, connectdb, finish, execParams, getvalue, invalidOid, + escapeIdentifier, resultStatus, errorMessage, Connection, Format(..), + ExecStatus(..)) +import Data.Maybe (mapMaybe, fromMaybe, catMaybes, fromJust) +import System.Timeout (timeout) +import Control.Exception (bracket, finally) +import System.FilePath (takeFileName, (), (<.>)) +import System.Environment (lookupEnv) +import Data.List (nubBy) +import Data.ByteString.Base64 (decodeLenient) +import Data.Char (ord, chr) +import Foreign +import Foreign.C + + +-- * libxml bindings and functions + +-- http://xmlsoft.org/html/index.html +-- http://xmlsoft.org/XSLT/html/index.html + +data XmlDoc +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 + -> [(BS.ByteString, BS.ByteString)] + -- ^ string params + -> IO (BS.ByteString, Maybe 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 -> + useAsCStrings (concatMap (\(x, y) -> [x, y]) $ + nubBy (\x y -> fst x == fst y) stringParams) [] $ \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 -> 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 + useAsCStrings (x:xs) a f = BS.useAsCString x $ \x' -> + useAsCStrings xs (a ++ [x']) f + notNull :: IO (Ptr a) -> IO (Ptr a) + 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 + + +-- * PostgreSQL-related functions + +connString :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString +connString [] = BS.empty +connString ((k,v):xs) = + BS.concat [k, "='", BS.pack (val $ BS.unpack v), "' ", connString xs] + where val [] = [] + val ('\\':cs) = '\\' : '\\' : val cs + val ('\'':cs) = '\\' : '\'' : val cs + val (c:cs) = c : val cs + +-- https://www.postgresql.org/docs/11/libpq-exec.html +-- https://hackage.haskell.org/package/postgresql-libpq-0.9.4.2/docs/Database-PostgreSQL-LibPQ.html +prepareQuery :: Connection + -> [(BS.ByteString, BS.ByteString)] + -- ^ Form data + -> [(BS.ByteString, BS.ByteString)] + -- ^ URL query + -> BS.ByteString + -- ^ SQL query template + -> IO (BS.ByteString, [BS.ByteString]) + -- ^ SQL query template and parameters +prepareQuery c f gq q = substWords [] [] $ BS.words q + where + placeholder :: Int -> BS.ByteString + placeholder n = BS.cons '$' $ BS.pack $ show $ n + 1 + placeholders :: Int -> BS.ByteString + placeholders cnt = BS.intercalate " , " + [placeholder (cnt + n) | n <- [0 .. length f - 1]] + substWords :: [BS.ByteString] + -- ^ query bits + -> [BS.ByteString] + -- ^ parameters + -> [BS.ByteString] + -- ^ remaining words + -> IO (BS.ByteString, [BS.ByteString]) + -- ^ query and parameters + substWords qs ps [] = pure (BS.unwords qs, ps) + substWords qs ps (":fields":rest) = do + identifiers <- BS.intercalate ", " . catMaybes + <$> mapM (escapeIdentifier c . fst) f + substWords (qs ++ [identifiers]) ps rest + substWords qs ps (":values":rest) = + substWords (qs ++ [placeholders $ length ps]) (ps ++ map snd f) rest + substWords qs ps (other:rest) = case BS.splitAt 2 other of + -- POST (form) parameter + ("f:", fieldName) -> case lookup fieldName f of + Nothing -> substWords (qs ++ [other]) ps rest + Just v -> substWords (qs ++ [placeholder $ length ps]) (ps ++ [v]) rest + -- GET (query/link or form) parameter + ("q:", fieldName) -> case lookup fieldName gq of + Nothing -> substWords (qs ++ [other]) ps rest + Just v -> substWords (qs ++ [placeholder $ length ps]) (ps ++ [v]) rest + _ -> substWords (qs ++ [other]) ps rest + +cancelAndClose :: Connection -> IO (Maybe BS.ByteString) +cancelAndClose c = cancelConn `finally` finish c + where cancelConn = do + cl <- getCancel c + case cl of + Nothing -> pure $ Just "Failed to get a Cancel structure" + Just cl' -> either Just (const Nothing) <$> cancel cl' + + +-- * CGI and HTTP utilities + +-- https://tools.ietf.org/html/rfc3875 +-- https://tools.ietf.org/html/rfc2396 + +-- https://www.w3.org/TR/html5/sec-forms.html +-- https://url.spec.whatwg.org/ +parseFormUrlencoded :: BS.ByteString -> [(BS.ByteString, BS.ByteString)] +parseFormUrlencoded s = mapMaybe seq2nv $ BS.split '&' s + where + seq2nv sq + | BS.null sq = Nothing + | otherwise = let (n, v') = BS.break (== '=') sq + v = if BS.null v' then v' else BS.tail v' + in Just (unescape n, unescape v) + unescape :: BS.ByteString -> BS.ByteString + unescape bs = case BS.uncons bs of + Nothing -> bs + Just ('+', rest) -> BS.cons ' ' (unescape rest) + Just ('%', rest) -> case BS.uncons rest of + Nothing -> BS.pack ['%'] + Just (c1, rest') -> case BS.uncons rest' of + Nothing -> BS.pack ['%', c1] + Just (c2, rest'') -> case (parseChar c1, parseChar c2) of + (Just c1', Just c2') -> + BS.cons (chr $ c1' * 0x10 + c2') (unescape rest'') + _ -> BS.cons '%' (unescape rest) + Just (c, rest) -> BS.cons c (unescape rest) + parseChar :: Char -> Maybe Int + parseChar c + | c >= 'A' && c <= 'F' = Just $ ord c - ord 'A' + 10 + | c >= '0' && c <= '9' = Just $ ord c - ord '0' + | otherwise = Nothing + +-- https://tools.ietf.org/html/rfc7235 +-- https://tools.ietf.org/html/rfc7617 +baCredentials :: BS.ByteString -> Maybe (BS.ByteString, BS.ByteString) +baCredentials cred = do + (login, password) <- + BS.break (== ':') . decodeLenient <$> BS.stripPrefix "Basic " cred + if BS.length password > 0 + then Just (login, BS.tail password) + else Nothing + +respond' :: Int -> [String] -> BS.ByteString -> IO () +respond' code headers content = do + mapM_ putStrLn headers + putStrLn $ concat ["Status:", show code, " ", reason, "\n"] + BS.putStr content + where + reason = case code of + 200 -> "OK" + 401 -> "Unauthorized" + 418 -> "I'm a teapot" + 504 -> "Gateway Timeout" + _ -> "" + +respond :: Int -> BS.ByteString -> IO () +respond c = respond' c [] + + +-- * Main routines + +errorXML :: [(BS.ByteString, BS.ByteString)] -> BS.ByteString +errorXML kv = xmlElem "error" " xmlns=\"urn:x-pgxhtml\"" $ + BS.concat $ map (\(k,v) -> xmlElem k "" v) kv + where + xmlElem n a s = BS.concat ["<", n, a, ">", s, ""] + +serve :: FilePath -> IO Connection -> [(BS.ByteString, BS.ByteString)] -> IO () +serve xsltDirectory ioc ps = case lookup "q" ps of + Just q -> bracket ioc cancelAndClose $ \c -> do + formData <- parseFormUrlencoded <$> BS.getContents + (q', params) <- prepareQuery c formData ps q + r <- execParams c q' + (map (\p -> Just (invalidOid, p, Text)) params) Text + case r of + Just r' -> do + rs <- resultStatus r' + case rs of + TuplesOk -> do + -- TODO: add more checks and error messages + val <- getvalue r' 0 0 + case val of + Nothing -> + respError 500 [("message", "Failed to read query result")] + Just val' -> resp 200 val' + CommandOk -> + respError 500 [("message", "The command didn't return XML")] + _ -> do + errMsg <- maybe [] (\m -> [("message", m)]) <$> errorMessage c + respError 500 $ ("exec_status", BS.pack (show rs)) : errMsg + Nothing -> respError 500 [("message", "Failed to execute the query")] + _ -> respError 418 [("message", "No query is provided")] + where + xsltPath = xsltDirectory + takeFileName (BS.unpack $ fromMaybe "default" $ lookup "t" ps) + <.> "xsl" + resp st xml = do + (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) + +main :: IO () +main = do + exsltRegisterAll + -- It's okay to fail when not invoked properly. + ps <- parseFormUrlencoded . BS.pack . fromJust <$> lookupEnv "QUERY_STRING" + ha <- lookupEnv "HTTP_AUTHORIZATION" + xsltDir <- fromMaybe "." <$> lookupEnv "XSLT_DIR" + to <- maybe 10 read <$> lookupEnv "TIMEOUT" + maybe (respond 504 "") pure =<< timeout (to * 10 ^ (6 :: Int)) + (case (lookup "auth" ps, baCredentials =<< BS.pack <$> ha) of + (Just "on", Just (l, p)) -> + serve xsltDir (connectdb (connString [("user", l), ("password", p)])) + ps + (Just "on", Nothing) -> + respond' 401 + ["WWW-Authenticate:Basic realm=\"Protected area\", charset=\"UTF-8\""] + "" + _ -> serve xsltDir (connectdb "") ps) -- cgit v1.2.3