packages feed

hsdev 0.1.6.0 → 0.1.6.1

raw patch · 3 files changed

+44/−43 lines, 3 files

Files

hsdev.cabal view
@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/
 
 name:                hsdev
-version:             0.1.6.0
+version:             0.1.6.1
 synopsis:            Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references etc.
 description:
   Haskell development library and tool with support of autocompletion, symbol info, go to declaration, find references, hayoo search etc.
src/HsDev/Server/Commands.hs view
@@ -99,7 +99,7 @@ 		parseResponse h str = case eitherDecode str of
 			Left e -> return $ Error e $ M.fromList [("response", toJSON $ fromUtf8 str)]
 			Right (Message _ r) -> do
-				r' <- unMmap r
+				Response r' <- unMmap r
 				case r' of
 					Left n -> onNotification n >> peekResponse h
 					Right res -> return res
@@ -166,30 +166,31 @@ 				-- NOTE: killing listener doesn't work on Windows, because accept blocks async exceptions
 				signalQSem listenerSem
 
-		s <- socket AF_INET Stream defaultProtocol
-		bind s $ SockAddrInet (fromIntegral $ serverPort sopts) iNADDR_ANY
-		listen s maxListenQueue
-		forever $ logAsync (commandLog copts Log.Fatal) $ logIO "exception: " (commandLog copts Log.Error) $ do
-			commandLog copts Log.Trace "accepting connection"
-			s' <- fst <$> accept s
-			commandLog copts Log.Trace $ "accepted " ++ show s'
-			void $ forkIO $ Log.scopeLog (commandLogger copts) (T.pack $ show s') $
-				logAsync (commandLog copts Log.Fatal) $ logIO ("exception: ") (commandLog copts Log.Error) $
-					flip finally (close s') $
-						bracket newEmptyMVar (`putMVar` ()) $ \done -> do
-							me <- myThreadId
-							let
-								timeoutWait = do
-									notDone <- isEmptyMVar done
-									when notDone $ do
-										commandLog copts Log.Trace $ "waiting for " ++ show s' ++ " to complete"
-										waitAsync <- async $ do
-											threadDelay 1000000
-											killThread me
-										void $ waitCatch waitAsync
-							F.putChan clientChan timeoutWait
-							processClientSocket s' (copts {
-								commandExit = serverStop })
+		bracket (socket AF_INET Stream defaultProtocol) close $ \s -> do
+			setSocketOption s ReuseAddr 1
+			bind s $ SockAddrInet (fromIntegral $ serverPort sopts) iNADDR_ANY
+			listen s maxListenQueue
+			forever $ logAsync (commandLog copts Log.Fatal) $ logIO "exception: " (commandLog copts Log.Error) $ do
+				commandLog copts Log.Trace "accepting connection"
+				s' <- fst <$> accept s
+				commandLog copts Log.Trace $ "accepted " ++ show s'
+				void $ forkIO $ Log.scopeLog (commandLogger copts) (T.pack $ show s') $
+					logAsync (commandLog copts Log.Fatal) $ logIO ("exception: ") (commandLog copts Log.Error) $
+						flip finally (close s') $
+							bracket newEmptyMVar (`putMVar` ()) $ \done -> do
+								me <- myThreadId
+								let
+									timeoutWait = do
+										notDone <- isEmptyMVar done
+										when notDone $ do
+											commandLog copts Log.Trace $ "waiting for " ++ show s' ++ " to complete"
+											waitAsync <- async $ do
+												threadDelay 1000000
+												killThread me
+											void $ waitCatch waitAsync
+								F.putChan clientChan timeoutWait
+								processClientSocket s' (copts {
+									commandExit = serverStop })
 
 	commandLog copts Log.Trace "waiting for accept thread"
 	waitQSem listenerSem
@@ -226,9 +227,9 @@ 		parseResp h str = case eitherDecode str of
 			Left e -> putStrLn $ "Can't decode response: " ++ e
 			Right (Message i r) -> do
-				r' <- unMmap r
+				Response r' <- unMmap r
 				putStrLn $ fromMaybe "_" i ++ ":" ++ fromUtf8 (encodeValue r')
-				case r of
+				case unResponse r of
 					Left _ -> waitResp h
 					_ -> return ()
 runServerCommand (Remote copts noFile c) = sendCommand copts noFile c printValue >>= printResult where
@@ -282,9 +283,9 @@ 					let
 						onNotify n
 							| silent = return ()
-							| otherwise = traverse (const $ mmap' noFile (Left n)) m >>= answer
+							| otherwise = traverse (const $ mmap' noFile (Response $ Left n)) m >>= answer
 					commandLog copts Log.Trace $ name ++ " >> " ++ fromUtf8 (encode c)
-					resp <- fmap Right $ handleTimeout tm $ handleError $
+					resp <- fmap result $ handleTimeout tm $ handleError $
 						processRequest
 							(copts {
 								commandRoot = cdir,
@@ -371,7 +372,7 @@ -- | If response points to mmap, get its contents and parse
 unMmap :: Response -> IO Response
 #if mingw32_HOST_OS
-unMmap (Right (Result v))
+unMmap (Response (Right (Result v)))
 	| Just (MmapFile f) <- parseMaybe parseJSON v = do
 		cts <- runExceptT (fmap L.fromStrict (readMapFile f))
 		case cts of
src/HsDev/Server/Message.hs view
@@ -4,7 +4,7 @@ 	Message(..),
 	messagesById,
 	Notification(..), Result(..), ResultPart(..),
-	Response, isNotification, notification, result, responseError, resultPart,
+	Response(..), isNotification, notification, result, responseError, resultPart,
 	groupResponses, responsesById
 	) where
 
@@ -80,38 +80,38 @@ instance FromJSON ResultPart where
 	parseJSON = withObject "result-part" $ \v -> ResultPart <$> v .:: "result-part"
 
-type Response = Either Notification Result
+newtype Response = Response { unResponse :: Either Notification Result }
 
 isNotification :: Response -> Bool
-isNotification = either (const True) (const False)
+isNotification = either (const True) (const False) . unResponse
 
 notification :: ToJSON a => a -> Response
-notification = Left . Notification . toJSON
+notification = Response . Left . Notification . toJSON
 
 result :: ToJSON a => a -> Response
-result = Right . Result . toJSON
+result = Response . Right . Result . toJSON
 
 responseError :: String -> [Pair] -> Response
-responseError e ds = Right $ Error e $ M.fromList $ map (first unpack) ds
+responseError e ds = Response $ Right $ Error e $ M.fromList $ map (first unpack) ds
 
 resultPart :: ToJSON a => a  -> Notification
 resultPart = Notification . toJSON . ResultPart . toJSON
 
 instance ToJSON Response where
-	toJSON (Left n) = toJSON n
-	toJSON (Right r) = toJSON r
+	toJSON (Response (Left n)) = toJSON n
+	toJSON (Response (Right r)) = toJSON r
 
 instance FromJSON Response where
-	parseJSON v = (Left <$> parseJSON v) <|> (Right <$> parseJSON v)
+	parseJSON v = Response <$> ((Left <$> parseJSON v) <|> (Right <$> parseJSON v))
 
 groupResponses :: [Response] -> [([Notification], Result)]
 groupResponses = unfoldr break' where
 	break' :: [Response] -> Maybe (([Notification], Result), [Response])
 	break' [] = Nothing
-	break' cs =  Just ((lefts ns, r), drop 1 cs') where
-		(ns, cs') = break isRight cs
+	break' cs =  Just ((lefts (map unResponse ns), r), drop 1 cs') where
+		(ns, cs') = break (isRight . unResponse) cs
 		r = case cs' of
-			(Right r' : _) -> r'
+			(Response (Right r') : _) -> r'
 			[] -> Error "groupResponses: no result" mempty
 			_ -> error "groupResponses: impossible happened"