CloogleServer.icl 14 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.Options
Camil Staps's avatar
Camil Staps committed
33
import System.Time
34
from Text import class Text(concat,join,toLowerCase), instance Text String, <+
35
import Text.GenJSON
Camil Staps's avatar
Camil Staps committed
36

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

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

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

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

63
derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction
64
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
65 66 67
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck

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

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

:: Options =
116 117 118
	{ port         :: !Int
	, reload_cache :: !Bool
	, test_file    :: !Maybe FilePath
Camil Staps's avatar
Camil Staps committed
119
	, test_options :: ![TestOption]
120 121
	}

Camil Staps's avatar
Camil Staps committed
122 123
:: TestOption = NoUnify

124 125 126 127 128 129
instance zero Options
where
	zero =
		{ port         = 31215
		, reload_cache = False
		, test_file    = Nothing
Camil Staps's avatar
Camil Staps committed
130
		, test_options = []
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
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"
	, 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)"
	]
157

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

204 205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227
handle :: !(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 (Just request=:{unify,name,page}) db w
	#! (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
	#! (res,db) = search request db
	#! results = drop drop_n res
	#! more = max 0 (length results - MAX_RESULTS)
	// Suggestions
228
	#! (suggs,db) = suggestions request results db
229
	#! (db,w) = seqSt
Camil Staps's avatar
Camil Staps committed
230
		(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
231
		(fromMaybe [] suggs)
232
		(db,w)
233
	#! suggs = sortBy ((<) `on` snd) <$> map (appSnd length) <$> suggs
234 235 236 237 238 239 240
	#! (results,nextpages) = splitAt MAX_RESULTS results
	// Response
	#! response = if (isEmpty results)
		(err NoResults "No results")
		{ zero
		& data           = results
		, more_available = Just more
241
		, suggestions    = suggs
242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
		}
	// 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
257

258 259 260 261 262 263 264 265 266 267 268 269 270 271
	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
272

273 274 275
	suggestions :: !Request ![Result] !*CloogleDB -> *(Maybe [(Request, [Result])], *CloogleDB)
	suggestions {page=Just n} _ db | n > 0 = (Nothing, db)
	suggestions orgreq orgresults db
276 277
	# (swapped, db)     = swap db
	# (capitalized, db) = capitalize db
278 279
	# (withapps, db)    = addapps db
	# suggs = case flatten [swapped, capitalized, withapps] of
280 281
		[] -> Nothing
		ss -> Just ss
282
	= (suggs, db)
Camil Staps's avatar
Camil Staps committed
283
	where
284 285 286 287
		orgtype = orgreq.unify >>= parseType o fromString

		swap db = case orgtype of
			Just (Func is r cc) | length is < 3
Camil Staps's avatar
Camil Staps committed
288
				-> appFst (filter enough) $ mapSt (\r -> appFst (tuple r) o search r o resetDB) reqs db
289
				with
290
					reqs = [{orgreq & unify=Just $ concat $ print False $ Func is` r cc}
291
						\\ is` <- permutations is | is` <> is]
Camil Staps's avatar
Camil Staps committed
292
			_ -> ([], db)
293 294 295 296 297 298 299
		where
			enough :: (Request, [Result]) -> Bool
			enough (_, res) = enough` (length orgresults) res
			where
				enough` 0 _      = True
				enough` _ []     = False
				enough` n [_:xs] = enough` (n-1) xs
300 301

		capitalize db = case t` of
302 303 304
			Just t` | fromJust orgtype <> t`
				-> appFst (\res -> [(req,res)]) $ search req $ resetDB db
					with req = {orgreq & unify=Just $ concat $ print False t`}
Camil Staps's avatar
Camil Staps committed
305
			_                 -> ([], db)
306 307 308 309 310 311 312 313 314 315
		where
			t` = assignAll
				[ ("int",     Type "Int" [])
				, ("bool",    Type "Bool" [])
				, ("char",    Type "Char" [])
				, ("real",    Type "Real" [])
				, ("file",    Type "File" [])
				, ("string",  Type "String" [])
				, ("dynamic", Type "Dynamic" [])
				, ("world",   Uniq (Type "World" []))
316
				] =<< orgtype
Camil Staps's avatar
Camil Staps committed
317

318 319 320 321 322 323 324 325 326 327 328
		addapps db
		| fromMaybe DEFAULT_INCLUDE_APPS orgreq.include_apps == DEFAULT_INCLUDE_APPS
			# req = {orgreq & include_apps=Just (not DEFAULT_INCLUDE_APPS)}
			# (res,db) = search req $ resetDB db
			| isEmpty res = ([], db)
			| isEmpty orgresults = ([(req,res)], db)
			# orghddistance = (fromJust (getBasicResult (hd orgresults))).distance
			| all (\r -> (fromJust (getBasicResult r)).distance < orghddistance) $ take 3 res
				= ([(req,res)], db)
				= ([], db)
		| otherwise = ([], db)
Camil Staps's avatar
Camil Staps committed
329

330 331 332 333 334 335 336 337 338 339 340
reloadCache :: !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
reloadCache (db,w)
# (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
	# (_,_,db,w) = handle (Just $ fromRequestCacheKey k) db w
	# db = resetDB db
Camil Staps's avatar
Camil Staps committed
341 342
	= loop ks db w

343 344 345 346 347 348 349
doInBackground :: (*a -> *a) *a -> *a
doInBackground f w
#! (pid,w) = fork w
| pid  < 0 = abort "fork failed\n"
| pid  > 0 = w // Parent: return directly
| pid == 0 = snd $ exit 0 $ f w // Child: do function

Camil Staps's avatar
Camil Staps committed
350 351
test :: ![TestOption] !*File !*CloogleDB !*World -> *World
test opts queries db w
352 353 354 355 356 357 358
# (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
Camil Staps's avatar
Camil Staps committed
359 360 361 362 363 364 365 366 367 368
	= test opts queries db w
# q = fromOk q
| excluded opts q
	= test opts queries db w
# (_,_,db,w) = handle (Just q) db w
= test opts queries db w
where
	excluded :: ![TestOption] !Request -> Bool
	excluded []           _ = False
	excluded [NoUnify:os] r = isJust r.unify || excluded os r
369

370 371 372 373
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
374
	, mem_request    :: Maybe Request
375 376 377 378 379 380 381 382 383 384 385
	}

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

386 387 388
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
389 390 391 392 393

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
394
	, microseconds  :: Int
395
	, request       :: Maybe Request
396
	, cachekey      :: Maybe String
397 398 399 400 401 402 403 404 405 406 407 408
	, 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
409
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
410 411 412 413 414
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
415 416
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
417 418
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
419
	updateMemory (Sent _ _)     s w
420 421 422 423
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
424
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
425
	makeLogEntry (Sent response (ck,us)) mem =
Camil Staps's avatar
Camil Staps committed
426
		{ ip            = toString mem.mem_ip
427 428
		, 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)
429
		, microseconds  = us
Camil Staps's avatar
Camil Staps committed
430 431 432 433 434
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
435 436 437 438 439 440 441 442

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