{--*-Mode:haskell;coding:utf-8;tab-width:4;c-basic-offset:4;indent-tabs-mode:()-*-
  ex: set ft=haskell fenc=utf-8 sts=4 ts=4 sw=4 et nomod: -}

{-

  MIT License

  Copyright (c) 2017-2020 Michael Truog <mjtruog at protonmail dot com>

  Permission is hereby granted, free of charge, to any person obtaining a
  copy of this software and associated documentation files (the "Software"),
  to deal in the Software without restriction, including without limitation
  the rights to use, copy, modify, merge, publish, distribute, sublicense,
  and/or sell copies of the Software, and to permit persons to whom the
  Software is furnished to do so, subject to the following conditions:

  The above copyright notice and this permission notice shall be included in
  all copies or substantial portions of the Software.

  THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
  FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
  DEALINGS IN THE SOFTWARE.

 -}

module Foreign.CloudI.Instance
    ( RequestType(..)
    , Source
    , Response(..)
    , Callback
    , T(..)
    , make
    , init
    , reinit
    , setResponse
    , setTransId
    , setTransIds
    , setSubscribeCount
    , callbacksAdd
    , callbacksRemove
    ) where

import Prelude hiding (init)
import Data.Typeable (Typeable)
import qualified Data.Array.IArray as IArray
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Builder as Builder
import qualified Data.Int as Int
import qualified Data.Map.Strict as Map
import qualified Data.Monoid as Monoid
import qualified Data.Sequence as Sequence
import qualified Data.Word as Word
import qualified Foreign.C.Types as C
import qualified Foreign.Erlang.Pid as Erlang
import qualified Network.Socket as Socket
import qualified System.IO as SysIO
type Array = IArray.Array
type Builder = Builder.Builder
type ByteString = ByteString.ByteString
type Handle = SysIO.Handle
type Int8 = Int.Int8
type Map = Map.Map
type Seq = Sequence.Seq
type Socket = Socket.Socket
type Word32 = Word.Word32

-- | provided when handling a service request
data RequestType =
      ASYNC
    | SYNC
    deriving (RequestType -> RequestType -> Bool
(RequestType -> RequestType -> Bool)
-> (RequestType -> RequestType -> Bool) -> Eq RequestType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RequestType -> RequestType -> Bool
$c/= :: RequestType -> RequestType -> Bool
== :: RequestType -> RequestType -> Bool
$c== :: RequestType -> RequestType -> Bool
Eq, Int -> RequestType -> ShowS
[RequestType] -> ShowS
RequestType -> String
(Int -> RequestType -> ShowS)
-> (RequestType -> String)
-> ([RequestType] -> ShowS)
-> Show RequestType
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RequestType] -> ShowS
$cshowList :: [RequestType] -> ShowS
show :: RequestType -> String
$cshow :: RequestType -> String
showsPrec :: Int -> RequestType -> ShowS
$cshowsPrec :: Int -> RequestType -> ShowS
Show)

-- | the Erlang pid that is the source of the service request
type Source = Erlang.Pid

-- | a function to handle a service request
type Callback s =
    RequestType ->
    ByteString -> ByteString ->
    ByteString -> ByteString ->
    Int -> Int -> ByteString -> Source ->
    s -> T s ->
    IO (Response s)

-- | service request callback function return type
data Response s =
      Response (ByteString, s, T s)
    | ResponseInfo (ByteString, ByteString, s, T s)
    | Forward (ByteString, ByteString, ByteString, s, T s)
    | Forward_ (ByteString, ByteString, ByteString, Int, Int, s, T s)
    | Null (s, T s)
    | NullError (String, s, T s)
    deriving (Int -> Response s -> ShowS
[Response s] -> ShowS
Response s -> String
(Int -> Response s -> ShowS)
-> (Response s -> String)
-> ([Response s] -> ShowS)
-> Show (Response s)
forall s. Show s => Int -> Response s -> ShowS
forall s. Show s => [Response s] -> ShowS
forall s. Show s => Response s -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Response s] -> ShowS
$cshowList :: forall s. Show s => [Response s] -> ShowS
show :: Response s -> String
$cshow :: forall s. Show s => Response s -> String
showsPrec :: Int -> Response s -> ShowS
$cshowsPrec :: forall s. Show s => Int -> Response s -> ShowS
Show, Typeable)

-- | an instance of the CloudI API
data T s = T
    { T s -> s
state :: !s
    , T s -> Bool
terminateException :: !Bool
    , T s -> Handle
socketHandle :: !Handle
    , T s -> Bool
useHeader :: !Bool
    , T s -> Bool
initializationComplete :: !Bool
    , T s -> Bool
terminate :: !Bool
    , T s -> Maybe Bool
timeout :: !(Maybe Bool)
    , T s -> Map ByteString (Seq (Callback s))
callbacks :: !(Map ByteString (Seq (Callback s)))
    , T s -> Int
bufferSize :: !Int
    , T s -> Builder
bufferRecv :: !Builder
    , T s -> Int
bufferRecvSize :: !Int
    , T s -> Int
processIndex :: !Int
    , T s -> Int
processCount :: !Int
    , T s -> Int
processCountMax :: !Int
    , T s -> Int
processCountMin :: !Int
    , T s -> ByteString
prefix :: !ByteString
    , T s -> Int
timeoutInitialize :: !Int
    , T s -> Int
timeoutAsync :: !Int
    , T s -> Int
timeoutSync :: !Int
    , T s -> Int
timeoutTerminate :: !Int
    , T s -> Int
priorityDefault :: !Int
    , T s -> ByteString
responseInfo :: !ByteString
    , T s -> ByteString
response :: !ByteString
    , T s -> ByteString
transId :: !ByteString
    , T s -> Array Int ByteString
transIds :: !(Array Int ByteString)
    , T s -> Int
subscribeCount :: !Int
    }
    deriving (Typeable)

instance Show (T s) where
    show :: T s -> String
show T s
_ = String
""

makeSocket :: String -> C.CInt -> IO Socket
makeSocket :: String -> CInt -> IO Socket
makeSocket String
"local" CInt
fd =
    CInt -> IO Socket
Socket.mkSocket CInt
fd
makeSocket String
"tcp" CInt
fd =
    CInt -> IO Socket
Socket.mkSocket CInt
fd
makeSocket String
"udp" CInt
fd =
    CInt -> IO Socket
Socket.mkSocket CInt
fd
makeSocket String
_ CInt
_ =
    String -> IO Socket
forall a. HasCallStack => String -> a
error String
"invalid protocol"

makeSocketHandle :: String -> C.CInt -> IO Handle
makeSocketHandle :: String -> CInt -> IO Handle
makeSocketHandle String
protocol CInt
fd = do
    Socket
socket <- String -> CInt -> IO Socket
makeSocket String
protocol CInt
fd
    Socket -> IOMode -> IO Handle
Socket.socketToHandle Socket
socket IOMode
SysIO.ReadWriteMode

make :: s -> Bool -> String -> C.CInt -> Bool -> Int -> Int -> IO (T s)
make :: s -> Bool -> String -> CInt -> Bool -> Int -> Int -> IO (T s)
make s
state' Bool
terminateException'
    String
protocol CInt
fd Bool
useHeader' Int
bufferSize' Int
timeoutTerminate' = do
    Handle
socketHandle' <- String -> CInt -> IO Handle
makeSocketHandle String
protocol CInt
fd
    T s -> IO (T s)
forall (m :: * -> *) a. Monad m => a -> m a
return (T s -> IO (T s)) -> T s -> IO (T s)
forall a b. (a -> b) -> a -> b
$ T :: forall s.
s
-> Bool
-> Handle
-> Bool
-> Bool
-> Bool
-> Maybe Bool
-> Map ByteString (Seq (Callback s))
-> Int
-> Builder
-> Int
-> Int
-> Int
-> Int
-> Int
-> ByteString
-> Int
-> Int
-> Int
-> Int
-> Int
-> ByteString
-> ByteString
-> ByteString
-> Array Int ByteString
-> Int
-> T s
T {
          state :: s
state = s
state'
        , terminateException :: Bool
terminateException = Bool
terminateException'
        , socketHandle :: Handle
socketHandle = Handle
socketHandle'
        , useHeader :: Bool
useHeader = Bool
useHeader'
        , initializationComplete :: Bool
initializationComplete = Bool
False
        , terminate :: Bool
terminate = Bool
False
        , timeout :: Maybe Bool
timeout = Maybe Bool
forall a. Maybe a
Nothing
        , callbacks :: Map ByteString (Seq (Callback s))
callbacks = Map ByteString (Seq (Callback s))
forall k a. Map k a
Map.empty
        , bufferSize :: Int
bufferSize = Int
bufferSize'
        , bufferRecv :: Builder
bufferRecv = Builder
forall a. Monoid a => a
Monoid.mempty
        , bufferRecvSize :: Int
bufferRecvSize = Int
0
        , processIndex :: Int
processIndex = Int
0
        , processCount :: Int
processCount = Int
0
        , processCountMax :: Int
processCountMax = Int
0
        , processCountMin :: Int
processCountMin = Int
0
        , prefix :: ByteString
prefix = ByteString
ByteString.empty
        , timeoutInitialize :: Int
timeoutInitialize = Int
0
        , timeoutAsync :: Int
timeoutAsync = Int
0
        , timeoutSync :: Int
timeoutSync = Int
0
        , timeoutTerminate :: Int
timeoutTerminate = Int
timeoutTerminate'
        , priorityDefault :: Int
priorityDefault = Int
0
        , responseInfo :: ByteString
responseInfo = ByteString
ByteString.empty
        , response :: ByteString
response = ByteString
ByteString.empty
        , transId :: ByteString
transId = ByteString
ByteString.empty
        , transIds :: Array Int ByteString
transIds = (Int, Int) -> [(Int, ByteString)] -> Array Int ByteString
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
IArray.array (Int
0, Int
0) [(Int
0, ByteString
ByteString.empty)]
        , subscribeCount :: Int
subscribeCount = Int
0
    }

init :: T s -> Word32 -> Word32 -> Word32 -> Word32 -> ByteString ->
    Word32 -> Word32 -> Word32 -> Word32 -> Int8 -> T s
init :: T s
-> Word32
-> Word32
-> Word32
-> Word32
-> ByteString
-> Word32
-> Word32
-> Word32
-> Word32
-> Int8
-> T s
init T s
api0
    Word32
processIndex' Word32
processCount' Word32
processCountMax' Word32
processCountMin'
    ByteString
prefix' Word32
timeoutInitialize' Word32
timeoutAsync' Word32
timeoutSync' Word32
timeoutTerminate'
    Int8
priorityDefault' =
    T s
api0{
          timeout :: Maybe Bool
timeout = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        , processIndex :: Int
processIndex = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
processIndex'
        , processCount :: Int
processCount = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
processCount'
        , processCountMax :: Int
processCountMax = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
processCountMax'
        , processCountMin :: Int
processCountMin = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
processCountMin'
        , prefix :: ByteString
prefix = ByteString
prefix'
        , timeoutInitialize :: Int
timeoutInitialize = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timeoutInitialize'
        , timeoutAsync :: Int
timeoutAsync = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timeoutAsync'
        , timeoutSync :: Int
timeoutSync = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timeoutSync'
        , timeoutTerminate :: Int
timeoutTerminate = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timeoutTerminate'
        , priorityDefault :: Int
priorityDefault = Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
priorityDefault'}

reinit :: T s -> Word32 -> Word32 -> Word32 -> Int8 -> T s
reinit :: T s -> Word32 -> Word32 -> Word32 -> Int8 -> T s
reinit T s
api0
    Word32
processCount' Word32
timeoutAsync' Word32
timeoutSync'
    Int8
priorityDefault' =
    T s
api0{
          processCount :: Int
processCount = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
processCount'
        , timeoutAsync :: Int
timeoutAsync = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timeoutAsync'
        , timeoutSync :: Int
timeoutSync = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
timeoutSync'
        , priorityDefault :: Int
priorityDefault = Int8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int8
priorityDefault'}

setResponse :: T s -> ByteString -> ByteString -> ByteString -> T s
setResponse :: T s -> ByteString -> ByteString -> ByteString -> T s
setResponse T s
api0
    ByteString
responseInfo' ByteString
response' ByteString
transId' =
    T s
api0{
          timeout :: Maybe Bool
timeout = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        , responseInfo :: ByteString
responseInfo = ByteString
responseInfo'
        , response :: ByteString
response = ByteString
response'
        , transId :: ByteString
transId = ByteString
transId'}

setTransId :: T s -> ByteString -> T s
setTransId :: T s -> ByteString -> T s
setTransId T s
api0
    ByteString
transId' =
    T s
api0{
          timeout :: Maybe Bool
timeout = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        , transId :: ByteString
transId = ByteString
transId'}

setTransIds :: T s -> ByteString -> Word32 -> T s
setTransIds :: T s -> ByteString -> Word32 -> T s
setTransIds T s
api0
    ByteString
transIds' Word32
transIdCount =
    let count :: Int
count = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
transIdCount :: Int
        loop :: Int -> [(Int, ByteString)] -> ByteString -> [(Int, ByteString)]
loop Int
i [(Int, ByteString)]
l ByteString
s =
            if Int
i Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
count then
                [(Int, ByteString)]
l
            else
                let (ByteString
e, ByteString
s') = Int -> ByteString -> (ByteString, ByteString)
ByteString.splitAt Int
16 ByteString
s in
                Int -> [(Int, ByteString)] -> ByteString -> [(Int, ByteString)]
loop (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) ((Int
i, ByteString
e)(Int, ByteString) -> [(Int, ByteString)] -> [(Int, ByteString)]
forall a. a -> [a] -> [a]
:[(Int, ByteString)]
l) ByteString
s'
    in
    T s
api0{
          timeout :: Maybe Bool
timeout = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        , transIds :: Array Int ByteString
transIds = (Int, Int) -> [(Int, ByteString)] -> Array Int ByteString
forall (a :: * -> * -> *) e i.
(IArray a e, Ix i) =>
(i, i) -> [(i, e)] -> a i e
IArray.array (Int
0, Int
count Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (Int -> [(Int, ByteString)] -> ByteString -> [(Int, ByteString)]
loop Int
0 [] ByteString
transIds')}

setSubscribeCount :: T s -> Word32 -> T s
setSubscribeCount :: T s -> Word32 -> T s
setSubscribeCount T s
api0
    Word32
subscribeCount' =
    T s
api0{
          timeout :: Maybe Bool
timeout = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
        , subscribeCount :: Int
subscribeCount = Word32 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word32
subscribeCount'}

callbacksAdd :: T s -> ByteString -> Callback s -> T s
callbacksAdd :: T s -> ByteString -> Callback s -> T s
callbacksAdd api0 :: T s
api0@T{
      callbacks :: forall s. T s -> Map ByteString (Seq (Callback s))
callbacks = Map ByteString (Seq (Callback s))
callbacks0
    , prefix :: forall s. T s -> ByteString
prefix = ByteString
prefix'} ByteString
pattern Callback s
f =
    let key :: ByteString
key = ByteString -> ByteString -> ByteString
ByteString.append ByteString
prefix' ByteString
pattern
        callbacks1 :: Map ByteString (Seq (Callback s))
callbacks1 = case ByteString
-> Map ByteString (Seq (Callback s)) -> Maybe (Seq (Callback s))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
key Map ByteString (Seq (Callback s))
callbacks0 of
            Maybe (Seq (Callback s))
Nothing ->
                ByteString
-> Seq (Callback s)
-> Map ByteString (Seq (Callback s))
-> Map ByteString (Seq (Callback s))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
key (Callback s -> Seq (Callback s)
forall a. a -> Seq a
Sequence.singleton Callback s
f) Map ByteString (Seq (Callback s))
callbacks0
            Just Seq (Callback s)
functionQueue ->
                ByteString
-> Seq (Callback s)
-> Map ByteString (Seq (Callback s))
-> Map ByteString (Seq (Callback s))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
key (Seq (Callback s) -> Callback s -> Seq (Callback s)
forall a. Seq a -> a -> Seq a
(Sequence.|>) Seq (Callback s)
functionQueue Callback s
f) Map ByteString (Seq (Callback s))
callbacks0
    in
    T s
api0{callbacks :: Map ByteString (Seq (Callback s))
callbacks = Map ByteString (Seq (Callback s))
callbacks1}

callbacksRemove :: T s -> ByteString -> T s
callbacksRemove :: T s -> ByteString -> T s
callbacksRemove api0 :: T s
api0@T{
      callbacks :: forall s. T s -> Map ByteString (Seq (Callback s))
callbacks = Map ByteString (Seq (Callback s))
callbacks0
    , prefix :: forall s. T s -> ByteString
prefix = ByteString
prefix'} ByteString
pattern =
    let key :: ByteString
key = ByteString -> ByteString -> ByteString
ByteString.append ByteString
prefix' ByteString
pattern
        callbacks1 :: Map ByteString (Seq (Callback s))
callbacks1 = case ByteString
-> Map ByteString (Seq (Callback s)) -> Maybe (Seq (Callback s))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup ByteString
key Map ByteString (Seq (Callback s))
callbacks0 of
            Maybe (Seq (Callback s))
Nothing ->
                String -> Map ByteString (Seq (Callback s))
forall a. HasCallStack => String -> a
error String
"callbacks empty"
            Just Seq (Callback s)
functionQueue ->
                let functionQueueNew :: Seq (Callback s)
functionQueueNew = Int -> Seq (Callback s) -> Seq (Callback s)
forall a. Int -> Seq a -> Seq a
Sequence.drop Int
1 Seq (Callback s)
functionQueue in
                if Seq (Callback s) -> Bool
forall a. Seq a -> Bool
Sequence.null Seq (Callback s)
functionQueueNew then
                    ByteString
-> Map ByteString (Seq (Callback s))
-> Map ByteString (Seq (Callback s))
forall k a. Ord k => k -> Map k a -> Map k a
Map.delete ByteString
key Map ByteString (Seq (Callback s))
callbacks0
                else
                    ByteString
-> Seq (Callback s)
-> Map ByteString (Seq (Callback s))
-> Map ByteString (Seq (Callback s))
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert ByteString
key Seq (Callback s)
functionQueueNew Map ByteString (Seq (Callback s))
callbacks0
    in
    T s
api0{callbacks :: Map ByteString (Seq (Callback s))
callbacks = Map ByteString (Seq (Callback s))
callbacks1}