|
sourcecode:
|
module Curry2CGI ( main )
where
import Control.Monad ( when, unless )
import Data.Char ( isSpace )
import Data.List ( intercalate, isPrefixOf, nub )
import Data.Maybe ( catMaybes )
import System.Environment ( getArgs, getEnv )
import Data.Time ( calendarTimeToString, getLocalTime )
import System.CurryPath ( setCurryPath )
import System.Directory ( createDirectoryIfMissing, doesFileExist
, getAbsolutePath )
import System.FilePath ( (</>), isRelative, takeDirectory, takeFileName )
import System.IOExts ( evalCmd )
import System.Process ( getPID, exitWith, system )
import FlatCurry.Files ( readFlatCurry )
import FlatCurry.TypeAnnotated.Files ( readTypeAnnotatedFlatCurry )
import C2C.Options
import C2C.ExtractForms ( extractFormsInProg )
import C2C.TransFlatCurryForms ( copyTransFlatCurry )
import C2C.TransTypedFlatCurryForms ( copyTransTypedFlatCurry )
------------------------------------------------------------------------
main :: IO ()
main = do
args <- getArgs
(opts0,prog) <- processOptions args
opts <- checkCurrySystem opts0
setCurryPath (optVerb opts < 2) (optCPM opts)
modformops <- mapM (extractFormsInProg opts) (optFormMods opts)
let (mbmods,formops) = unzip modformops
transmods = catMaybes mbmods
compileCGI (opts { optForms = nub (concat formops) }) transmods prog
checkCurrySystem :: Options -> IO Options
checkCurrySystem opts = do
let currybin = optSystem opts </> "bin" </> "curry"
isexec <- doesFileExist currybin
unless isexec $
error $ "Curry system executable '" ++ currybin ++ "' does not exist!"
(rc,out,_) <- evalCmd currybin ["--compiler-name"] ""
unless (rc == 0) $
error "Cannot determine kind of Curry system (pakcs,kics2,curry2go)!"
let sysname = filter (not . isSpace) out
case sysname of
"pakcs" -> return opts { optTypedFlat = False, optFixForms = True }
"kics2" -> return opts { optTypedFlat = True }
"curry2go" -> return opts { optTypedFlat = False }
_ -> do putStrLn $ "Unknown Curry system '" ++ sysname ++ "'."
exitWith 1
-- Generate the main program containing the wrapper for all forms
-- and compile it into a CGI binary.
compileCGI :: Options -> [String] -> String -> IO ()
compileCGI opts transmods mname = do
putStrLnInfo opts $ "Wrapping '" ++ mname ++ "' to generate CGI binary..."
pid <- getPID
let dot2us c = if c == '.' then '_' else c
mainmod = map dot2us mname ++ "_CGIMAIN_" ++ show pid
maincall = "main_cgi_9999_" ++ show pid
cgifile = if null (optOutput opts) then mname ++ ".cgi"
else optOutput opts
cgidir = takeDirectory cgifile
createDirectoryIfMissing True cgidir
let mainprog = genMainProg opts mname mainmod maincall
when (optVerb opts > 1) $ putStr $ unlines
[line, "GENERATED MAIN PROGRAM:", mainprog, line]
writeFile (mainmod ++ ".curry") mainprog
unless (null transmods) $ precompile mainmod
-- compile main module:
let curryverb = if optVerb opts == 2 then 1 else optVerb opts
compilecmd = unwords $
[ optSystem opts </> "bin" </> "curry" , "--nocypm" ] ++
map (\rcopts -> "-D" ++ rcopts) (optCurryRC opts) ++
[ ":set", 'v' : show curryverb ] ++
optCurryOpts opts ++
[ ":load", mainmod, ":save", maincall, ":quit" ]
putStrLnInter opts $ "Executing: " ++ compilecmd
cf <- system compilecmd
when (cf > 0) $ do
putStrLn "Error occurred, generation aborted."
cleanMain mainmod
exitWith 1
-- move compiled executable to final position and generate small shell
-- script to call the executable with ulimit and correct path:
system $ unwords ["mv", mainmod, cgifile ++ ".bin"]
system $ unwords ["chmod", "755", cgifile ++ ".bin"]
genShellScript opts cgifile
cleanMain mainmod
cdate <- getLocalTime >>= return . calendarTimeToString
writeFile (cgifile ++ ".log") (cdate ++ ": cgi script compiled\n")
putStrLnInfo opts $
"New files \"" ++ cgifile ++ "*\" with compiled cgi script generated."
where
precompile mainmod = do
putStrLnInter opts $ "Modules transformed by setting form IDs:\n" ++
unwords transmods
putStrLnInfo opts $ "Pre-compiling " ++ mainmod ++ "..."
if optTypedFlat opts
then do readTypeAnnotatedFlatCurry mainmod
mapM_ (copyTransTypedFlatCurry opts) transmods
else do readFlatCurry mainmod
mapM_ (copyTransFlatCurry opts) transmods
cleanMain mainmod = do
system $ unwords [optSystem opts </> "bin" </> "cleancurry", mainmod]
system $ "/bin/rm -f " ++ mainmod ++ ".curry"
-- Generates the small cgi shell script that actually calls the executable.
genShellScript :: Options -> String -> IO ()
genShellScript opts cgifile = do
system $ "/bin/rm -f " ++ cgifile
langenv <- getEnv "LANG"
cgibase <- if optAbsolute opts then getAbsolutePath cgifile
else return $ "./" ++ takeFileName cgifile
let limit = optLimit opts
script = unlines $
["#!/bin/sh"] ++
(if null langenv then []
else ["LANG=" ++ langenv, "export LANG"]) ++
(if null limit then [] else ["ulimit " ++ limit]) ++
["exec " ++ cgibase ++ ".bin 2>> " ++ cgibase ++ ".log"]
writeFile cgifile script
system $ unwords ["chmod", "755", cgifile]
return ()
--- Generates the main program which is compiled as the CGI executable.
--- The program defines a main operation of the following form:
---
--- main :: IO ()
--- main = HTML.CGI.Exec.printMainPage
--- [ (<formid1>, HTML.CGI.Exec.execFormDef <formdef1>)
--- , ...
--- , (<formidk>, HTML.CGI.Exec.execFormDef <formdefk>)
--- ]
--- <mainpage>
---
--- where `<formid1>,...<formidk>` are the identifiers of all form definitions
--- to be compiled.
genMainProg :: Options -> String -> String -> String -> String
genMainProg opts mname mainmod maincall = unlines $
[ "module " ++ mainmod ++ "(" ++ maincall ++ ") where"
, "import HTML.Base"
, "import HTML.CGI.Exec" ] ++
(map ("import " ++) (nub (mname : optFormMods opts))) ++
[ maincall ++ " :: IO ()"
, maincall ++ " = HTML.CGI.Exec.printMainPage\n [" ++
intercalate "\n ," formCalls ++ "]\n" ++
" (" ++ optMain opts ++ ")"
]
where
formCalls = map (\f -> "(\"" ++ f ++ "\", HTML.CGI.Exec.execFormDef " ++
f ++ ")")
(map showQName (optForms opts))
------------------------------------------------------------------------------
|