CloogleServer.icl 15.3 KB
Newer Older
1 2
module CloogleServer

3 4 5
import StdArray
import StdBool
import StdFile
Camil Staps's avatar
Camil Staps committed
6
from StdFunc import id, o
Camil Staps's avatar
Camil Staps committed
7
import StdList
8
import StdMisc
9 10
import StdOrdList
import StdOverloaded
11
import StdString
12
import StdTuple
13

14
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
15

16 17 18 19
import Clean.Types
import Clean.Types.Parse
import Clean.Types.Unify
import Clean.Types.Util
20
import Control.Applicative
21
import Control.Monad => qualified join
22
import Data.Error
23
import qualified Data.Foldable as Foldable
Camil Staps's avatar
Camil Staps committed
24
from Data.Foldable import class Foldable
25
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt, on, `on`
26
import Data.Functor
Camil Staps's avatar
Camil Staps committed
27
from Data.List import permutations
28
import Data.Maybe
29
import Data.Tuple
Camil Staps's avatar
Camil Staps committed
30
import System._Posix
31
import System.CommandLine
32
import System.File
33
import System.Options
34
import System.Process
Camil Staps's avatar
Camil Staps committed
35
import System.Time
36
from Text import class Text(concat,join,split,startsWith,toLowerCase), instance Text String, <+
37
import Text.GenJSON
Camil Staps's avatar
Camil Staps committed
38

Camil Staps's avatar
Camil Staps committed
39 40 41
import Cloogle.API
import Cloogle.DB
import Cloogle.Search
42
import Cloogle.Search.Rank
Camil Staps's avatar
Camil Staps committed
43 44 45 46

import Util.SimpleTCPServer
import Util.Cache
import Util.Memory
Camil Staps's avatar
Camil Staps committed
47

48 49
MAX_RESULTS        :== 15
CACHE_PREFETCH     :== 5
Camil Staps's avatar
Camil Staps committed
50
CACHE_NS_THRESHOLD :== 20000000
51

52
:: RequestCacheKey
Camil Staps's avatar
Camil Staps committed
53 54 55 56
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: Maybe String
57
	  , c_using            :: Maybe [String]
Camil Staps's avatar
Camil Staps committed
58 59 60
	  , c_modules          :: Maybe [String]
	  , c_libraries        :: Maybe [String]
	  , c_include_builtins :: Bool
61
	  , c_include_core     :: Bool
62
	  , c_include_apps     :: Bool
Camil Staps's avatar
Camil Staps committed
63
	  , c_page             :: Int
64 65
	  }

66 67
derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction, RankSettings
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction, RankSettings, RankConstraint
68 69 70
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck

71
toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
Camil Staps's avatar
Camil Staps committed
72
toRequestCacheKey db r
73
# (alwaysUnique,db) = alwaysUniquePredicate db
74
# (allsyns,db) = allTypeSynonyms db
Camil Staps's avatar
Camil Staps committed
75 76
= (
	{ c_unify            = snd <$>
77
		prepare_unification True alwaysUnique allsyns <$>
Camil Staps's avatar
Camil Staps committed
78
		(parseType o fromString =<< r.unify)
79
	, c_name             = toLowerCase <$> r.Request.name
80 81
	, c_className        = r.className
	, c_typeName         = r.typeName
82
	, c_using            = r.using
Camil Staps's avatar
Camil Staps committed
83 84
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
85 86 87 88
	, c_include_builtins = fromMaybe DEFAULT_INCLUDE_BUILTINS r.include_builtins
	, c_include_core     = fromMaybe DEFAULT_INCLUDE_CORE r.include_core
	, c_include_apps     = fromMaybe DEFAULT_INCLUDE_APPS r.include_apps
	, c_page             = fromMaybe 0 r.page
89
	}, db)
90 91
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
Camil Staps's avatar
Camil Staps committed
92
	{ unify            = concat <$> print False <$> unprepare <$> k.c_unify
93 94 95
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
96
	, using            = k.c_using
97 98 99 100 101 102 103
	, modules          = k.c_modules
	, libraries        = k.c_libraries
	, include_builtins = Just k.c_include_builtins
	, include_core     = Just k.c_include_core
	, include_apps     = Just k.c_include_apps
	, page             = Just k.c_page
	}
Camil Staps's avatar
Camil Staps committed
104 105 106 107 108 109 110 111 112
where
	unprepare :: !Type -> Type
	unprepare (Type t ts) = Type t (map unprepare ts)
	unprepare (Func is t tc) = Func (map unprepare is) (unprepare t) (map unprepareTR tc)
	unprepare (Var tv) = Var (tv % (1,size tv-1))
	unprepare (Cons v ts) = Cons (v % (1,size v-1)) (map unprepare ts)
	unprepare (Uniq t) = Uniq (unprepare t)
	unprepare (Forall ts t tc) = Forall (map unprepare ts) (unprepare t) (map unprepareTR tc)
	unprepare (Arrow mt) = Arrow (unprepare <$> mt)
Camil Staps's avatar
Camil Staps committed
113
	unprepare (Strict t) = Strict (unprepare t)
Camil Staps's avatar
Camil Staps committed
114 115 116 117

	unprepareTR :: !TypeRestriction -> TypeRestriction
	unprepareTR (Instance c ts) = Instance c (map unprepare ts)
	unprepareTR (Derivation g t) = Derivation g (unprepare t)
118 119

:: Options =
120 121 122 123 124
	{ port                      :: !Int
	, reload_cache              :: !Bool
	, rank_settings_constraints :: !Maybe FilePath
	, test_file                 :: !Maybe FilePath
	, test_options              :: ![TestOption]
125 126
	}

Camil Staps's avatar
Camil Staps committed
127 128
:: TestOption = NoUnify

129 130 131
instance zero Options
where
	zero =
132 133 134 135 136
		{ port                      = 31215
		, reload_cache              = False
		, rank_settings_constraints = Nothing
		, test_file                 = Nothing
		, test_options              = []
137
		}
138

139 140 141 142 143 144 145 146 147 148 149 150 151 152
optionDescription :: Option Options
optionDescription = WithHelp True $ Options
	[ Shorthand "-p" "--port" $ Option
		"--port"
		(\port opts -> case (toInt port, port) of
			(0, "0") -> Error ["Cannot use port 0"]
			(0, p)   -> Error ["'" <+ p <+ "' is not an integer"]
			(p, _)   -> Ok {Options | opts & port=p})
		"PORT"
		"Listen on port PORT (default: 31215)"
	, Flag
		"--reload-cache"
		(\opts -> Ok {opts & reload_cache=True})
		"Reload the cache in the background"
153 154 155 156 157
	, Option
		"--rank-settings-constraints"
		(\file opts -> Ok {opts & rank_settings_constraints=Just file})
		"FILE"
		"Output symbolic rank constraints in Z3 format based on test cases in FILE"
158 159 160 161 162 163 164 165 166 167
	, Option
		"--test"
		(\file opts -> Ok {opts & test_file=Just file})
		"FILE"
		"Load queries from FILE and execute them (do not start a TCP server)"
	, Flag
		"--test-no-unify"
		(\opts -> Ok {opts & test_options=[NoUnify:opts.test_options]})
		"Do not test queries that require unification (only used with --test)"
	]
168

169
Start w
170 171
# ([prog:args], w) = getCommandLine w
# opts = parseOptions optionDescription args zero
172 173
| isError opts
	# (io,w) = stdio w
174
	# io = io <<< join "\n" (fromError opts) <<< "\n"
175 176 177
	# (_,w) = fclose io w
	= w
# opts = fromOk opts
Camil Staps's avatar
Camil Staps committed
178 179
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
180 181
#! (db,f) = openDB f
#! (ok,db) = isJustU db
182 183
| not ok = errexit "Could not open database\n" -1 w
#! (_,w) = fclose f w
184
#! db = hyperstrict (fromJust db)
185 186 187 188 189
| isJust opts.rank_settings_constraints = computeRankConstraints (fromJust opts.rank_settings_constraints) db w
#! (f,w) = readFile "rank_settings.json" w
# rsets = fromJSON $ fromString $ fromOk f
| isError f || isNothing rsets = errexit "Could not open rank settings\n" -1 w
#! rsets = fromJust rsets
190 191
| isJust opts.test_file
	# (ok,f,w) = fopen (fromJust opts.test_file) FReadText w
192 193 194
	| not ok = errexit "Could not open test file\n" -1 w
	= test opts.test_options rsets f db w
#! (db,w) = if opts.reload_cache (doInBackground (reloadCache rsets)) id (db,w)
195
= serve
196
	{ handler           = handle rsets
197
	, logger            = Just log
198
	, port              = opts.Options.port
199 200
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
201
	} db w
202
where
Camil Staps's avatar
Camil Staps committed
203 204 205 206 207
	disableSwap :: *World -> *World
	disableSwap w
	# (ok,w) = mlockall (MCL_CURRENT bitor MCL_FUTURE) w
	| ok = w
	# (err,w) = errno w
208 209 210 211 212 213
	= snd $ fclose (stderr <<< "Could not lock memory (" <<< err <<< "); process may get swapped out\n") w

errexit :: !String !Int !*World -> *World
errexit msg rcode w
# (_,w) = fclose (stderr <<< msg) w
= setReturnCode rcode w
Camil Staps's avatar
Camil Staps committed
214

215 216 217
handle :: !RankSettings !(Maybe Request) !*CloogleDB !*World -> *(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
handle _ Nothing db w = (err InvalidInput "Couldn't parse input", (Nothing,0), db, w)
handle rsets (Just request=:{unify,name,page}) db w
218 219 220 221 222 223 224 225 226 227 228 229 230 231 232 233 234
	#! (start,w) = nsTime w
	//Check cache
	#! (key,db) = toRequestCacheKey db request
	#! (mbResponse, w) = readCache key w
	| isJust mbResponse
		# r = fromJust mbResponse
		= respond start Nothing {r & return = if (r.return == 0) 1 r.return} db w
	| isJust name && size (fromJust name) > 40
		= respond start Nothing (err InvalidName "Function name too long") db w
	| isJust name && any isSpace (fromString $ fromJust name)
		= respond start Nothing (err InvalidName "Name cannot contain spaces") db w
	| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
		= respond start Nothing (err InvalidType "Couldn't parse type") db w
	| all isNothing [unify,name,request.typeName,request.className] && isNothing request.using
		= respond start Nothing (err InvalidInput "Empty query") db w
	// Results
	#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
235
	#! (res,suggs,db) = searchWithSuggestions rsets request db
236
	#! suggs = if (isEmpty suggs) Nothing (Just suggs)
237 238 239 240
	#! results = drop drop_n res
	#! more = max 0 (length results - MAX_RESULTS)
	// Suggestions
	#! (db,w) = seqSt
Camil Staps's avatar
Camil Staps committed
241
		(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
242
		(fromMaybe [] suggs)
243
		(db,w)
244
	#! suggs = sortBy ((<) `on` snd) <$> map (appSnd length) <$> suggs
245 246 247 248 249 250 251
	#! (results,nextpages) = splitAt MAX_RESULTS results
	// Response
	#! response = if (isEmpty results)
		(err NoResults "No results")
		{ zero
		& data           = results
		, more_available = Just more
252
		, suggestions    = suggs
253 254 255 256 257 258 259 260 261 262 263 264 265 266 267
		}
	// Save page prefetches
	#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
	// Save cache file
	= respond start (Just key) response db w
where
	respond :: !Timespec !(Maybe RequestCacheKey) !Response !*CloogleDB !*World ->
		*(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
	respond start key r db w
	#! (end,w) = nsTime w
	#! duration = 1000000000 * (end.tv_sec - start.tv_sec) + end.tv_nsec - start.tv_nsec
	#! cache = duration > CACHE_NS_THRESHOLD
	= (r, (if cache (cacheKey <$> key) Nothing, duration / 1000), db, case (cache,key) of
		(True,Just k) -> writeCache LongTerm k r w
		_             -> w)
Camil Staps's avatar
Camil Staps committed
268

269 270 271 272 273 274 275 276 277 278 279 280 281 282
	cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
	cachePages key _ _  _ [] w = w
	cachePages key 0 _  _ _  w = w
	cachePages key npages i response results w
	# w = writeCache Brief req` resp` w
	= cachePages key (npages - 1) (i + 1) response keep w
	where
		req` = { key & c_page = key.c_page + i }
		resp` =
			{ response
			& more_available = Just $ max 0 (length results - MAX_RESULTS)
			, data = give
			}
		(give,keep) = splitAt MAX_RESULTS results
Mart Lubbers's avatar
Mart Lubbers committed
283

284 285
reloadCache :: !RankSettings !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
reloadCache rsets (db,w)
286 287 288 289 290 291 292
# (ks,w) = allCacheKeys LongTerm w
= loop ks db w
where
	loop :: ![RequestCacheKey] !*CloogleDB !*World -> *(!*CloogleDB, !*World)
	loop [] db w = (db,w)
	loop [k:ks] db w
	# w = removeFromCache LongTerm k w
293
	# (_,_,db,w) = handle rsets (Just $ fromRequestCacheKey k) db w
294
	# db = resetDB db
Camil Staps's avatar
Camil Staps committed
295 296
	= loop ks db w

297 298 299
doInBackground :: (*a -> *a) *a -> *a
doInBackground f w
#! (pid,w) = fork w
Camil Staps's avatar
Camil Staps committed
300 301 302
| pid < 0   = abort "fork failed\n"
| pid > 0   = w // Parent: return directly
| otherwise = snd $ exit 0 $ f w // Child: do function
303

304 305
test :: ![TestOption] !RankSettings !*File !*CloogleDB !*World -> *World
test opts rsets queries db w
306 307 308 309 310 311 312
# (e,queries) = fend queries
| e = w
# (qstring,queries) = freadline queries
# qstring = {c \\ c <-: qstring | c <> '\n' && c <> '\r'}
# q = parseSingleLineRequest qstring
| isError q
	# w = snd $ fclose (stderr <<< "Warning: could not parse '" <<< qstring <<< "'; " <<< fromError q <<< "\n") w
313
	= test opts rsets queries db w
Camil Staps's avatar
Camil Staps committed
314 315
# q = fromOk q
| excluded opts q
316 317 318
	= test opts rsets queries db w
# (_,_,db,w) = handle rsets (Just q) db w
= test opts rsets queries db w
Camil Staps's avatar
Camil Staps committed
319 320 321 322
where
	excluded :: ![TestOption] !Request -> Bool
	excluded []           _ = False
	excluded [NoUnify:os] r = isJust r.unify || excluded os r
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
computeRankConstraints :: !FilePath !*CloogleDB !*World -> *World
computeRankConstraints constraintfile db w
#! (f,w) = readFile constraintfile w
# constraints = fromJSON $ fromString $ fromOk f
| isError f || isNothing constraints = errexit "Could not open rank settings constraints\n" -1 w
# constraints = fromJust constraints
# (constraints,db) = rankConstraints constraints db
# (z3,w) = runProcessIO "z3" ["-in"] Nothing w
| isError z3 = errexit "Failed to run z3\n" -1 w
# (z3h,z3io) = fromOk z3
# z3input = join "\n" (constraints ++ ["(check-sat)","(get-model)","(exit)"]) +++ "\n"
# (err,w) = writePipe z3input z3io.stdIn w
| isError err = errexit "Failed to write constraints to z3\n" -1 w
# (rcode,w) = waitForProcess z3h w
| isError rcode || fromOk rcode <> 0
	= errexit
		("z3 failed to compute a model with these constraints:\n" +++ z3input)
		-1 w
# (out,w) = readPipeBlocking z3io.stdOut w
| isError out = errexit "Failed to read z3 output\n" -1 w
# out = split "\n" $ fromOk out
# settings = findSettings out
	{ rs_ngram_distance     = 0.0
	, rs_exact_result       = 0.0
	, rs_record_field       = 0.0
	, rs_constructor        = 0.0
	, rs_unifier_size       = 0.0
	, rs_used_synonyms      = 0.0
	, rs_resolved_context   = 0.0
	, rs_unresolved_context = 0.0
	}
# (io,w) = stdio w
# io = io <<< jsonPrettyPrint (toJSON settings) <<< "\n"
# (_,w) = fclose io w
= w
where
	findSettings :: ![String] !RankSettings -> RankSettings
	findSettings [s:v:ss] rs
	| startsWith "  (define-fun " s
		# name = s % (14,size s-9) // strip off '  (define-fun ' and ' () Real'
		# val = toReal (v % (4,size v-2))
		# rs = case name of
			"rs_ngram_distance"     -> {rs & rs_ngram_distance    =val}
			"rs_exact_result"       -> {rs & rs_exact_result      =val}
			"rs_record_field"       -> {rs & rs_record_field      =val}
			"rs_constructor"        -> {rs & rs_constructor       =val}
			"rs_unifier_size"       -> {rs & rs_unifier_size      =val}
			"rs_used_synonyms"      -> {rs & rs_used_synonyms     =val}
			"rs_resolved_context"   -> {rs & rs_resolved_context  =val}
			"rs_unresolved_context" -> {rs & rs_unresolved_context=val}
		= findSettings ss rs
	findSettings [s:ss] rs = findSettings ss rs
	findSettings [] rs = rs

378 379 380 381
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
382
	, mem_request    :: Maybe Request
383 384 385 386 387 388 389 390 391 392 393
	}

instance zero LogMemory
where
	zero =
		{ mem_ip         = undef
		, mem_time_start = undef
		, mem_time_end   = undef
		, mem_request    = undef
		}

394 395 396
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
397 398 399 400 401

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
402
	, microseconds  :: Int
403
	, request       :: Maybe Request
404
	, cachekey      :: Maybe String
405 406 407 408 409 410 411 412 413 414 415 416
	, response_code :: Int
	, results       :: Int
	}

derive JSONEncode LogEntry

log :: LogMessage` (Maybe LogMemory) *World -> *(Maybe LogMemory, *World)
log msg mem w
# mem     = fromJust (mem <|> pure zero)
# (mem,w) = updateMemory msg mem w
| not needslog = (Just mem, w)
# (io,w)  = stdio w
Camil Staps's avatar
Camil Staps committed
417
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
418 419 420 421 422
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
423 424
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
425 426
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
427
	updateMemory (Sent _ _)     s w
428 429 430 431
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
432
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
433
	makeLogEntry (Sent response (ck,us)) mem =
Camil Staps's avatar
Camil Staps committed
434
		{ ip            = toString mem.mem_ip
435 436
		, time_start    = (toString mem.mem_time_start, toInt $ timeGm mem.mem_time_start)
		, time_end      = (toString mem.mem_time_end, toInt $ timeGm mem.mem_time_end)
437
		, microseconds  = us
Camil Staps's avatar
Camil Staps committed
438 439 440 441 442
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
443
	makeLogEntry _ _ = abort "CloogleServer: failure in makeLogEntry\n"
Camil Staps's avatar
Camil Staps committed
444 445 446 447 448 449 450 451

err :: CloogleError String -> Response
err c m = { return         = toInt c
          , data           = []
          , msg            = m
          , more_available = Nothing
          , suggestions    = Nothing
          }