CloogleServer.icl 9.92 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
MAX_RESULTS    :== 15
Camil Staps's avatar
Camil Staps committed
42
CACHE_PREFETCH :== 5
43

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

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

62
toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
Camil Staps's avatar
Camil Staps committed
63
toRequestCacheKey db r
64
# (allsyns,db) = allTypeSynonyms db
Camil Staps's avatar
Camil Staps committed
65 66
= (
	{ c_unify            = snd <$>
67
		prepare_unification True allsyns <$>
Camil Staps's avatar
Camil Staps committed
68
		(parseType o fromString =<< r.unify)
69 70 71
	, c_name             = toLowerCase <$> r.name
	, c_className        = toLowerCase <$> r.className
	, c_typeName         = toLowerCase <$> r.typeName
Camil Staps's avatar
Camil Staps committed
72 73
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
74 75
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, c_include_core     = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
76
	, c_include_apps     = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
Camil Staps's avatar
Camil Staps committed
77
	, c_page             = fromJust (r.page <|> Just 0)
78
	}, db)
79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
	{ unify            = concat <$> print False <$> k.c_unify
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
	, 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 <+ "'"
111

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

Camil Staps's avatar
Camil Staps committed
148 149 150 151 152 153 154 155 156
	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

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

Camil Staps's avatar
Camil Staps committed
206
		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
Camil Staps's avatar
Camil Staps committed
207 208 209
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
210
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
211
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
212
		where
Camil Staps's avatar
Camil Staps committed
213
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
214 215 216 217 218 219
			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
220

Camil Staps's avatar
Camil Staps committed
221 222 223 224 225 226 227
	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
228

229
	reloadCache :: !CloogleDB -> *World -> *World
Camil Staps's avatar
Camil Staps committed
230
	reloadCache db = uncurry (flip (foldl (flip search))) o allCacheKeys LongTerm
231
	where
232 233
		search :: !RequestCacheKey -> *World -> *World
		search r = thd3 o handle db (Just $ fromRequestCacheKey r) o removeFromCache LongTerm r
234

235 236 237 238
	doInBackground :: (*World -> *World) *World -> *World
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
239 240
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function
241

242 243 244 245
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
246
	, mem_request    :: Maybe Request
247 248 249 250 251 252 253 254 255 256 257 258 259 260 261 262 263
	}

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

:: LogMessage` :== LogMessage (Maybe Request) Response CacheKey

:: LogEntry =
	{ ip            :: String
	, time_start    :: (String, Int)
	, time_end      :: (String, Int)
264
	, request       :: Maybe Request
265 266 267 268 269 270 271 272 273 274 275 276 277
	, cachekey      :: String
	, 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
278
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
279 280 281 282 283
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
284 285
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
286 287
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
288
	updateMemory (Sent _ _)     s w
289 290 291 292
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
293 294 295
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ ip            = toString mem.mem_ip
296 297
		, 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)
Camil Staps's avatar
Camil Staps committed
298 299 300 301 302
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
303 304 305 306 307 308 309 310

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