------------------------------------------------------------------------------
--- This library contains the implementation of the server based on CGI
--- to implement dynamic web pages.
---
--- @author Michael Hanus
--- @version October 2017
--- @category web
------------------------------------------------------------------------------

{-# OPTIONS_CYMAKE -Wno-incomplete-patterns #-}

module HTML.CgiServer
 ( runFormServerWithKey, runFormServerWithKeyAndFormParams
 , intForm, intFormMain
 ) where

import Char        ( isSpace )
import Directory    (getHomeDirectory)
import Distribution (installDir)
import HTML.Base
import HtmlCgi
import IO
import List ( intercalate )
import NamedSocket
import Profile
import Random       ( getRandomSeed, nextInt )
import ReadNumeric  ( readNat )
import ReadShowTerm ( showQTerm, readsQTerm )
import System
import Time
--import Unsafe(showAnyQExpression) -- to show status of cgi server

------------------------------------------------------------------------------
--- The server implementing an HTML form (possibly containing input fields).
--- It receives a message containing the environment of the client's
--- web browser, translates the HTML form w.r.t. this environment
--- into a string representation of the complete HTML document
--- and sends the string representation back to the client's browser
--- by binding the corresponding message argument.
--- @param url - the URL of this executable.
--- @param cgikey - a unique key to identify this CGI script (used for safe
---                 storing of event handlers in this server)
--- @param hformact - an IO action returning an HTML form
runFormServerWithKey :: String -> String -> IO HtmlForm -> IO ()
runFormServerWithKey url cgikey hformact =
  runFormServerWithKeyAndFormParams url cgikey [] hformact

--- The server implementing an HTML form (possibly containing input fields).
--- It receives a message containing the environment of the client's
--- web browser, translates the HTML form w.r.t. this environment
--- into a string representation of the complete HTML document
--- and sends the string representation back to the client's browser
--- by binding the corresponding message argument.
--- @param url - the URL of this executable.
--- @param cgikey - a unique key to identify this CGI script (used for safe
---                 storing of event handlers on the web server)
--- @param formparams - form parameters added to the initial and all
---                     subsequent forms
--- @param hformact - an IO action returning an HTML form
runFormServerWithKeyAndFormParams :: String -> String -> [FormParam]
                                  -> IO HtmlForm -> IO ()
runFormServerWithKeyAndFormParams url cgikey formparams hformact = do
  args <- getArgs
  let (timeout,rargs) = stripTimeoutArg args
  case rargs of
    ["-port",port,"-scriptkey",skey] -> startCgiServer timeout port skey
    _ -> putErrLn $ "ERROR: cgi server called with illegal arguments"
 where
  stripTimeoutArg args = case args of
    ("-servertimeout":tos:rargs) ->
         (tryReadNat defaultCgiServerTimeout tos, rargs)
    _ -> (defaultCgiServerTimeout,args)

  startCgiServer timeout port scriptkey = do
    time  <- getClockTime
    ltime <- toCalendarTime time
    (state,htmlstring) <- computeFormInStateAndEnv url cgikey formparams
                             (initialServerState time) scriptkey hformact []
    putStr htmlstring
    hClose stdout
    if isServerStateWithoutHandlers state
     then done
     else -- start server process:
      do let portname = port++scriptkey
         socket <- listenOn portname
         putErrLn $ calendarTimeToString ltime ++
                    ": server started on port " ++ portname
         registerCgiServer url portname
         serveCgiMessagesForForm timeout url cgikey portname formparams
                                 hformact socket state

-- The default timeout period for the cgi server in milliseconds:
defaultCgiServerTimeout :: Int
defaultCgiServerTimeout = 7200000 -- two hours


-- The main server loop:
serveCgiMessagesForForm :: Int -> String -> String -> String -> [FormParam]
                        -> IO HtmlForm -> Socket -> ServerState -> IO ()
serveCgiMessagesForForm servertimeout url cgikey portname
                        fparams initform socket = serveCgiMessages
 where
  serveCgiMessages state =
    if isServerStateWithoutHandlers state
    then do -- terminate server due to inactivity
            ltime <- getLocalTime
            putErrLn $ calendarTimeToString ltime ++
                       ": terminated due to empty handler list"
            unregisterCgiServer portname
            sClose socket
    else waitForSocketAccept socket servertimeout >>=
         maybe (do -- terminate server due to inactivity
                   ltime <- getLocalTime
                   putErrLn $ calendarTimeToString ltime ++
                              ": terminated due to timeout"
                   unregisterCgiServer portname
                   sClose socket )
               (\ (rhost,hdl) -> do
                  hostname <- getHostname
                  if rhost `elem` ["localhost","localhost.localdomain",hostname]
                     || take 8 rhost == "127.0.0."
                   then readCgiServerMsg hdl >>=
                        maybe (hClose hdl >> serveCgiMessages state)
                              (serveCgiMessage state hdl)
                   else putErrLn ("Ignored message from: "++rhost) >>
                        hClose hdl >> serveCgiMessages state )

  -- Process the received CgiServerMsg:
  serveCgiMessage _ hdl StopCgiServer = do
    hClose hdl
    ltime <- getLocalTime
    putErrLn $ calendarTimeToString ltime ++
              ": server terminated by stop message"
    unregisterCgiServer portname
    sClose socket

  serveCgiMessage state hdl CleanServer = do
    hClose hdl
    nstate <- cleanOldEventHandlers state
    serveCgiMessages nstate

  serveCgiMessage oldstate hdl GetLoad = do
    state <- cleanOldEventHandlers oldstate
    serverload <- getServerLoad state
    hPutStrLn hdl serverload
    hClose hdl
    serveCgiMessages state

  serveCgiMessage oldstate hdl SketchStatus = do
    state <- cleanOldEventHandlers oldstate
    serverstatus <- getServerStatus state
    hPutStrLn hdl serverstatus
    hClose hdl
    serveCgiMessages state

  serveCgiMessage state hdl SketchHandlers =
    reportStatus state hdl sketchEventHandler
   where
    sketchEventHandler (key,time,_,_,gkey) = do
      ltime <- toCalendarTime time
      return $ "No. " ++ show key ++ " (" ++ showGroupKey gkey ++
               "), expires at: " ++
               calendarTimeToString ltime ++ "\n"

  serveCgiMessage state hdl ShowStatus =
    reportStatus state hdl showEventHandler
   where
    showEventHandler (key,time,_,(_,_{-handler-}),gkey) = do
      ltime <- toCalendarTime time
      return $ "No. " ++ show key ++ " (" ++ showGroupKey gkey ++
               "), expires at " ++
               calendarTimeToString ltime ++ ": " ++
               --showAnyQExpression handler ++ "\n"
               "<sorry, can't show handler>\n"

  serveCgiMessage state hdl (CgiSubmit scriptenv formenv) = do
      let scriptkey = maybe "" id (lookup "SCRIPTKEY" scriptenv)
      mapIO_ (\(var,val) -> if var=="SCRIPTKEY" then done
                                                else setEnviron var val)
             scriptenv
      if null formenv -- initial form?
       then serveFormInEnv state scriptkey initform []
       else do
         (rstate,mfe) <- getNextFormAndCgiEnv state cgikey formenv
         maybe (do urlparam <- getUrlParameter
                   hPutStrLn hdl (noHandlerPage url urlparam)
                   hClose hdl
                   serveCgiMessages rstate)
               (\ (ioform,env) -> serveFormInEnv rstate scriptkey ioform env )
               mfe
   where
    serveFormInEnv rstate scriptkey hformact cenv = do
      (nstate,htmlstring) <- computeFormInStateAndEnv url cgikey fparams
                                                rstate scriptkey hformact cenv
      hPutStrLn hdl htmlstring
      hClose hdl
      serveCgiMessages nstate

  reportStatus state@(stime,maxkey,ctime,ehs) hdl eh2string = do
    lstime <- toCalendarTime stime
    lctime <- toCalendarTime ctime
    ehsstrings <- mapIO eh2string ehs
    hPutStrLn hdl $ "Started at: " ++ calendarTimeToString lstime ++ "\n" ++
                    "Next cleanup: " ++ calendarTimeToString lctime ++
                    " (maxkey: " ++ show maxkey ++")\n"++
                    "Current event handlers:\n" ++ concat ehsstrings
    hClose hdl
    serveCgiMessages state

-- computes a HTML form w.r.t. a state and a cgi environment:
computeFormInStateAndEnv
  :: String -> String -> [FormParam] -> ServerState -> String
  -> IO HtmlForm -> [(String,String)] -> IO (ServerState,String)
computeFormInStateAndEnv url cgikey fparams state scriptkey hformact cenv =
  catch tryComputeForm
        (\e -> do uparam <- getUrlParameter
                  return (state,errorAsHtml e uparam))
 where
  errorAsHtml e urlparam = addHtmlContentType $ showHtmlPage $
   page "Server Error"
    [h1 [htxt "Error: Failure during computation"],
     par [htxt "Your request cannot be processed due to a run-time error:"],
     pre [htxt (showError e)],
     par [htxt "You can try to ",
          href (url ++ if null urlparam then "" else '?':urlparam)
               [htxt "click here"],
          htxt " to try again loading the web page or inform the web ",
          htxt "administrator about this problem."]]

  tryComputeForm = do
    cform <- hformact
    let (cookiestring,hform) = extractCookies cform
    (htmlstring,evhs) <- showAnswerFormInEnv url scriptkey
                                             (addFormParams hform fparams)
                                             (getMaxFieldNr cenv + 1)
    nstate <- storeEnvHandlers state
                (formWithMultipleHandlers hform)
                (encodeKey cgikey)
                (filter (\ (t,_) -> t/="DEFAULT" && take 6 t /= "EVENT_") cenv)
                evhs
    seq (isList htmlstring) done -- to ensure to catch all failures here
    return (nstate, cookiestring++htmlstring)

  isList [] = True
  isList (_:xs) = isList xs

formWithMultipleHandlers :: HtmlForm -> Bool
formWithMultipleHandlers (HtmlAnswer _ _) = False
formWithMultipleHandlers (HtmlForm _ params _) = any isMultipleHandlers params
 where
  isMultipleHandlers formparam =
    case formparam of MultipleHandlers -> True
                      _                -> False

-- Encode an arbitrary string to make it less readable.
-- Used for encoding CGI keys before storing them on the web server.
encodeKey :: String -> String
encodeKey = map mapchr . reverse . filter (not . isSpace)
 where
  mapchr c | oc<33 || oc>126 = c
           | oc<114          = chr (oc+13)
           | otherwise       = chr (oc-81)
   where oc = ord c

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


--------------------------------------------------------------------------
-- Auxiliaries to implement the cgi script server:

-- get the next form and environment from a current environment (specifying a
-- user-selected event handler) and a server state holding all event handlers:
getNextFormAndCgiEnv :: ServerState -> String -> [(String,String)]
                     -> IO (ServerState, Maybe (IO HtmlForm,[(String,String)]))
getNextFormAndCgiEnv state cgikey newcenv = do
  (nstate,mbh) <- retrieveEnvHandlers state (encodeKey cgikey)
                             (urlencoded2string (getFormEvent "" newcenv))
  return $ maybe (nstate,Nothing)
                 (\ (oldcenv,handler) -> let cenv = newcenv++oldcenv in
                         (nstate, Just (handler (cgiGetValue cenv), cenv)))
                 mbh


-- put the HTML string corresponding to an HtmlForm with HTTP header on stdout:
showAnswerFormInEnv :: String -> String -> HtmlForm -> Int
                      -> IO (String,[(HtmlHandler,String)])
showAnswerFormInEnv url key hform@(HtmlForm _ _ _) crefnr = do
  (htmlstring,evhs) <- showHtmlFormInEnv url key hform crefnr
  return (addHtmlContentType htmlstring, evhs)
showAnswerFormInEnv _ _ (HtmlAnswer ctype cont) _ = do
  return ("Content-Length: " ++ show (length cont) ++
          "\nContent-Type: "++ctype++"\n\n"++cont, [])


-- Adds the initial content lines (including content length) to an HTML string.
addHtmlContentType :: String -> String
addHtmlContentType htmlstring =
    "Content-Length: " ++ show (length htmlstring) ++ "\n" ++
    "Content-Type: text/html\n\n" ++ htmlstring

-- return the HTML string corresponding to an HtmlForm:
showHtmlFormInEnv :: String -> String -> HtmlForm -> Int
                     -> IO (String,[(HtmlHandler,String)])
showHtmlFormInEnv url key (HtmlForm ftitle fparams fhexp) crefnr = do
  qstr <- getEnviron "QUERY_STRING"
  --putStrLn (showHtmlExps [pre [par (env2html cenv),hrule]]) --debug
  (title,params,hexps,firsthandler,evhs) <-
    htmlForm2html (HtmlForm ftitle fparams fhexp) crefnr
  return (showForm (if null evhs
                    then []
                    else [("SCRIPTKEY",key),("DEFAULT","EVENT_"++firsthandler)])
                   (if qstr=="" then url else url++"?"++qstr)
                   (HtmlForm title params hexps),
          evhs)


-- extract the cookies contained in a form and return the "set cookie" string
-- and the form without the cookies:
extractCookies :: HtmlForm -> (String,HtmlForm)
extractCookies (HtmlAnswer ctype cont) = ("",HtmlAnswer ctype cont)
extractCookies (HtmlForm title params hexp) =
  let cookiestring = if null cookies
                     then ""
                     else "Cache-control: no-cache=\"set-cookie\"\n" ++
                          concatMap ((++"\n") . formatCookie) cookies
   in (cookiestring, HtmlForm title otherparams hexp)
 where
   (cookies,otherparams) = splitFormParams params

   splitFormParams [] = ([],[])
   splitFormParams (fparam:fps) =
     let (cs,ops) = splitFormParams fps
      in case fparam of
           FormCookie n v ps -> ((n,v,ps):cs,ops)
           _                 -> (cs,fparam:ops)

-- get the EVENT_ definition of the cgi environment
-- (or "DEFAULT" value if it is not there):
getFormEvent :: String -> [(String,String)] -> String
getFormEvent deflt [] = deflt
getFormEvent deflt ((tag,val):tvs) =
   if tag == "DEFAULT" then getFormEvent (drop 6 val) tvs else
   if take 6 tag == "EVENT_" then urlencoded2string (drop 6 tag)
                             else getFormEvent deflt tvs

-- compute the maximal field number of all "FIELD_nr" in a CGI environment:
getMaxFieldNr :: [(String,String)] -> Int
getMaxFieldNr [] = 0
getMaxFieldNr ((name,_):env) =
  if take 6 name == "FIELD_"
  then max (tryReadNat 0 (drop 6 name)) (getMaxFieldNr env)
  else getMaxFieldNr env

-- try to read a natural number in a string or return first argument:
tryReadNat :: Int -> String -> Int
tryReadNat d s = maybe d (\(i,rs)->if null rs then i else d) (readNat s)

-- get the value assigned to a name in a given cgi environment
cgiGetValue :: [(String,String)] -> CgiRef -> String
cgiGetValue cenv cgiref =
    intercalate "\n" (map snd (filter (((idOfCgiRef cgiref) ==) . fst) cenv))

-- transform HTML form into HTML document (by instantiating CgiRefs
-- (starting with the second argument) and modifying event handlers):
-- (Result: title/HTML document/form params/encoded first handler)
htmlForm2html :: HtmlForm -> Int
             -> IO (String,[FormParam],[HtmlExp],String,[(HtmlHandler,String)])
htmlForm2html (HtmlForm title params html) crefnr = do
  let (htmlwithoutcrefs,newrefnr) = numberCgiRefs html crefnr
  -- enforce instantiation before handlers are stored:
  seq newrefnr done
  -- seq (normalForm htmlwithoutcrefs) done
  let (transhtml, evhs, fh) = translateHandlers htmlwithoutcrefs
  --storeEventHandlers cgikey oldcenv evhs
  return (title, params, transhtml, fh, evhs)


-- instantiate all CgiRefs with a unique tag in HTML expressions:
numberCgiRefs :: [HtmlExp] -> Int -> ([HtmlExp],Int)
-- arguments: HTMLExps, number for cgi-refs
-- result: translated HTMLExps, new number for cgi-refs
numberCgiRefs [] i = ([],i)
numberCgiRefs (HtmlText s : hexps) i =
  case numberCgiRefs hexps i of
    (nhexps,j) -> (HtmlText s : nhexps, j)
numberCgiRefs (HtmlStruct tag attrs hexps1 : hexps2) i =
  case numberCgiRefs hexps1 i of
    (nhexps1,j) -> case numberCgiRefs hexps2 j of
                     (nhexps2,k) -> (HtmlStruct tag attrs nhexps1 : nhexps2, k)
numberCgiRefs (HtmlEvent (HtmlStruct tag attrs hes) handler : hexps) i =
  case numberCgiRefs hexps i of
    (nhexps,j) -> (HtmlEvent (HtmlStruct tag attrs hes) handler : nhexps, j)
numberCgiRefs (HtmlCRef hexp cgiref : hexps) i
  | idOfCgiRef cgiref =:= ("FIELD_"++show i)
  = case numberCgiRefs [hexp] (i+1) of
      ([nhexp],j) -> case numberCgiRefs hexps j of
                       (nhexps,k) -> (nhexp : nhexps, k)

-- translate all event handlers into their internal form:
-- (assumption: all CgiRefs have already been instantiated and eliminated)
-- the result is the translated HTML expression list (without HtmlEvents),
-- the list of event handlers and their corresponding logical variables
-- denoting the key that is inserted for the event handler in the translated
-- HTML expression, and the string encoding of the first event handler
-- (for the default handler)
translateHandlers :: [HtmlExp] -> ([HtmlExp],[(HtmlHandler,String)],String)
translateHandlers [] = ([],[],"")
translateHandlers (HtmlText s : hexps) =
  let (nhexps,evhs,fh) = translateHandlers hexps
   in (HtmlText s : nhexps, evhs, fh)
translateHandlers (HtmlStruct tag attrs hexps1 : hexps2) =
  let (nhexps1,evhs1,fh1) = translateHandlers hexps1
      (nhexps2,evhs2,fh2) = translateHandlers hexps2
   in (HtmlStruct tag attrs nhexps1 : nhexps2, evhs1++evhs2,
       if fh1=="" then fh2 else fh1)
translateHandlers (HtmlEvent (HtmlStruct tag attrs hes) handler : hexps) =
  let (nhexps,evhs,_) = translateHandlers hexps
      fh = string2urlencoded key
   in (HtmlStruct tag (changeAssoc attrs "name" ("EVENT_" ++ fh)) hes : nhexps,
       (handler,key):evhs, fh)
 where key free

-- show a HTML form in String representation:
showForm :: [(String,String)] -> String -> HtmlForm -> String
showForm cenv url (HtmlForm title params html) =
  htmlPrelude ++
  showHtmlExp
   (HtmlStruct "html" htmlTagAttrs
     [HtmlStruct "head" []
                 ([HtmlStruct "title" [] [HtmlText (htmlQuote title)]] ++
                  concatMap param2html paramsWithEncoding),
      HtmlStruct "body" bodyattrs
       ((if null url || null cenv then id
         else \he->[HtmlStruct "form"
                               ([("method","post"),("action",url)]
                                ++ onsubmitattr ++ targetattr)
                               he])
          ( --[par (env2html cenv),hrule] ++ -- debug
           cenv2hidden cenv ++
           html))])
 where
  paramsWithEncoding = if null [e | (FormEnc e) <- params]
                       then FormEnc defaultEncoding : params
                       else params

  param2html (FormEnc enc) =
     [HtmlStruct "meta" [("http-equiv","Content-Type"),
                         ("content","text/html; charset="++enc)] []]
  param2html (FormCSS css) =
     [HtmlStruct "link" [("rel","stylesheet"),("type","text/css"),("href",css)]
                 []]
  param2html (FormMeta attrs) = [HtmlStruct "meta" attrs []]
  param2html (FormJScript js) =
     [HtmlStruct "script" [("type","text/javascript"),("src",js)] []]
  param2html (FormOnSubmit _) = []
  param2html (FormTarget _) = []
  -- no rule for FormCookie since they have been already processed
  param2html (HeadInclude hexp) = [hexp]
  param2html MultipleHandlers = []
  param2html (BodyAttr _) = []
  -- no rule for BodyAttr since it is considered later

  bodyattrs = [ps | (BodyAttr ps) <- params]

  onsubmit = [s | (FormOnSubmit s) <- params]

  onsubmitattr = if null onsubmit then [] else [("onsubmit",head onsubmit)]

  target = [s | (FormTarget s) <- params]

  targetattr = if null target then [] else [("target",head target)]


-- translate cgi environment into HTML (for debugging purposes):
env2html :: [(String,String)] -> [HtmlExp]
env2html env = concat (map (\(n,v)->[htxt (n++": "++v),breakline]) env)


-- translate environment into hidden fields (without EVENT field!):
-- (note: the field values are urlencoded to avoid problems
--  with passing special characters; moreover, the names of fields
--  containing urlencoded values are prefixed by "U")
cenv2hidden :: [(String,String)] -> [HtmlExp]
cenv2hidden env = concat (map pair2hidden env)
 where
   pair2hidden (n,v)
     | take 6 n == "EVENT_" = []
     | take 6 n == "FIELD_" = [hiddenfield ('U':n) (string2urlencoded v)]
     | otherwise            = [hiddenfield n v]

------------------------------------------------------------------------------
-- association lists (list of tag/value pairs):

-- change an associated value (or add association, if not there):
changeAssoc :: Eq tt => [(tt,tv)] -> tt -> tv -> [(tt,tv)]
changeAssoc [] tag val = [(tag,val)]
changeAssoc ((tag1,val1):tvs) tag val =
   if tag1 == tag then (tag,val) : tvs
                  else (tag1,val1) : changeAssoc tvs tag val


------------------------------------------------------------------------------
--- Execute an HTML form in "interactive" mode.
intForm :: IO HtmlForm -> IO ()
intForm = intFormMain "" "" "" "" False ""
--intcgi = intFormMain "http://localhost/~mh/" "/home/mh/public_html/" "" "fwdcgienv.cgi" False ""

--- Execute an HTML form in "interactive" mode with various parameters.
--- @param baseurl  - the base URL where this script is accessible for clients
--- @param basecgi  - the base directory in the local file system where
---                   this script should stored for execution
--- @param reldir   - the relative path added to baseurl and basecgi
--- @param cginame  - the name of the executable cgi script
--- @param forever  - True if the interactive execution should not be terminated
---                   when the final web page (without a handler) is shown
--- @param urlparam - the URL parameter for the initial call to the cgi script
--- @param hformact - IO action returning the HTML form
intFormMain :: String -> String -> String -> String ->
              Bool -> String -> IO HtmlForm -> IO ()
intFormMain baseurl basecgi reldir cginame forever urlparam hformact = do
  pid      <- getPID
  user     <- getEnviron "USER"
  home     <- getHomeDirectory
  let portname = "intcgi_" ++ show pid
  socket <- listenOn portname
  let cgiprogname = if null cginame then "cgitest_"++show pid++".cgi"
                                    else cginame
      url = (if null baseurl then "http://localhost/~"++user else baseurl)
            ++ "/" ++ reldir ++ "/" ++ cgiprogname
      cgifile = (if null basecgi then home++"/public_html/" else basecgi++"/")++
                (if null reldir  then "" else reldir ++"/") ++ cgiprogname
      cgikey = url++" 42"
  installShowCgiEnvScript portname cgifile
  setEnviron "QUERY_STRING" urlparam
  time <- getClockTime
  intFormInEnv url cgikey hformact hformact [] (initialServerState time)
               forever socket
  system ("rm "++cgifile) >> done

intFormInEnv :: String -> String -> IO HtmlForm -> IO HtmlForm
          -> [(String,String)] -> ServerState -> Bool -> Socket -> IO ()
intFormInEnv url cgikey initform hformact cenv state forever socket = do
  if null cenv then putStrLn ">>> Start initial web form..." else done
  cform <- hformact
  let (cookiestring,hform) = extractCookies cform
  (htmlstring,evhs) <- showHtmlFormInEnv url "" (extendForm hform)
                                         (getMaxFieldNr cenv + 1)
  nstate <- storeEnvHandlers state
                (formWithMultipleHandlers hform)
                (encodeKey cgikey)
                (filter (\ (t,_) -> t/="DEFAULT" && take 6 t /= "EVENT_") cenv)
                evhs
  showHtmlStringInBrowser (cookiestring++htmlstring)
  if forever || formWithHandlers hform
   then do putStrLn ">>> Waiting for web page submission..."
           (_,hdl) <- socketAccept socket
           mbmsg <- readCgiServerMsg hdl
           maybe (intFormInEnv url cgikey initform hformact
                               cenv state forever socket)
                 (intFormProceed nstate hdl)
                 mbmsg
   else putStrLn ">>> Final web page reached"
 where
   intFormProceed nstate hdl (CgiSubmit scriptenv newcenv) = do
    hPutStrLn hdl answerTxt
    hClose hdl
    mapIO_ (\ (var,val) -> setEnviron var val) scriptenv
    if null newcenv -- call to initial script?
     then intFormInEnv url cgikey initform initform [] nstate forever socket
     else do
       (rstate,mfe) <- getNextFormAndCgiEnv nstate cgikey newcenv
       maybe (putStrLn "ERROR: no submission handler")
             (\ (ioform,env) -> intFormInEnv url cgikey initform ioform
                                             env rstate forever socket)
             mfe

   answerTxt = "Content-Type: text/html\n\n" ++
                showHtmlExp (italic [htxt "Waiting for next web form..."])

   extendForm orgform =
     orgform `addFormParam` HeadInclude (HtmlStruct "base" [("href",url)] [])

-- has an HTML form event handlers?
formWithHandlers :: HtmlForm -> Bool
formWithHandlers (HtmlForm _ _ hexps) = hasHandlers hexps
 where
  hasHandlers :: [HtmlExp] -> Bool
  hasHandlers [] = False
  hasHandlers (HtmlText _ : hes) = hasHandlers hes
  hasHandlers (HtmlStruct _ _ hes1 : hes2) =
    hasHandlers hes1 || hasHandlers hes2
  hasHandlers (HtmlCRef he _ : hes) = hasHandlers [he] || hasHandlers hes
  hasHandlers (HtmlEvent _ _ : _) = True

--- Shows a string in HTML format in a browser.
showHtmlStringInBrowser :: String -> IO ()
showHtmlStringInBrowser htmlstring = do
  pid <- getPID
  let htmlfilename = "tmpcgiform_" ++ show pid ++ ".html"
  writeFile htmlfilename htmlstring
  system ("remote-netscape file:`pwd`/"++htmlfilename)
  done

-- install web script that forward user inputs:
installShowCgiEnvScript :: String -> String -> IO ()
installShowCgiEnvScript portname cgifile = do
  putStrLn ">>> Installing web script..."
  putStrLn $ "for port name: "++portname
  writeFile cgifile $ "#!/bin/sh\n"++
                      installDir++"/www/submitform \""++portname++"\"\n"
  system ("chmod 755 "++cgifile)
  done


------------------------------------------------------------------------------
-- The server for each dynamic web page manages the event handlers used in
-- dynamic web pages on the server side.
-- Each event handler is stored on the server side with a unique key.
-- Only this key is sent in the actual web page to the client.
-- Event handlers are only valid for a particular time period
-- specified by <code>eventHandlerExpiration</code>, i.e., after that time
-- event handlers will be deleted.

-- The structure of the internal state of the server:
-- Argument 1: Time when the server has been started.
-- Argument 2: Current index for numbering new events
-- Argument 3: Next date when cleanup is necessary
-- Argument 4: The current event handlers
--               (index,expiration date,cgikey,env,handler,groupindex)
--             where groupindex is Nothing for handlers with multiple use
--             and (Just gk) if the handlers should be deleted together
--             with all other handlers having the same groupindex
--             (usually, belonging to the same page)
type ServerState =
 (ClockTime, Int, ClockTime,
  [(Int,ClockTime,String,([(String,String)],HtmlHandler),Maybe Int)])

--- Creates a new state for a server started at some time.
initialServerState :: ClockTime -> ServerState
initialServerState ctime = (ctime, 0, nextCleanup ctime, [])

--- Is the list of event handlers of a server state empty?
isServerStateWithoutHandlers :: ServerState -> Bool
isServerStateWithoutHandlers (_,_,_,evhandlers) = null evhandlers

--- Gets a string describing the load of the server process.
--- If the server is "busy" it cannot accept further requests
--- for initial web pages.
getServerLoad :: ServerState -> IO String
getServerLoad (stime,maxkey,_,evs) = do
  ctime  <- getClockTime
  let busy = maxkey>500
             || (compareClockTime ctime (addMinutes 30 stime) == GT)
             || null evs -- since a server without handlers will be terminated
  return (if busy then "busy" else "ready")

--- Gets a string describing the status of the server process.
getServerStatus :: ServerState -> IO String
getServerStatus state@(stime,maxkey,_,evs) = do
  busy   <- getServerLoad state
  lstime <- toCalendarTime stime
  pinfos <- getProcessInfos
  return $ "Status: " ++ busy ++ ", Maxkey: "++show maxkey ++ ", #Handlers: " ++
           show (length evs) ++ ", Start time: " ++
           calendarTimeToString lstime ++ "\n" ++
           showMemInfo pinfos

--- Shows the group key of a handler as a string.
showGroupKey :: Maybe Int -> String
showGroupKey Nothing = "multiple use"
showGroupKey (Just gk) = "group " ++ show gk

--- Stores a list of new event handlers for a given cgi program and
--- the corresponding arguments with a new key.
--- The second argument is True if the event handlers should only be used once.
storeEnvHandlers :: ServerState -> Bool -> String -> [(String,String)]
                 -> [(HtmlHandler,String)] -> IO ServerState
storeEnvHandlers ostate multipleuse cgikey env handlerkeys = do
  time <- getClockTime
  cstate <- cleanOldEventHandlers ostate
  rannums <- getRandomSeed >>= return . drop 3 . nextInt
  let nstate = generateEventServerMessages
                 rannums
                 (if multipleuse then Nothing else Just (keyOfState cstate))
                 (eventHandlerExpiration time)
                 cstate
                 handlerkeys
  seq nstate done -- to ensure that handler keys are instantiated
  return nstate
 where
   generateEventServerMessages _ _ _ state [] = state
   generateEventServerMessages (rannum:rannums) groupkey expiredate state
                               ((handler,hkey) : evhs)
     | hkey =:= show (keyOfState state) ++ ' ':showQTerm (toUTCTime expiredate)
                ++ '_' : show rannum -- add random element to handler key string
     = generateEventServerMessages
            rannums
            groupkey
            expiredate
            (storeNewEnvEventWithCgiKey groupkey expiredate state env handler)
            evhs

   keyOfState (_,key,_,_) = key

   storeNewEnvEventWithCgiKey groupkey date (stime,maxkey,cleandate,ehs)
                              cenv info =
     (stime,
      if maxkey>30000 then 0 else maxkey+1, -- to avoid integer overflows
      cleandate,
      (maxkey,date,cgikey,(cenv,info),groupkey):ehs)

-- clean event handlers that are too old:
cleanOldEventHandlers :: ServerState -> IO ServerState
cleanOldEventHandlers state@(_,_,_,[]) = return state
cleanOldEventHandlers state@(stime,maxkey,cleandate,ehs@(_:_)) = do
  ctime <- getClockTime
  if compareClockTime ctime cleandate == LT
   then return state
   else do
     let currentehs = filter (isNotExpired ctime) ehs
         noehs = length ehs
         nocurrentehs = length currentehs
     if nocurrentehs < noehs
      then do -- report cleanup numbers:
        ltime <- toCalendarTime ctime
        putErrLn $ calendarTimeToString ltime ++ ": cleanup " ++
                   "(number of handlers: old = "++ show noehs ++ " / " ++
                   "current = "++ show nocurrentehs ++ ")"
      else done
     return (stime,maxkey, nextCleanup ctime, currentehs)
 where
  isNotExpired time (_,etime,_,_,_) = compareClockTime time etime == LT

-- Retrieves a previously stored event handler for a cgi program.
-- Returns Nothing if the handler is no longer available, i.e., expired.
retrieveEnvHandlers :: ServerState -> String -> String
                    -> IO (ServerState,Maybe ([(String,String)],HtmlHandler))
retrieveEnvHandlers state cgikey skey =
  let (numstring,datestring) = break (==' ') skey
      dateps = readsQTerm datestring
      num    = tryReadNat (-1) numstring
   in if null datestring || null dateps || num < 0
      then return (state,Nothing)
      else let (newstate,info) =
                   getEnvEventWithCgiKey state num (fst (head dateps))
            in seq newstate (return (newstate, info))
      -- the "seq"s are put here and below to enfore the evaluation of the
      -- new state in order to avoid space leaks with old, unused handlers
 where
  getEnvEventWithCgiKey oldstate@(stime,maxkey,cleandate,ehs) key date =
    maybe (oldstate,Nothing)
          (\ (evhdlr,groupkey) ->
            maybe (oldstate, Just evhdlr)
                  (\gk -> let newehs = deleteEv gk ehs
                           in seq newehs ((stime,maxkey,cleandate,newehs),
                                          Just evhdlr))
                  groupkey )
          (searchEv ehs)
   where
    -- search event handler
    searchEv [] = Nothing
    searchEv ((n,t,c,i,gk):es) =
      if key==n && date == toUTCTime t
      then if c==cgikey then Just (i,gk) else Nothing
      else searchEv es

    -- delete event handlers of the same group
    deleteEv _ [] = []
    deleteEv groupkey (ev@(_,_,_,_,Nothing):es) =
      let des = deleteEv groupkey es in seq des (ev : des)
    deleteEv groupkey (ev@(_,_,_,_,Just gk):es) =
      if groupkey==gk
      then deleteEvInGroup groupkey es
      else let des = deleteEv groupkey es in seq des (ev : des)

    deleteEvInGroup _ [] = []
    deleteEvInGroup _        (ev@(_,_,_,_,Nothing):es) = ev : es
    deleteEvInGroup groupkey (ev@(_,_,_,_,Just gk):es) =
      if groupkey==gk
      then deleteEvInGroup groupkey es
      else ev : es -- a new group has started so we stop the deletion


-- Define for a given date a new date when the event handler expires.
eventHandlerExpiration :: ClockTime -> ClockTime
eventHandlerExpiration = addHours 1
--eventHandlerExpiration = addMinutes 1

-- Define for a given date a new date when the next cleanup of event handlers
-- should be done.
nextCleanup :: ClockTime -> ClockTime
nextCleanup = addMinutes 5

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