CloogleServer.icl 6.81 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
22
import System.CommandLine
23
from Text import class Text(concat), instance Text String
24
import Text.JSON
Camil Staps's avatar
Camil Staps committed
25 26

import System.Time
27

28 29
from SimpleTCPServer import :: LogMessage{..}, serve, :: Logger
import qualified SimpleTCPServer
30
import Cache
31
import Cloogle
32 33 34
import Type
import TypeDB
import Search
Camil Staps's avatar
Camil Staps committed
35

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

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

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
57 58 59 60 61 62
	{ 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
63 64
	, 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
65
	, c_page             = fromJust (r.page <|> Just 0)
66 67
	}

68 69 70 71 72 73 74 75 76
Start w
# (io, w) = stdio w
# (cmdline, w) = getCommandLine w
| length cmdline <> 2 = help io w
# [_,port:_] = cmdline
# port = toInt port
# (db, io) = openDb io
# (_, w) = fclose io w
| isNothing db = abort "stdin does not have a TypeDB\n"
77
#! db = fromJust db
Camil Staps's avatar
Camil Staps committed
78
= serve (handle db) (Just log) port w
79
where
Camil Staps's avatar
Camil Staps committed
80 81 82 83 84
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

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

Camil Staps's avatar
Camil Staps committed
129
		respond :: Response *World -> *(Response, CacheKey, *World)
130
		respond r w = (r, cacheKey key, writeCache LongTerm key r w)
Camil Staps's avatar
Camil Staps committed
131

Camil Staps's avatar
Camil Staps committed
132 133 134 135
		cachePages :: RequestCacheKey Int Int Response [Result] *World -> *World
		cachePages key _ _  _ [] w = w
		cachePages key 0 _  _ _  w = w
		cachePages key npages i response results w
Camil Staps's avatar
Camil Staps committed
136
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
137
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
138
		where
Camil Staps's avatar
Camil Staps committed
139
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
140 141 142 143 144 145
			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
146

Camil Staps's avatar
Camil Staps committed
147
	suggs :: !(Maybe String) !Type !TypeDB -> Maybe [(Request, [Result])]
148
	suggs n (Func is r cc) db
149 150
		| length is < 3
			= Just [let t` = concat $ print False $ Func is` r cc in
151
			        let request = {zero & name=n, unify=Just t`} in
Camil Staps's avatar
Camil Staps committed
152
			        (request, search request db)
153
			        \\ is` <- permutations is | is` <> is]
154
	suggs _ _ _ = Nothing
Camil Staps's avatar
Camil Staps committed
155

156 157 158 159 160 161 162 163 164 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
:: 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
192
# io      = io <<< toString (toJSON $ makeLogEntry msg mem) <<< "\n"
193 194 195 196 197 198 199 200 201 202 203 204 205 206
= (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
207 208 209 210 211 212 213 214 215 216
	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
217 218 219 220 221 222 223 224

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