CloogleServer.icl 7.39 KB
Newer Older
1 2
module CloogleServer

3 4 5
import StdArray
import StdBool
import StdFile
6 7
from StdFunc import o, seq
from StdMisc import abort, 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 17
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable, instance Foldable Maybe
18
from Data.Func import $
19
import Data.Functor
Camil Staps's avatar
Camil Staps committed
20
import Data.List
21
import Data.Tuple
Camil Staps's avatar
Camil Staps committed
22
import System._Posix
23
import System.CommandLine
Camil Staps's avatar
Camil Staps committed
24
import System.Time
25
from Text import class Text(concat), instance Text String
26
import Text.JSON
Camil Staps's avatar
Camil Staps committed
27

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

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

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

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

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

toRequestCacheKey :: Request -> RequestCacheKey
toRequestCacheKey r =
Camil Staps's avatar
Camil Staps committed
59 60 61 62 63 64
	{ 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
65 66
	, c_include_builtins = fromJust (r.include_builtins <|> Just DEFAULT_INCLUDE_BUILTINS)
	, c_include_core     = fromJust (r.include_core <|> Just DEFAULT_INCLUDE_CORE)
67
	, c_include_apps     = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
Camil Staps's avatar
Camil Staps committed
68
	, c_page             = fromJust (r.page <|> Just 0)
69 70
	}

71 72
Start w
# (cmdline, w) = getCommandLine w
Camil Staps's avatar
Camil Staps committed
73 74
| length cmdline <> 2
	= help w
75
# [_,port:_] = cmdline
Camil Staps's avatar
Camil Staps committed
76 77 78
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
#! (db,f) = openDb f
Camil Staps's avatar
Camil Staps committed
79
#! db = eval_all_nodes db
Camil Staps's avatar
Camil Staps committed
80
#! (_,w) = fclose f w
81 82 83 84
= serve
	{ handler           = handle db
	, logger            = Just log
	, port              = toInt port
85 86
	, connect_timeout   = Just 3600000 // 1h
	, keepalive_timeout = Just 5000    // 5s
87
	} w
88
where
Camil Staps's avatar
Camil Staps committed
89 90 91
	help :: *World -> *World
	help w
	# (io, w) = stdio w
Camil Staps's avatar
Camil Staps committed
92 93 94
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

Camil Staps's avatar
Camil Staps committed
95 96 97 98 99 100 101 102 103
	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
104 105 106 107 108 109 110 111
	eval_all_nodes :: !.a -> .a // From GraphCopy
	eval_all_nodes g = code {
		push_a 0
		.d 1 0
		jsr	_eval_to_nf
		.o 0 0
	}

Camil Staps's avatar
Camil Staps committed
112
	handle :: !CloogleDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
Camil Staps's avatar
Camil Staps committed
113
	handle db Nothing w = (err InvalidInput "Couldn't parse input", "", w)
Camil Staps's avatar
Camil Staps committed
114
	handle db (Just request=:{unify,name,page}) w
115
		//Check cache
Camil Staps's avatar
Camil Staps committed
116
		#! (mbResponse, w) = readCache key w
117 118
		| isJust mbResponse
			# r = fromJust mbResponse
119
			= respond {r & return = if (r.return == 0) 1 r.return} w
120
		| isJust name && size (fromJust name) > 40
Camil Staps's avatar
Camil Staps committed
121
			= respond (err InvalidName "Function name too long") w
Camil Staps's avatar
Camil Staps committed
122
		| isJust name && any isSpace (fromString $ fromJust name)
Camil Staps's avatar
Camil Staps committed
123
			= respond (err InvalidName "Name cannot contain spaces") w
Camil Staps's avatar
Camil Staps committed
124
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
Camil Staps's avatar
Camil Staps committed
125
			= respond (err InvalidType "Couldn't parse type") w
Camil Staps's avatar
Camil Staps committed
126
		// Results
Camil Staps's avatar
Camil Staps committed
127 128 129
		#! 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
130
		// Suggestions
Camil Staps's avatar
Camil Staps committed
131
		#! suggestions = unify >>= parseType o fromString >>= flip (suggs name) db
Camil Staps's avatar
Camil Staps committed
132
		#! w = seq [cachePages
Camil Staps's avatar
Camil Staps committed
133
				(toRequestCacheKey req) CACHE_PREFETCH 0 zero suggs
134
				\\ (req,suggs) <- 'Foldable'.concat suggestions] w
Camil Staps's avatar
Camil Staps committed
135
		#! suggestions
136
			= sortBy (\a b -> snd a > snd b) <$>
Camil Staps's avatar
Camil Staps committed
137 138
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
Camil Staps's avatar
Camil Staps committed
139
		#! (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
140
		// Response
Camil Staps's avatar
Camil Staps committed
141
		#! response = if (isEmpty results)
Camil Staps's avatar
Camil Staps committed
142
			(err NoResults "No results")
Camil Staps's avatar
Camil Staps committed
143 144
			{ zero
		    & data           = results
Camil Staps's avatar
Camil Staps committed
145 146
		    , more_available = Just more
		    , suggestions    = suggestions
147
		    }
Camil Staps's avatar
Camil Staps committed
148
		// Save page prefetches
Camil Staps's avatar
Camil Staps committed
149
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
150
		// Save cache file
151 152
		= respond response w
	where
153 154
		key = toRequestCacheKey request

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

Camil Staps's avatar
Camil Staps committed
158
		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
Camil Staps's avatar
Camil Staps committed
159 160 161
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
162
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
163
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
164
		where
Camil Staps's avatar
Camil Staps committed
165
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
166 167 168 169 170 171
			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
172

Camil Staps's avatar
Camil Staps committed
173
	suggs :: !(Maybe String) !Type !CloogleDB -> Maybe [(Request, [Result])]
174
	suggs n (Func is r cc) db
175 176
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
177
			        let request = {zero & name=n, unify=Just t`} in
Camil Staps's avatar
Camil Staps committed
178
			        (request, search request db)
179
			        \\ is` <- permutations is | is` <> is]
180
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
181

182 183 184 185
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
186
	, mem_request    :: Maybe Request
187 188 189 190 191 192 193 194 195 196 197 198 199 200 201 202 203
	}

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)
204
	, request       :: Maybe Request
205 206 207 208 209 210 211 212 213 214 215 216 217
	, 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
218
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
219 220 221 222 223
= (Just mem, snd (fclose io w))
where
	needslog = case msg of (Sent _ _) = True; _ = False

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
224 225
	updateMemory (Connected ip) s w = ({s & mem_ip=ip}, w)
	updateMemory (Received r)   s w
226 227
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
228
	updateMemory (Sent _ _)     s w
229 230 231 232
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
233 234 235
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ ip            = toString mem.mem_ip
236 237
		, 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
238 239 240 241 242
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
243 244 245 246 247 248 249 250

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