CloogleServer.icl 10.8 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
# (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.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 85 86 87 88
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
	{ unify            = concat <$> print False <$> k.c_unify
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
89
	, using            = k.c_using
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 115
	, 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 <+ "'"
116

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

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

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

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

Camil Staps's avatar
Camil Staps committed
236 237 238 239 240 241 242
	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
243

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

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

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

280 281 282
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
283 284 285 286 287

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

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

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

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