summaryrefslogtreecommitdiff
path: root/Main.hs
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 /Main.hs
parenta5ffe01c8806b720a99569dd407a4b14a67693e3 (diff)
Handle media-type
Defaulting to application/xhtml+xml, but the xsl:output media-type attribute can now be set to change that.
Diffstat (limited to 'Main.hs')
-rw-r--r--Main.hs309
1 files changed, 0 insertions, 309 deletions
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 <defanor@uberspace.net>
-
-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 <http://www.gnu.org/licenses/>.
--}
-
-{- |
-Description : XSLT-based PostgreSQL web interface
-Maintainer : defanor <defanor@uberspace.net>
-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, "</", n, ">"]
-
-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)