CloogleServer.icl 9.47 KB
Newer Older
1 2
module CloogleServer

3 4 5
import StdArray
import StdBool
import StdFile
6
from StdFunc import id, o, seq
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 21
from Data.Foldable import class Foldable
from Data.Func import $, hyperstrict, instance Functor ((->) r)
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), 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 63 64 65 66
toRequestCacheKey :: CloogleDB Request -> RequestCacheKey
toRequestCacheKey db r =
	{ c_unify            = snd <$>
		prepare_unification True (map getTypeDef $ allTypes db) <$>
		(parseType o fromString =<< r.unify)
Camil Staps's avatar
Camil Staps committed
67 68 69 70 71
	, c_name             = r.name
	, c_className        = r.className
	, c_typeName         = r.typeName
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
72 73
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, c_include_core     = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
74
	, c_include_apps     = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
Camil Staps's avatar
Camil Staps committed
75
	, c_page             = fromJust (r.page <|> Just 0)
76
	}
77 78 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
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 <+ "'"
109

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

Camil Staps's avatar
Camil Staps committed
140 141 142 143 144 145 146 147 148
	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

Camil Staps's avatar
Camil Staps committed
149
	handle :: !CloogleDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
Camil Staps's avatar
Camil Staps committed
150
	handle db Nothing w = (err InvalidInput "Couldn't parse input", "", w)
Camil Staps's avatar
Camil Staps committed
151
	handle db (Just request=:{unify,name,page}) w
152
		//Check cache
Camil Staps's avatar
Camil Staps committed
153
		#! (mbResponse, w) = readCache key w
154 155
		| isJust mbResponse
			# r = fromJust mbResponse
156
			= respond {r & return = if (r.return == 0) 1 r.return} w
157
		| isJust name && size (fromJust name) > 40
Camil Staps's avatar
Camil Staps committed
158
			= respond (err InvalidName "Function name too long") w
Camil Staps's avatar
Camil Staps committed
159
		| isJust name && any isSpace (fromString $ fromJust name)
Camil Staps's avatar
Camil Staps committed
160
			= respond (err InvalidName "Name cannot contain spaces") w
Camil Staps's avatar
Camil Staps committed
161
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
Camil Staps's avatar
Camil Staps committed
162
			= respond (err InvalidType "Couldn't parse type") w
Camil Staps's avatar
Camil Staps committed
163
		// Results
Camil Staps's avatar
Camil Staps committed
164 165 166
		#! drop_n = fromJust (page <|> pure 0) * MAX_RESULTS
		#! results = drop drop_n $ sort $ search request db
		#! more = max 0 (length results - MAX_RESULTS)
Camil Staps's avatar
Camil Staps committed
167
		// Suggestions
Camil Staps's avatar
Camil Staps committed
168
		#! suggestions = unify >>= parseType o fromString >>= flip (suggs name) db
Camil Staps's avatar
Camil Staps committed
169
		#! w = seq [cachePages
170
				(toRequestCacheKey db req) CACHE_PREFETCH 0 zero suggs
171
				\\ (req,suggs) <- 'Foldable'.concat suggestions] w
Camil Staps's avatar
Camil Staps committed
172
		#! suggestions
173
			= sortBy (\a b -> snd a > snd b) <$>
Camil Staps's avatar
Camil Staps committed
174 175
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
Camil Staps's avatar
Camil Staps committed
176
		#! (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
177
		// Response
Camil Staps's avatar
Camil Staps committed
178
		#! response = if (isEmpty results)
Camil Staps's avatar
Camil Staps committed
179
			(err NoResults "No results")
Camil Staps's avatar
Camil Staps committed
180 181
			{ zero
		    & data           = results
Camil Staps's avatar
Camil Staps committed
182 183
		    , more_available = Just more
		    , suggestions    = suggestions
184
		    }
Camil Staps's avatar
Camil Staps committed
185
		// Save page prefetches
Camil Staps's avatar
Camil Staps committed
186
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
187
		// Save cache file
188 189
		= respond response w
	where
190
		key = toRequestCacheKey db request
191

Camil Staps's avatar
Camil Staps committed
192
		respond :: !Response !*World -> *(!Response, !CacheKey, !*World)
193
		respond r w = (r, cacheKey key, writeCache LongTerm key r w)
Camil Staps's avatar
Camil Staps committed
194

Camil Staps's avatar
Camil Staps committed
195
		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
Camil Staps's avatar
Camil Staps committed
196 197 198
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
199
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
200
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
201
		where
Camil Staps's avatar
Camil Staps committed
202
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
203 204 205 206 207 208
			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
209

Camil Staps's avatar
Camil Staps committed
210
	suggs :: !(Maybe String) !Type !CloogleDB -> Maybe [(Request, [Result])]
211
	suggs n (Func is r cc) db
212 213
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
214
			        let request = {zero & name=n, unify=Just t`} in
Camil Staps's avatar
Camil Staps committed
215
			        (request, search request db)
216
			        \\ is` <- permutations is | is` <> is]
217
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
218

219
	reloadCache :: !CloogleDB -> *World -> *World
Camil Staps's avatar
Camil Staps committed
220
	reloadCache db = uncurry (flip (foldl (flip search))) o allCacheKeys LongTerm
221
	where
222 223
		search :: !RequestCacheKey -> *World -> *World
		search r = thd3 o handle db (Just $ fromRequestCacheKey r) o removeFromCache LongTerm r
224

225 226 227 228
	doInBackground :: (*World -> *World) *World -> *World
	doInBackground f w
	#! (pid,w) = fork w
	| pid  < 0 = abort "fork failed\n"
229 230
	| pid  > 0 = w // Parent: return directly
	| pid == 0 = snd $ exit 0 $ f w // Child: do function
231

232 233 234 235
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
236
	, mem_request    :: Maybe Request
237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253
	}

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)
254
	, request       :: Maybe Request
255 256 257 258 259 260 261 262 263 264 265 266 267
	, 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
268
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
269 270 271 272 273
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
274 275
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
276 277
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
278
	updateMemory (Sent _ _)     s w
279 280 281 282
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
283 284 285
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ ip            = toString mem.mem_ip
286 287
		, 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
288 289 290 291 292
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
293 294 295 296 297 298 299 300

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