CloogleServer.icl 11.5 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
import Control.Applicative
import Control.Monad
18
import Data.Error
19
import qualified Data.Foldable as Foldable
Camil Staps's avatar
Camil Staps committed
20
from Data.Foldable import class Foldable
Camil Staps's avatar
Camil Staps committed
21
from Data.Func import $, hyperstrict, instance Functor ((->) r), mapSt, seqSt
22
import Data.Functor
Camil Staps's avatar
Camil Staps committed
23
from Data.List import permutations
24
import Data.Maybe
25
import Data.Tuple
Camil Staps's avatar
Camil Staps committed
26
import System._Posix
27
import System.CommandLine
Camil Staps's avatar
Camil Staps committed
28
import System.Time
29
from Text import class Text(concat,toLowerCase), instance Text String, <+
30
import Text.GenJSON
Camil Staps's avatar
Camil Staps committed
31

32
import Cloogle
33
import Type
Camil Staps's avatar
Camil Staps committed
34
import CloogleDB
35
import Search
Camil Staps's avatar
Camil Staps committed
36

37
import SimpleTCPServer
Camil Staps's avatar
Camil Staps committed
38 39 40
import Cache
import Memory

41 42 43
MAX_RESULTS        :== 15
CACHE_PREFETCH     :== 5
CACHE_NS_THRESHOLD :== 40000000
44

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

59
derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction
60
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
61 62 63
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck

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

:: Options =
	{ port         :: Int
	, help         :: Bool
	, reload_cache :: Bool
	}

instance zero Options where zero = {port=31215, help=False, reload_cache=False}

parseOptions :: Options [String] -> MaybeErrorString Options
parseOptions opt [] = Ok opt
parseOptions opt ["-p":p:rest] = case (toInt p, p) of
	(0, "0") -> Error "Cannot use port 0"
	(0, p)   -> Error $ "'" <+ p <+ "' is not an integer"
	(p, _)   -> parseOptions {Options | opt & port=p} rest
parseOptions opt ["-h":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--help":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--reload-cache":rest] = parseOptions {opt & reload_cache=True} rest
parseOptions opt [arg:_] = Error $ "Unknown option '" <+ arg <+ "'"
129

130 131
Start w
# (cmdline, w) = getCommandLine w
132 133 134 135 136 137 138 139
# opts = parseOptions zero (tl cmdline)
| isError opts
	# (io,w) = stdio w
	# io = io <<< fromError opts <<< "\n"
	# (_,w) = fclose io w
	= w
# opts = fromOk opts
| opts.help = help (hd cmdline) w
Camil Staps's avatar
Camil Staps committed
140 141
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
142 143 144 145 146 147 148 149
#! (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)
Camil Staps's avatar
Camil Staps committed
150
#! (db,w) = if opts.reload_cache (doInBackground reloadCache) id (db,w)
Camil Staps's avatar
Camil Staps committed
151
#! (_,w) = fclose f w
152
= serve
153
	{ handler           = handle
154
	, logger            = Just log
155
	, port              = opts.Options.port
156 157
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
158
	} db w
159
where
160 161
	help :: String *World -> *World
	help pgm w
Camil Staps's avatar
Camil Staps committed
162
	# (io, w) = stdio w
163
	# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
Camil Staps's avatar
Camil Staps committed
164 165
	= snd $ fclose io w

Camil Staps's avatar
Camil Staps committed
166 167 168 169 170 171 172 173 174
	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

175 176
	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)
177
	handle (Just request=:{unify,name,page}) db w
178
		#! (start,w) = nsTime w
179
		//Check cache
180
		#! (key,db) = toRequestCacheKey db request
Camil Staps's avatar
Camil Staps committed
181
		#! (mbResponse, w) = readCache key w
182 183
		| isJust mbResponse
			# r = fromJust mbResponse
184
			= respond start Nothing {r & return = if (r.return == 0) 1 r.return} db w
185
		| isJust name && size (fromJust name) > 40
186
			= respond start Nothing (err InvalidName "Function name too long") db w
Camil Staps's avatar
Camil Staps committed
187
		| isJust name && any isSpace (fromString $ fromJust name)
188
			= respond start Nothing (err InvalidName "Name cannot contain spaces") db w
Camil Staps's avatar
Camil Staps committed
189
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
190
			= respond start Nothing (err InvalidType "Couldn't parse type") db w
Camil Staps's avatar
Camil Staps committed
191
		| all isNothing [unify,name,request.typeName,request.className] && isNothing request.using
192
			= respond start Nothing (err InvalidInput "Empty query") db w
Camil Staps's avatar
Camil Staps committed
193
		// Results
Camil Staps's avatar
Camil Staps committed
194
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
195 196
		#! (res,db) = search request db
		#! results = drop drop_n res
Camil Staps's avatar
Camil Staps committed
197
		#! more = max 0 (length results - MAX_RESULTS)
Camil Staps's avatar
Camil Staps committed
198
		// Suggestions
Camil Staps's avatar
Camil Staps committed
199 200 201 202 203 204 205 206 207 208 209
		#! (suggestions,db) = case unify >>= parseType o fromString of
			Just t -> suggs name t db
			Nothing -> (Nothing, db)
		#! (db,w) = seqSt
			(\(req,res) (db,w) -> let (k,db`) = toRequestCacheKey db req in (db`,cachePages k CACHE_PREFETCH 0 zero res w))
			(fromMaybe [] suggestions)
			(db,w)
		#! suggestions
			= sortBy (\a b -> snd a > snd b) <$>
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
Camil Staps's avatar
Camil Staps committed
210
		#! (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
211
		// Response
Camil Staps's avatar
Camil Staps committed
212
		#! response = if (isEmpty results)
Camil Staps's avatar
Camil Staps committed
213
			(err NoResults "No results")
Camil Staps's avatar
Camil Staps committed
214 215
			{ zero
		    & data           = results
Camil Staps's avatar
Camil Staps committed
216 217
		    , more_available = Just more
		    , suggestions    = suggestions
218
		    }
Camil Staps's avatar
Camil Staps committed
219
		// Save page prefetches
Camil Staps's avatar
Camil Staps committed
220
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
221
		// Save cache file
222
		= respond start (Just key) response db w
223
	where
224 225 226 227 228 229 230 231 232
		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
233

Camil Staps's avatar
Camil Staps committed
234
		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
Camil Staps's avatar
Camil Staps committed
235 236 237
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
238
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
239
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
240
		where
Camil Staps's avatar
Camil Staps committed
241
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
242 243 244 245 246 247
			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
248

Camil Staps's avatar
Camil Staps committed
249 250 251 252 253 254 255
	suggs :: !(Maybe String) !Type !*CloogleDB -> *(Maybe [(Request, [Result])], *CloogleDB)
	suggs n (Func is r cc) db | length is < 3
	= appFst Just $ mapSt (\r -> appFst (tuple r) o search r o resetDB) reqs db
	where
		reqs = [{zero & name=n, unify=Just $ concat $ print False $ Func is` r cc}
			\\ is` <- permutations is | is` <> is]
	suggs _ _ db = (Nothing, db)
Camil Staps's avatar
Camil Staps committed
256

Camil Staps's avatar
Camil Staps committed
257 258 259 260
	reloadCache :: !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
	reloadCache (db,w)
	# (ks,w) = allCacheKeys LongTerm w
	= loop ks db w
261
	where
Camil Staps's avatar
Camil Staps committed
262 263 264 265 266 267 268 269 270
		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
		= loop ks db w

	doInBackground :: (*a -> *a) *a -> *a
271 272 273
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
274 275
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function
276

277 278 279 280
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
281
	, mem_request    :: Maybe Request
282 283 284 285 286 287 288 289 290 291 292
	}

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

293 294 295
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
296 297 298 299 300

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
301
	, microseconds  :: Int
302
	, request       :: Maybe Request
303
	, cachekey      :: Maybe String
304 305 306 307 308 309 310 311 312 313 314 315
	, 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
316
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
317 318 319 320 321
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
322 323
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
324 325
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
326
	updateMemory (Sent _ _)     s w
327 328 329 330
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
331
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
332
	makeLogEntry (Sent response (ck,us)) mem =
Camil Staps's avatar
Camil Staps committed
333
		{ ip            = toString mem.mem_ip
334 335
		, 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)
336
		, microseconds  = us
Camil Staps's avatar
Camil Staps committed
337 338 339 340 341
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
342 343 344 345 346 347 348 349

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