CloogleServer.icl 9.07 KB
Newer Older
1 2
module CloogleServer

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

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

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

29
import Cloogle
30
import Type
Camil Staps's avatar
Camil Staps committed
31
import CloogleDB
32
import Search
Camil Staps's avatar
Camil Staps committed
33

34
import SimpleTCPServer
Camil Staps's avatar
Camil Staps committed
35 36 37
import Cache
import Memory

38
MAX_RESULTS    :== 15
Camil Staps's avatar
Camil Staps committed
39
CACHE_PREFETCH :== 5
40

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

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

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

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

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

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

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

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

214 215
	reloadCache :: !CloogleDB -> *World -> *World
	reloadCache db = uncurry (flip (foldr search)) o allCacheKeys LongTerm
216
	where
217 218
		search :: !RequestCacheKey -> *World -> *World
		search r = thd3 o handle db (Just $ fromRequestCacheKey r) o removeFromCache LongTerm r
219

220 221 222 223
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
224
	, mem_request    :: Maybe Request
225 226 227 228 229 230 231 232 233 234 235 236 237 238 239 240 241
	}

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)
242
	, request       :: Maybe Request
243 244 245 246 247 248 249 250 251 252 253 254 255
	, 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
256
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
257 258 259 260 261
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
262 263
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
264 265
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
266
	updateMemory (Sent _ _)     s w
267 268 269 270
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
271 272 273
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ ip            = toString mem.mem_ip
274 275
		, 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
276 277 278 279 280
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
281 282 283 284 285 286 287 288

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