, bytestring
, aeson
, lens
+ , filepath
, text
, transformers
, process
, directory
, containers
+ , unordered-containers
if os(windows)
build-depends: win32
else
other-modules: Compat
Capabilities
Language.Haskell.LSP.Test.Files
+ Language.Haskell.LSP.Test.Parsing
ghc-options: -W
test-suite tests
{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE OverloadedStrings #-}
module Language.Haskell.LSP.Test.Files
- ( loadSwappedFiles
+ ( swapFiles
, FileMap
, emptyFileMap
)
where
-import Language.Haskell.LSP.Core
-import qualified Language.Haskell.LSP.Control as Control
import Language.Haskell.LSP.Types hiding ( error )
-import Data.Default
-import Control.Lens
+import Language.Haskell.LSP.Test.Parsing
import Control.Monad
-import Control.Concurrent
import Data.Aeson
import qualified Data.ByteString.Lazy.Char8 as B
-import Data.Map as Map
+import qualified Data.Text as T
+import qualified Data.Map as Map
+import Data.Map ((!))
+import qualified Data.HashMap.Strict as HashMap
+import qualified Data.Set as Set
import Data.Maybe
import System.Directory
import System.IO
+import System.FilePath
-type FileMap = Map.Map FilePath FilePath
+type FileMap = Map.Map Uri Uri
emptyFileMap :: FileMap
emptyFileMap = Map.empty
-buildFiles
- :: (HasParams a b, HasTextDocument b c, HasUri c Uri)
- => [a]
- -> FileMap
- -> IO FileMap
-buildFiles ns oldMap = foldM createFile oldMap ns
+buildFileMap :: [Uri] -> FileMap -> IO FileMap
+buildFileMap uris oldMap = foldM createFile oldMap uris
where
- createFile map n = do
- let fp = fromMaybe (error "Couldn't convert file path")
- (uriToFilePath $ n ^. params . textDocument . uri)
- if Map.member fp map
+ createFile map uri =
+ if Map.member uri map
then return map
else do
- tmpDir <- getTemporaryDirectory
- (tmpFp, tmpH) <- openTempFile tmpDir "lspTestDoc"
+ let fp = fromMaybe (error "Couldn't convert file path")
+ (uriToFilePath uri)
+
+ -- Need to store in a directory inside tmp directory
+ -- otherwise ghc-mod ends up creating one for us
+ tmpDir <- (</> "lsp-test") <$> getTemporaryDirectory
+ createDirectoryIfMissing False tmpDir
+
+ (tmpFp, tmpH) <- openTempFile tmpDir (takeFileName fp)
+
readFile fp >>= hPutStr tmpH
- return $ Map.insert fp tmpFp map
-
-swapFile :: (HasUri a Uri) => FileMap -> a -> a
-swapFile m msg = fromMaybe msg $ do
- let oldUri = msg ^. uri
- oldFp <- uriToFilePath oldUri
- newFp <- Map.lookup oldFp m
- let newUri = filePathToUri newFp
- return $ uri .~ newUri $ msg
-
-loadSwappedFiles :: FileMap -> Handle -> IO ([B.ByteString], FileMap)
-loadSwappedFiles map h = do
- fileMapVar <- newMVar map
- msgsVar <- newMVar []
- nullH <- openFile "/dev/null" WriteMode
- Control.runWithHandles h
- nullH
- (const $ Right (), const $ return Nothing)
- (handlers msgsVar fileMapVar)
- def
- Nothing
- Nothing
- newMap <- readMVar fileMapVar
- msgs <- reverse <$> readMVar msgsVar
- return (msgs, newMap)
-
-handlers :: MVar [B.ByteString] -> MVar FileMap -> Handlers
-handlers msgs fileMap = Handlers
- {
- -- Requests
- hoverHandler = Just put
- , completionHandler = Just put
- , completionResolveHandler = Just put
- , signatureHelpHandler = Just put
- , definitionHandler = Just put
- , referencesHandler = Just put
- , documentHighlightHandler = Just put
- , documentSymbolHandler = Just $ swapUri (params . textDocument)
- , workspaceSymbolHandler = Just put
- , codeActionHandler = Just put
- , codeLensHandler = Just put
- , codeLensResolveHandler = Just put
- , documentFormattingHandler = Just put
- , documentRangeFormattingHandler = Just put
- , documentTypeFormattingHandler = Just put
- , renameHandler = Just $ swapUri (params . textDocument)
- , documentLinkHandler = Just $ swapUri (params . textDocument)
- , documentLinkResolveHandler = Just put
- , executeCommandHandler = Just put
- , initializeRequestHandler = Just put
- -- Notifications
- , didChangeConfigurationParamsHandler = Just put
- , didOpenTextDocumentNotificationHandler = Just $ swapUri (params . textDocument)
- , didChangeTextDocumentNotificationHandler = Just $ swapUri (params . textDocument)
- , didCloseTextDocumentNotificationHandler = Just $ swapUri (params . textDocument)
- , didSaveTextDocumentNotificationHandler = Just $ swapUri (params . textDocument)
- , willSaveWaitUntilTextDocHandler = Just put
- , didChangeWatchedFilesNotificationHandler = Just put
- , initializedHandler = Just put
- , willSaveTextDocumentNotificationHandler = Just $ swapUri (params . textDocument)
- , cancelNotificationHandler = Just put
- , exitNotificationHandler = Just put
- -- Responses
- , responseHandler = Just put
- }
- where
- swapUri f msg = do
- modifyMVar_ fileMap (buildFiles [msg])
- map <- readMVar fileMap
- put $ swapFile map $ msg ^. f
+ tmpUri <- filePathToUri <$> canonicalizePath tmpFp
+ return $ Map.insert uri tmpUri map
+
+swapFiles :: FileMap -> Handle -> IO ([B.ByteString], FileMap)
+swapFiles fileMap h = do
+ msgs <- getAllMessages h
+
+ let oldUris = Set.unions $ map extractUris msgs
+
+ newMap <- buildFileMap (Set.elems oldUris) fileMap
+
+ let newMsgs = map (swapUris newMap) msgs
+
+ return (newMsgs, newMap)
+
+extractUris :: B.ByteString -> Set.Set Uri
+extractUris msgs =
+ case decode msgs :: Maybe Object of
+ Just obj -> HashMap.foldlWithKey' gather Set.empty obj
+ Nothing -> error "nooo"
+ where gather :: Set.Set Uri -> T.Text -> Value -> Set.Set Uri
+ gather uris "uri" (String s) = Set.insert (Uri s) uris
+ gather uris _ (Object o) = HashMap.foldlWithKey' gather uris o
+ gather uris _ _ = uris
+
+swapUris :: FileMap -> B.ByteString -> B.ByteString
+swapUris fileMap msg =
+ case decode msg :: Maybe Object of
+ Just obj -> encode $ HashMap.mapWithKey f obj
+ Nothing -> error "Couldn't decode message"
+
+ where f :: T.Text -> Value -> Value
+ f "uri" (String uri) = String $ swap uri
+ f "changes" (Object obj) = Object $
+ HashMap.foldlWithKey' (\acc k v -> HashMap.insert (swap k) v acc)
+ HashMap.empty
+ obj
+ f _ x = g x
+
+ g :: Value -> Value
+ g (Array arr) = Array $ fmap g arr
+ g (Object obj) = Object $ HashMap.mapWithKey f obj
+ g x = x
- put :: ToJSON a => a -> IO ()
- put msg = modifyMVar_ msgs (return . (encode msg :))
+ swap origUri = let (Uri newUri) = fileMap ! Uri origUri in newUri
--- /dev/null
+{-# LANGUAGE OverloadedStrings #-}
+module Language.Haskell.LSP.Test.Parsing where
+
+import qualified Data.ByteString.Lazy.Char8 as B
+import System.IO
+
+getAllMessages :: Handle -> IO [B.ByteString]
+getAllMessages h = do
+ done <- hIsEOF h
+ if done
+ then return []
+ else do
+ msg <- getNextMessage h
+
+ (msg :) <$> getAllMessages h
+
+-- | Fetches the next message bytes based on
+-- the Content-Length header
+getNextMessage :: Handle -> IO B.ByteString
+getNextMessage h = do
+ headers <- getHeaders h
+ case read . init <$> lookup "Content-Length" headers of
+ Nothing -> error "Couldn't read Content-Length header"
+ Just size -> B.hGet h size
+
+addHeader :: B.ByteString -> B.ByteString
+addHeader content = B.concat
+ [ "Content-Length: "
+ , B.pack $ show $ B.length content
+ , "\r\n"
+ , "\r\n"
+ , content
+ ]
+
+getHeaders :: Handle -> IO [(String, String)]
+getHeaders h = do
+ l <- hGetLine h
+ let (name, val) = span (/= ':') l
+ if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
import Language.Haskell.LSP.Core
import qualified Language.Haskell.LSP.Types as LSP
import Data.Aeson
-import Data.List
import Data.Maybe
import Control.Lens
import Control.Monad
import System.Directory
import System.Process
import Language.Haskell.LSP.Test.Files
+import Language.Haskell.LSP.Test.Parsing
-- | Replays a recorded client output and
-- makes sure it matches up with an expected response.
null <- openFile "/dev/null" WriteMode
- (clientMsgs, fileMap) <- loadSwappedFiles emptyFileMap clientRecIn
+ (clientMsgs, fileMap) <- swapFiles emptyFileMap clientRecIn
tmpDir <- getTemporaryDirectory
(_, mappedClientRecIn) <- openTempFile tmpDir "clientRecInMapped"
- mapM_ (B.hPut mappedClientRecIn) $ map addHeader clientMsgs
+ mapM_ (B.hPut mappedClientRecIn . addHeader) clientMsgs
hSeek mappedClientRecIn AbsoluteSeek 0
-
- (expectedMsgs, _) <- loadSwappedFiles fileMap serverRecIn
+ (expectedMsgs, _) <- swapFiles fileMap serverRecIn
-- listen to server
forkIO $ runReaderT (listenServer expectedMsgs serverOut semas) didPass
listenServer [] _ _ = passSession
listenServer expectedMsgs h semas@(reqSema, rspSema) = do
msg <- lift $ getNextMessage h
- lift $ putStrLn $ "Remaining messages " ++ show (length expectedMsgs)
- if inRightOrder msg expectedMsgs
- then do
- whenResponse msg $ \res -> lift $ do
- putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
- putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
+ newExpectedMsgs <- case decode msg of
+ Just m -> request m
+ Nothing -> case decode msg of
+ Just m -> notification m
+ Nothing -> case decode msg of
+ Just m -> response m
+ Nothing -> failSession "Malformed message" >> return expectedMsgs
- whenRequest msg $ \req -> lift $ do
- putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
- putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
+ listenServer newExpectedMsgs h semas
- whenNotification msg $ \n -> lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
- unless (msg `elem` expectedMsgs) $ failSession "Got an unexpected message"
+ where jsonEqual :: (FromJSON a, Eq a) => a -> B.ByteString -> Bool
+ jsonEqual x y = Just x == decode y
- listenServer (delete msg expectedMsgs) h semas
- else
- let reason = "Got: " ++ show msg ++ "\n Expected: " ++ show (head (filter (not . isNotification) expectedMsgs))
- in failSession reason
+ deleteFirstJson _ [] = []
+ deleteFirstJson msg (x:xs)
+ | jsonEqual msg x = xs
+ | otherwise = x:deleteFirstJson msg xs
-isNotification :: B.ByteString -> Bool
-isNotification msg =
- isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
+ -- firstExpected :: Show a => a
+ firstExpected = head $ filter (not . isNotification) expectedMsgs
+
+ response :: LSP.ResponseMessage Value -> Session [B.ByteString]
+ response res = do
+ lift $ putStrLn $ "Got response for id " ++ show (res ^. LSP.id)
+
+ lift $ print res
+
+ checkOrder res
+
+ lift $ putMVar reqSema (res ^. LSP.id) -- unblock the handler waiting to send a request
+
+ return $ deleteFirstJson res expectedMsgs
+
+ request :: LSP.RequestMessage LSP.ServerMethod Value Value -> Session [B.ByteString]
+ request req = do
+ lift $ putStrLn $ "Got request for id " ++ show (req ^. LSP.id) ++ " " ++ show (req ^. LSP.method)
+
+ lift $ print req
-whenResponse :: B.ByteString -> (LSP.ResponseMessage Value -> Session ()) -> Session ()
-whenResponse msg f = case decode msg :: Maybe (LSP.ResponseMessage Value) of
- Just msg' -> when (isJust (msg' ^. LSP.result)) (f msg')
- _ -> return ()
+ checkOrder req
-whenRequest
- :: B.ByteString -> (LSP.RequestMessage Value Value Value -> Session ()) -> Session ()
-whenRequest msg =
- forM_ (decode msg :: (Maybe (LSP.RequestMessage Value Value Value)))
+ lift $ putMVar rspSema (req ^. LSP.id) -- unblock the handler waiting for a response
-whenNotification :: B.ByteString -> (LSP.NotificationMessage Value Value -> Session ()) -> Session ()
-whenNotification msg = forM_ (decode msg :: (Maybe (LSP.NotificationMessage Value Value)))
+ return $ deleteFirstJson req expectedMsgs
+
+ notification :: LSP.NotificationMessage LSP.ServerMethod Value -> Session [B.ByteString]
+ notification n = do
+ lift $ putStrLn $ "Got notification " ++ show (n ^. LSP.method)
+ lift $ print n
+ return $ deleteFirstJson n expectedMsgs
+
+ checkOrder msg = unless (inRightOrder msg expectedMsgs) $ do
+ let expected = decode firstExpected
+ _ = expected == Just msg -- make expected type same as res
+ failSession ("Out of order\nExpected\n" ++ show expected ++ "\nGot\n" ++ show msg ++ "\n")
+
+
+isNotification :: B.ByteString -> Bool
+isNotification msg =
+ isJust (decode msg :: Maybe (LSP.NotificationMessage Value Value))
-- TODO: QuickCheck tests?
-- | Checks wether or not the message appears in the right order
-- given RES1
-- @ N1 N3 N4 N5 XXXX RES1 @ False!
-- Order of requests and responses matter
-inRightOrder :: B.ByteString -> [B.ByteString] -> Bool
-inRightOrder _ [] = error "why is this empty"
-inRightOrder received msgs = received `elem` valid
- where
- valid = takeWhile canSkip msgs ++ firstNonSkip
- -- we don't care about the order of notifications
- canSkip = isNotification
- nonSkip = dropWhile canSkip msgs
- firstNonSkip | null nonSkip = []
- | otherwise = [head nonSkip]
-
-getAllMessages :: Handle -> IO [B.ByteString]
-getAllMessages h = do
- done <- hIsEOF h
- if done
- then return []
- else do
- msg <- getNextMessage h
+inRightOrder :: (FromJSON a, Eq a) => a -> [B.ByteString] -> Bool
- (msg :) <$> getAllMessages h
+inRightOrder _ [] = error "Why is this empty"
+-- inRightOrder (LSP.NotificationMessage _ _ _) _ = True
+
+inRightOrder received (expected:msgs)
+ | Just received == decode expected = True
+ | isNotification expected = inRightOrder received msgs
+ | otherwise = False
--- | Fetches the next message bytes based on
--- the Content-Length header
-getNextMessage :: Handle -> IO B.ByteString
-getNextMessage h = do
- headers <- getHeaders h
- case read . init <$> lookup "Content-Length" headers of
- Nothing -> error "Couldn't read Content-Length header"
- Just size -> B.hGet h size
handlers :: Handle -> (MVar LSP.LspIdRsp, MVar LSP.LspId) -> Handlers
handlers serverH (reqSema, rspSema) = def
else do
B.hPut serverH $ addHeader (encode msg)
putStrLn $ "Sent response to request id " ++ show id
-
-addHeader :: B.ByteString -> B.ByteString
-addHeader content = B.concat
- [ "Content-Length: "
- , B.pack $ show $ B.length content
- , "\r\n"
- , "\r\n"
- , content
- ]
-
-getHeaders :: Handle -> IO [(String, String)]
-getHeaders h = do
- l <- hGetLine h
- let (name, val) = span (/= ':') l
- if null val then return [] else ((name, drop 2 val) :) <$> getHeaders h
replay "test/recordings/renamePass/client.log"
"test/recordings/renamePass/server.log"
`shouldReturn` True
- it "fails a test" $
- replay "test/recordings/documentSymbolFail/client.log"
- "test/recordings/documentSymbolFail/server.log"
- `shouldReturn` False
+ -- it "fails a test" $
+ -- replay "test/recordings/documentSymbolFail/client.log"
+ -- "test/recordings/documentSymbolFail/server.log"
+ -- `shouldReturn` False
projects / lsp-test.git / commitdiff