{-# LANGUAGE CPP                 #-}
{-# LANGUAGE GADTs               #-}
{-# LANGUAGE MultiWayIf          #-}
{-# LANGUAGE BinaryLiterals      #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Language.Haskell.LSP.Control
  (
    run
  , runWith
  , runWithHandles
  ) where

import           Control.Concurrent
import           Control.Concurrent.STM.TChan
import           Control.Concurrent.STM.TVar
import           Control.Monad
import           Control.Monad.STM
import qualified Data.Aeson as J
import qualified Data.Attoparsec.ByteString as Attoparsec
import Data.Attoparsec.ByteString.Char8
import qualified Data.ByteString as BS
import Data.ByteString.Builder.Extra (defaultChunkSize)
import qualified Data.ByteString.Lazy as BSL
import qualified Data.ByteString.Lazy.Char8 as B
import           Data.Time.Clock
import           Data.Time.Format
#if __GLASGOW_HASKELL__ < 804
import           Data.Monoid
#endif
import           Language.Haskell.LSP.Capture
import qualified Language.Haskell.LSP.Core as Core
import           Language.Haskell.LSP.Messages
import           Language.Haskell.LSP.VFS
import           Language.Haskell.LSP.Utility
import           System.IO
import           System.FilePath

-- ---------------------------------------------------------------------

-- | Convenience function for 'runWithHandles stdin stdout'.
run :: (Show configs) => Core.InitializeCallbacks configs
                -- ^ function to be called once initialize has
                -- been received from the client. Further message
                -- processing will start only after this returns.
    -> Core.Handlers
    -> Core.Options
    -> Maybe FilePath
    -- ^ File to capture the session to.
    -> IO Int
run :: InitializeCallbacks configs
-> Handlers -> Options -> Maybe FilePath -> IO Int
run = Handle
-> Handle
-> InitializeCallbacks configs
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
forall config.
Show config =>
Handle
-> Handle
-> InitializeCallbacks config
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
runWithHandles Handle
stdin Handle
stdout

-- | Convenience function for 'runWith' using the specified handles.
runWithHandles :: (Show config) =>
       Handle
    -- ^ Handle to read client input from.
    -> Handle
    -- ^ Handle to write output to.
    -> Core.InitializeCallbacks config
    -> Core.Handlers
    -> Core.Options
    -> Maybe FilePath
    -> IO Int         -- exit code
runWithHandles :: Handle
-> Handle
-> InitializeCallbacks config
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
runWithHandles Handle
hin Handle
hout InitializeCallbacks config
initializeCallbacks Handlers
h Options
o Maybe FilePath
captureFp = do
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hin BufferMode
NoBuffering
  Handle -> TextEncoding -> IO ()
hSetEncoding  Handle
hin TextEncoding
utf8

  Handle -> BufferMode -> IO ()
hSetBuffering Handle
hout BufferMode
NoBuffering
  Handle -> TextEncoding -> IO ()
hSetEncoding  Handle
hout TextEncoding
utf8

  let
    clientIn :: IO ByteString
clientIn = Handle -> Int -> IO ByteString
BS.hGetSome Handle
hin Int
defaultChunkSize

    clientOut :: ByteString -> IO ()
clientOut ByteString
out = do
      Handle -> ByteString -> IO ()
BSL.hPut Handle
hout ByteString
out
      Handle -> IO ()
hFlush Handle
hout

  IO ByteString
-> (ByteString -> IO ())
-> InitializeCallbacks config
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
forall config.
Show config =>
IO ByteString
-> (ByteString -> IO ())
-> InitializeCallbacks config
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
runWith IO ByteString
clientIn ByteString -> IO ()
clientOut InitializeCallbacks config
initializeCallbacks Handlers
h Options
o Maybe FilePath
captureFp

-- | Starts listening and sending requests and responses
-- using the specified I/O.
runWith :: (Show config) =>
       IO BS.ByteString
    -- ^ Client input.
    -> (BSL.ByteString -> IO ())
    -- ^ Function to provide output to.
    -> Core.InitializeCallbacks config
    -> Core.Handlers
    -> Core.Options
    -> Maybe FilePath
    -> IO Int         -- exit code
runWith :: IO ByteString
-> (ByteString -> IO ())
-> InitializeCallbacks config
-> Handlers
-> Options
-> Maybe FilePath
-> IO Int
runWith IO ByteString
clientIn ByteString -> IO ()
clientOut InitializeCallbacks config
initializeCallbacks Handlers
h Options
o Maybe FilePath
captureFp = do

  ByteString -> IO ()
logm (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack FilePath
"\n\n\n\n\nhaskell-lsp:Starting up server ..."

  FilePath
timestamp <- TimeLocale -> FilePath -> UTCTime -> FilePath
forall t. FormatTime t => TimeLocale -> FilePath -> t -> FilePath
formatTime TimeLocale
defaultTimeLocale (Maybe FilePath -> FilePath
iso8601DateFormat (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
"%H-%M-%S")) (UTCTime -> FilePath) -> IO UTCTime -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO UTCTime
getCurrentTime
  let timestampCaptureFp :: Maybe FilePath
timestampCaptureFp = (FilePath -> FilePath) -> Maybe FilePath -> Maybe FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\FilePath
f -> FilePath -> FilePath
dropExtension FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
timestamp FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
takeExtension FilePath
f)
                                Maybe FilePath
captureFp
  CaptureContext
captureCtx <- IO CaptureContext
-> (FilePath -> IO CaptureContext)
-> Maybe FilePath
-> IO CaptureContext
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CaptureContext -> IO CaptureContext
forall (m :: * -> *) a. Monad m => a -> m a
return CaptureContext
noCapture) FilePath -> IO CaptureContext
captureToFile Maybe FilePath
timestampCaptureFp

  TChan FromServerMessage
cout <- STM (TChan FromServerMessage) -> IO (TChan FromServerMessage)
forall a. STM a -> IO a
atomically STM (TChan FromServerMessage)
forall a. STM (TChan a)
newTChan :: IO (TChan FromServerMessage)
  ThreadId
_rhpid <- IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ TChan FromServerMessage
-> (ByteString -> IO ()) -> CaptureContext -> IO ()
sendServer TChan FromServerMessage
cout ByteString -> IO ()
clientOut CaptureContext
captureCtx


  let sendFunc :: Core.SendFunc
      sendFunc :: SendFunc
sendFunc FromServerMessage
msg = STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TChan FromServerMessage -> FromServerMessage -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan TChan FromServerMessage
cout FromServerMessage
msg
  let lf :: a
lf = FilePath -> a
forall a. HasCallStack => FilePath -> a
error FilePath
"LifeCycle error, ClientCapabilities not set yet via initialize maessage"

  TVar Int
tvarId <- STM (TVar Int) -> IO (TVar Int)
forall a. STM a -> IO a
atomically (STM (TVar Int) -> IO (TVar Int))
-> STM (TVar Int) -> IO (TVar Int)
forall a b. (a -> b) -> a -> b
$ Int -> STM (TVar Int)
forall a. a -> STM (TVar a)
newTVar Int
0
  (VFS -> IO ()) -> IO ()
forall r. (VFS -> IO r) -> IO r
initVFS ((VFS -> IO ()) -> IO ()) -> (VFS -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \VFS
vfs -> do
    TVar (LanguageContextData config)
tvarDat <- STM (TVar (LanguageContextData config))
-> IO (TVar (LanguageContextData config))
forall a. STM a -> IO a
atomically (STM (TVar (LanguageContextData config))
 -> IO (TVar (LanguageContextData config)))
-> STM (TVar (LanguageContextData config))
-> IO (TVar (LanguageContextData config))
forall a b. (a -> b) -> a -> b
$ LanguageContextData config
-> STM (TVar (LanguageContextData config))
forall a. a -> STM (TVar a)
newTVar (LanguageContextData config
 -> STM (TVar (LanguageContextData config)))
-> LanguageContextData config
-> STM (TVar (LanguageContextData config))
forall a b. (a -> b) -> a -> b
$ Handlers
-> Options
-> LspFuncs config
-> TVar Int
-> SendFunc
-> CaptureContext
-> VFS
-> LanguageContextData config
forall config.
Handlers
-> Options
-> LspFuncs config
-> TVar Int
-> SendFunc
-> CaptureContext
-> VFS
-> LanguageContextData config
Core.defaultLanguageContextData Handlers
h Options
o LspFuncs config
forall a. a
lf TVar Int
tvarId SendFunc
sendFunc CaptureContext
captureCtx VFS
vfs

    IO ByteString
-> InitializeCallbacks config
-> TVar (LanguageContextData config)
-> IO ()
forall config.
Show config =>
IO ByteString
-> InitializeCallbacks config
-> TVar (LanguageContextData config)
-> IO ()
ioLoop IO ByteString
clientIn InitializeCallbacks config
initializeCallbacks TVar (LanguageContextData config)
tvarDat

  Int -> IO Int
forall (m :: * -> *) a. Monad m => a -> m a
return Int
1


-- ---------------------------------------------------------------------

ioLoop :: (Show config) => IO BS.ByteString
                   -> Core.InitializeCallbacks config
                   -> TVar (Core.LanguageContextData config)
                   -> IO ()
ioLoop :: IO ByteString
-> InitializeCallbacks config
-> TVar (LanguageContextData config)
-> IO ()
ioLoop IO ByteString
clientIn InitializeCallbacks config
dispatcherProc TVar (LanguageContextData config)
tvarDat =
  Result ByteString -> IO ()
go (Parser ByteString -> ByteString -> Result ByteString
forall a. Parser a -> ByteString -> Result a
parse Parser ByteString
parser ByteString
"")
  where
    go :: Result BS.ByteString -> IO ()
    go :: Result ByteString -> IO ()
go (Fail ByteString
_ [FilePath]
ctxs FilePath
err) = ByteString -> IO ()
logm (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack
      FilePath
"\nhaskell-lsp: Failed to parse message header:\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
" > " ((FilePath -> ByteString) -> [FilePath] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> ByteString
str2lbs [FilePath]
ctxs) ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
": " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<>
      FilePath -> ByteString
str2lbs FilePath
err ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\n exiting 1 ...\n"
    go (Partial ByteString -> Result ByteString
c) = do
      ByteString
bs <- IO ByteString
clientIn
      if ByteString -> Bool
BS.null ByteString
bs
        then ByteString -> IO ()
logm (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack FilePath
"\nhaskell-lsp:Got EOF, exiting 1 ...\n"
        else Result ByteString -> IO ()
go (ByteString -> Result ByteString
c ByteString
bs)
    go (Done ByteString
remainder ByteString
msg) = do
      ByteString -> IO ()
logm (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack FilePath
"---> " ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString
BSL.fromStrict ByteString
msg
      InitializeCallbacks config
-> TVar (LanguageContextData config) -> ByteString -> IO ()
forall config.
Show config =>
InitializeCallbacks config
-> TVar (LanguageContextData config) -> ByteString -> IO ()
Core.handleMessage InitializeCallbacks config
dispatcherProc TVar (LanguageContextData config)
tvarDat (ByteString -> ByteString
BSL.fromStrict ByteString
msg)
      Result ByteString -> IO ()
go (Parser ByteString -> ByteString -> Result ByteString
forall a. Parser a -> ByteString -> Result a
parse Parser ByteString
parser ByteString
remainder)
    parser :: Parser ByteString
parser = do
      ByteString
_ <- ByteString -> Parser ByteString
string ByteString
"Content-Length: "
      Int
len <- Parser Int
forall a. Integral a => Parser a
decimal
      ByteString
_ <- ByteString -> Parser ByteString
string ByteString
_TWO_CRLF
      Int -> Parser ByteString
Attoparsec.take Int
len

-- ---------------------------------------------------------------------

-- | Simple server to make sure all output is serialised
sendServer :: TChan FromServerMessage -> (BSL.ByteString -> IO ()) -> CaptureContext -> IO ()
sendServer :: TChan FromServerMessage
-> (ByteString -> IO ()) -> CaptureContext -> IO ()
sendServer TChan FromServerMessage
msgChan ByteString -> IO ()
clientOut CaptureContext
captureCtxt =
  IO () -> IO ()
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FromServerMessage
msg <- STM FromServerMessage -> IO FromServerMessage
forall a. STM a -> IO a
atomically (STM FromServerMessage -> IO FromServerMessage)
-> STM FromServerMessage -> IO FromServerMessage
forall a b. (a -> b) -> a -> b
$ TChan FromServerMessage -> STM FromServerMessage
forall a. TChan a -> STM a
readTChan TChan FromServerMessage
msgChan

    -- We need to make sure we only send over the content of the message,
    -- and no other tags/wrapper stuff
    let str :: ByteString
str = Value -> ByteString
forall a. ToJSON a => a -> ByteString
J.encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$
                Options -> FromServerMessage -> Value
forall a.
(Generic a, GToJSON' Value Zero (Rep a)) =>
Options -> a -> Value
J.genericToJSON (Options
J.defaultOptions { sumEncoding :: SumEncoding
J.sumEncoding = SumEncoding
J.UntaggedValue }) FromServerMessage
msg

    let out :: ByteString
out = [ByteString] -> ByteString
BSL.concat
                 [ FilePath -> ByteString
str2lbs (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Content-Length: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int64 -> FilePath
forall a. Show a => a -> FilePath
show (ByteString -> Int64
BSL.length ByteString
str)
                 , ByteString -> ByteString
BSL.fromStrict ByteString
_TWO_CRLF
                 , ByteString
str ]

    ByteString -> IO ()
clientOut ByteString
out
    ByteString -> IO ()
logm (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
B.pack FilePath
"<--2--" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
str

    FromServerMessage -> CaptureContext -> IO ()
captureFromServer FromServerMessage
msg CaptureContext
captureCtxt

-- |
--
--
_TWO_CRLF :: BS.ByteString
_TWO_CRLF :: ByteString
_TWO_CRLF = ByteString
"\r\n\r\n"