Conduit.hs

{-# LANGUAGE
      LambdaCase
    , FlexibleInstances 
    , FlexibleContexts
    , DeriveGeneric  
    , OverloadedStrings 
    #-}
    
module Plugin.Internal.Conduit (
    inConduit, 
    ParseResult(..), 
    Res(..), 
    Req(..) 
    ) where 

import GHC.Generics
import Data.Text (Text)
import Control.Applicative  ((<|>))
import Control.Monad.State.Lazy
import Data.Aeson.Types hiding ( parse )
import Data.Aeson 
import Data.Aeson.Parser (json')
import Data.Conduit
import Data.ByteString (ByteString)
import Data.Attoparsec.ByteString as A
import Control.Monad

-- | Decode from bytestring into a JSON object. inspired by package json-rpc 
inConduit :: (Monad n, FromJSON a) => 
             ConduitT ByteString (ParseResult a) n ()
inConduit = evalStateT (l) Nothing  
    where 
    l = lift await >>= maybe (error "non") p
    p = r >=> h
    r i = get >>= \case
        Nothing -> pure $ parse json' i  
        Just k  -> pure $ k i 
    h = \case
        Fail{} -> lift (yield ParseErr) >> put Nothing >> l
        Partial i -> put (Just i) >> l
        Done rest v -> do 
            lift . yield . maybe InvalidReq Correct $ parseMaybe parseJSON v 
            if rest == "\n\n" then put Nothing >> l else p rest
            
data ParseResult x = 
    Correct !x |
    InvalidReq | 
    ParseErr 
    deriving (Show, Generic) 
instance ToJSON a => ToJSON (ParseResult a) where 
    toJSON = genericToJSON defaultOptions 
instance FromJSON a => FromJSON (ParseResult a) 

data Req = Req { 
   reqId :: Maybe Int,
   reqMethod :: Text,
   reqParams :: Value
   } deriving (Show) 
   
data Res =
    Res { resBody :: Value,
          resId :: Int }
    | ErrRes  {
          errMsg :: Text,
          errCode :: Int,
          errData :: Maybe Value,
          errId :: Int }
    deriving (Show, Generic)

instance FromJSON Req where
    parseJSON (Object v) = do
        version <- v .: "jsonrpc"
        guard (version == ("2.0" :: Text))
        Req <$> v .:?  "id"
            <*> v .:  "method"
            <*> (v .:? "params") .!= emptyArray
    parseJSON _ = mempty

instance FromJSON Res where
    parseJSON (Object v) = do
        version <- v .: "jsonrpc"
        guard (version == ("2.0" :: Text))
        fromResult <|> fromError
        where
            fromResult = Res <$> v .: "result" 
                             <*> v .: "id"
            fromError = do
                err <- v .: "error"
                ErrRes  <$> err .: "message"
                        <*> err .: "code"
                        <*> err .:? "data"
                        <*> v   .: "id"
    parseJSON (Array _) = mempty
    parseJSON _ = mempty

instance ToJSON (Req) where
    toJSON (Req i m ps ) =
        object [ "jsonrpc" .= ("2.0" :: Text)
               , "method"  .= m
               , "params"  .= ps
               , "id"      .= i ]

instance ToJSON Res where
    toJSON (Res x i) = object [ 
        "jsonrpc" .= ("2.0" :: Text),
        "result"  .= x,
        "id"      .= i ]

    toJSON (ErrRes msg c d i) = object [ 
        "jsonrpc" .= ("2.0" :: Text),
        "error"   .= object ["message" .= msg, 
                             "code" .= c,
                             "data" .= d 
                            ],
        "id"      .= i ]