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

:: 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 <+ "'"
115

116 117
Start w
# (cmdline, w) = getCommandLine w
118 119 120 121 122 123 124 125
# 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
126 127
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
128 129 130 131 132 133 134 135
#! (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
136
#! (db,w) = if opts.reload_cache (doInBackground reloadCache) id (db,w)
Camil Staps's avatar
Camil Staps committed
137
#! (_,w) = fclose f w
138
= serve
139
	{ handler           = handle
140
	, logger            = Just log
141
	, port              = opts.Options.port
142 143
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
144
	} db w
145
where
146 147
	help :: String *World -> *World
	help pgm w
Camil Staps's avatar
Camil Staps committed
148
	# (io, w) = stdio w
149
	# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
Camil Staps's avatar
Camil Staps committed
150 151
	= snd $ fclose io w

Camil Staps's avatar
Camil Staps committed
152 153 154 155 156 157 158 159 160
	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

161 162
	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)
163
	handle (Just request=:{unify,name,page}) db w
164
		#! (start,w) = nsTime w
165
		//Check cache
166
		#! (key,db) = toRequestCacheKey db request
Camil Staps's avatar
Camil Staps committed
167
		#! (mbResponse, w) = readCache key w
168 169
		| isJust mbResponse
			# r = fromJust mbResponse
170
			= respond start Nothing {r & return = if (r.return == 0) 1 r.return} db w
171
		| isJust name && size (fromJust name) > 40
172
			= respond start Nothing (err InvalidName "Function name too long") db w
Camil Staps's avatar
Camil Staps committed
173
		| isJust name && any isSpace (fromString $ fromJust name)
174
			= respond start Nothing (err InvalidName "Name cannot contain spaces") db w
Camil Staps's avatar
Camil Staps committed
175
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
176
			= respond start Nothing (err InvalidType "Couldn't parse type") db w
Camil Staps's avatar
Camil Staps committed
177
		// Results
Camil Staps's avatar
Camil Staps committed
178
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
179 180
		#! (res,db) = search request db
		#! results = drop drop_n res
Camil Staps's avatar
Camil Staps committed
181
		#! more = max 0 (length results - MAX_RESULTS)
Camil Staps's avatar
Camil Staps committed
182
		// Suggestions
Camil Staps's avatar
Camil Staps committed
183 184 185 186 187 188 189 190 191 192 193
		#! (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
194
		#! (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
195
		// Response
Camil Staps's avatar
Camil Staps committed
196
		#! response = if (isEmpty results)
Camil Staps's avatar
Camil Staps committed
197
			(err NoResults "No results")
Camil Staps's avatar
Camil Staps committed
198 199
			{ zero
		    & data           = results
Camil Staps's avatar
Camil Staps committed
200 201
		    , more_available = Just more
		    , suggestions    = suggestions
202
		    }
Camil Staps's avatar
Camil Staps committed
203
		// Save page prefetches
Camil Staps's avatar
Camil Staps committed
204
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
205
		// Save cache file
206
		= respond start (Just key) response db w
207
	where
208 209 210 211 212 213 214 215 216
		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
217

Camil Staps's avatar
Camil Staps committed
218
		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
Camil Staps's avatar
Camil Staps committed
219 220 221
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
222
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
223
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
224
		where
Camil Staps's avatar
Camil Staps committed
225
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
226 227 228 229 230 231
			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
232

Camil Staps's avatar
Camil Staps committed
233 234 235 236 237 238 239
	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
240

Camil Staps's avatar
Camil Staps committed
241 242 243 244
	reloadCache :: !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
	reloadCache (db,w)
	# (ks,w) = allCacheKeys LongTerm w
	= loop ks db w
245
	where
Camil Staps's avatar
Camil Staps committed
246 247 248 249 250 251 252 253 254
		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
255 256 257
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
258 259
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function
260

261 262 263 264
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
265
	, mem_request    :: Maybe Request
266 267 268 269 270 271 272 273 274 275 276
	}

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

277 278 279
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
280 281 282 283 284

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
285
	, microseconds  :: Int
286
	, request       :: Maybe Request
287
	, cachekey      :: Maybe String
288 289 290 291 292 293 294 295 296 297 298 299
	, 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
300
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
301 302 303 304 305
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
306 307
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
308 309
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
310
	updateMemory (Sent _ _)     s w
311 312 313 314
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
315
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
316
	makeLogEntry (Sent response (ck,us)) mem =
Camil Staps's avatar
Camil Staps committed
317
		{ ip            = toString mem.mem_ip
318 319
		, 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)
320
		, microseconds  = us
Camil Staps's avatar
Camil Staps committed
321 322 323 324 325
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
326 327 328 329 330 331 332 333

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