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.hs | 309 ------------------------------------------------------- Main.hsc | 321 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ pgxhtml.cabal | 1 + 3 files changed, 322 insertions(+), 309 deletions(-) delete mode 100644 Main.hs create mode 100644 Main.hsc diff --git a/Main.hs b/Main.hs deleted file mode 100644 index 5128c3a..0000000 --- a/Main.hs +++ /dev/null @@ -1,309 +0,0 @@ -{- -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 #-} - -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 -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 -> - xsltSaveResultToString bufPtr lenPtr res stylesheet >> - bracket (peek bufPtr) free BS.packCString) - 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 - -- 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 - putStrLn "Content-Type:application/xhtml+xml" - 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 <- transform xml "" xsltPath ps - 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) 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) 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 -- cgit v1.2.3