{-# LANGUAGE ForeignFunctionInterface #-}

module TD.Lib
  ( create,
    send,
    sendWExtra,
    receive,
    destroy,
    Client,
    Extra,
    ShortShow (shortShow),
    createExtra,
    sendWMyExtra,
  )
where

import Data.Aeson qualified as A
import Data.Aeson.Key qualified as K
import Data.Aeson.KeyMap qualified as KM
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as BL
import Data.Hashable qualified as H
import Data.List (intercalate)
import Data.Text qualified as T
import Data.Text.Lazy qualified as TL
import Data.Text.Lazy.Encoding qualified as TL
import Data.Time.Clock.System qualified as Time
import Foreign (Ptr, nullPtr)
import Foreign.C.String (CString)
import TD.GeneralResult (GeneralResult)
import TD.Lib.Internal (Extra (..), ShortShow (shortShow))

foreign import ccall "libtdjson td_json_client_create" c_create :: IO Client

foreign import ccall "libtdjson td_json_client_send" c_send :: Client -> CString -> IO ()

foreign import ccall "libtdjson td_json_client_receive" c_receive :: Client -> Timeout -> IO CString

foreign import ccall "libtdjson td_json_client_destroy" c_destroy :: Client -> IO ()

type Client = Ptr ()

type Timeout = Double

create :: IO Client
create :: IO Client
create = IO Client
c_create

send :: (A.ToJSON a) => Client -> a -> IO ()
send :: forall a. ToJSON a => Client -> a -> IO ()
send Client
client a
json = ByteString -> (CString -> IO ()) -> IO ()
forall a. ByteString -> (CString -> IO a) -> IO a
B.useAsCString (a -> ByteString
enc a
json) (Client -> CString -> IO ()
c_send Client
client)
  where
    enc :: a -> ByteString
enc = ByteString -> ByteString
BL.toStrict (ByteString -> ByteString) -> (a -> ByteString) -> a -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode

sendWExtra :: (A.ToJSON a) => Client -> a -> IO Extra
sendWExtra :: forall a. ToJSON a => Client -> a -> IO Extra
sendWExtra Client
client a
json = do
  Extra
extra <- ByteString -> IO Extra
forall a. Hashable a => a -> IO Extra
createExtra (ByteString -> IO Extra) -> ByteString -> IO Extra
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode a
json
  Client -> KeyMap Value -> IO ()
forall a. ToJSON a => Client -> a -> IO ()
send Client
client (a -> Extra -> KeyMap Value
forall a. ToJSON a => a -> Extra -> KeyMap Value
addExtra a
json Extra
extra)
  Extra -> IO Extra
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Extra
extra

addExtra :: (A.ToJSON a) => a -> Extra -> KM.KeyMap A.Value
addExtra :: forall a. ToJSON a => a -> Extra -> KeyMap Value
addExtra a
json (Extra [Char]
extra) =
  case a -> Value
forall a. ToJSON a => a -> Value
A.toJSON a
json of
    A.Object KeyMap Value
t ->
      Key -> Value -> KeyMap Value -> KeyMap Value
forall v. Key -> v -> KeyMap v -> KeyMap v
KM.insert ([Char] -> Key
K.fromString [Char]
"@extra") (Text -> Value
A.String ([Char] -> Text
T.pack [Char]
extra)) KeyMap Value
t
    Value
_ ->
      let enc :: [Char] -> [Char]
enc = Text -> [Char]
TL.unpack (Text -> [Char]) -> ([Char] -> Text) -> [Char] -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
TL.decodeUtf8 (ByteString -> Text) -> ([Char] -> ByteString) -> [Char] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode
       in [Char] -> KeyMap Value
forall a. HasCallStack => [Char] -> a
error ([Char] -> KeyMap Value) -> [Char] -> KeyMap Value
forall a b. (a -> b) -> a -> b
$ [Char]
"error. not object: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
enc [Char]
extra

sendWMyExtra :: (A.ToJSON a) => Client -> a -> Extra -> IO ()
sendWMyExtra :: forall a. ToJSON a => Client -> a -> Extra -> IO ()
sendWMyExtra Client
client a
json Extra
extra = Client -> KeyMap Value -> IO ()
forall a. ToJSON a => Client -> a -> IO ()
send Client
client (a -> Extra -> KeyMap Value
forall a. ToJSON a => a -> Extra -> KeyMap Value
addExtra a
json Extra
extra)

createExtra :: (H.Hashable a) => a -> IO Extra
createExtra :: forall a. Hashable a => a -> IO Extra
createExtra a
str = do
  SystemTime
t <- IO SystemTime
Time.getSystemTime
  let s :: Int64
s = SystemTime -> Int64
Time.systemSeconds SystemTime
t
      ns :: Word32
ns = SystemTime -> Word32
Time.systemNanoseconds SystemTime
t
      h :: Int
h = a -> Int
forall a. Hashable a => a -> Int
H.hash a
str
   in Extra -> IO Extra
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extra -> IO Extra) -> ([Char] -> Extra) -> [Char] -> IO Extra
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Extra
Extra ([Char] -> IO Extra) -> [Char] -> IO Extra
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"." [Int64 -> [Char]
forall a. Show a => a -> [Char]
show Int64
s, Word32 -> [Char]
forall a. Show a => a -> [Char]
show Word32
ns, Int -> [Char]
forall a. Show a => a -> [Char]
show Int
h]

receive :: Client -> IO (Maybe (GeneralResult, Maybe Extra))
receive :: Client -> IO (Maybe (GeneralResult, Maybe Extra))
receive Client
c = IO CString -> IO (Maybe (GeneralResult, Maybe Extra))
dec (IO CString -> IO (Maybe (GeneralResult, Maybe Extra)))
-> IO CString -> IO (Maybe (GeneralResult, Maybe Extra))
forall a b. (a -> b) -> a -> b
$ Client -> Timeout -> IO CString
c_receive Client
c Timeout
1.0
  where
    dec :: IO CString -> IO (Maybe (GeneralResult, Maybe Extra))
    dec :: IO CString -> IO (Maybe (GeneralResult, Maybe Extra))
dec IO CString
ics = do
      CString
cs <- IO CString
ics
      if CString
cs CString -> CString -> Bool
forall a. Eq a => a -> a -> Bool
== CString
forall a. Ptr a
nullPtr
        then Maybe (GeneralResult, Maybe Extra)
-> IO (Maybe (GeneralResult, Maybe Extra))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GeneralResult, Maybe Extra)
forall a. Maybe a
Nothing
        else do
          -- B.packCString cs >>= print --DEBUG
          Maybe GeneralResult
a <- ByteString -> Maybe GeneralResult
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict (ByteString -> Maybe GeneralResult)
-> IO ByteString -> IO (Maybe GeneralResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO ByteString
B.packCString CString
cs
          case Maybe GeneralResult
a of
            Maybe GeneralResult
Nothing -> Maybe (GeneralResult, Maybe Extra)
-> IO (Maybe (GeneralResult, Maybe Extra))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (GeneralResult, Maybe Extra)
forall a. Maybe a
Nothing
            (Just GeneralResult
r) -> do
              Maybe Extra
b <- ByteString -> Maybe Extra
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict (ByteString -> Maybe Extra) -> IO ByteString -> IO (Maybe Extra)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CString -> IO ByteString
B.packCString CString
cs
              Maybe (GeneralResult, Maybe Extra)
-> IO (Maybe (GeneralResult, Maybe Extra))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (GeneralResult, Maybe Extra)
 -> IO (Maybe (GeneralResult, Maybe Extra)))
-> Maybe (GeneralResult, Maybe Extra)
-> IO (Maybe (GeneralResult, Maybe Extra))
forall a b. (a -> b) -> a -> b
$ (GeneralResult, Maybe Extra) -> Maybe (GeneralResult, Maybe Extra)
forall a. a -> Maybe a
Just (GeneralResult
r, Maybe Extra
b)

destroy :: Client -> IO ()
destroy :: Client -> IO ()
destroy = Client -> IO ()
c_destroy