{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeInType #-}
module Language.LSP.Test.Decoding where

import           Prelude                 hiding ( id )
import           Data.Aeson
import           Data.Aeson.Types
import           Data.Foldable
import           Data.Functor.Product
import           Data.Functor.Const
import           Control.Exception
import           Control.Lens
import qualified Data.ByteString.Lazy.Char8    as B
import           Data.Maybe
import           System.IO
import           System.IO.Error
import           Language.LSP.Types
import           Language.LSP.Types.Lens
import           Language.LSP.Test.Exceptions

import Data.IxMap
import Data.Kind

-- | Fetches the next message bytes based on
-- the Content-Length header
getNextMessage :: Handle -> IO B.ByteString
getNextMessage :: Handle -> IO ByteString
getNextMessage Handle
h = do
  [(String, String)]
headers <- Handle -> IO [(String, String)]
getHeaders Handle
h
  case String -> Int
forall a. Read a => String -> a
read (String -> Int) -> (String -> String) -> String -> Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
forall a. [a] -> [a]
init (String -> Int) -> Maybe String -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
"Content-Length" [(String, String)]
headers of
    Maybe Int
Nothing   -> SessionException -> IO ByteString
forall a e. Exception e => e -> a
throw SessionException
NoContentLengthHeader
    Just Int
size -> Handle -> Int -> IO ByteString
B.hGet Handle
h Int
size

addHeader :: B.ByteString -> B.ByteString
addHeader :: ByteString -> ByteString
addHeader ByteString
content = [ByteString] -> ByteString
B.concat
  [ ByteString
"Content-Length: "
  , String -> ByteString
B.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ Int64 -> String
forall a. Show a => a -> String
show (Int64 -> String) -> Int64 -> String
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
B.length ByteString
content
  , ByteString
"\r\n"
  , ByteString
"\r\n"
  , ByteString
content
  ]

getHeaders :: Handle -> IO [(String, String)]
getHeaders :: Handle -> IO [(String, String)]
getHeaders Handle
h = do
  String
l <- IO String -> (IOError -> IO String) -> IO String
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Handle -> IO String
hGetLine Handle
h) IOError -> IO String
forall p. IOError -> p
eofHandler
  let (String
name, String
val) = (Char -> Bool) -> String -> (String, String)
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
':') String
l
  if String -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null String
val then [(String, String)] -> IO [(String, String)]
forall (m :: * -> *) a. Monad m => a -> m a
return [] else ((String
name, Int -> String -> String
forall a. Int -> [a] -> [a]
drop Int
2 String
val) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
:) ([(String, String)] -> [(String, String)])
-> IO [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO [(String, String)]
getHeaders Handle
h
  where eofHandler :: IOError -> p
eofHandler IOError
e
          | IOError -> Bool
isEOFError IOError
e = SessionException -> p
forall a e. Exception e => e -> a
throw SessionException
UnexpectedServerTermination
          | Bool
otherwise = IOError -> p
forall a e. Exception e => e -> a
throw IOError
e

type RequestMap = IxMap LspId (SMethod :: Method FromClient Request -> Type )

newRequestMap :: RequestMap
newRequestMap :: RequestMap
newRequestMap = RequestMap
forall a (k :: a -> *) (f :: a -> *). IxMap k f
emptyIxMap

updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
reqMap LspId m
id SClientMethod m
method = LspId m -> SClientMethod m -> RequestMap -> Maybe RequestMap
forall a (k :: a -> *) (m :: a) (f :: a -> *).
IxOrd k =>
k m -> f m -> IxMap k f -> Maybe (IxMap k f)
insertIxMap LspId m
id SClientMethod m
method RequestMap
reqMap

getRequestMap :: [FromClientMessage] -> RequestMap
getRequestMap :: [FromClientMessage] -> RequestMap
getRequestMap = (RequestMap -> FromClientMessage -> RequestMap)
-> RequestMap -> [FromClientMessage] -> RequestMap
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RequestMap -> FromClientMessage -> RequestMap
helper RequestMap
forall a (k :: a -> *) (f :: a -> *). IxMap k f
emptyIxMap
 where
  helper :: RequestMap -> FromClientMessage -> RequestMap
  helper :: RequestMap -> FromClientMessage -> RequestMap
helper RequestMap
acc FromClientMessage
msg = case FromClientMessage
msg of
    FromClientMess SMethod m
m Message m
mess -> case SMethod m -> ClientNotOrReq m
forall (t :: MethodType) (m :: Method 'FromClient t).
SClientMethod m -> ClientNotOrReq m
splitClientMethod SMethod m
m of
      ClientNotOrReq m
IsClientNot -> RequestMap
acc
      ClientNotOrReq m
IsClientReq -> Maybe RequestMap -> RequestMap
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe RequestMap -> RequestMap) -> Maybe RequestMap -> RequestMap
forall a b. (a -> b) -> a -> b
$ RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
forall (m :: Method 'FromClient 'Request).
RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
acc (Message m
RequestMessage m
mess RequestMessage m
-> Getting (LspId m) (RequestMessage m) (LspId m) -> LspId m
forall s a. s -> Getting a s a -> a
^. Getting (LspId m) (RequestMessage m) (LspId m)
forall s a. HasId s a => Lens' s a
id) SMethod m
SClientMethod m
m
      ClientNotOrReq m
IsClientEither -> case Message m
mess of
        NotMess _ -> RequestMap
acc
        ReqMess msg -> Maybe RequestMap -> RequestMap
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe RequestMap -> RequestMap) -> Maybe RequestMap -> RequestMap
forall a b. (a -> b) -> a -> b
$ RequestMap
-> LspId 'CustomMethod
-> SClientMethod 'CustomMethod
-> Maybe RequestMap
forall (m :: Method 'FromClient 'Request).
RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
acc (RequestMessage 'CustomMethod
msg RequestMessage 'CustomMethod
-> Getting
     (LspId 'CustomMethod)
     (RequestMessage 'CustomMethod)
     (LspId 'CustomMethod)
-> LspId 'CustomMethod
forall s a. s -> Getting a s a -> a
^. Getting
  (LspId 'CustomMethod)
  (RequestMessage 'CustomMethod)
  (LspId 'CustomMethod)
forall s a. HasId s a => Lens' s a
id) SMethod m
SClientMethod 'CustomMethod
m
    FromClientMessage
_ -> RequestMap
acc

decodeFromServerMsg :: RequestMap -> B.ByteString -> (RequestMap, FromServerMessage)
decodeFromServerMsg :: RequestMap -> ByteString -> (RequestMap, FromServerMessage)
decodeFromServerMsg RequestMap
reqMap ByteString
bytes = Result (FromServerMessage' (Product SMethod (Const RequestMap)))
-> (RequestMap, FromServerMessage)
unP (Result (FromServerMessage' (Product SMethod (Const RequestMap)))
 -> (RequestMap, FromServerMessage))
-> Result (FromServerMessage' (Product SMethod (Const RequestMap)))
-> (RequestMap, FromServerMessage)
forall a b. (a -> b) -> a -> b
$ (Value
 -> Parser
      (FromServerMessage' (Product SMethod (Const RequestMap))))
-> Value
-> Result (FromServerMessage' (Product SMethod (Const RequestMap)))
forall a b. (a -> Parser b) -> a -> Result b
parse Value
-> Parser (FromServerMessage' (Product SMethod (Const RequestMap)))
p Value
obj
  where obj :: Value
obj = Maybe Value -> Value
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Value -> Value) -> Maybe Value -> Value
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Value
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes :: Value
        p :: Value
-> Parser (FromServerMessage' (Product SMethod (Const RequestMap)))
p = LookupFunc 'FromClient (Product SMethod (Const RequestMap))
-> Value
-> Parser (FromServerMessage' (Product SMethod (Const RequestMap)))
forall (a :: Method 'FromClient 'Request -> *).
LookupFunc 'FromClient a -> Value -> Parser (FromServerMessage' a)
parseServerMessage (LookupFunc 'FromClient (Product SMethod (Const RequestMap))
 -> Value
 -> Parser
      (FromServerMessage' (Product SMethod (Const RequestMap))))
-> LookupFunc 'FromClient (Product SMethod (Const RequestMap))
-> Value
-> Parser (FromServerMessage' (Product SMethod (Const RequestMap)))
forall a b. (a -> b) -> a -> b
$ \LspId m
lid ->
          let (Maybe (SMethod m)
mm, RequestMap
newMap) = LspId m -> RequestMap -> (Maybe (SMethod m), RequestMap)
forall a (k :: a -> *) (m :: a) (f :: a -> *).
IxOrd k =>
k m -> IxMap k f -> (Maybe (f m), IxMap k f)
pickFromIxMap LspId m
lid RequestMap
reqMap
            in case Maybe (SMethod m)
mm of
              Maybe (SMethod m)
Nothing -> Maybe (SMethod m, Product SMethod (Const RequestMap) m)
forall a. Maybe a
Nothing
              Just SMethod m
m -> (SMethod m, Product SMethod (Const RequestMap) m)
-> Maybe (SMethod m, Product SMethod (Const RequestMap) m)
forall a. a -> Maybe a
Just ((SMethod m, Product SMethod (Const RequestMap) m)
 -> Maybe (SMethod m, Product SMethod (Const RequestMap) m))
-> (SMethod m, Product SMethod (Const RequestMap) m)
-> Maybe (SMethod m, Product SMethod (Const RequestMap) m)
forall a b. (a -> b) -> a -> b
$ (SMethod m
m, SMethod m
-> Const RequestMap m -> Product SMethod (Const RequestMap) m
forall k (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair SMethod m
m (RequestMap -> Const RequestMap m
forall k a (b :: k). a -> Const a b
Const RequestMap
newMap))
        unP :: Result (FromServerMessage' (Product SMethod (Const RequestMap)))
-> (RequestMap, FromServerMessage)
unP (Success (FromServerMess SMethod m
m Message m
msg)) = (RequestMap
reqMap, SMethod m -> Message m -> FromServerMessage
forall (t :: MethodType) (m :: Method 'FromServer t)
       (a :: Method 'FromClient 'Request -> *).
SMethod m -> Message m -> FromServerMessage' a
FromServerMess SMethod m
m Message m
msg)
        unP (Success (FromServerRsp (Pair m (Const newMap)) ResponseMessage m
msg)) = (RequestMap
newMap, SMethod m -> ResponseMessage m -> FromServerMessage
forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage m -> FromServerMessage' a
FromServerRsp SMethod m
m ResponseMessage m
msg)
        unP (Error String
e) = String -> (RequestMap, FromServerMessage)
forall a. HasCallStack => String -> a
error (String -> (RequestMap, FromServerMessage))
-> String -> (RequestMap, FromServerMessage)
forall a b. (a -> b) -> a -> b
$ String
"Error decoding " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall a. Show a => a -> String
show Value
obj String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
" :" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
e
        {-
        WorkspaceWorkspaceFolders      -> error "ReqWorkspaceFolders not supported yet"
        WorkspaceConfiguration         -> error "ReqWorkspaceConfiguration not supported yet"
        CustomServerMethod _
            | "id" `HM.member` obj && "method" `HM.member` obj -> ReqCustomServer $ fromJust $ decode bytes
            | "id" `HM.member` obj -> RspCustomServer $ fromJust $ decode bytes
            | otherwise -> NotCustomServer $ fromJust $ decode bytes

      Error e -> error e
      -}