CloogleServer.icl 7.06 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 30 31
import Type
import TypeDB
import Search
Camil Staps's avatar
Camil Staps committed
32

Camil Staps's avatar
Camil Staps committed
33 34 35 36 37
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
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
Camil Staps's avatar
Camil Staps committed
50
	  , c_page             :: Int
51 52 53 54 55 56 57 58
	  }

derive JSONEncode Kind, ClassOrGeneric, Type, RequestCacheKey
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)
Camil Staps's avatar
Camil Staps committed
67
	, c_page             = fromJust (r.page <|> Just 0)
68 69
	}

70 71
Start w
# (cmdline, w) = getCommandLine w
Camil Staps's avatar
Camil Staps committed
72 73
| length cmdline <> 2
	= help w
74
# [_,port:_] = cmdline
Camil Staps's avatar
Camil Staps committed
75 76 77 78 79
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
#! (db,f) = openDb f
#! (_,w) = fclose f w
= serve (handle db) (Just log) (toInt port) w
80
where
Camil Staps's avatar
Camil Staps committed
81 82 83
	help :: *World -> *World
	help w
	# (io, w) = stdio w
Camil Staps's avatar
Camil Staps committed
84 85 86
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

Camil Staps's avatar
Camil Staps committed
87 88 89 90 91 92 93 94 95
	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
96
	handle :: !TypeDB !(Maybe Request) !*World -> *(!Response, CacheKey, !*World)
Camil Staps's avatar
Camil Staps committed
97
	handle db Nothing w = (err InvalidInput "Couldn't parse input", "", w)
Camil Staps's avatar
Camil Staps committed
98
	handle db (Just request=:{unify,name,page}) w
99
		//Check cache
Camil Staps's avatar
Camil Staps committed
100
		#! (mbResponse, w) = readCache key w
101 102
		| isJust mbResponse
			# r = fromJust mbResponse
Camil Staps's avatar
Camil Staps committed
103
			= ({r & return = if (r.return == 0) 1 r.return}, cacheKey key, w)
104
		| isJust name && size (fromJust name) > 40
Camil Staps's avatar
Camil Staps committed
105
			= respond (err InvalidName "Function name too long") w
Camil Staps's avatar
Camil Staps committed
106
		| isJust name && any isSpace (fromString $ fromJust name)
Camil Staps's avatar
Camil Staps committed
107
			= respond (err InvalidName "Name cannot contain spaces") w
Camil Staps's avatar
Camil Staps committed
108
		| isJust unify && isNothing (parseType $ fromString $ fromJust unify)
Camil Staps's avatar
Camil Staps committed
109
			= respond (err InvalidType "Couldn't parse type") w
Camil Staps's avatar
Camil Staps committed
110
		// Results
Camil Staps's avatar
Camil Staps committed
111 112 113
		#! 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
114
		// Suggestions
Camil Staps's avatar
Camil Staps committed
115
		#! suggestions = unify >>= parseType o fromString >>= flip (suggs name) db
Camil Staps's avatar
Camil Staps committed
116
		#! w = seq [cachePages
Camil Staps's avatar
Camil Staps committed
117
				(toRequestCacheKey req) CACHE_PREFETCH 0 zero suggs
118
				\\ (req,suggs) <- 'Foldable'.concat suggestions] w
Camil Staps's avatar
Camil Staps committed
119
		#! suggestions
120
			= sortBy (\a b -> snd a > snd b) <$>
Camil Staps's avatar
Camil Staps committed
121 122
			  filter ((<) (length results) o snd) <$>
			  map (appSnd length) <$> suggestions
Camil Staps's avatar
Camil Staps committed
123
		#! (results,nextpages) = splitAt MAX_RESULTS results
Camil Staps's avatar
Camil Staps committed
124
		// Response
Camil Staps's avatar
Camil Staps committed
125
		#! response = if (isEmpty results)
Camil Staps's avatar
Camil Staps committed
126
			(err NoResults "No results")
Camil Staps's avatar
Camil Staps committed
127 128
			{ zero
		    & data           = results
Camil Staps's avatar
Camil Staps committed
129 130
		    , more_available = Just more
		    , suggestions    = suggestions
131
		    }
Camil Staps's avatar
Camil Staps committed
132
		// Save page prefetches
Camil Staps's avatar
Camil Staps committed
133
		#! w = cachePages key CACHE_PREFETCH 1 response nextpages w
134
		// Save cache file
135 136
		= respond response w
	where
137 138
		key = toRequestCacheKey request

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

Camil Staps's avatar
Camil Staps committed
142
		cachePages :: !RequestCacheKey !Int !Int !Response ![Result] !*World -> *World
Camil Staps's avatar
Camil Staps committed
143 144 145
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
146
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
147
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
148
		where
Camil Staps's avatar
Camil Staps committed
149
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
150 151 152 153 154 155
			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
156

Camil Staps's avatar
Camil Staps committed
157
	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, [Result])]
158
	suggs n (Func is r cc) db
159 160
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
161
			        let request = {zero & name=n, unify=Just t`} in
Camil Staps's avatar
Camil Staps committed
162
			        (request, search request db)
163
			        \\ is` <- permutations is | is` <> is]
164
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
165

166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189 190 191 192 193 194 195 196 197 198 199 200 201
:: LogMemory =
	{ mem_ip         :: IPAddress
	, mem_time_start :: Tm
	, mem_time_end   :: Tm
	, mem_request    :: Request
	}

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

	updateMemory :: LogMessage` LogMemory *World -> *(LogMemory, *World)
	updateMemory (Connected ip)      s w = ({s & mem_ip=ip}, w)
	updateMemory (Received (Just r)) s w
	# (t,w) = localTime w
	= ({s & mem_time_start=t, mem_request=r}, w)
	updateMemory (Sent _ _)          s w
	# (t,w) = localTime w
	= ({s & mem_time_end=t}, w)
	updateMemory _                   s w = (s,w)

Camil Staps's avatar
Camil Staps committed
217 218 219 220 221 222 223 224 225 226
	makeLogEntry :: LogMessage` LogMemory -> LogEntry
	makeLogEntry (Sent response ck) mem =
		{ ip            = toString mem.mem_ip
		, time_start    = (toString mem.mem_time_start, toInt $ mkTime mem.mem_time_start)
		, time_end      = (toString mem.mem_time_end, toInt $ mkTime mem.mem_time_end)
		, request       = mem.mem_request
		, cachekey      = ck
		, response_code = response.return
		, results       = length response.data
		}
Camil Staps's avatar
Camil Staps committed
227 228 229 230 231 232 233 234

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