CloogleServer.icl 14.9 KB
Newer Older
1 2
module CloogleServer

3 4 5 6 7 8 9 10
import StdArray
import StdBool
import StdFile
import StdList
import StdOrdList
import StdOverloaded
import StdString
import StdTuple
Camil Staps's avatar
Camil Staps committed
11
from StdFunc import o, flip, const, seq
12
from StdMisc import abort
13

14
from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
15 16

from Data.Func import $
Camil Staps's avatar
Camil Staps committed
17
import Data.List
18
import Data.Tuple
19 20 21 22
import Data.Maybe
import System.CommandLine
import Data.Functor
import Control.Applicative
23
import Control.Monad
Camil Staps's avatar
Camil Staps committed
24
from Text import class Text(concat,trim,indexOf,toLowerCase),
25
	instance Text String, instance + String
26
import Text.JSON
Camil Staps's avatar
Camil Staps committed
27 28

import System.Time
29

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

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 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
	  , 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 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
	, c_include_builtins = fromJust (r.include_builtins <|> Just True)
	, c_page             = fromJust (r.page <|> Just 0)
65 66
	}

67 68 69 70 71 72 73 74 75
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"
76
#! db = fromJust db
Camil Staps's avatar
Camil Staps committed
77
= serve (handle db) (Just log) port w
78
where
Camil Staps's avatar
Camil Staps committed
79 80 81 82 83
	help :: *File *World -> *World
	help io w
	# io = io <<< "Usage: ./CloogleServer <port>\n"
	= snd $ fclose io w

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

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

Camil Staps's avatar
Camil Staps committed
133 134 135 136
		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
137
		# w = writeCache Brief req` resp` w
Camil Staps's avatar
Camil Staps committed
138
		= cachePages key (npages - 1) (i + 1) response keep w
Camil Staps's avatar
Camil Staps committed
139
		where
Camil Staps's avatar
Camil Staps committed
140
			req` = { key & c_page = key.c_page + i }
Camil Staps's avatar
Camil Staps committed
141 142 143 144 145 146
			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
147

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

157
	search :: !Request !TypeDB -> [Result]
Camil Staps's avatar
Camil Staps committed
158 159
	search {unify,name,className,typeName,modules,libraries,page,include_builtins} db
		# include_builtins = fromJust (include_builtins <|> Just True)
Camil Staps's avatar
Camil Staps committed
160
		# db = case libraries of
Camil Staps's avatar
Camil Staps committed
161
			(Just ls) = filterLocations (isLibMatch include_builtins ls) db
Camil Staps's avatar
Camil Staps committed
162
			Nothing   = db
163 164 165
		# db = case modules of
			(Just ms) = filterLocations (isModMatch ms) db
			Nothing   = db
Camil Staps's avatar
Camil Staps committed
166 167 168 169
		| isJust className
			# className = fromJust className
			# classes = findClass className db
			= map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
170 171 172
		| isJust typeName
			# typeName = fromJust typeName
			# types = findType typeName db
173
			= [makeTypeResult (Just typeName) l td db \\ (l,td) <- types]
174
		# mbType = prepare_unification True <$> (unify >>= parseType o fromString)
Camil Staps's avatar
Camil Staps committed
175
		// Search normal functions
176
		# filts = catMaybes [ (\t _ -> isUnifiable t) <$> mbType
177
		                    , (\n loc _ -> isNameMatch (size n*2/3) n loc) <$> name
178
		                    ]
179
		# funs = map (\f -> makeFunctionResult name mbType Nothing f db) $ findFunction`` filts db
Camil Staps's avatar
Camil Staps committed
180
		// Search macros
181
		# macros = case (isNothing mbType,name) of
182
			(True,Just n) = findMacro` (\loc _ -> isNameMatch (size n*2/3) n loc) db
183
			_             = []
Camil Staps's avatar
Camil Staps committed
184
		# macros = map (\(lhs,rhs) -> makeMacroResult name lhs rhs) macros
Camil Staps's avatar
Camil Staps committed
185
		// Search class members
Camil Staps's avatar
Camil Staps committed
186
		# filts = catMaybes [ (\t _ _ _ _->isUnifiable t) <$> mbType
187 188
		                    , (\n (Location lib mod _ _ _) _ _ f _ -> isNameMatch
		                      (size n*2/3) n (Location lib mod Nothing Nothing f)) <$> name
189
		                    ]
Camil Staps's avatar
Camil Staps committed
190
		# members = findClassMembers`` filts db
191 192
		# members = map (\(Location lib mod line iclline cls,vs,_,f,et) -> makeFunctionResult name mbType
			(Just {cls_name=cls,cls_vars=vs}) (Location lib mod line iclline f,et) db) members
Camil Staps's avatar
Camil Staps committed
193
		// Search types
194
		# lcName = if (isJust mbType && isType (fromJust mbType))
Camil Staps's avatar
Camil Staps committed
195 196
			(let (Type name _) = fromJust mbType in Just $ toLowerCase name)
			(toLowerCase <$> name)
197 198 199
		# types = case (isNothing mbType,lcName) of
			(True,Just n) = findType` (\loc _ -> toLowerCase (getName loc) == n) db
			_             = []
200
		# types = map (\(tl,td) -> makeTypeResult name tl td db) types
201 202
		// Search classes
		# classes = case (isNothing mbType, toLowerCase <$> name) of
Camil Staps's avatar
Camil Staps committed
203
			(True, Just c) = findClass` (\loc _ _ _ -> toLowerCase (getName loc) == c) db
Camil Staps's avatar
Camil Staps committed
204 205
			_              = []
		# classes = map (flip makeClassResult db) classes
Camil Staps's avatar
Camil Staps committed
206
		// Merge results
Camil Staps's avatar
Camil Staps committed
207
		= sort $ funs ++ members ++ types ++ classes ++ macros
Camil Staps's avatar
Camil Staps committed
208

209
	makeClassResult :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
Camil Staps's avatar
Camil Staps committed
210
		TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
211 212 213 214 215
	makeClassResult rec=:(Builtin _, _, _, _) db
		= ClassResult
		  ( { library  = ""
		    , filename = ""
		    , dcl_line = Nothing
216
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
217 218 219 220 221 222
		    , modul    = ""
		    , distance = -100
		    , builtin  = Just True
		    }
		  , makeClassResultExtras rec db
		  )
223
	makeClassResult rec=:(Location lib mod line iclline cls, vars, cc, funs) db
Camil Staps's avatar
Camil Staps committed
224 225 226
		= ClassResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
227
		    , dcl_line = line
228
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
229
		    , modul    = mod
230
		    , distance = -100
Camil Staps's avatar
Camil Staps committed
231
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
232
		    }
Camil Staps's avatar
Camil Staps committed
233
		  , makeClassResultExtras rec db
Camil Staps's avatar
Camil Staps committed
234
		  )
Camil Staps's avatar
Camil Staps committed
235 236 237 238 239
	makeClassResultExtras :: (Location, [TypeVar], ClassContext, [(Name,ExtendedType)])
		TypeDB -> ClassResultExtras
	makeClassResultExtras (l, vars, cc, funs) db
		= { class_name = cls
		  , class_heading = foldl ((+) o (flip (+) " ")) cls vars +
240
		      if (isEmpty cc) "" " | " + concat (print False cc)
Camil Staps's avatar
Camil Staps committed
241 242 243 244 245 246
		  , class_funs = [print_fun fun \\ fun <- funs]
		  , class_instances
		      = sortBy (\(a,_) (b,_) -> a < b)
		          [([concat (print False t) \\ t <- ts], map loc ls)
		          \\ (ts,ls) <- getInstances cls db]
		  }
247
	where
Camil Staps's avatar
Camil Staps committed
248 249
		cls = case l of
			Builtin c = c
250
			Location _ _ _ _ c = c
Camil Staps's avatar
Camil Staps committed
251

252 253 254
		print_fun :: (Name,ExtendedType) -> String
		print_fun f=:(_,ET _ et) = fromJust $
			et.te_representation <|> (pure $ concat $ print False f)
Camil Staps's avatar
Camil Staps committed
255

256
	makeTypeResult :: (Maybe String) Location TypeDef TypeDB -> Result
257
	makeTypeResult mbName (Location lib mod line iclline t) td db
Camil Staps's avatar
Camil Staps committed
258 259 260
		= TypeResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
261
		    , dcl_line = line
262
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
263
		    , modul    = mod
Camil Staps's avatar
Camil Staps committed
264
		    , distance
265
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
Camil Staps's avatar
Camil Staps committed
266 267
		    , builtin  = Nothing
		    }
268
		  , { type             = concat $ print False td
269 270
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
271 272
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
273
		  )
274
	makeTypeResult mbName (Builtin t) td db
Camil Staps's avatar
Camil Staps committed
275 276 277
		= TypeResult
		  ( { library  = ""
		    , filename = ""
Camil Staps's avatar
Camil Staps committed
278
		    , dcl_line = Nothing
279
		    , icl_line = Nothing
Camil Staps's avatar
Camil Staps committed
280 281 282 283
		    , modul    = ""
		    , distance
		        = if (isNothing mbName) -100 (levenshtein` t (fromJust mbName))
		    , builtin  = Just True
Camil Staps's avatar
Camil Staps committed
284
		    }
285
		  , { type             = concat $ print False td
286 287
		    , type_instances   = map (appSnd3 (map (concat o (print False)))) $
		        map (appThd3 (map loc)) $ getTypeInstances t db
288 289
		    , type_derivations = map (appSnd (map loc)) $ getTypeDerivations t db
		    }
Camil Staps's avatar
Camil Staps committed
290 291
		  )

292
	makeMacroResult :: (Maybe String) Location Macro -> Result
293
	makeMacroResult mbName (Location lib mod line iclline m) mac
Camil Staps's avatar
Camil Staps committed
294 295 296
		= MacroResult
		  ( { library  = lib
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
297
		    , dcl_line = line
298
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
299 300
		    , modul    = mod
		    , distance
Camil Staps's avatar
Camil Staps committed
301
		        = if (isNothing mbName) -100 (levenshtein` (fromJust mbName) m)
Camil Staps's avatar
Camil Staps committed
302
		    , builtin  = Nothing
Camil Staps's avatar
Camil Staps committed
303 304 305 306 307 308
		    }
		  , { macro_name = m
		    , macro_representation = mac.macro_as_string
		    }
		  )

Camil Staps's avatar
Camil Staps committed
309
	makeFunctionResult :: (Maybe String) (Maybe Type) (Maybe ShortClassResult)
310
		(Location, ExtendedType) TypeDB -> Result
Camil Staps's avatar
Camil Staps committed
311
	makeFunctionResult
Camil Staps's avatar
Camil Staps committed
312
		orgsearch orgsearchtype mbCls (fl, et=:(ET type tes)) db
Camil Staps's avatar
Camil Staps committed
313 314
		= FunctionResult
		  ( { library  = lib
Camil Staps's avatar
Camil Staps committed
315
		    , filename = modToFilename mod
Camil Staps's avatar
Camil Staps committed
316
		    , dcl_line = line
317
		    , icl_line = iclline
Camil Staps's avatar
Camil Staps committed
318 319
		    , modul    = mod
		    , distance = distance
Camil Staps's avatar
Camil Staps committed
320
		    , builtin  = builtin
Camil Staps's avatar
Camil Staps committed
321
		    }
322 323
		  , { func     = fromJust (tes.te_representation <|>
		                           (pure $ concat $ print False (fname,et)))
324 325
		    , unifier  = toStrUnifier <$> finish_unification <$>
		        (orgsearchtype >>= unify [] (prepare_unification False type))
Camil Staps's avatar
Camil Staps committed
326
		    , cls      = mbCls
327
		    , constructor_of = if tes.te_isconstructor
Camil Staps's avatar
Camil Staps committed
328 329
		        (let (Func _ r _) = type in Just $ concat $ print False r)
		        Nothing
330
		    , recordfield_of = if tes.te_isrecordfield
Camil Staps's avatar
Camil Staps committed
331 332
		        (let (Func [t:_] _ _) = type in Just $ concat $ print False t)
		        Nothing
333 334
		    , generic_derivations
		        = let derivs = getDerivations fname db in
Camil Staps's avatar
Camil Staps committed
335 336
		          const (sortBy (\(a,_) (b,_) -> a < b)
				    [(concat $ print False d, map loc ls) \\ (d,ls) <- derivs]) <$>
Camil Staps's avatar
Camil Staps committed
337
		          tes.te_generic_vars
Camil Staps's avatar
Camil Staps committed
338 339
		    }
		  )
Camil Staps's avatar
Camil Staps committed
340
	where
341 342 343
		(lib,mod,fname,line,iclline,builtin) = case fl of
			(Location l m ln iln f) = (l,  m,  f, ln,      iln,     Nothing)
			(Builtin f)             = ("", "", f, Nothing, Nothing, Just True)
Camil Staps's avatar
Camil Staps committed
344

345 346
		toStrUnifier :: Unifier -> StrUnifier
		toStrUnifier (tvas1, tvas2) = (map toStr tvas1, map toStr tvas2)
347
		where toStr (var, type) = (var, concat $ print False type)
348

Camil Staps's avatar
Camil Staps committed
349
		toStrPriority :: (Maybe Priority) -> String
350
		toStrPriority p = case print False p of [] = ""; ss = concat [" ":ss]
Camil Staps's avatar
Camil Staps committed
351

Camil Staps's avatar
Camil Staps committed
352
		distance
Camil Staps's avatar
Camil Staps committed
353
			| isNothing orgsearch || fromJust orgsearch == ""
Camil Staps's avatar
Camil Staps committed
354 355
				| isNothing orgsearchtype = 0
				# orgsearchtype = fromJust orgsearchtype
356 357
				# (Just (ass1, ass2)) = finish_unification <$>
					unify [] orgsearchtype (prepare_unification False type)
358
				= penalty + toInt (sum [typeComplexity t \\ (_,t)<-ass1 ++ ass2 | not (isVar t)])
359
			# orgsearch = fromJust orgsearch
360
			= penalty + levenshtein` orgsearch fname
361
		where
362 363 364 365 366
			penalty
			| tes.te_isrecordfield = 2
			| tes.te_isconstructor = 1
			| otherwise            = 0

367 368 369 370 371 372
			typeComplexity :: Type -> Real
			typeComplexity (Type _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Func is r _) = 2.0 * foldr ((+) o typeComplexity) 1.0 [r:is]
			typeComplexity (Var _) = 1.0
			typeComplexity (Cons _ ts) = 1.2 * foldr ((+) o typeComplexity) 1.0 ts
			typeComplexity (Uniq t) = 3.0 + typeComplexity t
Camil Staps's avatar
Camil Staps committed
373

Camil Staps's avatar
Camil Staps committed
374
	levenshtein` :: String String -> Int
Camil Staps's avatar
Camil Staps committed
375
	levenshtein` a b = if (indexOf a b == -1) 0 -100 + levenshtein [c \\ c <-: a] [c \\ c <-: b]
Camil Staps's avatar
Camil Staps committed
376

Camil Staps's avatar
Camil Staps committed
377 378
	modToFilename :: String -> String
	modToFilename mod = (toString $ reverse $ takeWhile ((<>)'.')
379
	                              $ reverse $ fromString mod) + ".dcl"
Camil Staps's avatar
Camil Staps committed
380

Camil Staps's avatar
Camil Staps committed
381
	isUnifiable :: Type ExtendedType -> Bool
382
	isUnifiable t1 (ET t2 _) = isJust (unify [] t1 (prepare_unification False t2))
Camil Staps's avatar
Camil Staps committed
383

384 385 386
	isNameMatch :: !Int !String Location -> Bool
	isNameMatch maxdist n1 loc
		# (n1, n2) = ({toLower c \\ c <-: n1}, {toLower c \\ c <-: getName loc})
Camil Staps's avatar
Camil Staps committed
387
		= n1 == "" || indexOf n1 n2 <> -1 || levenshtein [c \\ c <-: n1] [c \\ c <-: n2] <= maxdist
Camil Staps's avatar
Camil Staps committed
388

389
	isModMatch :: ![String] Location -> Bool
390 391
	isModMatch mods (Location _ mod _ _ _) = isMember mod mods
	isModMatch _    (Builtin _)            = False
Camil Staps's avatar
Camil Staps committed
392

Camil Staps's avatar
Camil Staps committed
393 394 395
	isLibMatch :: !Bool ![String] Location -> Bool
	isLibMatch _    libs (Location lib _ _ _ _) = any (\l -> indexOf l lib == 0) libs
	isLibMatch blti _    (Builtin _)            = blti
Camil Staps's avatar
Camil Staps committed
396

397
	loc :: Location -> LocationResult
398
	loc (Location lib mod ln iln _) = (lib, mod, ln, iln)
Camil Staps's avatar
Camil Staps committed
399

Camil Staps's avatar
Camil Staps committed
400
	log :: (LogMessage (Maybe Request) Response CacheKey) IPAddress *World
401
		-> *(IPAddress, *World)
Camil Staps's avatar
Camil Staps committed
402
	log msg s w
Camil Staps's avatar
Camil Staps committed
403 404
	| not needslog = (newS msg s, w)
	# (tm,w) = localTime w
Camil Staps's avatar
Camil Staps committed
405
	# (io,w) = stdio w
Camil Staps's avatar
Camil Staps committed
406
	# io = io <<< trim (toString tm) <<< " " <<< msgToString msg s
Camil Staps's avatar
Camil Staps committed
407
	= (newS msg s, snd (fclose io w))
Camil Staps's avatar
Camil Staps committed
408
	where
Camil Staps's avatar
Camil Staps committed
409
		needslog = case msg of (Received _) = True; (Sent _ _) = True; _ = False
Camil Staps's avatar
Camil Staps committed
410

Camil Staps's avatar
Camil Staps committed
411
	newS :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> IPAddress
Camil Staps's avatar
Camil Staps committed
412 413
	newS m s = case m of (Connected ip) = ip; _ = s

Camil Staps's avatar
Camil Staps committed
414
	msgToString :: (LogMessage (Maybe Request) Response CacheKey) IPAddress -> String
Camil Staps's avatar
Camil Staps committed
415
	msgToString (Received Nothing) ip
416
		= toString ip + " <-- Nothing\n"
Camil Staps's avatar
Camil Staps committed
417
	msgToString (Received (Just a)) ip
418
		= toString ip + " <-- " + toString a + "\n"
Camil Staps's avatar
Camil Staps committed
419
	msgToString (Sent {return,data,msg,more_available} ck) ip
420
		= toString ip + " --> " + toString (length data)
Camil Staps's avatar
Camil Staps committed
421 422 423
			+ " results (" + toString return + "; " + msg
			+ if (isJust more_available) ("; " + toString (fromJust more_available) + " more") ""
			+ "; cache: " + ck + ")\n"
Camil Staps's avatar
Camil Staps committed
424
	msgToString _ _ = ""