1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
|
module CPM.Query.Main
where
import Control.Monad ( unless, when, replicateM )
import Data.List ( intercalate, isPrefixOf, nub, union )
import System.Environment ( getArgs )
import System.IO ( getContents, hFlush, stderr, hClose, hGetLine
, hPutStrLn )
import FlatCurry.Types ( QName )
import Network.Socket ( connectToSocket )
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 CPM.Query.Configuration
import CPM.Query.Options
banner :: String
banner = unlines [bannerLine, bannerText, bannerLine]
where
bannerText = "CPM Query Tool (Version of 11/01/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 ls <- if genfile == "-" then getContents else readFile genfile
mapM_ (genFromLine opts)
(nub (filter (\l -> take 1 l /= "#") (lines ls)))
_ -> do putStrLn $ "Illegal arguments: " ++ unwords args ++ "\n\n" ++
usageText
exitWith 1
where
genFromLine opts l = case words l of
[p,v] -> generateForPackage opts p v
[] -> return ()
_ -> hPutStrLn stderr $ "Ignore illegal line in generate file: " ++ l
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
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
when (null (optRequest opts)) $ do
printWhenStatus opts $
"Cleaning old information of package '" ++ pkgid ++ "'..."
let cleanopts = [ "--package=" ++ pkg, "--version=" ++ vsn, "--clean" ]
callCurryInfo opts cleanopts
when (optRemote opts) $ do
printWhenStatus opts "Update package repository index..."
callCurryInfo opts [ "--update" ]
mods <- getPackageModules opts pkg vsn
mapM_ (generateForModule opts pkg vsn) mods
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 ("--allclasses" : defaultRequests Class)
infoAndCallCurry ciopts ("--alltypes" : defaultRequests Type)
mapM_ (genOpRequest ciopts)
(union ["signature", "definition", "documentation"]
(defaultRequests Operation))
else case optEntity opts of
Class -> infoAndCallCurry ciopts ("--allclasses" : optreqs)
Type -> infoAndCallCurry ciopts ("--alltypes" : optreqs)
Operation -> mapM_ (genOpRequest ciopts) optreqs
Unknown -> return ()
where
singleOpRequest req = "cass-" `isPrefixOf` req || req == "failfree"
genOpRequest ciopts req
| singleOpRequest req
=
infoAndCallCurry ciopts ["--operation=", req]
| otherwise
= infoAndCallCurry ciopts ["--alloperations", req]
infoAndCallCurry ciopts reqs = do
genInfoMsg reqs
callCurryInfo opts $ ciopts ++ reqs
genInfoMsg req = printWhenStatus opts $
"Generating infos for '" ++ mn ++
(if null req then "" else "' and '" ++ unwords req) ++ "'..."
curryInfoBin :: String
curryInfoBin = "curry-info"
addColorCIOption :: Options -> [String] -> [String]
addColorCIOption opts ciopts =
if optColor opts then "--color" : ciopts else ciopts
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)
isModuleID :: String -> Bool
isModuleID [] = False
isModuleID (x:xs) = isAlpha x && all (\c -> isAlphaNum c || c `elem` "'_") xs
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)
let 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 (optEntity opts1) ++ " " ++
mname ++ "." ++ ename) ++
" (package " ++ pname ++ "-" ++ vers ++ ")"
putStrLn edescr
let opts2 = opts1 { optPackage = pname, optVersion = vers }
request = if null (optRequest opts2)
then if null ename
then [ "classes", "types", "operations" ]
else defaultRequests (optEntity opts2)
else optRequest opts2
ciopts = curryInfoOptions opts2 ++ request
callCurryInfo opts2 ciopts
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
queryPackage :: Options -> IO ()
queryPackage opts0 = do
let opts = opts0 { optModule = "", optEName = ""
, optAll = False, optShowAll = False }
let request = if null (optRequest opts)
then if null (optVersion opts)
then [ "versions" ]
else [ "modules" ]
else optRequest opts
ciopts = curryInfoOptions opts ++ request
callCurryInfo opts ciopts
curryInfoOptions :: Options -> [String]
curryInfoOptions opts =
[ "--format=" ++ optOutFormat opts ] ++
(if optForce opts && not (optShowAll opts) then ["-f1"]
else ["-f0"]) ++
(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)
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 -> []
curryInfoCmd :: Options -> [String] -> (String, [String])
curryInfoCmd opts ciopts =
if optRemote opts
then ("curl",
["--max-time", "3600", "--silent", "--show-error",
optRemoteURL opts ++ "?" ++
intercalate "&"
(addColorCIOption opts (map string2urlencoded ciopts))])
else (curryInfoBin,
addColorCIOption opts ["--verbosity=" ++ show (optVerb opts)] ++
ciopts)
callCurryInfo :: Options -> [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) $
printWhenStatus opts $ "Execution error! Return code: " ++ show ec
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
(srvin, srvout, srverr) <- execCmd "curry-info --quiet -f0 --server &"
port <- fmap readPort (hGetLine srvout)
hPutStrLn stderr $ "Connecting to port " ++ port
handle <- connectToSocket "localhost" (read port)
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
hPutStrLn handle "StopServer"
hFlush handle
hClose srvin
hClose srvout
hClose srverr
return result
where
readPort s = words s !! 2
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)
askCurryInfoCmd :: Bool -> String -> CurryEntity -> String
-> IO (Maybe [(QName, String)])
askCurryInfoCmd useserver modname entkind req
| entkind == Unknown = return Nothing
| otherwise = do
mres <- getPackageVersionOfModule modname
case mres of
Nothing -> return Nothing
Just (pkg, vsn) -> do
let alloption = case entkind of Type -> "--alltypes"
Class -> "--allclasses"
_ -> "--alloperations"
queryopts = defaultOptions { optVerb = 0, optRemote = useserver
, optRemoteURL = curryInfoURL }
ciopts = [ "-f0", "--package=" ++ pkg, "--version=" ++ vsn
, "--module=" ++ modname, alloption
, "--format=CurryTerm", req]
(cmd,cmdopts) = curryInfoCmd queryopts ciopts
(ec, out, err) <- evalCmd cmd cmdopts ""
if ec > 0
then do putStrLn "Execution error. Output:"
unless (null out) $ putStrLn out
unless (null err) $ putStrLn err
return Nothing
else do let results = read out :: [(String, String)]
fmap Just (mapM readResult results)
where
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)
queryCurryInfo :: Read a => [(String,String)] -> String -> IO a
queryCurryInfo especs req = do
opts <- getDefaultOptions
queryCurryInfoWithOptions opts especs req
queryCurryInfoWithOptions :: Read a => Options -> [(String,String)] -> String
-> IO a
queryCurryInfoWithOptions opts especs req = do
let ciopts = [ "-v" ++ show (optVerb opts), "--format=CurryTerm" ] ++
map (\(t,v) -> t ++ "=" ++ v) 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"
resterm <- case reads sout of
[(ms,_)] -> return (ms :: [(String,String)])
_ -> reportError $ "Parse error for: " ++ sout
case resterm of
[] -> reportError "NO INFORMATION FOUND!"
((_,infos):_) -> do
infolist <- case reads infos of
[(ms,_)] -> return (ms :: [(String,String)])
_ -> reportError ("Parse error for: " ++ infos)
let infostring = snd (head infolist)
case reads infostring of
[(ms,_)] -> return ms
_ -> reportError ("Parse error for: " ++ infostring)
where
reportError s = putStrLn s >> exitWith 1
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"
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]])))
string2urlencoded :: String -> String
string2urlencoded [] = []
string2urlencoded (c:cs)
| noEncode c = c : string2urlencoded cs
| c == ' ' = '+' : string2urlencoded cs
| otherwise
= let oc = ord c
in '%' : int2hex(oc `div` 16) : int2hex(oc `mod` 16) : string2urlencoded cs
where
noEncode x = isAlphaNum x || x `elem` "=-"
int2hex i = if i<10 then chr (ord '0' + i)
else chr (ord 'A' + i - 10)
escapeShellString :: String -> String
escapeShellString s
| all isAlphaNum s = s
| null s = "''"
| otherwise = '\'' : concatMap escapeSingleQuote s ++ "'"
where
escapeSingleQuote c | c == '\'' = "'\\''"
| otherwise = [c]
|