{-# LANGUAGE GADTs #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeInType #-}

module Language.LSP.Test.Decoding where

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

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 ClientToServer 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 'ClientToServer '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 TMessage m
mess -> case forall {t :: MessageKind} (m :: Method 'ClientToServer 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 'ClientToServer 'Request).
RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
acc (TMessage m
mess forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.id) SMethod m
m
      ClientNotOrReq m
IsClientEither -> case TMessage m
mess of
        NotMess TNotificationMessage ('Method_CustomMethod s)
_ -> RequestMap
acc
        ReqMess TRequestMessage ('Method_CustomMethod s)
msg -> forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall (m :: Method 'ClientToServer 'Request).
RequestMap -> LspId m -> SClientMethod m -> Maybe RequestMap
updateRequestMap RequestMap
acc (TRequestMessage ('Method_CustomMethod s)
msg forall s a. s -> Getting a s a -> a
^. forall s a. HasId s a => Lens' s a
L.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 'ClientToServer 'Request -> *).
LookupFunc 'ClientToServer 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 TMessage m
msg)) = (RequestMap
reqMap, forall (t :: MessageKind) (m :: Method 'ServerToClient t)
       (a :: Method 'ClientToServer 'Request -> *).
SMethod m -> TMessage m -> FromServerMessage' a
FromServerMess SMethod m
m TMessage m
msg)
  unP (Success (FromServerRsp (Pair SMethod m
m (Const RequestMap
newMap)) TResponseMessage m
msg)) = (RequestMap
newMap, forall (m :: Method 'ClientToServer 'Request)
       (a :: Method 'ClientToServer 'Request -> *).
a m -> TResponseMessage m -> FromServerMessage' a
FromServerRsp SMethod m
m TResponseMessage 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
-}