CloogleServer.icl 11.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.GenJSON
Camil Staps's avatar
Camil Staps committed
31

Camil Staps's avatar
Camil Staps committed
32 33 34 35 36 37 38 39 40 41 42 43
import Clean.Types
import Clean.Types.Parse
import Clean.Types.Unify
import Clean.Types.Util

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 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132

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

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

Camil Staps's avatar
Camil Staps committed
170 171 172 173 174 175 176 177 178
	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

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

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

Camil Staps's avatar
Camil Staps committed
253 254 255 256 257 258 259
	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
260

Camil Staps's avatar
Camil Staps committed
261 262 263 264
	reloadCache :: !*(!*CloogleDB, !*World) -> *(!*CloogleDB, !*World)
	reloadCache (db,w)
	# (ks,w) = allCacheKeys LongTerm w
	= loop ks db w
265
	where
Camil Staps's avatar
Camil Staps committed
266 267 268 269 270 271 272 273 274
		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
275 276 277
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
278 279
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function
280

281 282 283 284
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
285
	, mem_request    :: Maybe Request
286 287 288 289 290 291 292 293 294 295 296
	}

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

297 298 299
:: MicroSeconds :== Int

:: LogMessage` :== LogMessage (Maybe Request) Response (Maybe CacheKey, MicroSeconds)
300 301 302 303 304

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

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

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

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