CloogleServer.icl 9.86 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), 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
Camil Staps's avatar
Camil Staps committed
176 177 178 179 180 181 182 183 184 185 186
		#! (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
187
		#! (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
188
		// Response
Camil Staps's avatar
Camil Staps committed
189
		#! response = if (isEmpty results)
Camil Staps's avatar
Camil Staps committed
190
			(err NoResults "No results")
Camil Staps's avatar
Camil Staps committed
191 192
			{ zero
		    & data           = results
Camil Staps's avatar
Camil Staps committed
193 194
		    , more_available = Just more
		    , suggestions    = suggestions
195
		    }
Camil Staps's avatar
Camil Staps committed
196
		// Save page prefetches
Camil Staps's avatar
Camil Staps committed
197
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
198
		// Save cache file
199
		= respond key response db w
200
	where
201 202
		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
203

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

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

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

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

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

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

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

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

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