{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE MultiParamTypeClasses #-}



module Language.Explorer.Tools.Protocol where

import GHC.Generics
import Data.Monoid
import Data.Aeson
import Network.HTTP.Types.Status
import Network.HTTP.Types.Header (hContentType)
import Data.Maybe
import Control.Concurrent (forkFinally)
import qualified Control.Exception as E
import Control.Monad (unless, forever, void)
import qualified Data.ByteString.Lazy as S
import qualified Data.Attoparsec.ByteString.Lazy as AB
import qualified Data.Attoparsec.ByteString.Char8 as ABC
import Network.Socket hiding (recv)
import Network.Socket.ByteString.Lazy (recv, sendAll)
import Data.Scientific
import qualified Language.Explorer.Monadic as Ex
import Control.Monad.RWS.Lazy hiding (listen)
import Control.Monad.Trans.Except
import Data.List

type ExplorerParser p m c o = (Ex.Explorer p m c o, String -> Maybe p)
type ProcessResult = Either ErrorMessage Value

type EIP p m c o = RWST (String -> Maybe p) S.ByteString (Ex.Explorer p m c o) m

class ExplorerPostValue p c o where
    postExecute :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> o -> Value
    postExecute = \Explorer p m c o
_ Explorer p m c o
_ o
_ -> Value
Null
    postJump :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> Value
    postJump = \Explorer p m c o
_ Explorer p m c o
_ -> Value
Null
    postRevert :: Ex.Explorer p m c o -> Ex.Explorer p m c o -> [Ex.Ref] -> Value
    postRevert = \ Explorer p m c o
_ Explorer p m c o
_ [Ref]
_ -> Value
Null

data RequestMessage = RequestMessage {
    RequestMessage -> String
jsonrpc :: String,
    RequestMessage -> String
req_id :: String,
    RequestMessage -> String
method :: String,
    RequestMessage -> Maybe Value
params :: Maybe Value
} deriving (Ref -> RequestMessage -> ShowS
[RequestMessage] -> ShowS
RequestMessage -> String
(Ref -> RequestMessage -> ShowS)
-> (RequestMessage -> String)
-> ([RequestMessage] -> ShowS)
-> Show RequestMessage
forall a.
(Ref -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestMessage] -> ShowS
$cshowList :: [RequestMessage] -> ShowS
show :: RequestMessage -> String
$cshow :: RequestMessage -> String
showsPrec :: Ref -> RequestMessage -> ShowS
$cshowsPrec :: Ref -> RequestMessage -> ShowS
Show, (forall x. RequestMessage -> Rep RequestMessage x)
-> (forall x. Rep RequestMessage x -> RequestMessage)
-> Generic RequestMessage
forall x. Rep RequestMessage x -> RequestMessage
forall x. RequestMessage -> Rep RequestMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RequestMessage x -> RequestMessage
$cfrom :: forall x. RequestMessage -> Rep RequestMessage x
Generic)

instance ToJSON RequestMessage where
    toEncoding :: RequestMessage -> Encoding
toEncoding = Options -> RequestMessage -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

instance FromJSON RequestMessage where
    parseJSON :: Value -> Parser RequestMessage
parseJSON = String
-> (Object -> Parser RequestMessage)
-> Value
-> Parser RequestMessage
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RequestMessage" ((Object -> Parser RequestMessage)
 -> Value -> Parser RequestMessage)
-> (Object -> Parser RequestMessage)
-> Value
-> Parser RequestMessage
forall a b. (a -> b) -> a -> b
$ \Object
v -> String -> String -> String -> Maybe Value -> RequestMessage
RequestMessage
        (String -> String -> String -> Maybe Value -> RequestMessage)
-> Parser String
-> Parser (String -> String -> Maybe Value -> RequestMessage)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"jsonrpc"
        Parser (String -> String -> Maybe Value -> RequestMessage)
-> Parser String
-> Parser (String -> Maybe Value -> RequestMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"id"
        Parser (String -> Maybe Value -> RequestMessage)
-> Parser String -> Parser (Maybe Value -> RequestMessage)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"method"
        Parser (Maybe Value -> RequestMessage)
-> Parser (Maybe Value) -> Parser RequestMessage
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
v Object -> Text -> Parser (Maybe Value)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
.:? Text
"params"

data ResponseMessage = ResponseMessage {
    ResponseMessage -> String
res_id :: String,
    ResponseMessage -> ProcessResult
body :: ProcessResult
} deriving (Ref -> ResponseMessage -> ShowS
[ResponseMessage] -> ShowS
ResponseMessage -> String
(Ref -> ResponseMessage -> ShowS)
-> (ResponseMessage -> String)
-> ([ResponseMessage] -> ShowS)
-> Show ResponseMessage
forall a.
(Ref -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ResponseMessage] -> ShowS
$cshowList :: [ResponseMessage] -> ShowS
show :: ResponseMessage -> String
$cshow :: ResponseMessage -> String
showsPrec :: Ref -> ResponseMessage -> ShowS
$cshowsPrec :: Ref -> ResponseMessage -> ShowS
Show)

instance ToJSON ResponseMessage where
    toJSON :: ResponseMessage -> Value
toJSON (ResponseMessage String
res_id (Left ErrorMessage
e)) = [Pair] -> Value
object [Text
"id" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
res_id, Text
"error" Text -> ErrorMessage -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ErrorMessage
e]
    toJSON (ResponseMessage String
res_id (Right Value
res)) = [Pair] -> Value
object [Text
"id" Text -> String -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
res_id, Text
"result" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
res]

    toEncoding :: ResponseMessage -> Encoding
toEncoding (ResponseMessage String
res_id (Left ErrorMessage
e)) = Series -> Encoding
pairs (Text
"id" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
res_id Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"error" Text -> ErrorMessage -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= ErrorMessage
e)
    toEncoding (ResponseMessage String
res_id (Right Value
res)) = Series -> Encoding
pairs (Text
"id" Text -> String -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= String
res_id Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"result" Text -> Value -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
res)


data ErrorMessage = ErrorMessage {
    ErrorMessage -> Ref
code :: Int,
    ErrorMessage -> String
message :: String,
    ErrorMessage -> Maybe Value
error_data :: Maybe Value
} deriving (Ref -> ErrorMessage -> ShowS
[ErrorMessage] -> ShowS
ErrorMessage -> String
(Ref -> ErrorMessage -> ShowS)
-> (ErrorMessage -> String)
-> ([ErrorMessage] -> ShowS)
-> Show ErrorMessage
forall a.
(Ref -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ErrorMessage] -> ShowS
$cshowList :: [ErrorMessage] -> ShowS
show :: ErrorMessage -> String
$cshow :: ErrorMessage -> String
showsPrec :: Ref -> ErrorMessage -> ShowS
$cshowsPrec :: Ref -> ErrorMessage -> ShowS
Show, (forall x. ErrorMessage -> Rep ErrorMessage x)
-> (forall x. Rep ErrorMessage x -> ErrorMessage)
-> Generic ErrorMessage
forall x. Rep ErrorMessage x -> ErrorMessage
forall x. ErrorMessage -> Rep ErrorMessage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ErrorMessage x -> ErrorMessage
$cfrom :: forall x. ErrorMessage -> Rep ErrorMessage x
Generic)

instance ToJSON ErrorMessage where
    toEncoding :: ErrorMessage -> Encoding
toEncoding = Options -> ErrorMessage -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

instance FromJSON ErrorMessage
    -- No need to provide a parseJSON implementation.

-- instance Except ErrorMessage 
-- where
--     noMsg = ErrorMessage { code = 0, message = "", error_data = Nothing}
--     strMsg msg = ErrorMessage {code = 0, message = msg, error_data = Nothing }

data JumpParams = JumpParams {
    JumpParams -> Ref
jump_ref :: Int
}

instance FromJSON JumpParams where
    parseJSON :: Value -> Parser JumpParams
parseJSON = String
-> (Object -> Parser JumpParams) -> Value -> Parser JumpParams
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"JumpParams" ((Object -> Parser JumpParams) -> Value -> Parser JumpParams)
-> (Object -> Parser JumpParams) -> Value -> Parser JumpParams
forall a b. (a -> b) -> a -> b
$ \Object
v -> Ref -> JumpParams
JumpParams
        (Ref -> JumpParams) -> Parser Ref -> Parser JumpParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Ref
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"reference"

data JumpResult = JumpResult {
    JumpResult -> Value
jump_post :: Value
}

instance ToJSON JumpResult where 
    toJSON :: JumpResult -> Value
toJSON JumpResult
res = [Pair] -> Value
object [Text
"post" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= JumpResult -> Value
jump_post JumpResult
res]

data ExecuteParams = ExecuteParams {
    ExecuteParams -> String
program :: String
} deriving (Ref -> ExecuteParams -> ShowS
[ExecuteParams] -> ShowS
ExecuteParams -> String
(Ref -> ExecuteParams -> ShowS)
-> (ExecuteParams -> String)
-> ([ExecuteParams] -> ShowS)
-> Show ExecuteParams
forall a.
(Ref -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ExecuteParams] -> ShowS
$cshowList :: [ExecuteParams] -> ShowS
show :: ExecuteParams -> String
$cshow :: ExecuteParams -> String
showsPrec :: Ref -> ExecuteParams -> ShowS
$cshowsPrec :: Ref -> ExecuteParams -> ShowS
Show, (forall x. ExecuteParams -> Rep ExecuteParams x)
-> (forall x. Rep ExecuteParams x -> ExecuteParams)
-> Generic ExecuteParams
forall x. Rep ExecuteParams x -> ExecuteParams
forall x. ExecuteParams -> Rep ExecuteParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ExecuteParams x -> ExecuteParams
$cfrom :: forall x. ExecuteParams -> Rep ExecuteParams x
Generic)

instance FromJSON ExecuteParams

data ExecuteResult = ExecuteResult {
    ExecuteResult -> Ref
exec_ref :: Int,
    ExecuteResult -> Value
exec_out :: Value,
    ExecuteResult -> Value
exec_post :: Value
}

instance ToJSON ExecuteResult where
    toJSON :: ExecuteResult -> Value
toJSON (ExecuteResult Ref
ref Value
out Value
post) = [Pair] -> Value
object [Text
"reference" Text -> Ref -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Ref
ref, Text
"output" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
out, Text
"post" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
post]

    toEncoding :: ExecuteResult -> Encoding
toEncoding (ExecuteResult Ref
ref Value
out Value
post) = Series -> Encoding
pairs (Text
"reference" Text -> Ref -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Ref
ref Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"output" Text -> Value -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
out Series -> Series -> Series
forall a. Semigroup a => a -> a -> a
<> Text
"post" Text -> Value -> Series
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
post)

data RevertParams = RevertParams {
    RevertParams -> Ref
revert_ref :: Int
}

instance FromJSON RevertParams where
    parseJSON :: Value -> Parser RevertParams
parseJSON = String
-> (Object -> Parser RevertParams) -> Value -> Parser RevertParams
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"RevertParams" ((Object -> Parser RevertParams) -> Value -> Parser RevertParams)
-> (Object -> Parser RevertParams) -> Value -> Parser RevertParams
forall a b. (a -> b) -> a -> b
$ \Object
v -> Ref -> RevertParams
RevertParams
        (Ref -> RevertParams) -> Parser Ref -> Parser RevertParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Ref
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"reference"

data RevertResult = RevertResult {
    RevertResult -> [Ref]
revert_deleted :: [Ex.Ref],
    RevertResult -> Value
post_revert :: Value
}

instance ToJSON RevertResult where 
    toJSON :: RevertResult -> Value
toJSON RevertResult
res = [Pair] -> Value
object [Text
"deleted" Text -> [Ref] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RevertResult -> [Ref]
revert_deleted RevertResult
res, Text
"post" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= RevertResult -> Value
post_revert RevertResult
res]

data DerefParams = DerefParams {
    DerefParams -> Ref
deref_ref :: Int
}

instance FromJSON DerefParams where
    parseJSON :: Value -> Parser DerefParams
parseJSON = String
-> (Object -> Parser DerefParams) -> Value -> Parser DerefParams
forall a. String -> (Object -> Parser a) -> Value -> Parser a
withObject String
"DerefParams" ((Object -> Parser DerefParams) -> Value -> Parser DerefParams)
-> (Object -> Parser DerefParams) -> Value -> Parser DerefParams
forall a b. (a -> b) -> a -> b
$ \Object
v -> Ref -> DerefParams
DerefParams
        (Ref -> DerefParams) -> Parser Ref -> Parser DerefParams
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
v Object -> Text -> Parser Ref
forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"reference"


data TraceParams = TraceParams {
    TraceParams -> Ref
reference :: Int
} deriving ((forall x. TraceParams -> Rep TraceParams x)
-> (forall x. Rep TraceParams x -> TraceParams)
-> Generic TraceParams
forall x. Rep TraceParams x -> TraceParams
forall x. TraceParams -> Rep TraceParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TraceParams x -> TraceParams
$cfrom :: forall x. TraceParams -> Rep TraceParams x
Generic)

instance FromJSON TraceParams


data Edge = Edge {
    Edge -> Ref
source :: Int,
    Edge -> Ref
target :: Int,
    Edge -> EdgeLabel
label  :: EdgeLabel
} deriving ((forall x. Edge -> Rep Edge x)
-> (forall x. Rep Edge x -> Edge) -> Generic Edge
forall x. Rep Edge x -> Edge
forall x. Edge -> Rep Edge x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Edge x -> Edge
$cfrom :: forall x. Edge -> Rep Edge x
Generic)

instance ToJSON Edge where
    toEncoding :: Edge -> Encoding
toEncoding = Options -> Edge -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions


data EdgeLabel = EdgeLabel {
    EdgeLabel -> Value
program :: Value,
    EdgeLabel -> Value
mval :: Value
} deriving ((forall x. EdgeLabel -> Rep EdgeLabel x)
-> (forall x. Rep EdgeLabel x -> EdgeLabel) -> Generic EdgeLabel
forall x. Rep EdgeLabel x -> EdgeLabel
forall x. EdgeLabel -> Rep EdgeLabel x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep EdgeLabel x -> EdgeLabel
$cfrom :: forall x. EdgeLabel -> Rep EdgeLabel x
Generic)

instance ToJSON EdgeLabel where
    toEncoding :: EdgeLabel -> Encoding
toEncoding = Options -> EdgeLabel -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions


data ExecutionTree = ExecutionTree {
    ExecutionTree -> Ref
current :: Int,
    ExecutionTree -> [Ref]
references :: [Int],
    ExecutionTree -> [Edge]
edges :: [Edge]
} deriving ((forall x. ExecutionTree -> Rep ExecutionTree x)
-> (forall x. Rep ExecutionTree x -> ExecutionTree)
-> Generic ExecutionTree
forall x. Rep ExecutionTree x -> ExecutionTree
forall x. ExecutionTree -> Rep ExecutionTree x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ExecutionTree x -> ExecutionTree
$cfrom :: forall x. ExecutionTree -> Rep ExecutionTree x
Generic)

instance ToJSON ExecutionTree where
    toEncoding :: ExecutionTree -> Encoding
toEncoding = Options -> ExecutionTree -> Encoding
forall a.
(Generic a, GToJSON' Encoding Zero (Rep a)) =>
Options -> a -> Encoding
genericToEncoding Options
defaultOptions

data PathParams = PathParams {
    PathParams -> Ref
source :: Int,
    PathParams -> Ref
target :: Int
} deriving ((forall x. PathParams -> Rep PathParams x)
-> (forall x. Rep PathParams x -> PathParams) -> Generic PathParams
forall x. Rep PathParams x -> PathParams
forall x. PathParams -> Rep PathParams x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PathParams x -> PathParams
$cfrom :: forall x. PathParams -> Rep PathParams x
Generic)

instance FromJSON PathParams

parseErrorCode :: Ref
parseErrorCode = -Ref
32700
invalidRequestCode :: Integer
invalidRequestCode = -Integer
32600
methodNotFoundCode :: Ref
methodNotFoundCode = -Ref
32601
invalidParamsCode :: Ref
invalidParamsCode = -Ref
32602
internalErrorCode :: Integer
internalErrorCode = -Integer
32603

referenceNotInTreeCode :: Ref
referenceNotInTreeCode = Ref
1
referenceRevertInvalidCode :: Ref
referenceRevertInvalidCode = Ref
2
programParseErrorCode :: Ref
programParseErrorCode = Ref
3
pathNonExistingCode :: Ref
pathNonExistingCode = Ref
4



parseError :: ErrorMessage
parseError :: ErrorMessage
parseError = ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage {
    $sel:code:ErrorMessage :: Ref
code = Ref
parseErrorCode,
    $sel:message:ErrorMessage :: String
message = String
"Parse error",
    $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing
}

methodNotFound :: ErrorMessage
methodNotFound :: ErrorMessage
methodNotFound = ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage {
    $sel:code:ErrorMessage :: Ref
code = Ref
methodNotFoundCode,
    $sel:message:ErrorMessage :: String
message = String
"Method not found",
    $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing
}

invalidParams :: ErrorMessage
invalidParams :: ErrorMessage
invalidParams = ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage {
    $sel:code:ErrorMessage :: Ref
code = Ref
invalidParamsCode,
    $sel:message:ErrorMessage :: String
message = String
"Invalid method parameter(s)",
    $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing
}

ensureParameter :: Monad m => Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
ensureParameter :: Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
ensureParameter Maybe Value
Nothing = ErrorMessage -> ExceptT ErrorMessage (EIP p m c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
invalidParams
ensureParameter (Just Value
v) = Value -> ExceptT ErrorMessage (EIP p m c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
v

fromResult :: Monad m => Result a -> Value -> ExceptT ErrorMessage (EIP p m c o) Value
fromResult :: Result a -> Value -> ExceptT ErrorMessage (EIP p m c o) Value
fromResult Result a
res Value
onSuccess = case Result a
res of
    (Error String
e) -> ErrorMessage -> ExceptT ErrorMessage (EIP p m c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
invalidParams
    (Success a
v) -> Value -> ExceptT ErrorMessage (EIP p m c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return Value
onSuccess

jump :: (Monad m, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p m c o) Value
jump :: Value -> ExceptT ErrorMessage (EIP p m c o) Value
jump Value
v = case (Value -> Result JumpParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
v) :: Result JumpParams of
    (Error String
e) -> ErrorMessage -> ExceptT ErrorMessage (EIP p m c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
invalidParams
    (Success JumpParams
v') -> do
        Explorer p m c o
ex <- EIP p m c o (Explorer p m c o)
-> ExceptT ErrorMessage (EIP p m c o) (Explorer p m c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p m c o (Explorer p m c o)
 -> ExceptT ErrorMessage (EIP p m c o) (Explorer p m c o))
-> EIP p m c o (Explorer p m c o)
-> ExceptT ErrorMessage (EIP p m c o) (Explorer p m c o)
forall a b. (a -> b) -> a -> b
$ EIP p m c o (Explorer p m c o)
forall s (m :: * -> *). MonadState s m => m s
get
        case Ref -> Explorer p m c o -> Maybe (Explorer p m c o)
forall p (m :: * -> *) c o.
Ref -> Explorer p m c o -> Maybe (Explorer p m c o)
Ex.jump (JumpParams -> Ref
jump_ref JumpParams
v') Explorer p m c o
ex of
            Just Explorer p m c o
ex' -> do
                EIP p m c o () -> ExceptT ErrorMessage (EIP p m c o) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p m c o () -> ExceptT ErrorMessage (EIP p m c o) ())
-> EIP p m c o () -> ExceptT ErrorMessage (EIP p m c o) ()
forall a b. (a -> b) -> a -> b
$ Explorer p m c o -> EIP p m c o ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (Explorer p m c o -> EIP p m c o ())
-> Explorer p m c o -> EIP p m c o ()
forall a b. (a -> b) -> a -> b
$ Explorer p m c o
ex'
                Value -> ExceptT ErrorMessage (EIP p m c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p m c o) Value)
-> (Value -> Value)
-> Value
-> ExceptT ErrorMessage (EIP p m c o) Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. JumpResult -> Value
forall a. ToJSON a => a -> Value
toJSON (JumpResult -> Value) -> (Value -> JumpResult) -> Value -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> JumpResult
JumpResult (Value -> ExceptT ErrorMessage (EIP p m c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p m c o) Value
forall a b. (a -> b) -> a -> b
$ Explorer p m c o -> Explorer p m c o -> Value
forall p c o (m :: * -> *).
ExplorerPostValue p c o =>
Explorer p m c o -> Explorer p m c o -> Value
postJump Explorer p m c o
ex Explorer p m c o
ex'
            Maybe (Explorer p m c o)
Nothing -> ErrorMessage -> ExceptT ErrorMessage (EIP p m c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage { $sel:code:ErrorMessage :: Ref
code = Ref
referenceNotInTreeCode, $sel:message:ErrorMessage :: String
message = String
"", $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing }

execute :: (Eq o, Monoid o, ToJSON o, Eq p, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
execute :: Value -> ExceptT ErrorMessage (EIP p IO c o) Value
execute Value
v = case (Value -> Result ExecuteParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
v) :: Result ExecuteParams of
    (Error String
e) -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
invalidParams
    (Success ExecuteParams
v') -> do
        String -> Maybe p
parser <- EIP p IO c o (String -> Maybe p)
-> ExceptT ErrorMessage (EIP p IO c o) (String -> Maybe p)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (String -> Maybe p)
 -> ExceptT ErrorMessage (EIP p IO c o) (String -> Maybe p))
-> EIP p IO c o (String -> Maybe p)
-> ExceptT ErrorMessage (EIP p IO c o) (String -> Maybe p)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (String -> Maybe p)
forall r (m :: * -> *). MonadReader r m => m r
ask
        let pl :: Maybe p
pl = String -> Maybe p
parser (String -> Maybe p) -> String -> Maybe p
forall a b. (a -> b) -> a -> b
$ ExecuteParams -> String
program (ExecuteParams
v' :: ExecuteParams)
        case Maybe p
pl of
            Just p
prog -> do
                Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
                (Explorer p IO c o
ex', o
output) <- IO (Explorer p IO c o, o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o, o)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Explorer p IO c o, o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o, o))
-> IO (Explorer p IO c o, o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o, o)
forall a b. (a -> b) -> a -> b
$ p -> Explorer p IO c o -> IO (Explorer p IO c o, o)
forall p (m :: * -> *) c o.
Language p m c o =>
p -> Explorer p m c o -> m (Explorer p m c o, o)
Ex.execute p
prog Explorer p IO c o
ex
                EIP p IO c o () -> ExceptT ErrorMessage (EIP p IO c o) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o () -> ExceptT ErrorMessage (EIP p IO c o) ())
-> EIP p IO c o () -> ExceptT ErrorMessage (EIP p IO c o) ()
forall a b. (a -> b) -> a -> b
$ Explorer p IO c o -> EIP p IO c o ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Explorer p IO c o
ex'
                Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ ExecuteResult -> Value
forall a. ToJSON a => a -> Value
toJSON (ExecuteResult -> Value) -> ExecuteResult -> Value
forall a b. (a -> b) -> a -> b
$ ExecuteResult :: Ref -> Value -> Value -> ExecuteResult
ExecuteResult { $sel:exec_ref:ExecuteResult :: Ref
exec_ref = Explorer p IO c o -> Ref
forall programs (m :: * -> *) configs output.
Explorer programs m configs output -> Ref
Ex.currRef Explorer p IO c o
ex', $sel:exec_out:ExecuteResult :: Value
exec_out = o -> Value
forall a. ToJSON a => a -> Value
toJSON o
output, $sel:exec_post:ExecuteResult :: Value
exec_post = Explorer p IO c o -> Explorer p IO c o -> o -> Value
forall p c o (m :: * -> *).
ExplorerPostValue p c o =>
Explorer p m c o -> Explorer p m c o -> o -> Value
postExecute Explorer p IO c o
ex Explorer p IO c o
ex' o
output }
            Maybe p
Nothing -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage { $sel:code:ErrorMessage :: Ref
code = Ref
programParseErrorCode, $sel:message:ErrorMessage :: String
message = String
"", $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing }

allRefs :: Ex.Explorer p IO c o -> [(Ex.Ref, c)]
allRefs :: Explorer p IO c o -> [(Ref, c)]
allRefs Explorer p IO c o
ex = [(Ref, c)]
refs
    where
        ((Ref, c)
_, [(Ref, c)]
refs, [((Ref, c), (p, o), (Ref, c))]
_) = Explorer p IO c o
-> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])
forall p (m :: * -> *) c o.
Explorer p m c o
-> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])
Ex.executionGraph Explorer p IO c o
ex


revert :: (Eq o, Monoid o, Eq p, ExplorerPostValue p c o) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
revert :: Value -> ExceptT ErrorMessage (EIP p IO c o) Value
revert Value
v = case (Value -> Result RevertParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
v) :: Result RevertParams of
    (Error String
e) -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
invalidParams
    (Success RevertParams
v) -> do
        Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
        case Ref -> Explorer p IO c o -> Maybe (Explorer p IO c o)
forall p (m :: * -> *) c o.
Ref -> Explorer p m c o -> Maybe (Explorer p m c o)
Ex.revert (RevertParams -> Ref
revert_ref RevertParams
v) Explorer p IO c o
ex of
            Just Explorer p IO c o
ex' -> do
                EIP p IO c o () -> ExceptT ErrorMessage (EIP p IO c o) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o () -> ExceptT ErrorMessage (EIP p IO c o) ())
-> EIP p IO c o () -> ExceptT ErrorMessage (EIP p IO c o) ()
forall a b. (a -> b) -> a -> b
$ Explorer p IO c o -> EIP p IO c o ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put Explorer p IO c o
ex'
                Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ RevertResult -> Value
forall a. ToJSON a => a -> Value
toJSON (RevertResult -> Value) -> RevertResult -> Value
forall a b. (a -> b) -> a -> b
$ RevertResult :: [Ref] -> Value -> RevertResult
RevertResult { $sel:revert_deleted:RevertResult :: [Ref]
revert_deleted = [Ref]
deleted, $sel:post_revert:RevertResult :: Value
post_revert = Explorer p IO c o -> Explorer p IO c o -> [Ref] -> Value
forall p c o (m :: * -> *).
ExplorerPostValue p c o =>
Explorer p m c o -> Explorer p m c o -> [Ref] -> Value
postRevert Explorer p IO c o
ex Explorer p IO c o
ex' [Ref]
deleted}
                where 
                    refs :: [Ref]
refs = ((Ref, c) -> Ref) -> [(Ref, c)] -> [Ref]
forall a b. (a -> b) -> [a] -> [b]
map (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Explorer p IO c o -> [(Ref, c)]
forall p c o. Explorer p IO c o -> [(Ref, c)]
allRefs Explorer p IO c o
ex)
                    refs' :: [Ref]
refs' = ((Ref, c) -> Ref) -> [(Ref, c)] -> [Ref]
forall a b. (a -> b) -> [a] -> [b]
map (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Explorer p IO c o -> [(Ref, c)]
forall p c o. Explorer p IO c o -> [(Ref, c)]
allRefs Explorer p IO c o
ex')
                    deleted :: [Ref]
deleted = ([Ref]
refs [Ref] -> [Ref] -> [Ref]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Ref]
refs')
            Maybe (Explorer p IO c o)
Nothing -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage { $sel:code:ErrorMessage :: Ref
code = Ref
referenceRevertInvalidCode, $sel:message:ErrorMessage :: String
message = String
"", $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing }

deref :: (Eq o, Monoid o, Eq p, ToJSON c) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
deref :: Value -> ExceptT ErrorMessage (EIP p IO c o) Value
deref Value
v = case (Value -> Result DerefParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
v) :: Result DerefParams of
    (Error String
e) -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
invalidParams
    (Success DerefParams
v) -> do
        Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
        case Explorer p IO c o -> Ref -> Maybe c
forall p (m :: * -> *) c o. Explorer p m c o -> Ref -> Maybe c
Ex.deref Explorer p IO c o
ex (DerefParams -> Ref
deref_ref DerefParams
v) of
            (Just c
conf) -> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ c -> Value
forall a. ToJSON a => a -> Value
toJSON c
conf
            Maybe c
Nothing -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage { $sel:code:ErrorMessage :: Ref
code = Ref
referenceNotInTreeCode, $sel:message:ErrorMessage :: String
message = String
"", $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing}

executionTree :: (ToJSON o, ToJSON p) => ExceptT ErrorMessage (EIP p IO c o) Value
executionTree :: ExceptT ErrorMessage (EIP p IO c o) Value
executionTree = do
    Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
    let ((Ref, c)
curr, [(Ref, c)]
nodes, [((Ref, c), (p, o), (Ref, c))]
edges) = Explorer p IO c o
-> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])
forall p (m :: * -> *) c o.
Explorer p m c o
-> ((Ref, c), [(Ref, c)], [((Ref, c), (p, o), (Ref, c))])
Ex.executionGraph Explorer p IO c o
ex
    Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ ExecutionTree -> Value
forall a. ToJSON a => a -> Value
toJSON (ExecutionTree -> Value) -> ExecutionTree -> Value
forall a b. (a -> b) -> a -> b
$ ExecutionTree :: Ref -> [Ref] -> [Edge] -> ExecutionTree
ExecutionTree 
        { $sel:current:ExecutionTree :: Ref
current = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
curr
        , $sel:references:ExecutionTree :: [Ref]
references = ((Ref, c) -> Ref) -> [(Ref, c)] -> [Ref]
forall a b. (a -> b) -> [a] -> [b]
map (Ref, c) -> Ref
forall a b. (a, b) -> a
fst [(Ref, c)]
nodes
        , $sel:edges:ExecutionTree :: [Edge]
edges = (((Ref, c), (p, o), (Ref, c)) -> Edge)
-> [((Ref, c), (p, o), (Ref, c))] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (\((Ref, c)
s, (p
p, o
o), (Ref, c)
t) -> Edge :: Ref -> Ref -> EdgeLabel -> Edge
Edge { $sel:source:Edge :: Ref
source = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
s
        , $sel:label:Edge :: EdgeLabel
label = EdgeLabel :: Value -> Value -> EdgeLabel
EdgeLabel { $sel:program:EdgeLabel :: Value
program = p -> Value
forall a. ToJSON a => a -> Value
toJSON p
p, $sel:mval:EdgeLabel :: Value
mval = o -> Value
forall a. ToJSON a => a -> Value
toJSON o
o}
        , $sel:target:Edge :: Ref
target = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
t} ) [((Ref, c), (p, o), (Ref, c))]
edges}

getCurrentReference :: ExceptT ErrorMessage (EIP p IO c o) Value
getCurrentReference :: ExceptT ErrorMessage (EIP p IO c o) Value
getCurrentReference = do
    Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
    Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ Ref -> Value
forall a. ToJSON a => a -> Value
toJSON (Ref -> Value) -> Ref -> Value
forall a b. (a -> b) -> a -> b
$ Explorer p IO c o -> Ref
forall programs (m :: * -> *) configs output.
Explorer programs m configs output -> Ref
Ex.currRef Explorer p IO c o
ex

getAllReferences :: ExceptT ErrorMessage (EIP p IO c o) Value
getAllReferences :: ExceptT ErrorMessage (EIP p IO c o) Value
getAllReferences = do
    Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
    Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ [Ref] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Ref] -> Value) -> [Ref] -> Value
forall a b. (a -> b) -> a -> b
$ ((Ref, c) -> Ref) -> [(Ref, c)] -> [Ref]
forall a b. (a -> b) -> [a] -> [b]
map (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Explorer p IO c o -> [(Ref, c)]
forall p c o. Explorer p IO c o -> [(Ref, c)]
allRefs Explorer p IO c o
ex)

getTrace :: (ToJSON p, ToJSON o) => Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
getTrace :: Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
getTrace (Just Value
r) = case (Value -> Result TraceParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
r) :: Result TraceParams of
    (Error String
e) -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
invalidParams
    (Success TraceParams
v) -> do
        Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
        let path :: [((Ref, c), (p, o), (Ref, c))]
path = Explorer p IO c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]
forall p (m :: * -> *) c o.
Explorer p m c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]
Ex.getPathFromTo Explorer p IO c o
ex Ref
1 (TraceParams -> Ref
reference (TraceParams
v :: TraceParams)) -- Fix hardcode 1(it's initialRef).
        Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ [Edge] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Edge] -> Value) -> [Edge] -> Value
forall a b. (a -> b) -> a -> b
$ (((Ref, c), (p, o), (Ref, c)) -> Edge)
-> [((Ref, c), (p, o), (Ref, c))] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (\((Ref, c)
s, (p
p, o
o), (Ref, c)
t) -> Edge :: Ref -> Ref -> EdgeLabel -> Edge
Edge { $sel:source:Edge :: Ref
source = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
s, $sel:target:Edge :: Ref
target = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
t, $sel:label:Edge :: EdgeLabel
label = EdgeLabel :: Value -> Value -> EdgeLabel
EdgeLabel { $sel:program:EdgeLabel :: Value
program = p -> Value
forall a. ToJSON a => a -> Value
toJSON p
p, $sel:mval:EdgeLabel :: Value
mval = o -> Value
forall a. ToJSON a => a -> Value
toJSON o
o} }) [((Ref, c), (p, o), (Ref, c))]
path
getTrace Maybe Value
Nothing = do
    Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
    let trace :: [((Ref, c), (p, o), (Ref, c))]
trace = Explorer p IO c o -> [((Ref, c), (p, o), (Ref, c))]
forall p (m :: * -> *) c o.
Explorer p m c o -> [((Ref, c), (p, o), (Ref, c))]
Ex.getTrace Explorer p IO c o
ex
    Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ [Edge] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Edge] -> Value) -> [Edge] -> Value
forall a b. (a -> b) -> a -> b
$ (((Ref, c), (p, o), (Ref, c)) -> Edge)
-> [((Ref, c), (p, o), (Ref, c))] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (\((Ref, c)
s, (p
p, o
o), (Ref, c)
t) -> Edge :: Ref -> Ref -> EdgeLabel -> Edge
Edge { $sel:source:Edge :: Ref
source = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
s, $sel:target:Edge :: Ref
target = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
t, $sel:label:Edge :: EdgeLabel
label = EdgeLabel :: Value -> Value -> EdgeLabel
EdgeLabel { $sel:program:EdgeLabel :: Value
program = p -> Value
forall a. ToJSON a => a -> Value
toJSON p
p, $sel:mval:EdgeLabel :: Value
mval = o -> Value
forall a. ToJSON a => a -> Value
toJSON o
o} }) [((Ref, c), (p, o), (Ref, c))]
trace

getPath :: (ToJSON o, ToJSON p) => Value -> ExceptT ErrorMessage (EIP p IO c o) Value
getPath :: Value -> ExceptT ErrorMessage (EIP p IO c o) Value
getPath Value
val = case (Value -> Result PathParams
forall a. FromJSON a => Value -> Result a
fromJSON Value
val) :: Result PathParams of
    (Error String
e) -> ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage :: Ref -> String -> Maybe Value -> ErrorMessage
ErrorMessage { $sel:code:ErrorMessage :: Ref
code = Ref
pathNonExistingCode, $sel:message:ErrorMessage :: String
message = String
"", $sel:error_data:ErrorMessage :: Maybe Value
error_data = Maybe Value
forall a. Maybe a
Nothing}
    (Success PathParams
v) -> do
        Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
        let path :: [((Ref, c), (p, o), (Ref, c))]
path = Explorer p IO c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]
forall p (m :: * -> *) c o.
Explorer p m c o -> Ref -> Ref -> [((Ref, c), (p, o), (Ref, c))]
Ex.getPathFromTo Explorer p IO c o
ex (PathParams -> Ref
source (PathParams
v :: PathParams)) (PathParams -> Ref
target (PathParams
v :: PathParams))
        Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ [Edge] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Edge] -> Value) -> [Edge] -> Value
forall a b. (a -> b) -> a -> b
$ (((Ref, c), (p, o), (Ref, c)) -> Edge)
-> [((Ref, c), (p, o), (Ref, c))] -> [Edge]
forall a b. (a -> b) -> [a] -> [b]
map (\((Ref, c)
s, (p
p, o
o), (Ref, c)
t) -> Edge :: Ref -> Ref -> EdgeLabel -> Edge
Edge { $sel:source:Edge :: Ref
source = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
s, $sel:target:Edge :: Ref
target = (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Ref, c)
t, $sel:label:Edge :: EdgeLabel
label = EdgeLabel :: Value -> Value -> EdgeLabel
EdgeLabel { $sel:program:EdgeLabel :: Value
program = p -> Value
forall a. ToJSON a => a -> Value
toJSON p
p, $sel:mval:EdgeLabel :: Value
mval = o -> Value
forall a. ToJSON a => a -> Value
toJSON o
o} }) [((Ref, c), (p, o), (Ref, c))]
path

getLeaves :: ExceptT ErrorMessage (EIP p IO c o) Value
getLeaves :: ExceptT ErrorMessage (EIP p IO c o) Value
getLeaves = do
    Explorer p IO c o
ex <- EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (EIP p IO c o (Explorer p IO c o)
 -> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o))
-> EIP p IO c o (Explorer p IO c o)
-> ExceptT ErrorMessage (EIP p IO c o) (Explorer p IO c o)
forall a b. (a -> b) -> a -> b
$ EIP p IO c o (Explorer p IO c o)
forall s (m :: * -> *). MonadState s m => m s
get
    Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a. Monad m => a -> m a
return (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall a b. (a -> b) -> a -> b
$ [Ref] -> Value
forall a. ToJSON a => a -> Value
toJSON ([Ref] -> Value) -> [Ref] -> Value
forall a b. (a -> b) -> a -> b
$ ((Ref, c) -> Ref) -> [(Ref, c)] -> [Ref]
forall a b. (a -> b) -> [a] -> [b]
map (Ref, c) -> Ref
forall a b. (a, b) -> a
fst (Explorer p IO c o -> [(Ref, c)]
forall p (m :: * -> *) c o. Explorer p m c o -> [(Ref, c)]
Ex.leaves Explorer p IO c o
ex)

methodDispatch :: (Eq o, Monoid o, ToJSON o, ToJSON p, Eq p, ToJSON c, ExplorerPostValue p c o) => String -> Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
methodDispatch :: String -> Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
methodDispatch String
"jump" Maybe Value
mval = Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) p c o.
Monad m =>
Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
ensureParameter Maybe Value
mval ExceptT ErrorMessage (EIP p IO c o) Value
-> (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) p c o.
(Monad m, ExplorerPostValue p c o) =>
Value -> ExceptT ErrorMessage (EIP p m c o) Value
jump
methodDispatch String
"execute" Maybe Value
mval = Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) p c o.
Monad m =>
Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
ensureParameter Maybe Value
mval ExceptT ErrorMessage (EIP p IO c o) Value
-> (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall o p c.
(Eq o, Monoid o, ToJSON o, Eq p, ExplorerPostValue p c o) =>
Value -> ExceptT ErrorMessage (EIP p IO c o) Value
execute
methodDispatch String
"revert" Maybe Value
mval = Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) p c o.
Monad m =>
Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
ensureParameter Maybe Value
mval ExceptT ErrorMessage (EIP p IO c o) Value
-> (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall o p c.
(Eq o, Monoid o, Eq p, ExplorerPostValue p c o) =>
Value -> ExceptT ErrorMessage (EIP p IO c o) Value
revert
methodDispatch String
"deref" Maybe Value
mval = Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) p c o.
Monad m =>
Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
ensureParameter Maybe Value
mval ExceptT ErrorMessage (EIP p IO c o) Value
-> (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall o p c.
(Eq o, Monoid o, Eq p, ToJSON c) =>
Value -> ExceptT ErrorMessage (EIP p IO c o) Value
deref
methodDispatch String
"getTrace" Maybe Value
mval = Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall p o c.
(ToJSON p, ToJSON o) =>
Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
getTrace Maybe Value
mval
methodDispatch String
"getPath" Maybe Value
mval = Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) p c o.
Monad m =>
Maybe Value -> ExceptT ErrorMessage (EIP p m c o) Value
ensureParameter Maybe Value
mval ExceptT ErrorMessage (EIP p IO c o) Value
-> (Value -> ExceptT ErrorMessage (EIP p IO c o) Value)
-> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall o p c.
(ToJSON o, ToJSON p) =>
Value -> ExceptT ErrorMessage (EIP p IO c o) Value
getPath
methodDispatch String
"getExecutionTree" Maybe Value
_ = ExceptT ErrorMessage (EIP p IO c o) Value
forall o p c.
(ToJSON o, ToJSON p) =>
ExceptT ErrorMessage (EIP p IO c o) Value
executionTree
methodDispatch String
"getCurrentReference" Maybe Value
_ = ExceptT ErrorMessage (EIP p IO c o) Value
forall p c o. ExceptT ErrorMessage (EIP p IO c o) Value
getCurrentReference
methodDispatch String
"getAllReferences" Maybe Value
_ = ExceptT ErrorMessage (EIP p IO c o) Value
forall p c o. ExceptT ErrorMessage (EIP p IO c o) Value
getAllReferences
methodDispatch String
"getLeaves" Maybe Value
_ = ExceptT ErrorMessage (EIP p IO c o) Value
forall p c o. ExceptT ErrorMessage (EIP p IO c o) Value
getLeaves
methodDispatch String
_ Maybe Value
_ = ErrorMessage -> ExceptT ErrorMessage (EIP p IO c o) Value
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE ErrorMessage
methodNotFound

handleRequest :: (Eq o, Monoid o, ToJSON o, ToJSON o, ToJSON p, Eq p, ToJSON c, ExplorerPostValue p c o) => Maybe RequestMessage -> EIP p IO c o ResponseMessage
handleRequest :: Maybe RequestMessage -> EIP p IO c o ResponseMessage
handleRequest (Just RequestMessage
msg) = do
    ProcessResult
res <- ExceptT ErrorMessage (EIP p IO c o) Value
-> EIP p IO c o ProcessResult
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT ErrorMessage (EIP p IO c o) Value
 -> EIP p IO c o ProcessResult)
-> ExceptT ErrorMessage (EIP p IO c o) Value
-> EIP p IO c o ProcessResult
forall a b. (a -> b) -> a -> b
$ String -> Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
forall o p c.
(Eq o, Monoid o, ToJSON o, ToJSON p, Eq p, ToJSON c,
 ExplorerPostValue p c o) =>
String -> Maybe Value -> ExceptT ErrorMessage (EIP p IO c o) Value
methodDispatch (RequestMessage -> String
method RequestMessage
msg) (RequestMessage -> Maybe Value
params RequestMessage
msg)
    ResponseMessage -> EIP p IO c o ResponseMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseMessage -> EIP p IO c o ResponseMessage)
-> ResponseMessage -> EIP p IO c o ResponseMessage
forall a b. (a -> b) -> a -> b
$ ResponseMessage :: String -> ProcessResult -> ResponseMessage
ResponseMessage { $sel:res_id:ResponseMessage :: String
res_id = RequestMessage -> String
req_id RequestMessage
msg, $sel:body:ResponseMessage :: ProcessResult
body = ProcessResult
res }
handleRequest Maybe RequestMessage
Nothing = ResponseMessage -> EIP p IO c o ResponseMessage
forall (m :: * -> *) a. Monad m => a -> m a
return (ResponseMessage -> EIP p IO c o ResponseMessage)
-> ResponseMessage -> EIP p IO c o ResponseMessage
forall a b. (a -> b) -> a -> b
$ ResponseMessage :: String -> ProcessResult -> ResponseMessage
ResponseMessage { $sel:res_id:ResponseMessage :: String
res_id = String
"0", $sel:body:ResponseMessage :: ProcessResult
body = ErrorMessage -> ProcessResult
forall a b. a -> Either a b
Left ErrorMessage
parseError { $sel:message:ErrorMessage :: String
message = String
"NOthing" }}


handleRequest' :: (Eq o, Monoid o, ToJSON o, Eq p, ToJSON p, ToJSON c, ExplorerPostValue p c o) => S.ByteString -> EIP p IO c o ResponseMessage
handleRequest' :: ByteString -> EIP p IO c o ResponseMessage
handleRequest' ByteString
body =
    case ByteString -> Maybe (Maybe RequestMessage)
forall a. FromJSON a => ByteString -> Maybe a
decode ByteString
body of
        (Just Maybe RequestMessage
m) -> Maybe RequestMessage -> EIP p IO c o ResponseMessage
forall o p c.
(Eq o, Monoid o, ToJSON o, ToJSON o, ToJSON p, Eq p, ToJSON c,
 ExplorerPostValue p c o) =>
Maybe RequestMessage -> EIP p IO c o ResponseMessage
handleRequest Maybe RequestMessage
m
        Maybe (Maybe RequestMessage)
Nothing -> ResponseMessage -> EIP p IO c o ResponseMessage
forall (m :: * -> *) a. Monad m => a -> m a
return ResponseMessage
invalidHeader

invalidHeader :: ResponseMessage
invalidHeader :: ResponseMessage
invalidHeader = ResponseMessage :: String -> ProcessResult -> ResponseMessage
ResponseMessage { $sel:res_id:ResponseMessage :: String
res_id = String
"0", $sel:body:ResponseMessage :: ProcessResult
body = ErrorMessage -> ProcessResult
forall a b. a -> Either a b
Left ErrorMessage
parseError {$sel:message:ErrorMessage :: String
message = String
"Headeer"} }

parseHeader :: AB.Parser (Int, String)
parseHeader :: Parser (Ref, String)
parseHeader = do
    ByteString -> Parser ByteString
AB.string ByteString
"Content-Length:"
    Parser ByteString Char -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
AB.skipMany (Char -> Parser ByteString Char
ABC.char Char
' ')
    Scientific
res <- Parser Scientific
ABC.scientific
    Parser ByteString Char -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
AB.skipMany (Char -> Parser ByteString Char
ABC.char Char
' ')
    Char -> Parser ByteString Char
ABC.char Char
'\r'
    Char -> Parser ByteString Char
ABC.char Char
'\n'
    ByteString -> Parser ByteString
ABC.string ByteString
"Content-Type:"
    Parser ByteString Char -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
AB.skipMany (Char -> Parser ByteString Char
ABC.char Char
' ')
    String
typ <- Parser ByteString Char
-> Parser ByteString Char -> Parser ByteString String
forall (f :: * -> *) a b. Alternative f => f a -> f b -> f [a]
AB.manyTill Parser ByteString Char
ABC.letter_ascii (Char -> Parser ByteString Char
ABC.char Char
'\r')
    Parser ByteString Char -> Parser ByteString ()
forall (f :: * -> *) a. Alternative f => f a -> f ()
AB.skipMany (Char -> Parser ByteString Char
ABC.char Char
' ')
    Char -> Parser ByteString Char
ABC.char Char
'\n'
    Char -> Parser ByteString Char
ABC.char Char
'\r'
    Char -> Parser ByteString Char
ABC.char Char
'\n'
    (Ref, String) -> Parser (Ref, String)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Ref, String) -> Parser (Ref, String))
-> (Ref, String) -> Parser (Ref, String)
forall a b. (a -> b) -> a -> b
$ (Maybe Ref -> Ref
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Ref -> Ref) -> Maybe Ref -> Ref
forall a b. (a -> b) -> a -> b
$ ((Scientific -> Maybe Ref
forall i. (Integral i, Bounded i) => Scientific -> Maybe i
toBoundedInteger Scientific
res) :: Maybe Int), String
typ)


intProg :: Int -> Int -> IO (Maybe Int, ())
intProg :: Ref -> Ref -> IO (Maybe Ref, ())
intProg Ref
x Ref
y = do
    String -> IO ()
putStrLn (String -> IO ()) -> (Ref -> String) -> Ref -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ref -> String
forall a. Show a => a -> String
show (Ref -> IO ()) -> Ref -> IO ()
forall a b. (a -> b) -> a -> b
$ Ref
y
    (Maybe Ref, ()) -> IO (Maybe Ref, ())
forall (m :: * -> *) a. Monad m => a -> m a
return (Ref -> Maybe Ref
forall a. a -> Maybe a
Just Ref
x, ())

intParse :: String -> Maybe Int
intParse :: String -> Maybe Ref
intParse String
_ = Ref -> Maybe Ref
forall a. a -> Maybe a
Just Ref
1

-- TODO: Handle incorrect request.
-- TODO: Send correct error messages.
serve :: (Eq o, Monoid o, ToJSON o, Eq p, ToJSON p, ToJSON c, ExplorerPostValue p c o) => String -> Ex.Explorer p IO c o -> (String -> Maybe p) -> IO ()
serve :: String -> Explorer p IO c o -> (String -> Maybe p) -> IO ()
serve String
port Explorer p IO c o
ex String -> Maybe p
parser = IO () -> IO ()
forall a. IO a -> IO a
withSocketsDo (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    AddrInfo
addr <- String -> IO AddrInfo
resolve String
port
    IO Socket -> (Socket -> IO ()) -> (Socket -> IO ()) -> IO ()
forall a b c. IO a -> (a -> IO b) -> (a -> IO c) -> IO c
E.bracket (AddrInfo -> IO Socket
open AddrInfo
addr) Socket -> IO ()
close Socket -> IO ()
forall b. Socket -> IO b
loop
  where
    resolve :: String -> IO AddrInfo
resolve String
port = do
        let hints :: AddrInfo
hints = AddrInfo
defaultHints {
                addrFlags :: [AddrInfoFlag]
addrFlags = [AddrInfoFlag
AI_PASSIVE]
              , addrSocketType :: SocketType
addrSocketType = SocketType
Stream
              }
        AddrInfo
addr:[AddrInfo]
_ <- Maybe AddrInfo -> Maybe String -> Maybe String -> IO [AddrInfo]
getAddrInfo (AddrInfo -> Maybe AddrInfo
forall a. a -> Maybe a
Just AddrInfo
hints) Maybe String
forall a. Maybe a
Nothing (String -> Maybe String
forall a. a -> Maybe a
Just String
port)
        AddrInfo -> IO AddrInfo
forall (m :: * -> *) a. Monad m => a -> m a
return AddrInfo
addr
    open :: AddrInfo -> IO Socket
open AddrInfo
addr = do
        Socket
sock <- Family -> SocketType -> ProtocolNumber -> IO Socket
socket (AddrInfo -> Family
addrFamily AddrInfo
addr) (AddrInfo -> SocketType
addrSocketType AddrInfo
addr) (AddrInfo -> ProtocolNumber
addrProtocol AddrInfo
addr)
        Socket -> SocketOption -> Ref -> IO ()
setSocketOption Socket
sock SocketOption
ReuseAddr Ref
1
        Socket -> SockAddr -> IO ()
bind Socket
sock (AddrInfo -> SockAddr
addrAddress AddrInfo
addr)
        -- If the prefork technique is not used,
        -- set CloseOnExec for the security reasons.
        ProtocolNumber
fd <- Socket -> IO ProtocolNumber
fdSocket Socket
sock
        ProtocolNumber -> IO ()
setCloseOnExecIfNeeded ProtocolNumber
fd
        Socket -> Ref -> IO ()
listen Socket
sock Ref
10
        Socket -> IO Socket
forall (m :: * -> *) a. Monad m => a -> m a
return Socket
sock
    loop :: Socket -> IO b
loop Socket
sock = IO ThreadId -> IO b
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever (IO ThreadId -> IO b) -> IO ThreadId -> IO b
forall a b. (a -> b) -> a -> b
$ do
        (Socket
conn, SockAddr
peer) <- Socket -> IO (Socket, SockAddr)
accept Socket
sock
        String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ String
"Connection from " String -> ShowS
forall a. [a] -> [a] -> [a]
++ SockAddr -> String
forall a. Show a => a -> String
show SockAddr
peer
        IO () -> (Either SomeException () -> IO ()) -> IO ThreadId
forall a. IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
forkFinally (Explorer p IO c o -> (String -> Maybe p) -> Socket -> IO ()
forall o p c.
(Monoid o, Eq o, Eq p, ToJSON o, ToJSON p, ToJSON c,
 ExplorerPostValue p c o) =>
Explorer p IO c o -> (String -> Maybe p) -> Socket -> IO ()
talk Explorer p IO c o
ex String -> Maybe p
parser Socket
conn) (\Either SomeException ()
_ -> Socket -> IO ()
close Socket
conn)
    talk :: Explorer p IO c o -> (String -> Maybe p) -> Socket -> IO ()
talk Explorer p IO c o
ex String -> Maybe p
parser Socket
conn = do
        String -> IO ()
putStrLn String
"Hello receiving"
        ByteString
msg <- Socket -> Int64 -> IO ByteString
recv Socket
conn Int64
1024
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ByteString -> Bool
S.null ByteString
msg) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Explorer p IO c o
ex' <- Explorer p IO c o
-> (String -> Maybe p)
-> Socket
-> ByteString
-> IO (Explorer p IO c o)
forall o p c.
(Monoid o, Eq o, Eq p, ToJSON o, ToJSON p, ToJSON c,
 ExplorerPostValue p c o) =>
Explorer p IO c o
-> (String -> Maybe p)
-> Socket
-> ByteString
-> IO (Explorer p IO c o)
acceptCommand Explorer p IO c o
ex String -> Maybe p
parser Socket
conn ByteString
msg
            Explorer p IO c o -> (String -> Maybe p) -> Socket -> IO ()
talk Explorer p IO c o
ex' String -> Maybe p
parser Socket
conn

acceptCommand :: Explorer p IO c o
-> (String -> Maybe p)
-> Socket
-> ByteString
-> IO (Explorer p IO c o)
acceptCommand Explorer p IO c o
ex String -> Maybe p
parser Socket
conn ByteString
command = do
    let res :: Result (Ref, String)
res = Parser (Ref, String) -> ByteString -> Result (Ref, String)
forall a. Parser a -> ByteString -> Result a
AB.parse Parser (Ref, String)
parseHeader ByteString
command
    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Result (Ref, String) -> String
forall a. Show a => a -> String
show Result (Ref, String)
res
    (Maybe (ResponseMessage, Explorer p IO c o, ByteString)
result, ByteString
toParse) <- case Result (Ref, String)
res of
        (AB.Done ByteString
rem (Ref
val, String
_)) -> do
            case ByteString -> Int64
S.length ByteString
rem Int64 -> Int64 -> Bool
forall a. Ord a => a -> a -> Bool
< (Ref -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ref
val) of
                Bool
True -> do
                    ByteString
msg <- Socket -> Int64 -> IO ByteString
recv Socket
conn Int64
1024
                    (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
 ByteString)
-> IO
     (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
      ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ResponseMessage, Explorer p IO c o, ByteString)
forall a. Maybe a
Nothing, ByteString -> ByteString -> ByteString
S.append ByteString
command ByteString
msg)
                Bool
False -> do
                    let command :: ByteString
command = Int64 -> ByteString -> ByteString
S.take (Ref -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ref
val) ByteString
rem
                    String -> IO ()
putStrLn String
"-------------------------"
                    String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
command
                    String -> IO ()
putStrLn String
"-------------------------"
                    (ResponseMessage, Explorer p IO c o, ByteString)
out <- RWST
  (String -> Maybe p)
  ByteString
  (Explorer p IO c o)
  IO
  ResponseMessage
-> (String -> Maybe p)
-> Explorer p IO c o
-> IO (ResponseMessage, Explorer p IO c o, ByteString)
forall r w s (m :: * -> *) a.
RWST r w s m a -> r -> s -> m (a, s, w)
runRWST (ByteString
-> RWST
     (String -> Maybe p)
     ByteString
     (Explorer p IO c o)
     IO
     ResponseMessage
forall o p c.
(Eq o, Monoid o, ToJSON o, Eq p, ToJSON p, ToJSON c,
 ExplorerPostValue p c o) =>
ByteString -> EIP p IO c o ResponseMessage
handleRequest' ByteString
command) String -> Maybe p
parser Explorer p IO c o
ex
                    (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
 ByteString)
-> IO
     (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
      ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ResponseMessage, Explorer p IO c o, ByteString)
-> Maybe (ResponseMessage, Explorer p IO c o, ByteString)
forall a. a -> Maybe a
Just (ResponseMessage, Explorer p IO c o, ByteString)
out, Int64 -> ByteString -> ByteString
S.drop (Ref -> Int64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Ref
val) ByteString
rem)
        (AB.Fail ByteString
_ [String]
_ String
"not enough input") -> do
            ByteString
msg <- Socket -> Int64 -> IO ByteString
recv Socket
conn Int64
1024
            (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
 ByteString)
-> IO
     (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
      ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (ResponseMessage, Explorer p IO c o, ByteString)
forall a. Maybe a
Nothing, ByteString -> ByteString -> ByteString
S.append ByteString
command ByteString
msg)
        Result (Ref, String)
_ ->  (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
 ByteString)
-> IO
     (Maybe (ResponseMessage, Explorer p IO c o, ByteString),
      ByteString)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ResponseMessage, Explorer p IO c o, ByteString)
-> Maybe (ResponseMessage, Explorer p IO c o, ByteString)
forall a. a -> Maybe a
Just (ResponseMessage
invalidHeader, Explorer p IO c o
ex, ByteString
""), ByteString
"")
    case Maybe (ResponseMessage, Explorer p IO c o, ByteString)
result of
        Maybe (ResponseMessage, Explorer p IO c o, ByteString)
Nothing -> if ByteString
toParse ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then Explorer p IO c o -> IO (Explorer p IO c o)
forall (m :: * -> *) a. Monad m => a -> m a
return Explorer p IO c o
ex else Explorer p IO c o
-> (String -> Maybe p)
-> Socket
-> ByteString
-> IO (Explorer p IO c o)
acceptCommand Explorer p IO c o
ex String -> Maybe p
parser Socket
conn ByteString
toParse
        Just (ResponseMessage
resp, Explorer p IO c o
ex', ByteString
log) -> do
            let encoded_resp :: ByteString
encoded_resp = ResponseMessage -> ByteString
forall a. ToJSON a => a -> ByteString
encode ResponseMessage
resp
            let full_resp :: ByteString
full_resp = [ByteString] -> ByteString
S.concat [ByteString
"Content-Length:", Int64 -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Int64 -> ByteString) -> Int64 -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Int64
S.length ByteString
encoded_resp, ByteString
"\r\nContent-Type: jrpcei\r\n\r\n", ByteString
encoded_resp]
            Socket -> ByteString -> IO ()
sendAll Socket
conn ByteString
full_resp
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
full_resp
            String -> IO ()
putStrLn (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString -> String
forall a. Show a => a -> String
show ByteString
toParse
            if ByteString
toParse ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"" then Explorer p IO c o -> IO (Explorer p IO c o)
forall (m :: * -> *) a. Monad m => a -> m a
return Explorer p IO c o
ex' else Explorer p IO c o
-> (String -> Maybe p)
-> Socket
-> ByteString
-> IO (Explorer p IO c o)
acceptCommand Explorer p IO c o
ex' String -> Maybe p
parser Socket
conn ByteString
toParse