CloogleServer.icl 9.43 KB
Newer Older
1 2
module CloogleServer

3 4 5
import StdArray
import StdBool
import StdFile
6
from StdFunc import id, o, seq
7
import StdMisc
8 9
import StdOrdList
import StdOverloaded
10
import StdString
11
import StdTuple
12

13
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
14

15 16
import Control.Applicative
import Control.Monad
17
import Data.Error
18 19
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable, instance Foldable Maybe
20
from Data.Func import $, hyperstrict
21
import Data.Functor
Camil Staps's avatar
Camil Staps committed
22
import Data.List
23
import Data.Maybe
24
import Data.Tuple
Camil Staps's avatar
Camil Staps committed
25
import System._Posix
26
import System.CommandLine
Camil Staps's avatar
Camil Staps committed
27
import System.Time
28
from Text import class Text(concat), instance Text String, <+
29
import Text.JSON
Camil Staps's avatar
Camil Staps committed
30

31
import Cloogle
32
import Type
Camil Staps's avatar
Camil Staps committed
33
import CloogleDB
34
import Search
Camil Staps's avatar
Camil Staps committed
35

36
import SimpleTCPServer
Camil Staps's avatar
Camil Staps committed
37 38 39
import Cache
import Memory

40
MAX_RESULTS    :== 15
Camil Staps's avatar
Camil Staps committed
41
CACHE_PREFETCH :== 5
42

43
:: RequestCacheKey
Camil Staps's avatar
Camil Staps committed
44 45 46 47 48 49 50
	= { 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
51
	  , c_include_core     :: Bool
52
	  , c_include_apps     :: Bool
Camil Staps's avatar
Camil Staps committed
53
	  , c_page             :: Int
54 55
	  }

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

61 62 63 64 65
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
66 67 68 69 70
	, c_name             = r.name
	, c_className        = r.className
	, c_typeName         = r.typeName
	, c_modules          = sort <$> r.modules
	, c_libraries        = sort <$> r.libraries
71 72
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, c_include_core     = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
73
	, c_include_apps     = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
Camil Staps's avatar
Camil Staps committed
74
	, c_page             = fromJust (r.page <|> Just 0)
75
	}
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
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 <+ "'"
108

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

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

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

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

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

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

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

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

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

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

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

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