{-# 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
  [([Char], [Char])]
headers <- Handle -> IO [([Char], [Char])]
getHeaders Handle
h
  case forall a. Read a => [Char] -> a
read forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
init forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"Content-Length" [([Char], [Char])]
headers of
    Maybe Int
Nothing   -> 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: "
  , [Char] -> ByteString
B.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show 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 [([Char], [Char])]
getHeaders Handle
h = do
  [Char]
l <- forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch (Handle -> IO [Char]
hGetLine Handle
h) forall {a}. IOError -> a
eofHandler
  let ([Char]
name, [Char]
val) = forall a. (a -> Bool) -> [a] -> ([a], [a])
span (forall a. Eq a => a -> a -> Bool
/= Char
':') [Char]
l
  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Char]
val then forall (m :: * -> *) a. Monad m => a -> m a
return [] else (([Char]
name, forall a. Int -> [a] -> [a]
drop Int
2 [Char]
val) forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handle -> IO [([Char], [Char])]
getHeaders Handle
h
  where eofHandler :: IOError -> a
eofHandler IOError
e
          | IOError -> Bool
isEOFError IOError
e = forall a e. Exception e => e -> a
throw SessionException
UnexpectedServerTermination
          | Bool
otherwise = forall a e. Exception e => e -> a
throw IOError
e

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

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

updateRequestMap :: RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap :: forall (m :: Method 'FromClient 'Request).
RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
reqMap LspId m
id SClientMethod m
method = 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 = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' RequestMap -> FromClientMessage -> RequestMap
helper 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 forall {t :: MethodType} (m :: Method 'FromClient t).
SClientMethod m -> ClientNotOrReq m
splitClientMethod SMethod m
m of
      ClientNotOrReq m
IsClientNot -> RequestMap
acc
      ClientNotOrReq m
IsClientReq -> forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
acc (Message m
mess forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
id) SMethod m
m
      ClientNotOrReq m
IsClientEither -> case Message m
mess of
        NotMess NotificationMessage 'CustomMethod
_ -> RequestMap
acc
        ReqMess RequestMessage 'CustomMethod
msg -> forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'FromClient 'Request).
RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
acc (RequestMessage 'CustomMethod
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
id) SMethod m
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 forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Parser b) -> a -> Result b
parse Value
-> Parser (FromServerMessage' (Product SMethod (Const RequestMap)))
p Value
obj
  where obj :: Value
obj = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
bytes :: Value
        p :: Value
-> Parser (FromServerMessage' (Product SMethod (Const RequestMap)))
p = forall (a :: Method 'FromClient 'Request -> *).
LookupFunc 'FromClient a -> Value -> Parser (FromServerMessage' a)
parseServerMessage forall a b. (a -> b) -> a -> b
$ \LspId m
lid ->
          let (Maybe (SMethod m)
mm, RequestMap
newMap) = 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 -> forall a. Maybe a
Nothing
              Just SMethod m
m -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (SMethod m
m, forall {k} (f :: k -> *) (g :: k -> *) (a :: k).
f a -> g a -> Product f g a
Pair SMethod m
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, 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 SMethod m
m (Const RequestMap
newMap)) ResponseMessage m
msg)) = (RequestMap
newMap, forall (m :: Method 'FromClient 'Request)
       (a :: Method 'FromClient 'Request -> *).
a m -> ResponseMessage m -> FromServerMessage' a
FromServerRsp SMethod m
m ResponseMessage m
msg)
        unP (Error [Char]
e) = forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Error decoding " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> [Char]
show Value
obj forall a. Semigroup a => a -> a -> a
<> [Char]
" :" forall a. Semigroup a => a -> a -> a
<> [Char]
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
      -}