src/Language/Haskell/LSP/Test/Session.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 {-# LANGUAGE FlexibleInstances #-}
   3
   4 module Language.Haskell.LSP.Test.Session
   5   ( Session
   6   , SessionConfig(..)
   7   , SessionContext(..)
   8   , SessionState(..)
   9   , MonadSessionConfig(..)
  10   , runSessionWithHandles
  11   , get
  12   , put
  13   , modify
  14   , modifyM
  15   , ask)
  16
  17 where
  18
  19 import Control.Concurrent hiding (yield)
  20 import Control.Exception
  21 import Control.Lens hiding (List)
  22 import Control.Monad
  23 import Control.Monad.IO.Class
  24 import Control.Monad.Except
  25 import Control.Monad.Trans.Reader (ReaderT, runReaderT)
  26 import qualified Control.Monad.Trans.Reader as Reader (ask)
  27 import Control.Monad.Trans.State (StateT, runStateT)
  28 import qualified Control.Monad.Trans.State as State (get, put, modify)
  29 import qualified Data.ByteString.Lazy.Char8 as B
  30 import Data.Aeson
  31 import Data.Conduit hiding (await)
  32 import Data.Conduit.Parser
  33 import Data.Default
  34 import Data.Foldable
  35 import Data.List
  36 import qualified Data.Map as Map
  37 import qualified Data.Text as T
  38 import qualified Data.Text.IO as T
  39 import qualified Data.HashMap.Strict as HashMap
  40 import Data.Maybe
  41 import Language.Haskell.LSP.Messages
  42 import Language.Haskell.LSP.TH.ClientCapabilities
  43 import Language.Haskell.LSP.Types hiding (error)
  44 import Language.Haskell.LSP.VFS
  45 import Language.Haskell.LSP.Test.Compat
  46 import Language.Haskell.LSP.Test.Decoding
  47 import Language.Haskell.LSP.Test.Exceptions
  48 import System.Directory
  49 import System.IO
  50
  51 -- | A session representing one instance of launching and connecting to a server.
  52 --
  53 -- You can send and receive messages to the server within 'Session' via 'getMessage',
  54 -- 'sendRequest' and 'sendNotification'.
  55 --
  56 -- @
  57 -- runSession \"path\/to\/root\/dir\" $ do
  58 --   docItem <- getDocItem "Desktop/simple.hs" "haskell"
  59 --   sendNotification TextDocumentDidOpen (DidOpenTextDocumentParams docItem)
  60 --   diagnostics <- getMessage :: Session PublishDiagnosticsNotification
  61 -- @
  62 type Session = ParserStateReader FromServerMessage SessionState SessionContext IO
  63
  64 -- | Stuff you can configure for a 'Session'.
  65 data SessionConfig = SessionConfig
  66   {
  67     capabilities :: ClientCapabilities -- ^ Specific capabilities the client should advertise. Default is yes to everything.
  68   , timeout :: Int -- ^ Maximum time to wait for a request in seconds. Defaults to 60.
  69   , logStdErr :: Bool -- ^ When True redirects the servers stderr output to haskell-lsp-test's stdout. Defaults to False
  70   }
  71
  72 instance Default SessionConfig where
  73   def = SessionConfig def 60 False
  74
  75 class Monad m => MonadSessionConfig m where
  76   sessionConfig :: m SessionConfig
  77
  78 instance Monad m => MonadSessionConfig (StateT SessionState (ReaderT SessionContext m)) where
  79   sessionConfig = config <$> lift Reader.ask
  80
  81 data SessionContext = SessionContext
  82   {
  83     serverIn :: Handle
  84   , rootDir :: FilePath
  85   , messageChan :: Chan FromServerMessage
  86   , requestMap :: MVar RequestMap
  87   , initRsp :: MVar InitializeResponse
  88   , config :: SessionConfig
  89   }
  90
  91 data SessionState = SessionState
  92   {
  93     curReqId :: LspId
  94   , vfs :: VFS
  95   }
  96
  97 type ParserStateReader a s r m = ConduitParser a (StateT s (ReaderT r m))
  98
  99 type SessionProcessor = ConduitM FromServerMessage FromServerMessage (StateT SessionState (ReaderT SessionContext IO))
 100
 101 runSession :: Chan FromServerMessage -> SessionProcessor () -> SessionContext -> SessionState -> Session a -> IO (a, SessionState)
 102 runSession chan preprocessor context state session = runReaderT (runStateT conduit state) context
 103   where conduit = runConduit $ chanSource chan .| preprocessor .| runConduitParser (catchError session handler)
 104         handler e@(Unexpected "ConduitParser.empty") = do
 105
 106           -- Horrible way to get last item in conduit:
 107           -- Add a fake message so we can tell when to stop
 108           liftIO $ writeChan chan (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing))
 109           x <- peek
 110           case x of
 111             Just x -> do
 112               lastMsg <- skipToEnd x
 113               name <- getParserName
 114               liftIO $ throw (UnexpectedMessageException (T.unpack name) lastMsg)
 115             Nothing -> throw e
 116
 117         handler e = throw e
 118
 119         skipToEnd x = do
 120           y <- peek
 121           case y of
 122             Just (RspShutdown (ResponseMessage "EMPTY" IdRspNull Nothing Nothing)) -> return x
 123             Just _ -> await >>= skipToEnd
 124             Nothing -> return x
 125
 126 get :: Monad m => ParserStateReader a s r m s
 127 get = lift State.get
 128
 129 put :: Monad m => s -> ParserStateReader a s r m ()
 130 put = lift . State.put
 131
 132 modify :: Monad m => (s -> s) -> ParserStateReader a s r m ()
 133 modify = lift . State.modify
 134
 135 modifyM :: Monad m => (s -> m s) -> ParserStateReader a s r m ()
 136 modifyM f = do
 137   old <- lift State.get
 138   new <- lift $ lift $ lift $ f old
 139   lift $ State.put new
 140
 141 ask :: Monad m => ParserStateReader a s r m r
 142 ask = lift $ lift Reader.ask
 143
 144 -- | An internal version of 'runSession' that allows for a custom handler to listen to the server.
 145 -- It also does not automatically send initialize and exit messages.
 146 runSessionWithHandles :: Handle -- ^ Server in
 147                       -> Handle -- ^ Server out
 148                       -> (Handle -> Session ()) -- ^ Server listener
 149                       -> SessionConfig
 150                       -> FilePath
 151                       -> Session a
 152                       -> IO a
 153 runSessionWithHandles serverIn serverOut serverHandler config rootDir session = do
 154   absRootDir <- canonicalizePath rootDir
 155
 156   hSetBuffering serverIn  NoBuffering
 157   hSetBuffering serverOut NoBuffering
 158
 159   reqMap <- newMVar newRequestMap
 160   messageChan <- newChan
 161   meaninglessChan <- newChan
 162   initRsp <- newEmptyMVar
 163
 164   let context = SessionContext serverIn absRootDir messageChan reqMap initRsp config
 165       initState = SessionState (IdInt 0) mempty
 166
 167   threadId <- forkIO $ void $ runSession meaninglessChan processor context initState (serverHandler serverOut)
 168   (result, _) <- runSession messageChan processor context initState session
 169
 170   killThread threadId
 171
 172   return result
 173
 174   where processor :: SessionProcessor ()
 175         processor = awaitForever $ \msg -> do
 176           processTextChanges msg
 177           yield msg
 178
 179
 180 processTextChanges :: FromServerMessage -> SessionProcessor ()
 181 processTextChanges (ReqApplyWorkspaceEdit r) = do
 182
 183   allChangeParams <- case r ^. params . edit . documentChanges of
 184     Just (List cs) -> do
 185       mapM_ (checkIfNeedsOpened . (^. textDocument . uri)) cs
 186       return $ map getParams cs
 187     Nothing -> case r ^. params . edit . changes of
 188       Just cs -> do
 189         mapM_ checkIfNeedsOpened (HashMap.keys cs)
 190         return $ concatMap (uncurry getChangeParams) (HashMap.toList cs)
 191       Nothing -> error "No changes!"
 192
 193   oldVFS <- vfs <$> lift State.get
 194   newVFS <- liftIO $ changeFromServerVFS oldVFS r
 195   lift $ State.modify (\s -> s { vfs = newVFS })
 196
 197   let groupedParams = groupBy (\a b -> (a ^. textDocument == b ^. textDocument)) allChangeParams
 198       mergedParams = map mergeParams groupedParams
 199
 200   ctx <- lift $ lift Reader.ask
 201
 202   -- TODO: Don't do this when replaying a session
 203   forM_ mergedParams $ \p -> do
 204     let h = serverIn ctx
 205         msg = NotificationMessage "2.0" TextDocumentDidChange p
 206     liftIO $ B.hPut h $ addHeader (encode msg)
 207
 208   where checkIfNeedsOpened uri = do
 209           oldVFS <- vfs <$> lift State.get
 210           ctx <- lift $ lift Reader.ask
 211
 212           -- if its not open, open it
 213           unless (uri `Map.member` oldVFS) $ do
 214             let fp = fromJust $ uriToFilePath uri
 215             contents <- liftIO $ T.readFile fp
 216             let item = TextDocumentItem (filePathToUri fp) "" 0 contents
 217                 msg = NotificationMessage "2.0" TextDocumentDidOpen (DidOpenTextDocumentParams item)
 218             liftIO $ B.hPut (serverIn ctx) $ addHeader (encode msg)
 219
 220             oldVFS <- vfs <$> lift State.get
 221             newVFS <- liftIO $ openVFS oldVFS msg
 222             lift $ State.modify (\s -> s { vfs = newVFS })
 223
 224         getParams (TextDocumentEdit docId (List edits)) =
 225           let changeEvents = map (\e -> TextDocumentContentChangeEvent (Just (e ^. range)) Nothing (e ^. newText)) edits
 226             in DidChangeTextDocumentParams docId (List changeEvents)
 227
 228         textDocumentVersions uri = map (VersionedTextDocumentIdentifier uri) [0..]
 229
 230         textDocumentEdits uri edits = map (\(v, e) -> TextDocumentEdit v (List [e])) $ zip (textDocumentVersions uri) edits
 231
 232         getChangeParams uri (List edits) = map getParams (textDocumentEdits uri (reverse edits))
 233
 234         mergeParams :: [DidChangeTextDocumentParams] -> DidChangeTextDocumentParams
 235         mergeParams params = let events = concat (toList (map (toList . (^. contentChanges)) params))
 236                               in DidChangeTextDocumentParams (head params ^. textDocument) (List events)
 237 processTextChanges _ = return ()