CloogleServer.icl 9.96 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
	= { c_unify            :: Maybe Type
	  , c_name             :: Maybe String
	  , c_className        :: Maybe String
	  , c_typeName         :: Maybe String
49
	  , c_using            :: Bool
Camil Staps's avatar
Camil Staps committed
50 51 52
	  , c_modules          :: Maybe [String]
	  , c_libraries        :: Maybe [String]
	  , c_include_builtins :: Bool
53
	  , c_include_core     :: Bool
54
	  , c_include_apps     :: Bool
Camil Staps's avatar
Camil Staps committed
55
	  , c_page             :: Int
56 57
	  }

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

63
toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
Camil Staps's avatar
Camil Staps committed
64
toRequestCacheKey db r
65
# (allsyns,db) = allTypeSynonyms db
Camil Staps's avatar
Camil Staps committed
66 67
= (
	{ c_unify            = snd <$>
68
		prepare_unification True allsyns <$>
Camil Staps's avatar
Camil Staps committed
69
		(parseType o fromString =<< r.unify)
70
	, c_name             = toLowerCase <$> r.name
71 72
	, c_className        = r.className
	, c_typeName         = r.typeName
73
	, c_using            = fromMaybe False r.using
Camil Staps's avatar
Camil Staps committed
74 75
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
76 77 78 79
	, 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
80
	}, db)
81 82 83 84 85 86
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
	{ unify            = concat <$> print False <$> k.c_unify
	, name             = k.c_name
	, className        = k.c_className
	, typeName         = k.c_typeName
87
	, using            = Just k.c_using
88 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
	, 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 <+ "'"
114

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

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

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

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

Camil Staps's avatar
Camil Staps committed
224 225 226 227 228 229 230
	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
231

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

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

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

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

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

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

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