CloogleServer.icl 9.8 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
toRequestCacheKey :: !*CloogleDB !Request -> *(!RequestCacheKey, !*CloogleDB)
toRequestCacheKey db r = (
	{ c_unify            = Nothing /*snd <$>
65
		prepare_unification True (map getTypeDef $ allTypes db) <$>
66
		(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
	}, db)
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
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
122 123 124 125 126 127 128 129 130
#! (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
131
#! (_,w) = fclose f w
132
= serve
133
	{ handler           = handle
134
	, logger            = Just log
135
	, port              = opts.Options.port
136 137
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
138
	} db w
139
where
140 141
	help :: String *World -> *World
	help pgm w
Camil Staps's avatar
Camil Staps committed
142
	# (io, w) = stdio w
143
	# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
Camil Staps's avatar
Camil Staps committed
144 145
	= snd $ fclose io w

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

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

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

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

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

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

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

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

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

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

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