{-# LANGUAGE ForeignFunctionInterface #-}

module TD.Lib
  ( create,
    send,
    sendWExtra,
    receive,
    destroy,
    Client,
    Extra,
    ShortShow (shortShow),
  )
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
  [Char]
extra <- IO [Char]
makeExtra
  Client -> KeyMap Value -> IO ()
forall a. ToJSON a => Client -> a -> IO ()
send Client
client ([Char] -> KeyMap Value
addExtra [Char]
extra)
  Extra -> IO Extra
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Extra -> IO Extra) -> Extra -> IO Extra
forall a b. (a -> b) -> a -> b
$ [Char] -> Extra
Extra [Char]
extra
  where
    addExtra :: String -> KM.KeyMap A.Value
    addExtra :: [Char] -> KeyMap Value
addExtra [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

    makeExtra :: IO String
    makeExtra :: IO [Char]
makeExtra = 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 = ByteString -> Int
forall a. Hashable a => a -> Int
H.hash (ByteString -> Int) -> ByteString -> Int
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
A.encode a
json
      [Char] -> IO [Char]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char] -> IO [Char]) -> [Char] -> IO [Char]
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