CloogleServer.icl 13.7 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
Camil Staps's avatar
Camil Staps committed
21
import Control.Monad
22
import Data.Error
23
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt, on, `on`
24
import Data.Functor
Camil Staps's avatar
Camil Staps committed
25
from Data.List import permutations
26
import Data.Maybe
27
import Data.Tuple
Camil Staps's avatar
Camil Staps committed
28
import System._Posix
29
import System.CommandLine
30
import System.File
31
import System.Options
32
import System.Process
Camil Staps's avatar
Camil Staps committed
33
import System.Time
Camil Staps's avatar
Camil Staps committed
34 35
import qualified Text
from Text import class Text(concat,split,startsWith,toLowerCase), instance Text String, <+
36
import Text.GenJSON
Camil Staps's avatar
Camil Staps committed
37

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

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

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

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

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

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

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

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

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

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

138 139 140 141 142 143 144 145 146 147 148 149 150 151
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"
152 153 154 155 156
	, 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"
157 158 159 160 161 162 163 164 165 166
	, 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)"
	]
167

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

218 219 220
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
221 222 223 224 225 226 227 228
	#! (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
229
		= respond start Nothing (err InvalidName "Function name too long" Nothing) db w
230
	| isJust name && any isSpace (fromString $ fromJust name)
231
		= respond start Nothing (err InvalidName "Name cannot contain spaces" Nothing) db w
232
	| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
233
		= respond start Nothing (err InvalidType "Couldn't parse type" Nothing) db w
234
	| all isNothing [unify,name,request.typeName,request.className] && isNothing request.using
235
		= respond start Nothing (err InvalidInput "Empty query" Nothing) db w
236 237
	// Results
	#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
238
	#! (res,suggs,db) = searchWithSuggestions request db
239
	#! suggs = if (isEmpty suggs) Nothing (Just suggs)
240 241 242 243
	#! results = drop drop_n res
	#! more = max 0 (length results - MAX_RESULTS)
	// Suggestions
	#! (db,w) = seqSt
Camil Staps's avatar
Camil Staps committed
244
		(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
245
		(fromMaybe [] suggs)
246
		(db,w)
247
	#! suggs = sortBy ((<) `on` snd) <$> map (appSnd length) <$> suggs
248 249 250
	#! (results,nextpages) = splitAt MAX_RESULTS results
	// Response
	#! response = if (isEmpty results)
251
		(err NoResults "No results" suggs)
252 253 254
		{ zero
		& data           = results
		, more_available = Just more
255
		, suggestions    = suggs
256 257 258 259 260 261 262 263 264 265 266 267 268 269 270
		}
	// 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
271

272 273 274 275 276 277 278 279 280 281 282 283 284 285
	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
286

287 288
reloadCache :: !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
reloadCache (db,w)
289 290 291 292 293 294 295
# (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
296
	# (_,_,db,w) = handle (Just $ fromRequestCacheKey k) db w
297
	# db = resetDB db
Camil Staps's avatar
Camil Staps committed
298 299
	= loop ks db w

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

307 308
test :: ![TestOption] !*File !*CloogleDB !*World -> *World
test opts queries db w
309 310 311 312 313 314 315
# (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
316
	= test opts queries db w
Camil Staps's avatar
Camil Staps committed
317 318
# q = fromOk q
| excluded opts q
319 320 321
	= test opts queries db w
# (_,_,db,w) = handle (Just q) db w
= test opts queries db w
Camil Staps's avatar
Camil Staps committed
322 323 324 325
where
	excluded :: ![TestOption] !Request -> Bool
	excluded []           _ = False
	excluded [NoUnify:os] r = isJust r.unify || excluded os r
326

327 328 329 330 331 332
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
333 334 335
# (settings,db,w) = findRankSettings constraints db w
| isError settings = errexit (fromError settings +++ "\n") -1 w
# settings = fromOk settings
336 337 338 339 340
# (io,w) = stdio w
# io = io <<< jsonPrettyPrint (toJSON settings) <<< "\n"
# (_,w) = fclose io w
= w

341 342 343 344
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
345
	, mem_request    :: Maybe Request
346 347 348 349 350 351 352 353 354 355 356
	}

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

357 358 359
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
360 361 362 363 364

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
365
	, microseconds  :: Int
366
	, request       :: Maybe Request
367
	, cachekey      :: Maybe String
368 369 370 371 372 373 374 375 376 377 378 379
	, 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
380
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
381 382 383 384 385
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
386 387
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
388 389
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
390
	updateMemory (Sent _ _)     s w
391 392 393 394
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
395
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
396
	makeLogEntry (Sent response (ck,us)) mem =
Camil Staps's avatar
Camil Staps committed
397
		{ ip            = toString mem.mem_ip
398 399
		, 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)
400
		, microseconds  = us
Camil Staps's avatar
Camil Staps committed
401 402 403 404 405
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
406
	makeLogEntry _ _ = abort "CloogleServer: failure in makeLogEntry\n"
Camil Staps's avatar
Camil Staps committed
407

408 409 410 411 412 413 414 415
err :: !CloogleError !String !(Maybe [(Request,Int)]) -> Response
err c m suggs =
	{ return         = toInt c
	, data           = []
	, msg            = m
	, more_available = Nothing
	, suggestions    = suggs
	}