Commit a87ee3f5 authored by Michael Hanus 's avatar Michael Hanus

Script generation made safe w.r.t. broken form info files

parent f4e5e067
...@@ -4,14 +4,15 @@ ...@@ -4,14 +4,15 @@
--- necessary. --- necessary.
--- ---
--- @author Michael Hanus --- @author Michael Hanus
--- @version August 2020 --- @version September 2020
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
module C2C.ExtractForms ( extractFormsInProg ) module C2C.ExtractForms ( extractFormsInProg )
where where
import Directory ( doesFileExist, getModificationTime ) import Directory ( doesFileExist, getModificationTime, removeFile )
import FilePath ( (</>), (<.>) ) import FilePath ( (</>), (<.>) )
import IO ( hGetContents, openFile, IOMode(..) )
import List ( intercalate, partition ) import List ( intercalate, partition )
import System ( exitWith, getArgs, getPID, system ) import System ( exitWith, getArgs, getPID, system )
...@@ -29,8 +30,10 @@ import C2C.TransTypedFlatCurryForms ( setFormIDsInTypedFlatCurry ) ...@@ -29,8 +30,10 @@ import C2C.TransTypedFlatCurryForms ( setFormIDsInTypedFlatCurry )
formCacheFile :: String -> String -> String formCacheFile :: String -> String -> String
formCacheFile mdir mname = inCurrySubdir (mdir </> mname) <.> "htmlforms" formCacheFile mdir mname = inCurrySubdir (mdir </> mname) <.> "htmlforms"
--- Extract and check all forms defined in a Curry module (third argument). --- Extract and check all forms defined in a Curry module.
--- Returns the qualified names of the exported forms. --- Returns the qualified names of the exported forms as the second component.
--- The first component is `Nothing` when the module was not transformed
--- to attach form ids, otherwise it is `Just` the module name.
extractFormsInProg :: Options -> String -> IO (Maybe String, [QName]) extractFormsInProg :: Options -> String -> IO (Maybe String, [QName])
extractFormsInProg opts mname = extractFormsInProg opts mname =
lookupModuleSourceInLoadPath mname >>= lookupModuleSourceInLoadPath mname >>=
...@@ -49,7 +52,14 @@ extractFormsInProg opts mname = ...@@ -49,7 +52,14 @@ extractFormsInProg opts mname =
then readFormsInProg opts mname formfile then readFormsInProg opts mname formfile
else do else do
putStrLnInter opts $ "Reading file '" ++ formfile ++ "'" putStrLnInter opts $ "Reading file '" ++ formfile ++ "'"
readFile formfile >>= return . read ffcont <- openFile formfile ReadMode >>= hGetContents
case reads ffcont of
[(t,"")] -> return t
_ -> do
putStrLnInfo opts $
"WARNING: removing broken form info file '" ++ formfile ++ "'"
removeFile formfile
extractWithFormCache (mdir,mfile)
readFormsInProg :: Options -> String -> String -> IO (Maybe String, [QName]) readFormsInProg :: Options -> String -> String -> IO (Maybe String, [QName])
readFormsInProg opts mname formfile = do readFormsInProg opts mname formfile = do
...@@ -62,7 +72,7 @@ readFormsInProg opts mname formfile = do ...@@ -62,7 +72,7 @@ readFormsInProg opts mname formfile = do
unless (null privatenames) $ putStrLn $ unless (null privatenames) $ putStrLn $
"WARNING: Private form operations found (and not translated):\n" ++ "WARNING: Private form operations found (and not translated):\n" ++
unwords (map snd privatenames) unwords (map snd privatenames)
unless (null formnames) $ putStrLnIfNQ opts $ unless (null formnames) $ putStrLnInfo opts $
"Form operations found: " ++ unwords (map snd formnames) "Form operations found: " ++ unwords (map snd formnames)
mbtrans <- if null formnames mbtrans <- if null formnames
then return Nothing then return Nothing
...@@ -96,7 +106,7 @@ checkFormIDsInProg opts mname formnames = do ...@@ -96,7 +106,7 @@ checkFormIDsInProg opts mname formnames = do
if fidok if fidok
then return Nothing then return Nothing
else do else do
putStrLnIfNQ opts $ putStrLnInfo opts $
"Some forms have non-matching IDs: setting correct form IDs..." "Some forms have non-matching IDs: setting correct form IDs..."
case optSysName opts of case optSysName opts of
"pakcs" -> setFormIDsInFlatCurry opts mname "pakcs" -> setFormIDsInFlatCurry opts mname
......
...@@ -2,7 +2,7 @@ ...@@ -2,7 +2,7 @@
--- Option process for the `curry2cgi` script. --- Option process for the `curry2cgi` script.
--- ---
--- @author Michael Hanus --- @author Michael Hanus
--- @version August 2020 --- @version September 2020
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
module C2C.Options module C2C.Options
...@@ -24,7 +24,7 @@ banner :: String ...@@ -24,7 +24,7 @@ banner :: String
banner = unlines [bannerLine,bannerText,bannerLine] banner = unlines [bannerLine,bannerText,bannerLine]
where where
bannerText = "Compile Curry programs with HTML forms to CGI executables " ++ bannerText = "Compile Curry programs with HTML forms to CGI executables " ++
"(Version of 18/08/20)" "(Version of 02/09/20)"
bannerLine = take (length bannerText) (repeat '=') bannerLine = take (length bannerText) (repeat '=')
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
...@@ -88,7 +88,11 @@ options = ...@@ -88,7 +88,11 @@ options =
"run quietly (no output, only exit code)" "run quietly (no output, only exit code)"
, Option "v" ["verb"] , Option "v" ["verb"]
(OptArg (maybe (checkVerb 2) (safeReadNat checkVerb)) "<n>") (OptArg (maybe (checkVerb 2) (safeReadNat checkVerb)) "<n>")
"verbosity level:\n0: quiet (same as `-q')\n1: show status messages (default)\n2: show intermediate results (same as `-v')\n3: show all details" ("verbosity level:\n" ++
"0: quiet (same as `-q')\n" ++
"1: show status messages (default)\n" ++
"2: show intermediate results (same as `-v')\n" ++
"3: show all details")
, Option "m" ["main"] , Option "m" ["main"]
(ReqArg (\s opts -> opts { optMain = s }) "<m>") (ReqArg (\s opts -> opts { optMain = s }) "<m>")
("Curry expression (of type IO HtmlPage) computing\n" ++ ("Curry expression (of type IO HtmlPage) computing\n" ++
...@@ -104,8 +108,9 @@ options = ...@@ -104,8 +108,9 @@ options =
"form handlers should be generated") "form handlers should be generated")
, Option "s" ["system"] , Option "s" ["system"]
(ReqArg (\s opts -> opts { optSystem = s }) "<s>") (ReqArg (\s opts -> opts { optSystem = s }) "<s>")
("set path to the root of Curry system\n" ++ ("set path to the root of Curry system so that\n" ++
"(then 'path/bin/curry' is invoked to compile script)") "'<s>/bin/curry' is invoked to compile script\n" ++
"(default: '" ++ installDir ++ "')")
, Option "" ["cpmexec"] , Option "" ["cpmexec"]
(ReqArg (\s opts -> opts { optCPM = s }) "<c>") (ReqArg (\s opts -> opts { optCPM = s }) "<c>")
("set the command to execute programs with the\n" ++ ("set the command to execute programs with the\n" ++
...@@ -130,9 +135,6 @@ options = ...@@ -130,9 +135,6 @@ options =
then opts { optVerb = n } then opts { optVerb = n }
else error "Illegal verbosity level (try `-h' for help)" else error "Illegal verbosity level (try `-h' for help)"
putStrLnIfNQ :: Options -> String -> IO ()
putStrLnIfNQ opts s = unless (optVerb opts == 0) $ putStrLn s
putStrLnInfo :: Options -> String -> IO () putStrLnInfo :: Options -> String -> IO ()
putStrLnInfo opts s = when (optVerb opts > 0) $ putStrLn s putStrLnInfo opts s = when (optVerb opts > 0) $ putStrLn s
......
...@@ -5,7 +5,7 @@ ...@@ -5,7 +5,7 @@
--- for executing cgi scripts. --- for executing cgi scripts.
--- ---
--- @author Michael Hanus --- @author Michael Hanus
--- @version August 2020 --- @version September 2020
------------------------------------------------------------------------------ ------------------------------------------------------------------------------
module Curry2CGI ( main ) module Curry2CGI ( main )
...@@ -65,7 +65,7 @@ checkCurrySystem opts = do ...@@ -65,7 +65,7 @@ checkCurrySystem opts = do
-- and compile it into a CGI binary. -- and compile it into a CGI binary.
compileCGI :: Options -> [String] -> String -> IO () compileCGI :: Options -> [String] -> String -> IO ()
compileCGI opts transmods mname = do compileCGI opts transmods mname = do
putStrLnIfNQ opts $ "Wrapping '" ++ mname ++ "' to generate CGI binary..." putStrLnInfo opts $ "Wrapping '" ++ mname ++ "' to generate CGI binary..."
pid <- getPID pid <- getPID
let mainmod = mname ++ "_CGIMAIN_" ++ show pid let mainmod = mname ++ "_CGIMAIN_" ++ show pid
maincall = "main_cgi_9999_" ++ show pid maincall = "main_cgi_9999_" ++ show pid
...@@ -97,13 +97,13 @@ compileCGI opts transmods mname = do ...@@ -97,13 +97,13 @@ compileCGI opts transmods mname = do
cleanMain mainmod cleanMain mainmod
cdate <- getLocalTime >>= return . calendarTimeToString cdate <- getLocalTime >>= return . calendarTimeToString
writeFile (cgifile ++ ".log") (cdate ++ ": cgi script compiled\n") writeFile (cgifile ++ ".log") (cdate ++ ": cgi script compiled\n")
putStrLnIfNQ opts $ putStrLnInfo opts $
"New files \"" ++ cgifile ++ "*\" with compiled cgi script generated." "New files \"" ++ cgifile ++ "*\" with compiled cgi script generated."
where where
precompile mainmod = do precompile mainmod = do
putStrLnInter opts $ "Modules transformed by setting form IDs:\n" ++ putStrLnInter opts $ "Modules transformed by setting form IDs:\n" ++
unwords transmods unwords transmods
putStrLnIfNQ opts $ "Pre-compiling " ++ mainmod ++ "..." putStrLnInfo opts $ "Pre-compiling " ++ mainmod ++ "..."
case optSysName opts of case optSysName opts of
"pakcs" -> do readFlatCurry mainmod "pakcs" -> do readFlatCurry mainmod
mapM_ (copyTransFlatCurry opts) transmods mapM_ (copyTransFlatCurry opts) transmods
...@@ -120,7 +120,7 @@ genShellScript opts cgifile = do ...@@ -120,7 +120,7 @@ genShellScript opts cgifile = do
system $ "/bin/rm -f " ++ cgifile system $ "/bin/rm -f " ++ cgifile
langenv <- getEnviron "LANG" langenv <- getEnviron "LANG"
let limit = optLimit opts let limit = optLimit opts
let script = unlines $ script = unlines $
["#!/bin/sh"] ++ ["#!/bin/sh"] ++
(if null langenv then [] (if null langenv then []
else ["LANG=" ++ langenv, "export LANG"]) ++ else ["LANG=" ++ langenv, "export LANG"]) ++
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment