Use plain CGI

This eliminates the last of large Haskell dependencies.

The multipart enctype is not supported now.

6 files changed, 146 insertions, 117 deletions

diff --git a/Main.hs b/Main.hs
index 165aaeb..5128c3a 100644
--- a/Main.hs
+++ b/Main.hs
@@ -31,28 +31,18 @@ HTTP basic authentication and PostgreSQL roles for authentication.
 {-# LANGUAGE ForeignFunctionInterface #-}
 
 import qualified Data.ByteString.Char8 as BS
-import qualified Data.ByteString.Lazy as BL
-import qualified Data.HashMap.Lazy as HM
-import qualified Data.Text as T
-import Network.Wai
-import Network.HTTP.Types as HT
-import Web.FormUrlEncoded (Form(..), urlDecodeForm)
 import Database.PostgreSQL.LibPQ
   (getCancel, cancel, connectdb, finish, execParams, getvalue, invalidOid,
    escapeIdentifier, resultStatus, errorMessage, Connection, Format(..),
    ExecStatus(..))
-import Data.Maybe (mapMaybe, fromMaybe, catMaybes)
-import Data.Text.Encoding (encodeUtf8)
-import Network.HTTP.Types.Header (hWWWAuthenticate)
+import Data.Maybe (mapMaybe, fromMaybe, catMaybes, fromJust)
 import System.Timeout (timeout)
-import Network.Wai.Handler.FastCGI (run)
-import Control.Monad (join)
-import Control.Arrow ((***))
 import Control.Exception (bracket, finally)
-import System.FilePath (replaceExtension, takeFileName, (</>))
+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
 
@@ -92,7 +82,7 @@ transform :: BS.ByteString
           -- ^ base URI
           -> FilePath
           -- ^ path to stylesheet
-          -> [(String, String)]
+          -> [(BS.ByteString, BS.ByteString)]
           -- ^ string params
           -> IO BS.ByteString
 transform docBS baseStr pathStr stringParams =
@@ -104,9 +94,8 @@ transform docBS baseStr pathStr stringParams =
   bracket
   (notNull $ xmlReadMemory docCStr (fromIntegral docCStrLen) baseCStr nullPtr 0)
   xmlFreeDoc $ \doc ->
-  bracket (mapM newCString (concatMap (\(x, y) -> [x, y]) $
-                            nubBy (\x y -> fst x == fst y) stringParams))
-  (mapM free) $ \params ->
+  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 $
@@ -121,6 +110,10 @@ transform docBS baseStr pathStr stringParams =
       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"
@@ -144,7 +137,7 @@ connString ((k,v):xs) =
 prepareQuery :: Connection
              -> [(BS.ByteString, BS.ByteString)]
              -- ^ Form data
-             -> [(BS.ByteString, Maybe BS.ByteString)]
+             -> [(BS.ByteString, BS.ByteString)]
              -- ^ URL query
              -> BS.ByteString
              -- ^ SQL query template
@@ -178,19 +171,11 @@ prepareQuery c f gq q = substWords [] [] $ BS.words q
         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 join (lookup fieldName gq) of
+      ("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
 
-
--- * Web interface
-
-formToFields :: Form -> [(T.Text, T.Text)]
-formToFields = mapMaybe toField . HM.toList . unForm
-  where toField (f, [v]) = Just (f, v)
-        toField _ = Nothing
-
 cancelAndClose :: Connection -> IO (Maybe BS.ByteString)
 cancelAndClose c = cancelConn `finally` finish c
   where cancelConn = do
@@ -199,61 +184,40 @@ cancelAndClose c = cancelConn `finally` finish c
             Nothing -> pure $ Just "Failed to get a Cancel structure"
             Just cl' -> either Just (const Nothing) <$> cancel cl'
 
-makeParams :: HT.Query -> [(String, String)]
-makeParams = mapMaybe makeParam
-  where makeParam (k, Just v) = Just (BS.unpack k, BS.unpack v)
-        makeParam _ = Nothing
 
-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, ">"]
+-- * CGI and HTTP utilities
 
-serve :: FilePath -> IO Connection -> Application
-serve xsltDirectory ioc req respond = do
-  form' <- urlDecodeForm <$> strictRequestBody req
-  case form' of
-    Left err -> respError notAcceptable406
-      [("message", BS.pack $ "Failed to read form data:" ++ T.unpack err)]
-    Right form -> case join $ lookup "q" $ queryString req of
-      Just q -> bracket ioc cancelAndClose $ \c -> do
-        (q', params) <- prepareQuery c
-          (map (encodeUtf8 *** encodeUtf8) $ formToFields form) qs 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 status500
-                    [("message", "Failed to read query result")]
-                  Just val' -> resp ok200 val'
-              CommandOk ->
-                respError status500
-                  [("message", "The command didn't return XML")]
-              _ -> do
-                errMsg <- maybe [] (\m -> [("message", m)]) <$> errorMessage c
-                respError status500 $
-                  ("exec_status", BS.pack (show rs)) : errMsg
-          Nothing -> respError status500
-            [("message", "Failed to execute the query")]
-      _ -> respError imATeapot418 [("message", "No query is provided")]
+-- 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
-    qs = queryString req
-    xsltPath = xsltDirectory
-               </> replaceExtension
-               (takeFileName (BS.unpack $ rawPathInfo req)) "xsl"
-    resp st xml = do
-      doc <- transform xml "" xsltPath (makeParams qs)
-      respond $ responseLBS st
-        [(hContentType, "application/xhtml+xml")]
-        (BL.fromStrict doc)
-    respError st e = resp st (errorXML e)
+    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
@@ -265,22 +229,81 @@ baCredentials cred = do
     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"
-  run $ \req respond ->
-    maybe (respond $ responseLBS status504 [] "") pure =<<
-    timeout (to * 10 ^ (6 :: Int))
-    (case ("authorised" `elem` pathInfo req, baCredentials
-            =<< lookup hAuthorization (requestHeaders req)) of
-        (True, Just (l, p)) ->
-          serve xsltDir
-          (connectdb (connString [("user", l), ("password", p)]))
-          req respond
-        (True, Nothing) ->
-          respond $ responseLBS unauthorized401
-          [( hWWWAuthenticate
-           , "Basic realm=\"Protected area\", charset=\"UTF-8\"")] ""
-        _ -> serve xsltDir (connectdb "") req respond)
+  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/README.md b/README.md
index abb2c0c..6e57199 100644
--- a/README.md
+++ b/README.md
@@ -4,20 +4,19 @@ This is a tool to make custom web interfaces to PostgreSQL databases,
 using simple and standard technologies:
 
 - SQL for querying
-- XSLT for templating (translation of XML query results into XHTML)
+- XSLT for templating
 - HTML forms for user input
 - Optional HTTP basic authentication for PostgreSQL authentication
+- CGI
 
 URL query parameters are available for use from XSLTs. SQL query
-templates also can use those, as well as HTML form data submitted with
+templates can use those too, as well as HTML form data submitted with
 the POST method.
 
 Request timeouts are enforced and do cancel DB queries, but otherwise
 it relies on PostgreSQL for access permissions and security policies,
 as well as for any business logic that may be needed.
 
-FastCGI is used.
-
 
 ## Usage
 
@@ -41,8 +40,8 @@ of SQL queries (which are expected to return a single XML document,
 using `query_to_xml` or similar functions), or error documents (which
 contain error details) in case of an error.
 
-The XSLTs are taken from `XSLT_DIR`, using file name from the URL
-query, with its extension changed to `xsl`.
+The XSLTs are taken from `XSLT_DIR`, using file name the `t` URL query
+parameter, with added `xsl` extension.
 
 ### Querying
 
@@ -62,7 +61,7 @@ afterwards, hence some whitespace separation is needed.
 
 ### Authentication
 
-Presence of `authorised` in the URL path requires HTTP basic
+Presence of `auth=on` in the URL query requires HTTP basic
 authentication, and the provided credentials are used directly for
 PostgreSQL authentication.
 
diff --git a/example/README.md b/example/README.md
index d70b595..3aa50bf 100644
--- a/example/README.md
+++ b/example/README.md
@@ -14,10 +14,17 @@ them.
 
 `list.xsl` includes report and search forms, and lists the bugs.
 
-To quickly try it, run `spawn-fcgi -p 5152 /bin/env pgxhtml` in this
-directory, with database connection environment variables set if
-needed, an `127.0.0.1 pgxhtml-test` entry in `/etc/hosts`, and a nginx
-config akin to the following:
+To quickly try the example after preparing a database, it can be
+invoked directly in the `example` directory, e.g.:
+
+```sh
+echo | QUERY_STRING="t=list&q=select+bug_search('','',10,0)" pgxhtml
+```
+
+To try it with a web server, ensure that `fcgiwrap` is running (e.g.,
+`fcgiwrap -s 'tcp:127.0.0.1:5152'`), database connection environment
+variables are set if needed, an `127.0.0.1 pgxhtml-test` entry is in
+`/etc/hosts`, and a nginx config akin to the following is set:
 
 ```
 server {
@@ -26,8 +33,13 @@ server {
 
     location / {
       include fastcgi_params;
-      fastcgi_param PATH_INFO $fastcgi_script_name;
+      fastcgi_param SCRIPT_FILENAME /home/defanor/.cabal/bin/pgxhtml;
+      fastcgi_param FCGI_CHDIR /home/defanor/proj/haskell/pgxhtml/example/;
       fastcgi_pass 127.0.0.1:5152;
     }
 }
 ```
+
+Then
+[http://pgxhtml-test/?t=list&q=select+bug_search('','',10,0)](http://pgxhtml-test/?t=list&q=select%20bug_search(%27%27,%27%27,10,0))
+should be available.
diff --git a/example/list.xsl b/example/list.xsl
index f229e3e..f4b0cf3 100644
--- a/example/list.xsl
+++ b/example/list.xsl
@@ -11,13 +11,14 @@
   <xsl:include href="common.xsl"/>
   <xsl:param name="project" />
   <xsl:param name="description" />
+  <xsl:param name="auth" />
   <xsl:param name="limit" select="10" />
   <xsl:param name="offset" select="0" />
 
   <xsl:template match="bugs:table">
     <!-- Report form -->
     <h2>Report</h2>
-    <form method="post" action="view.xhtml?q=insert%20into%20bugs%20(%20:fields%20)%20values%20(%20:values%20)%20returning%20xmlelement(name%20table,xmlattributes('urn:x-bugs'%20as%20xmlns),xmlelement(name%20row,xmlelement(name%20id,id),xmlelement(name%20reported,reported),xmlelement(name%20reporter,reporter),xmlelement(name%20project,project),xmlelement(name%20description,description)))">
+    <form method="post" action="?auth={$auth}&amp;t=view&amp;q=insert%20into%20bugs%20(%20:fields%20)%20values%20(%20:values%20)%20returning%20xmlelement(name%20table,xmlattributes('urn:x-bugs'%20as%20xmlns),xmlelement(name%20row,xmlelement(name%20id,id),xmlelement(name%20reported,reported),xmlelement(name%20reporter,reporter),xmlelement(name%20project,project),xmlelement(name%20description,description)))">
       <dl>
         <dt><label for="report_project">Project</label></dt>
         <dd>
@@ -37,7 +38,7 @@
 
     <!-- Search form -->
     <h2>Search</h2>
-    <form method="get" action="list.xhtml">
+    <form method="get">
       <dl>
         <dt><label for="search_project">Project</label></dt>
         <dd>
@@ -59,6 +60,7 @@
           <input id="search_offset" type="number" name="offset" min="0"
                  value="{$offset}" />
         </dd>
+        <input type="hidden" name="t" value="list" />
         <input type="hidden" name="q"
                value="select bug_search( q:project , q:description , q:limit , q:offset )" />
       </dl>
@@ -78,12 +80,12 @@
           <td><xsl:copy-of select="bugs:reported/text()" /></td>
           <td><xsl:copy-of select="bugs:reporter/text()" /></td>
           <td>
-            <a href="list.xhtml?q=select%20bug_search(%20q:project%20,'',{$limit},{$offset})&amp;project={str:encode-uri(bugs:project/text(), true())}">
+            <a href="?auth={$auth}&amp;t=list&amp;q=select%20bug_search(%20q:project%20,'',{$limit},{$offset})&amp;project={str:encode-uri(bugs:project/text(), true())}">
               <xsl:copy-of select="bugs:project/text()" />
             </a>
           </td>
           <td>
-            <a href="view.xhtml?q=select%20query_to_xml('select%20*%20from%20bugs%20where%20id=''{bugs:id}''',false,false,'urn:x-bugs')">
+            <a href="?auth={$auth}&amp;t=view&amp;q=select%20query_to_xml('select%20*%20from%20bugs%20where%20id=''{bugs:id}''',false,false,'urn:x-bugs')">
               <xsl:copy-of select="bugs:summary/text()" />
             </a>
           </td>
diff --git a/example/view.xsl b/example/view.xsl
index 84a9d5a..8b5dde8 100644
--- a/example/view.xsl
+++ b/example/view.xsl
@@ -9,7 +9,7 @@
   <xsl:include href="common.xsl"/>
 
   <xsl:template match="bugs:table/bugs:row">
-    <a href="list.xhtml?q=select%20bug_search(%27%27,%20%27%27,%2010,%200)">back to listing</a>
+    <a href="?auth={$auth}&amp;t=list&amp;q=select%20bug_search(%27%27,%20%27%27,%2010,%200)">back to listing</a>
     <dl>
       <dt>ID</dt>
       <dd><xsl:copy-of select="bugs:id/text()" /></dd>
diff --git a/pgxhtml.cabal b/pgxhtml.cabal
index 79370ae..204d4e0 100644
--- a/pgxhtml.cabal
+++ b/pgxhtml.cabal
@@ -20,14 +20,7 @@ executable pgxhtml
                      , base64-bytestring >= 1.0.0.1
                      , bytestring >=0.10 && <0.11
                      , filepath >=1.4 && <1.5
-                     , http-api-data >=0.3 && <0.4
-                     , http-types >=0.12 && <0.13
-                     , network-uri >= 2.6.1.0
                      , postgresql-libpq >=0.9 && <0.10
-                     , text >=1.2 && <1.3
-                     , unordered-containers >=0.2 && <0.3
-                     , wai >=3.2 && <3.3
-                     , wai-handler-fastcgi >= 3.0.0.2
   default-language:    Haskell2010
   pkgconfig-depends:   libxml-2.0, libxslt, libexslt
   ghc-options:         -Wall