------------------------------------------------------------------------------
--- Library to support CGI programming in the HTML library.
--- It is only intended as an auxiliary library to implement dynamic web
--- pages according to the HTML library.
--- It contains a simple script that is installed for a dynamic
--- web page and which sends the user input to the real application
--- server implementing the application.
---
--- @author Michael Hanus
--- @version September 2012
--- @category web
------------------------------------------------------------------------------

module HtmlCgi(CgiServerMsg(..),runCgiServerCmd,
               cgiServerRegistry,registerCgiServer,unregisterCgiServer,
               readCgiServerMsg,noHandlerPage,submitForm)
  where

import System
import Char
import NamedSocket
import CPNS(unregisterPort)
import IO
import IOExts(exclusiveIO,connectToCommand)
import Directory(doesFileExist,getCurrentDirectory)
import ReadNumeric
import ReadShowTerm
import Time
import List

--------------------------------------------------------------------------
-- Should the log messages of the server stored in a log file?
withCgiLogging :: Bool
withCgiLogging = True

--------------------------------------------------------------------------
--- The messages to comunicate between the cgi script and the server program.
--- CgiSubmit env cgienv nextpage - pass the environment and show next page,
---   where env are the values of the environment variables of the web script
---   (e.g., QUERY_STRING, REMOTE_HOST, REMOTE_ADDR),
---   cgienv are the values in the current form submitted by the client,
---   and nextpage is the answer text to be shown in the next web page
--- @cons GetLoad - get info about the current load of the server process
--- @cons SketchStatus - get a sketch of the status of the server
--- @cons SketchHandlers - get a sketch of all event handlers of the server
--- @cons ShowStatus - show the status of the server with all event handlers
--- @cons CleanServer - clean up the server (with possible termination)
--- @cons StopCgiServer - stop the server
data CgiServerMsg = CgiSubmit [(String,String)] [(String,String)]
                  | GetLoad
                  | SketchStatus
                  | SketchHandlers
                  | ShowStatus
                  | CleanServer
                  | StopCgiServer

--- Reads a line from a handle and check whether it is a syntactically
--- correct cgi server message.
readCgiServerMsg :: Handle -> IO (Maybe CgiServerMsg)
readCgiServerMsg handle = do
  line <- hGetLine handle
  case readsQTerm line of
     [(msg,rem)] -> return (if all isSpace rem then Just msg else Nothing)
     _ -> return Nothing

--------------------------------------------------------------------------
-- Main program to start a cgi script. It reads arguments and starts a small
-- script to forward the arguments to a cgi server process.
--
-- Optional script arguments:
-- "-servertimeout n": The timeout period for the cgi server in milliseconds.
--                     If the cgi server process does not receive any request
--                     during this period, it will be terminated.
--                     The default value is defined in the library HTML.
--
-- "-loadbalance <t>": specifies kind of load balancing (see makecurrycgi)
--                     Current possible values for <t>:
--                     "no|standard|multiple"
submitForm :: IO ()
submitForm = do
  args <- getArgs
  let (serverargs,lb,rargs) = stripServerArgs "" NoBalance args
  case rargs of
    [url,cgikey,serverprog] -> cgiScript url serverargs lb
                                         (cgikey2portname cgikey) serverprog
    [portname] -> cgiInteractiveScript portname -- for interactive execution
    _ -> putStrLn $ "ERROR: cgi script called with illegal arguments!"
 where
  stripServerArgs serverargs load args = case args of
    ("-servertimeout":tos:rargs) ->
         stripServerArgs (" -servertimeout "++tos) load rargs
    ("-multipleservers":rargs) -> stripServerArgs serverargs Multiple rargs
    ("-loadbalance":lbt:rargs) ->
      stripServerArgs serverargs
                      (if lbt=="no" then NoBalance else
                       if lbt=="multiple" then Multiple else Standard) rargs
    _ -> (serverargs,load,args)

-- load balance types:
data LoadBalance = NoBalance | Standard | Multiple
 deriving Eq

--- Executes a specific command for a cgi server.
runCgiServerCmd :: String -> CgiServerMsg -> IO ()
runCgiServerCmd portname cmd = case cmd of
  StopCgiServer -> do
    putStrLn $ "Trying to stop server at port " ++ portname ++ "..."
    h <- trySendScriptServerMessage portname StopCgiServer
    hClose h
    unregisterPort portname
  CleanServer -> do
    putStrLn $ "Trying to clean server at port " ++ portname ++ "..."
    h <- trySendScriptServerMessage portname CleanServer
    hClose h
  GetLoad ->  do
     -- for upward compatibility with previous implementations:
    h <- trySendScriptServerMessage portname GetLoad
    cs <- hGetContents h
    if length cs < 7
     then do h' <- trySendScriptServerMessage portname SketchStatus
             copyOutputAndClose h'
             putChar '\n'
     else putStrLn cs
  ShowStatus ->  do
    h <- trySendScriptServerMessage portname ShowStatus
    copyOutputAndClose h
  SketchStatus -> do
    h <- trySendScriptServerMessage portname SketchStatus
    copyOutputAndClose h
  SketchHandlers -> do
     -- for upward compatibility with previous implementations:
    lh <- trySendScriptServerMessage portname GetLoad
    cs <- hGetContents lh
    if length cs < 7
     then do h <- trySendScriptServerMessage portname SketchHandlers
             copyOutputAndClose h
     else do h <- trySendScriptServerMessage portname SketchStatus
             copyOutputAndClose h
  _ -> error "HtmlCgi.runCgiServerCmd: called with illegal command!"

--- Translates a cgi progname and key into a name for a port:
cgikey2portname :: String -> String
cgikey2portname cgikey =
  concatMap (\c->if isAlphaNum c then [c] else []) cgikey

-- Forward user inputs for interactive execution of cgi scripts:
cgiInteractiveScript :: String -> IO ()
cgiInteractiveScript portname = do
  cgiServerEnvVals <- mapIO getEnviron cgiServerEnvVars
  let cgiServerEnv = zip cgiServerEnvVars cgiServerEnvVals
  formEnv <- getFormVariables
  catch (sendToServerAndPrintOrFail cgiServerEnv formEnv)
        (putStrLn . errorPage)
 where
  sendToServerAndPrintOrFail cgiEnviron newcenv = do
    h <- trySendScriptServerMessage portname (CgiSubmit cgiEnviron newcenv)
    copyOutputAndClose h

  errorPage e =
    "Content-type: text/html\n\n" ++
    "<html>\n<head><title>Server Error</title></head>\n" ++
    "<body>\n<h1>Server Error</h1>\n" ++ showError e ++ "</body>\n</html>"


-- Forward user inputs to cgi server process:
cgiScript :: String -> String -> LoadBalance -> String -> String -> IO ()
cgiScript url serverargs loadbalance portname serverprog = do
  cgiServerEnvVals <- mapIO getEnviron cgiServerEnvVars
  let cgiServerEnv = zip cgiServerEnvVars cgiServerEnvVals
  let urlparam = head cgiServerEnvVals
  formEnv <- getFormVariables
  if null formEnv
   then do -- call to initial script
     scriptKey <- if loadbalance==Multiple then getFreshKey
                                           else return ""
     catch (submitToServerOrStart url serverargs loadbalance portname
                                      scriptKey serverprog cgiServerEnv)
           (\_ -> putStrLn (noHandlerPage url urlparam))
   else do -- call to continuation script
     let scriptKey = maybe "" id (lookup "SCRIPTKEY" formEnv)
         cgiEnviron = ("SCRIPTKEY",scriptKey) : cgiServerEnv
         newcenv = filter (\e -> fst e /= "SCRIPTKEY") formEnv
     catch (sendToServerAndPrintOrFail scriptKey cgiEnviron newcenv)
           (\_ -> putStrLn (noHandlerPage url urlparam))
 where
  sendToServerAndPrintOrFail scriptKey cgiEnviron newcenv = do
    h <- trySendScriptServerMessage (portname++scriptKey)
                                    (CgiSubmit cgiEnviron newcenv)
    eof <- hIsEOF h
    if eof then error "Html.cgiScript: unexpected EOF failure"
           else copyOutputAndClose h

-- get a new unique key for a script:
getFreshKey :: IO String
getFreshKey = do
  ctime <- getClockTime
  pid <- getPID
  return (show (clockTimeToInt ctime) ++ '_' : show pid)


------------------------------------------------------------------------
-- Generate HTML string of a web page with "no handler" error:
noHandlerPage :: String -> String -> String
noHandlerPage cgiurl urlparam =
 "Content-type: text/html\n\n" ++
 "<html>\n<head><title>Server Error</title></head>\n" ++
 "<body>\n<h1>Error: no submission handler</h1>\n" ++
 "<p>Your request cannot be processed due to one of the following reasons:</p>\n" ++
 "<ul>\n" ++
 "<li>You have not submitted the web form for a long period (timeout).</li>\n"++
 "<li>You have used the 'back' button of your browser and submitted\n"++
 "  the web form again (which should not be done in order to avoid the\n"++
 "  double submission of data).</li>\n" ++
 "<li>The web server has been rebooted.</li>\n" ++
 "</ul>\n" ++
 "<p>In any case, <a href=\"" ++
   (cgiurl ++ if null urlparam then "" else '?':urlparam) ++
 "\">please click here to restart.</a></p>\n" ++
 "</body>\n</html>"

------------------------------------------------------------------------
--- The values of the environment variables of the web script server
--- that are transmitted to the application program.
--- Currently, it contains only a selection of all reasonable variables
--- but this list can be easily extended.
cgiServerEnvVars :: [String]
cgiServerEnvVars =
  ["PATH_INFO","QUERY_STRING","HTTP_COOKIE","REMOTE_HOST","REMOTE_ADDR",
   "REQUEST_METHOD","SCRIPT_NAME","SERVER_NAME","SERVER_PORT"]

-- The timeout (in msec) of the script server.
-- If the port of the application server is not available within the timeout
-- period, we assume that the application server does not exist and we start
-- a new one.
scriptServerTimeOut :: Int
scriptServerTimeOut = 1000

-- send a message to the script server and return the connection handle,
-- or fail:
trySendScriptServerMessage :: String -> a -> IO Handle
trySendScriptServerMessage portname msg =
  connectToSocketRepeat scriptServerTimeOut done 0 (portname++"@localhost") >>=
  maybe failed (\h -> hPutStrLn h (showQTerm msg) >> hFlush h >> return h)

-- submit an initial web page request to a server or restart it:
submitToServerOrStart :: String -> String -> LoadBalance -> String -> String
                      -> String -> [(String,String)] -> IO ()
submitToServerOrStart url serverargs loadbalance pname scriptkey
                      serverprog cgiServerEnv =
   connectToSocketRepeat scriptServerTimeOut done 0 completeportname >>=
   maybe (execAndCopyOutput servercmd)
         (\h ->
           if loadbalance/=Standard
           then cgiSubmit h
           else do
            isbusy <- getLoadOfServer h
            if isbusy
             then submitToOtherServer
             else connectToSocketRepeat scriptServerTimeOut done 0
                                        completeportname >>=
                  maybe (execAndCopyOutput servercmd) cgiSubmit )
 where
  completeportname = pname++scriptkey++"@localhost"
  cmd = serverprog ++ serverargs ++ " -port \"" ++ pname
                   ++ "\" -scriptkey \"" ++ scriptkey ++ "\""
  errout = if withCgiLogging then " 2>> "++url++".log" else ""
  servercmd = cmd++errout++" &"

  cgiSubmit h = do
    let cgiEnviron = ("SCRIPTKEY",scriptkey) : cgiServerEnv
    hPutStrLn h (showQTerm (CgiSubmit cgiEnviron []))
    hFlush h
    copyOutputAndClose h

  getLoadOfServer h = do
    hPutStrLn h (showQTerm GetLoad)
    hFlush h
    loadanswer <- hGetLine h
    hClose h
    return (take 4 loadanswer == "busy")

  submitToOtherServer = do
    other <- findOtherReadyServer
    otherscriptkey <- maybe (getFreshKey >>= \k -> return (scriptkey++k))
                            return
                            other
    submitToServerOrStart url serverargs loadbalance pname
                          otherscriptkey serverprog cgiServerEnv

  -- try to return the scriptkey of another ready server
  findOtherReadyServer = do
    regs <- readCgiServerRegistry
    let otherports = map (\ (_,_,p)->p)
                         (filter (\ (_,prog,_) -> serverprog==prog) regs)
    findOtherReadyServerInPorts otherports

  findOtherReadyServerInPorts [] = return Nothing
  findOtherReadyServerInPorts (p:ps) = do
    let (ppname,pscriptkey) = splitAt (length pname) p
    if ppname==pname -- it is a port for the current script version
     then connectToSocketRepeat scriptServerTimeOut done 0 (p++"@localhost") >>=
          maybe (findOtherReadyServerInPorts ps) -- no connection
                (\h -> do
                   isbusy <- getLoadOfServer h
                   if isbusy
                    then findOtherReadyServerInPorts ps
                    else return (Just pscriptkey) )
     else findOtherReadyServerInPorts ps

-- Execute a command and copy its output to stdout.
-- This is necessary since some web servers do not transfer
-- the output of cgi programs if the process is not terminated.
execAndCopyOutput :: String -> IO ()
execAndCopyOutput cmd = connectToCommand cmd >>= copyOutputAndClose

-- Copy input from the given handle to stdout and close it after eof.
copyOutputAndClose :: Handle -> IO ()
copyOutputAndClose h = do
  clen <- copyUntilEmptyLine 0
  if clen==0 then copyOutputUntilEOF else copyOutputLength clen
  hClose h
 where
  copyUntilEmptyLine clen = do
    l <- hGetLine h
    putStrLn l
    let clen' = if "Content-Length:" `isPrefixOf` l
                then maybe clen fst (readNat (drop 15 l))
                else clen
    if null l then return clen' else copyUntilEmptyLine clen'

  copyOutputUntilEOF = do
    eof <- hIsEOF h
    if eof
     then done
     else hGetLine h >>= putStrLn >> copyOutputUntilEOF

  copyOutputLength n = do
    if n>0 then hGetChar h >>= putChar >> copyOutputLength (n-1)
           else done

-- Puts a line to stderr:
putErrLn :: String -> IO ()
putErrLn s = hPutStrLn stderr s >> hFlush stderr

------------------------------------------------------------------------------
--- Gets the list of variable/value pairs sent from the browser for the
--- current CGI script.
--- Used for the implementation of the HTML event handlers.
getFormVariables :: IO [(String,String)]
getFormVariables = do
  clen <- getEnviron "CONTENT_LENGTH"
  cont <- getNChar (maybe 0 fst (readNat clen))
  return (includeCoordinates (parseCgiEnv cont))

-- translate a string of cgi environment bindings into list of binding pairs:
parseCgiEnv :: String -> [(String,String)]
parseCgiEnv s | s == ""   = []
              | otherwise = map ufield2field
                             (map (\(n,v)->(n,utf2latin (urlencoded2string v)))
                                  (map (splitChar '=') (split (=='&') s)))
 where
   ufield2field (n,v) = if take 7 n == "UFIELD_"
                        then (tail n, utf2latin (urlencoded2string v))
                        else (n,v)

   -- split a string at particular character:
   splitChar c xs = let (ys,zs) = break (==c) xs
                    in if zs==[] then (ys,zs) else (ys,tail zs)

   -- split a string at all positions of a particular character:
   split p xs =
    let (ys,zs) = break p xs
    in if zs==[] then [ys]
                 else ys : split p (tail zs)

--- Translates urlencoded string into equivalent ASCII string.
urlencoded2string :: String -> String
urlencoded2string [] = []
urlencoded2string (c:cs)
  | c == '+'  = ' ' : urlencoded2string cs
  | c == '%'  = chr (maybe 0 fst (readHex (take 2 cs)))
                 : urlencoded2string (drop 2 cs)
  | otherwise = c : urlencoded2string cs

--- Transforms a string with UTF-8 umlauts into a string with latin1 umlauts.
utf2latin :: String -> String
utf2latin [] = []
utf2latin [c] = [c]
utf2latin (c1:c2:cs)
 | ord c1 == 195 = chr (ord c2 + 64) : utf2latin cs
 | otherwise     = c1 : utf2latin (c2:cs)

includeCoordinates :: [(String,String)] -> [(String,String)]
includeCoordinates [] = []
includeCoordinates ((tag,val):cenv)
  = case break (=='.') tag of
      (_,[]) -> (tag,val):includeCoordinates cenv
      (event,['.','x']) -> ("x",val):(event,val):includeCoordinates cenv
      (_,['.','y']) -> ("y",val):includeCoordinates cenv
      _ -> error "includeCoordinates: unexpected . in url parameter"


-- get n chars from stdin:
getNChar :: Int -> IO String
getNChar n = if n<=0 then return ""
                     else do c <- getChar
                             cs <- getNChar (n-1)
                             return (c:cs)

------------------------------------------------------------------------------
--- The name of the file to register all cgi servers.
cgiServerRegistry :: String
cgiServerRegistry = "/tmp/CURRY_CGI_REGISTRY"

-- Register a new cgi server process (for global management of all such
-- processes on a host):
registerCgiServer :: String -> String -> IO ()
registerCgiServer eurl epname =
  -- we want to be sure that everything is evaluated before locking:
  (register $## eurl) $## epname
 where
  register url pname = exclusiveIO (cgiServerRegistry++".lock") $ do
    exreg <- doesFileExist cgiServerRegistry
    if exreg then done else do
      writeFile cgiServerRegistry ""
      system ("chmod 666 "++cgiServerRegistry) >> done
    pid <- getPID
    wd <- getCurrentDirectory
    appendFile cgiServerRegistry (show (pid,wd++"/"++url++".server",pname)++"\n")

-- Unregister the previously registered cgi server process:
-- processes on a host):
unregisterCgiServer :: String -> IO ()
unregisterCgiServer epname =
  -- we want to be sure that everything is evaluated before locking:
  unregister $## epname
 where
  unregister pname = exclusiveIO (cgiServerRegistry++".lock") $ do
    exreg <- doesFileExist cgiServerRegistry
    if not exreg then done else do
      mypid <- getPID
      regs <- readCgiServerRegistry
      let uregs = filter (\ (pid,_,port) -> mypid/=pid || pname/=port) regs
      writeFile cgiServerRegistry (concatMap (\reg->show reg++"\n") uregs)

-- Return the current server registry:
readCgiServerRegistry :: IO [(Int,String,String)]
readCgiServerRegistry = do
  regs <- readQTermListFile cgiServerRegistry
  seq (length regs) done -- just to be sure that everything is immediately read
  return regs

---------------------------------------------------------------------------