|
sourcecode:
|
module CPM.Query.Main
( main, askCurryInfoServer, askCurryInfoCmd, getPackageModules )
where
import Control.Monad ( unless, when, replicateM, void )
import Data.List ( intercalate, nubBy )
import System.Environment ( getArgs )
import System.IO ( getContents, hFlush, stderr, hClose, hGetLine
, hPutStr, hPutStrLn )
import FlatCurry.Types ( QName )
import Network.Socket ( connectToSocket )
import Network.URL ( params2urlencoded, string2urlencoded )
import System.CurryPath ( lookupModuleSourceInLoadPath
, getPackageVersionOfDirectory
, getPackageVersionOfModule, setCurryPathIfNecessary
, sysLibPath )
import System.Directory ( doesFileExist, getCurrentDirectory
, getModificationTime )
import System.FilePath ( (</>), joinPath, splitDirectories, replaceDirectory )
import System.IOExts ( evalCmd, execCmd, readCompleteFile )
import System.Path ( fileInPath )
import System.Process ( exitWith, system )
import Text.CSV ( readCSV, showCSV )
import CPM.Query.Configuration
import CPM.Query.Options
---------------------------------------------------------------------
banner :: String
banner = unlines [bannerLine, bannerText, bannerLine]
where
bannerText = "CPM Query Tool (Version of 02/04/25)"
bannerLine = take (length bannerText) (repeat '=')
main :: IO ()
main = do
(opts,args) <- getArgs >>= processOptions banner
unless (optRemote opts) checkExecutable
when (optEntity opts == Unknown) $ do
printWhenStatus opts $
"No information for entity of kind '" ++ optCLS opts ++ "'"
exitWith 0
let genfile = optGenFrom opts
case args of
[pkg,vsn,mn] | optGenerate opts -> generateForModule opts pkg vsn mn
[mn,fn] -> if optGenerate opts then generateForPackage opts mn fn
else queryModuleEntity opts mn fn
[mn] -> queryModuleEntity opts mn ""
[] | not (null (optModule opts))
-> queryModuleEntity opts (optModule opts) ""
| not (null (optPackage opts))
-> queryPackage opts
| optGenerate opts && not (null genfile)
-> do table <- readCSV <$> if genfile == "-" then getContents
else readFile genfile
mapM_ (genFromFields opts) (nubBy eqPkgVrs table)
_ -> do putStrLn $ "Illegal arguments: " ++ unwords args ++ "\n\n" ++
usageText
exitWith 1
where
eqPkgVrs l1 l2 = case (l1,l2) of (p1:v1:_, p2:v2:_) -> p1==p2 && v1==v2
_ -> False
genFromFields opts fs = case fs of
(p:v:_) | isPackageName p -> generateForPackage opts p v
[] -> return () -- skip empty lines
_ -> hPutStr stderr $
"*** Ignore illegal line in generate file: " ++ showCSV [fs]
checkExecutable = do
hascurryinfo <- fileInPath "curry-info"
unless hascurryinfo $ do
putStrLn $ "Binary 'curry-info' not found in PATH!\n" ++
"Use 'curry-info' web service (option '--remote') or\n" ++
"install it by the the following commands:\n\n" ++
"> git clone https://github.com/curry-language/curry-info-system.git\n" ++
"> cd curry-info-system\n" ++
"> cypm install\n"
exitWith 1
------------------------------------------------------------------------------
-- Generate analysis information for a given package and version.
-- In remote mode, the package repository index is also updated.
generateForPackage:: Options -> String -> String -> IO ()
generateForPackage opts pkg vsn = do
let pkgid = pkg ++ "-" ++ vsn
printWhenStatus opts $
"Generating infos for package '" ++ pkgid ++ "' for " ++
show (optEntity opts) ++ " entities..."
when (optEntity opts == Unknown) $ exitWith 0
let pkgvsnopts = [ ("--package", pkg), ("--version", vsn) ]
when (null (optRequest opts)) $ do
printWhenStatus opts $
"Cleaning old information of package '" ++ pkgid ++ "'..."
callCurryInfo opts (pkgvsnopts ++ [("--clean","")])
when (optRemote opts) $ do -- update repo index in remote mode:
printWhenStatus opts "Update package repository index..."
callCurryInfo opts [ ("--update","") ]
callCurryInfo opts
(("--package", pkg) : ("--force","2") : map (\r->(r,"")) packageRequests)
callCurryInfo opts
(pkgvsnopts ++ ("--force","2") : map (\r->(r,"")) packageVersionRequests)
mods <- getPackageModules opts pkg vsn
mapM_ (generateForModule opts pkg vsn) mods
-- Generate analysis information for a given package, version, and module.
generateForModule :: Options -> String -> String -> String -> IO ()
generateForModule opts pkg vsn mn = do
genInfoMsg []
let ciopts = [ ("--force","2"), ("--package", pkg), ("--version", vsn)
, ("--module", mn) ]
let optreqs = optRequest opts
if null optreqs
then do
infoAndCallCurry ciopts moduleRequests
mapM_ (genClassRequest ciopts) classRequests
mapM_ (genTypeRequest ciopts) typeRequests
mapM_ (genOpRequest ciopts) operationRequests
else case optEntity opts of
Class -> mapM_ (genClassRequest ciopts) optreqs
Type -> mapM_ (genTypeRequest ciopts) optreqs
Operation -> mapM_ (genOpRequest ciopts) optreqs
Unknown -> return ()
where
genClassRequest ciopts req
-- for a `documentation` or `definition` request, compute it only for
-- a dummy entity since this sets the results for all entities
| req `elem` ["documentation", "definition"]
= infoAndCallCurry ciopts ["--class=", req]
| otherwise
= infoAndCallCurry ciopts ["--allclasses", req]
genTypeRequest ciopts req
-- for a `documentation` or `definition` request, compute it only for
-- a dummy entity since this sets the results for all entities
| req `elem` ["documentation", "definition"]
= infoAndCallCurry ciopts ["--type=", req]
| otherwise
= infoAndCallCurry ciopts ["--alltypes", req]
genOpRequest ciopts req
-- for operation requests (different from `name`), compute requests only
-- for a dummy operation since this sets the analysis results
-- for all operations
| req `notElem` ["name"]
= infoAndCallCurry ciopts ["--operation=", req]
| otherwise
= infoAndCallCurry ciopts ["--alloperations", req]
infoAndCallCurry ciopts reqs = do
genInfoMsg reqs
callCurryInfo opts $ ciopts ++ map (\r->(r,"")) reqs
genInfoMsg req = printWhenStatus opts $
"Generating infos for '" ++ mn ++
(if null req then "" else "' and '" ++ unwords req) ++ "'..."
------------------------------------------------------------------------------
-- Query an entity of a given module. The module is looked up in the
-- current load path of Curry if information about the package/version
-- is not provided.
queryModuleEntity :: Options -> String -> String -> IO ()
queryModuleEntity opts0 mname ename = do
let opts1 = opts0 { optModule = mname, optEName = ename }
(pname,vers) <- if null (optPackage opts1) || null (optVersion opts1)
then getPackageVersion opts1
else return (optPackage opts1, optVersion opts1)
-- do something with package, version, module, and function:
let entity = optEntity opts1
edescr = if optVerb opts1 > 1
then unlines [ "Package name : " ++ pname
, "Package version: " ++ vers
, "Module name : " ++ mname
, "Entity name : " ++ ename ]
else (if null ename
then "Module " ++ mname
else show entity ++ " " ++ mname ++ "." ++ ename) ++
" (package " ++ pname ++ "-" ++ vers ++ ")"
putStrLn edescr
let requests = if null (optRequest opts1)
then if null ename && not (optAll opts1)
then [ "classes", "types", "operations" ]
else let rcreq = case entity of
Class -> optCRequests opts1
Type -> optTRequests opts1
Operation -> optORequests opts1
Unknown -> []
in if null rcreq then defaultShowRequests entity
else rcreq
else optRequest opts1
opts2 = opts1 { optPackage = pname, optVersion = vers
, optRequest = requests }
callCurryInfo opts2 (curryInfoOptions opts2)
where
getPackageVersion opts = do
setCurryPathIfNecessary
mbsrc <- lookupModuleSourceInLoadPath mname
case mbsrc of
Nothing -> error $ "Module '" ++ mname ++ "' not found!"
Just (dirname,filename) -> do
getPackageVersionOfDirectory dirname >>= maybe
(printWhenStatus opts
("Module '" ++ mname ++ "' " ++
(if optVerb opts > 1
then "stored in file\n " ++ filename ++
"\nbut this does not belong to the sources of a "
else "does not belong to a ") ++
"registered CPM package!") >> exitWith 0)
return
-- Query a package specified in the option argument.
queryPackage :: Options -> IO ()
queryPackage opts0 = do
let opts = opts0 { optModule = "", optEName = ""
, optAll = False, optShowAll = False
, optRequest = if null (optRequest opts0)
then if null (optVersion opts0)
then [ "versions" ]
else [ "modules" ]
else optRequest opts0 }
callCurryInfo opts (curryInfoOptions opts)
-- Generate curry-info options from cpm-query options.
curryInfoOptions :: Options -> [(String,String)]
curryInfoOptions opts =
[ ("--format", optOutFormat opts)
, ("--force", if optShowAll opts then "0" else show (optForce opts)) ] ++
(if optShowAll opts then [("--showall","")] else []) ++
(if null (optPackage opts) then [] else [("--package", optPackage opts)]) ++
(if null (optVersion opts) then [] else [("--version", optVersion opts)]) ++
(if null (optModule opts) then [] else [("--module", optModule opts)]) ++
(if optAll opts then allEntOpt
else if null ename then [] else entityOpt) ++
map (\r -> (r,"")) (optRequest opts)
where
ename = optEName opts
allEntOpt = case optEntity opts of
Operation -> [ ("--alloperations","") ]
Type -> [ ("--alltypes","") ]
Class -> [ ("--allclasses","") ]
Unknown -> []
entityOpt = case optEntity opts of
Operation -> [ ("--operation", ename) ]
Type -> [ ("--type", ename) ]
Class -> [ ("--class", ename) ]
Unknown -> []
-- The command and parameters to invoke `curry-info` depending on the
-- options passed as the first parameter.
-- The verbosity and color options are set according to these options.
-- The second parameters are the actual options for the `curry-info` command.
curryInfoCmd :: Options -> [(String,String)] -> (String, [String])
curryInfoCmd opts ciopts =
if optRemote opts
then ("curl",
["--max-time", show (optMaxTime opts), "--silent", "--show-error",
optRemoteURL opts ++ "?" ++ params2urlencoded (addOptions ciopts)])
else (curryInfoBin,
map (\(o,v) -> if null v then o else o ++ '=' : v)
(addOptions (("--verbosity", show (optVerb opts)) : ciopts)))
where
addOptions = addCacheOption . addColorOption
-- Add the option `--color` to a list of `curry-info` options, if demanded.
addColorOption ncopts =
if optColor opts then ("--color","") : ncopts else ncopts
-- Add the option `--cache` to a list of `curry-info` options
-- if the `curryInfoCache` is not null.
addCacheOption ncopts
| null curryInfoCache = ncopts
| otherwise = ("--cache", curryInfoCache) : ncopts
-- Calls `curry-info` locally or in remote mode with the given parameters.
-- In dry mode, show only the command.
callCurryInfo :: Options -> [(String,String)] -> IO ()
callCurryInfo opts ciopts = do
let (cmdbin,cmdopts) = curryInfoCmd opts ciopts
cmd = unwords $ cmdbin : map escapeShellString cmdopts
when (optVerb opts > 1 || optDryRun opts) $ putStrLn $ "Executing: " ++ cmd
unless (optDryRun opts) $ do
ec <- system cmd
when (ec > 0) $
if optRemote opts && ec == 28 -- timeout return code of `curl`
then putStrLn "(timeout from CurryInfo web service)"
else printWhenStatus opts $ "Execution error! Return code: " ++ show ec
------------------------------------------------------------------------------
--- This action starts `curry-info` in server mode and returns the result
--- of the given request (third argument) for all operations in the module
--- provided as the first argument. The requested result is returned in its
--- string representation for each entity in the module.
--- The second argument is the kind of entity to be queried.
--- If it is `Unknown`, `Nothing` is returned.
---
--- The package and version are determined using the Curry loadpath.
--- If something goes wrong, Nothing is returned.
---
--- Example: get the demanded arguments of all operation in module `Data.List`:
---
--- > askCurryInfoServer "Data.List" Operation "demand"
---
askCurryInfoServer :: String -> CurryEntity -> String
-> IO (Maybe [(QName, String)])
askCurryInfoServer modname entkind req
| entkind == Unknown = return Nothing
| otherwise = do
mres <- getPackageVersionOfModule modname
case mres of
Nothing -> return Nothing
Just (pkg, vsn) -> do
-- Note: force=0 is important to avoid loops if the analysis tools
-- also use `curry-info`!
(srvin, srvout, srverr) <- execCmd "curry-info --quiet -f0 --server &"
-- Get port
port <- fmap readPort (hGetLine srvout)
hPutStrLn stderr $ "Connecting to port " ++ port
-- Connect to server
handle <- connectToSocket "localhost" (read port)
-- Send requests
let srvcmd = case entkind of
Type -> "RequestAllTypesInformation"
Class -> "RequestAllClassesInformation"
_ -> "RequestAllOperationsInformation"
let msg = srvcmd ++ " curryterm 0 " ++ pkg ++ " " ++ vsn ++ " " ++
modname ++ " " ++ req
hPutStrLn handle msg
hFlush handle
resultMsg <- hGetLine handle
result <- case words resultMsg of
["ok", numberOfLines] -> do
ls <- replicateM (read numberOfLines) (hGetLine handle)
let results = read (unlines ls) :: [(String, String)]
fmap Just (mapM readResult results)
("error":errmsg) -> do
hPutStrLn stderr $ "Error message: " ++ unwords errmsg
return Nothing
_ -> do hPutStrLn stderr $ "Unexpected message: " ++ resultMsg
return Nothing
-- Shut down server
hPutStrLn handle "StopServer"
hFlush handle
-- Close handles
hClose srvin
hClose srvout
hClose srverr
return result
where
readPort s = words s !! 2 -- First line of server: "Server Port: <n>"
readResult :: (String, String) -> IO (QName, String)
readResult (obj, res) = do
let (m, o) = read obj :: (String, String)
[(_, result)] = read res :: [(String, String)]
return ((m, o), result)
------------------------------------------------------------------------------
--- This action uses the `curry-info` command to return the result
--- of the given request (third argument) for all entities in the module
--- provided as the third argument. The requested result is returned in its
--- string representation for each entity in the module.
--- If the first argument is `True`, the `curry-info` web service is queried.
--- The second is the verbosity (where 0 means quiet).
--- The fourth argument is the kind of entity to be queried.
--- If it is `Unknown`, `Nothing` is returned.
---
--- The package and version are determined using the Curry loadpath.
--- If something goes wrong, Nothing is returned.
---
--- Example: get the demanded arguments of all operations in module `Data.List`:
---
--- > askCurryInfoCmd True 1 "Data.List" Operation "demand"
---
askCurryInfoCmd :: Bool -> Int -> String -> CurryEntity -> String
-> IO (Maybe [(QName, String)])
askCurryInfoCmd remote verb modname entkind req
| entkind == Unknown = return Nothing
| otherwise = do
mres <- getPackageVersionOfModule modname
case mres of
Nothing -> return Nothing
Just (pkg, vsn) -> do
-- Note: force=0 is important to avoid loops if the analysis tools
-- also use `curry-info`!
-- Verbosity 0/quiet is also important, otherwise buffer for stderr
-- will be filled in the `evalCmd` call so that it might overflow.
let queryopts = defaultOptions
{ optForce = 0, optVerb = 0, optAll = True
, optRemote = remote, optRemoteURL = curryInfoURL
, optOutFormat = "CurryTerm"
, optPackage = pkg, optVersion = vsn
, optModule = modname
, optRequest = [req] }
(cmd,cmdopts) = curryInfoCmd queryopts (curryInfoOptions queryopts)
when (verb > 1) $ hPutStrLn stderr $
unwords $ ["Executing:", cmd] ++ cmdopts
(ec, out, err) <- evalCmd cmd cmdopts ""
if ec > 0
then do when (verb > 0) $ do
hPutStrLn stderr $ line ++ "Execution error. Output:"
unless (null out) $ hPutStrLn stderr out
unless (null err) $ hPutStrLn stderr err
hPutStrLn stderr line
return Nothing
else do
let mbres = do results <- (safeRead out :: Maybe [(String, String)])
mapM readResult results
maybe (readError out) (return . Just) mbres
where
line = take 70 (repeat '-') ++ "\n"
readError s = do
when (verb > 0) $ hPutStrLn stderr $
line ++ "Error reading output:\n" ++ s ++ line
return Nothing
readResult :: (String, String) -> Maybe (QName, String)
readResult (obj, res) = do
(m, o) <- (safeRead obj :: Maybe (String, String))
[(_, result)] <- (safeRead res :: Maybe [(String, String)])
return ((m, o), result)
-- This operation tries to read a value from a string and returns Nothing
-- in case of a read failure.
safeRead :: Read a => String -> Maybe a
safeRead s = case reads s of
[(x, bs)] | all isSpace bs -> Just x
_ -> Nothing
----------------------------------------------------------------------------
--- Query `curry-info` with some request where the options are taken
--- from the RC file.
--- The first argument are the `curry-info` arguments to specify the entity
--- (e.g., package/version/module/option).
--- The second argument is the (single!) request.
--- The result must be readable so that it it is returned as data.
--- In case of a parse error, the program is terminated with an error code.
queryCurryInfo :: Read a => [(String,String)] -> String -> IO a
queryCurryInfo especs req = do
opts <- getDefaultOptions
queryCurryInfoWithOptions opts especs req
--- Query `curry-info` with some request.
--- The first argument are the `cpm-query` options to be used for the query.
--- The second argument are the `curry-info` arguments to specify the entity
--- (e.g., package/version/module/option).
--- The third argument is the (single!) request.
--- The result must be readable so that it it is returned as data.
queryCurryInfoWithOptions :: Read a => Options -> [(String,String)] -> String
-> IO a
queryCurryInfoWithOptions opts especs req = do
let ciopts = [("--verbosity",show (optVerb opts)), ("--format","CurryTerm")]
++ especs ++ [(req,"")]
(cmd,cmdopts) = curryInfoCmd opts ciopts
printWhenAll opts $ unwords $ ["Executing:", cmd] ++ cmdopts
(ec,sout,serr) <- evalCmd cmd cmdopts ""
when (optVerb opts > 2 || ec > 0) $ putStrLn $
"Exit code: " ++ show ec ++ "\nSTDOUT:\n" ++ sout ++ "\nSTDERR:\n" ++ serr
when (ec > 0) $ reportError "ERROR OCCURRED"
-- Now we parse the output of curry-info:
-- curry-info returns a list of strings pairs (package string, info string):
resterm <- case reads sout of
[(ms,_)] -> return (ms :: [(String,String)])
_ -> reportError $ "Parse error for: " ++ sout
-- the info string is a pair of requests and results as strings:
case resterm of
[] -> reportError "NO INFORMATION FOUND!"
((_,infos):_) -> do
infolist <- case reads infos of
[(ms,_)] -> return (ms :: [(String,String)])
_ -> reportError ("Parse error for: " ++ infos)
-- finally, the (first) result string is a list of module names:
let infostring = snd (head infolist)
case reads infostring of
[(ms,_)] -> return ms
_ -> reportError ("Parse error for: " ++ infostring)
where
reportError s = putStrLn s >> exitWith 1
-- Examples to use `queryCurryInfoWithOptions`:
--- Get all modules of a package version by `curry-info`.
--- In case of a parse error, the program is terminated with an error state.
getPackageModules :: Options -> String -> String -> IO [String]
getPackageModules opts pkg vsn = do
printWhenStatus opts $
"Get modules of package '" ++ pkg ++ "-" ++ vsn ++ "'..."
queryCurryInfoWithOptions opts { optVerb = 0 }
[("--package",pkg), ("--version",vsn)] "modules"
--- Get the number of operations of all modules of a package version.
--- In case of a parse error, the program is terminated with an error state.
getPackageModuleOps :: Options -> String -> String -> IO [(String,Int)]
getPackageModuleOps opts pkg vsn = do
let qopts = opts { optVerb = 0 }
mods <- getPackageModules opts pkg vsn
mops <- mapM (\m -> (queryCurryInfoWithOptions qopts
[("--package",pkg), ("--version",vsn), ("--module",m)]
"operations"))
mods
return (zip mods (map length (mops :: [[String]])))
-- >>= return . foldr (+) 0 . map snd -- to add all numbers
----------------------------------------------------------------------------
-- Auxiliaries:
-- Is the string a valid package name?
isPackageName :: String -> Bool
isPackageName [] = False
isPackageName (c:cs) = isAlphaNum c &&
all (\d -> isAlphaNum d || d == '-' || d == '_') cs
--- The binary name of the curry-info tool.
curryInfoBin :: String
curryInfoBin = "curry-info"
--- Transforms a possible qualified name into a pair of a module name
--- (which might be empty) and an unqualified name.
fromQName :: String -> (String,String)
fromQName = fromQN ""
where
fromQN mp s =
let (m,dotn) = break (=='.') s
in if null dotn || not (isModuleID m)
then (mp,s)
else if null mp then fromQN m (tail dotn)
else fromQN (mp ++ '.':m) (tail dotn)
-- Is a string a (non-hierarchical) module identifier?
isModuleID :: String -> Bool
isModuleID [] = False
isModuleID (x:xs) = isAlpha x && all (\c -> isAlphaNum c || c `elem` "'_") xs
-- Escape a string to use it as a parameter in a shell command.
escapeShellString :: String -> String
escapeShellString s
| all isAlphaNum s = s
| null s = "''"
| otherwise = '\'' : concatMap escapeSingleQuote s ++ "'"
where
escapeSingleQuote c | c == '\'' = "'\\\''"
| otherwise = [c]
----------------------------------------------------------------------------
|