CloogleServer.icl 14.1 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 StdOverloadedList
12
import StdString
13
import StdTuple
14

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

17 18 19 20
import Clean.Types
import Clean.Types.Parse
import Clean.Types.Unify
import Clean.Types.Util
21
import Control.Applicative
22
import Control.Monad
23
import Data.Error
24
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt, on, `on`
25
import Data.Functor
Camil Staps's avatar
Camil Staps committed
26
from Data.List import permutations
27
import Data.Maybe
28
import Data.Tuple
Camil Staps's avatar
Camil Staps committed
29
import System._Posix
30
import System.CommandLine
31
import System.File
32
import System.Options
33
import System.Process
Camil Staps's avatar
Camil Staps committed
34
import System.Time
35 36
import qualified Text
from Text import class Text(concat,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
53 54 55 56 57 58 59 60 61 62 63 64
	= { c_unify            :: !Maybe Type
	  , c_name             :: !Maybe String
	  , c_exactName        :: !Maybe String
	  , c_className        :: !Maybe String
	  , c_typeName         :: !Maybe String
	  , c_using            :: !Maybe [String]
	  , c_modules          :: !Maybe [String]
	  , c_libraries        :: !Maybe [String]
	  , c_include_builtins :: !Bool
	  , c_include_core     :: !Bool
	  , c_include_apps     :: !Bool
	  , c_page             :: !Int
65 66
	  }

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

72
toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
Camil Staps's avatar
Camil Staps committed
73
toRequestCacheKey db r
74
# (alwaysUnique,db) = alwaysUniquePredicate db
75
# (allsyns,db) = allTypeSynonyms db
Camil Staps's avatar
Camil Staps committed
76 77
= (
	{ c_unify            = snd <$>
78
		prepare_unification True alwaysUnique allsyns <$>
Camil Staps's avatar
Camil Staps committed
79
		(parseType o fromString =<< r.unify)
80
	, c_name             = toLowerCase <$> r.Request.name
81
	, c_exactName        = r.exactName
82 83
	, c_className        = r.className
	, c_typeName         = r.typeName
84
	, c_using            = r.using
Camil Staps's avatar
Camil Staps committed
85 86
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
87 88 89 90
	, 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
91
	}, db)
92 93
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
Camil Staps's avatar
Camil Staps committed
94
	{ unify            = concat <$> print False <$> unprepare <$> k.c_unify
95
	, name             = k.c_name
96
	, exactName        = k.c_exactName
97 98
	, className        = k.c_className
	, typeName         = k.c_typeName
99
	, using            = k.c_using
100 101 102 103 104 105 106
	, 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
107 108 109 110 111 112 113 114 115
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)
116
	unprepare (Strict t) = Strict (unprepare t)
Camil Staps's avatar
Camil Staps committed
117 118 119 120

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

:: Options =
123 124 125 126 127
	{ port                      :: !Int
	, reload_cache              :: !Bool
	, rank_settings_constraints :: !Maybe FilePath
	, test_file                 :: !Maybe FilePath
	, test_options              :: ![TestOption]
128 129
	}

130 131 132 133 134 135 136 137
:: TestOption
	= TO_NoUnify
	| TO_Quiet

instance == TestOption
where
	== TO_NoUnify to = to=:TO_NoUnify
	== TO_Quiet   to = to=:TO_Quiet
Camil Staps's avatar
Camil Staps committed
138

139 140 141
instance zero Options
where
	zero =
142 143 144 145 146
		{ port                      = 31215
		, reload_cache              = False
		, rank_settings_constraints = Nothing
		, test_file                 = Nothing
		, test_options              = []
147
		}
148

149 150 151 152 153 154 155 156 157 158 159 160 161 162
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"
163 164 165 166 167
	, 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"
168 169 170 171 172 173 174
	, 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"
175
		(\opts -> Ok {opts & test_options=[TO_NoUnify:opts.test_options]})
176
		"Do not test queries that require unification (only used with --test)"
177 178 179 180
	, Flag
		"--test-quiet"
		(\opts -> Ok {opts & test_options=[TO_Quiet:opts.test_options]})
		"Do not print test queries as they are executed (only used with --test)"
181
	]
182

183
Start w
Camil Staps's avatar
Camil Staps committed
184 185 186
# (prog,args,w) = case getCommandLine w of
	([prog:args],w) -> (prog,args,w)
	_               -> abort "getCommandLine returned 0 elements\n"
187
# opts = parseOptions optionDescription args zero
188 189
| isError opts
	# (io,w) = stdio w
190
	# io = io <<< 'Text'.join "\n" (fromError opts) <<< "\n"
191 192 193
	# (_,w) = fclose io w
	= w
# opts = fromOk opts
Camil Staps's avatar
Camil Staps committed
194 195
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
196 197
#! (db,f) = openDB f
#! (ok,db) = isJustU db
198 199
| not ok = errexit "Could not open database\n" -1 w
#! (_,w) = fclose f w
200
#! db = hyperstrict (fromJust db)
201 202 203 204 205
| 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
206 207
#! (ok,rsets) = setRankSettings rsets
| not ok = errexit "Failed to set rank settings\n" -1 w
208 209
| isJust opts.test_file
	# (ok,f,w) = fopen (fromJust opts.test_file) FReadText w
210
	| not ok = errexit "Could not open test file\n" -1 w
211
	= test opts.test_options f db w
Camil Staps's avatar
Camil Staps committed
212 213
| opts.reload_cache
	= reloadCache db w
214
= serve
215
	{ handler           = handle
216
	, logger            = Just log
217
	, port              = opts.Options.port
218 219
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
220
	} db w
221
where
Camil Staps's avatar
Camil Staps committed
222 223 224 225 226
	disableSwap :: *World -> *World
	disableSwap w
	# (ok,w) = mlockall (MCL_CURRENT bitor MCL_FUTURE) w
	| ok = w
	# (err,w) = errno w
227 228 229 230 231 232
	= 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
233

234 235 236
handle :: !(Maybe Request) !*CloogleDB !*World -> *(!Response, !(!Maybe CacheKey, !MicroSeconds), !*CloogleDB, !*World)
handle Nothing db w = (err InvalidInput "Couldn't parse input" Nothing, (Nothing,0), db, w)
handle (Just request=:{unify,name,page}) db w
237 238 239 240 241 242 243 244
	#! (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
245
		= respond start Nothing (err InvalidName "Function name too long" Nothing) db w
246
	| isJust name && any isSpace (fromString $ fromJust name)
247
		= respond start Nothing (err InvalidName "Name cannot contain spaces" Nothing) db w
248
	| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
249
		= respond start Nothing (err InvalidType "Couldn't parse type" Nothing) db w
250
	| all isNothing [unify,name,request.exactName,request.typeName,request.className] && isNothing request.using
251
		= respond start Nothing (err InvalidInput "Empty query" Nothing) db w
252 253
	// Results
	#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
254
	#! (res,suggs,db) = searchWithSuggestions request db
255
	#! suggs = if (isEmpty suggs) Nothing (Just suggs)
256
	#! results = [r \\ r <|- Drop drop_n res]
257 258 259
	#! more = max 0 (length results - MAX_RESULTS)
	// Suggestions
	#! (db,w) = seqSt
Camil Staps's avatar
Camil Staps committed
260
		(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
261
		(fromMaybe [] suggs)
262
		(db,w)
263
	#! suggs = sortBy ((<) `on` snd) <$> map (appSnd length) <$> suggs
264 265 266
	#! (results,nextpages) = splitAt MAX_RESULTS results
	// Response
	#! response = if (isEmpty results)
267
		(err NoResults "No results" suggs)
268 269 270
		{ zero
		& data           = results
		, more_available = Just more
271
		, suggestions    = suggs
272 273 274 275 276 277 278 279 280 281 282 283 284 285 286
		}
	// 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
287

288 289 290 291 292 293 294 295 296 297 298 299 300 301
	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
302

Camil Staps's avatar
Camil Staps committed
303 304
reloadCache :: !*CloogleDB !*World -> *World
reloadCache db w
305 306 307
# (ks,w) = allCacheKeys LongTerm w
= loop ks db w
where
Camil Staps's avatar
Camil Staps committed
308 309
	loop :: ![RequestCacheKey] !*CloogleDB !*World -> *World
	loop [] _ w = w
310 311
	loop [k:ks] db w
	# w = removeFromCache LongTerm k w
312
	# (_,_,db,w) = handle (Just $ fromRequestCacheKey k) db w
313
	# db = resetDB db
Camil Staps's avatar
Camil Staps committed
314 315
	= loop ks db w

316 317
test :: ![TestOption] !*File !*CloogleDB !*World -> *World
test opts queries db w
318 319 320 321 322 323 324
# (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
325
	= test opts queries db w
Camil Staps's avatar
Camil Staps committed
326
# q = fromOk q
327
| excluded q
328
	= test opts queries db w
329 330 331 332 333 334 335 336 337 338
# w = if (isMember TO_Quiet opts)
	w
	(snd $ fclose (stderr <<< qstring) w)
#! (Clock start,w) = clock w
#! (resp,_,db,w) = handle (Just q) db w
| (hyperstrict resp).return < 0 = abort "return code was < 0\n"
#! (Clock end,w) = clock w
# w = if (isMember TO_Quiet opts)
	w
	(snd $ fclose (stderr <<< "\t" <<< (end-start) <<< "\n") w)
339
= test opts queries db w
Camil Staps's avatar
Camil Staps committed
340
where
341 342
	excluded :: !Request -> Bool
	excluded r = isJust r.unify && isMember TO_NoUnify opts
343

344 345 346 347 348 349
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
350 351 352
# (settings,db,w) = findRankSettings constraints db w
| isError settings = errexit (fromError settings +++ "\n") -1 w
# settings = fromOk settings
353 354 355 356 357
# (io,w) = stdio w
# io = io <<< jsonPrettyPrint (toJSON settings) <<< "\n"
# (_,w) = fclose io w
= w

358 359 360 361
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
362
	, mem_request    :: Maybe Request
363 364 365 366 367 368 369 370 371 372 373
	}

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

374 375 376
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
377 378 379 380 381

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
382
	, microseconds  :: Int
383
	, request       :: Maybe Request
384
	, cachekey      :: Maybe String
385 386 387 388 389 390 391 392 393 394 395 396
	, 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
397
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
398 399 400 401 402
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
403 404
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
405 406
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
407
	updateMemory (Sent _ _)     s w
408 409 410 411
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
412
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
413
	makeLogEntry (Sent response (ck,us)) mem =
Camil Staps's avatar
Camil Staps committed
414
		{ ip            = toString mem.mem_ip
415 416
		, 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)
417
		, microseconds  = us
Camil Staps's avatar
Camil Staps committed
418 419 420 421 422
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
423
	makeLogEntry _ _ = abort "CloogleServer: failure in makeLogEntry\n"
Camil Staps's avatar
Camil Staps committed
424

425 426 427 428 429 430 431 432
err :: !CloogleError !String !(Maybe [(Request,Int)]) -> Response
err c m suggs =
	{ return         = toInt c
	, data           = []
	, msg            = m
	, more_available = Nothing
	, suggestions    = suggs
	}