-- |
-- Module: M.IO.Internal.EffectSocket
-- Description: Socket-based effect interpretation
-- Copyright: (c) axionbuster, 2025
-- License: BSD-3-Clause
--
-- Implements the interpretation of the 'Talking' effect in terms of socket
-- connections, providing both client and server capabilities.
module M.IO.Internal.EffectSocket
  ( SocketTalkingError (..),
    withtalkingserver,
  )
where

import Control.Monad
import Data.ByteString qualified as B
import Data.ByteString.Builder (Builder, toLazyByteString)
import Data.Data
import Data.Functor
import Data.Maybe
import Effectful
import Effectful.Concurrent.STM
import Effectful.Dispatch.Dynamic
import Effectful.Exception
import Effectful.NonDet
import Effectful.State.Dynamic
import M.IO.Internal.Datagram
import M.IO.Internal.EffectTypes
import M.IO.Internal.Socket
import M.Pack
import Network.SocketA hiding
  ( accept,
    bind,
    close,
    getaddrinfo,
    listen,
    socket,
    withaddrlen,
    withsocket,
  )
import Network.SocketA.Unlift
import System.IO.Streams
import UnliftIO.Exception qualified as Unfe
import Prelude hiding (read)

-- https://hackage.haskell.org/package/effectful-core-2.5.1.0/docs/Effectful.html#g:13
-- SeqUnlift: fail when calling 'run' (=unlift) from outside the spawning thread
-- SeqForkUnlift: fork (-> gain independence) at unlift
-- ConcUnlift: allow concurrent access

-- | error in communication
data SocketTalkingError
  = UnknownCode Direction TypeRep
  | Mismatch Direction TypeRep TypeRep
  deriving (SocketTalkingError -> SocketTalkingError -> Bool
(SocketTalkingError -> SocketTalkingError -> Bool)
-> (SocketTalkingError -> SocketTalkingError -> Bool)
-> Eq SocketTalkingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: SocketTalkingError -> SocketTalkingError -> Bool
== :: SocketTalkingError -> SocketTalkingError -> Bool
$c/= :: SocketTalkingError -> SocketTalkingError -> Bool
/= :: SocketTalkingError -> SocketTalkingError -> Bool
Eq, Int -> SocketTalkingError -> ShowS
[SocketTalkingError] -> ShowS
SocketTalkingError -> String
(Int -> SocketTalkingError -> ShowS)
-> (SocketTalkingError -> String)
-> ([SocketTalkingError] -> ShowS)
-> Show SocketTalkingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> SocketTalkingError -> ShowS
showsPrec :: Int -> SocketTalkingError -> ShowS
$cshow :: SocketTalkingError -> String
show :: SocketTalkingError -> String
$cshowList :: [SocketTalkingError] -> ShowS
showList :: [SocketTalkingError] -> ShowS
Show, Typeable, Show SocketTalkingError
Typeable SocketTalkingError
(Typeable SocketTalkingError, Show SocketTalkingError) =>
(SocketTalkingError -> SomeException)
-> (SomeException -> Maybe SocketTalkingError)
-> (SocketTalkingError -> String)
-> (SocketTalkingError -> Bool)
-> Exception SocketTalkingError
SomeException -> Maybe SocketTalkingError
SocketTalkingError -> Bool
SocketTalkingError -> String
SocketTalkingError -> SomeException
forall e.
(Typeable e, Show e) =>
(e -> SomeException)
-> (SomeException -> Maybe e)
-> (e -> String)
-> (e -> Bool)
-> Exception e
$ctoException :: SocketTalkingError -> SomeException
toException :: SocketTalkingError -> SomeException
$cfromException :: SomeException -> Maybe SocketTalkingError
fromException :: SomeException -> Maybe SocketTalkingError
$cdisplayException :: SocketTalkingError -> String
displayException :: SocketTalkingError -> String
$cbacktraceDesired :: SocketTalkingError -> Bool
backtraceDesired :: SocketTalkingError -> Bool
Exception)

reify ::
  (State ParserState :> es) =>
  TypeRep ->
  Builder ->
  Eff es Uninterpreted
reify :: forall (es :: [Effect]).
(State ParserState :> es) =>
TypeRep -> Builder -> Eff es Uninterpreted
reify TypeRep
t Builder
b = do
  ParserState p <- Eff es ParserState
forall s (es :: [Effect]).
(HasCallStack, State s :> es) =>
Eff es s
get
  case p (Code Outbound t) of
    Just Word8
u -> Uninterpreted -> Eff es Uninterpreted
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Uninterpreted -> Eff es Uninterpreted)
-> Uninterpreted -> Eff es Uninterpreted
forall a b. (a -> b) -> a -> b
$ Word8 -> ByteString -> Uninterpreted
Uninterpreted Word8
u (LazyByteString -> ByteString
B.toStrict (LazyByteString -> ByteString) -> LazyByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Builder -> LazyByteString
toLazyByteString Builder
b)
    Maybe Word8
Nothing -> SocketTalkingError -> Eff es Uninterpreted
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO (SocketTalkingError -> Eff es Uninterpreted)
-> SocketTalkingError -> Eff es Uninterpreted
forall a b. (a -> b) -> a -> b
$ Direction -> TypeRep -> SocketTalkingError
UnknownCode Direction
Outbound TypeRep
t

-- Run a computation with Talking effect using a Connection
runtalking0 ::
  (IOE :> es, NonDet :> es, State ParserState :> es, Concurrent :> es) =>
  Connection -> Eff (Talking : es) a -> Eff es a
runtalking0 :: forall (es :: [Effect]) a.
(IOE :> es, NonDet :> es, State ParserState :> es,
 Concurrent :> es) =>
Connection -> Eff (Talking : es) a -> Eff es a
runtalking0 Connection
cx = EffectHandler_ Talking es -> Eff (Talking : es) a -> Eff es a
forall (e :: Effect) (es :: [Effect]) a.
(HasCallStack, DispatchOf e ~ 'Dynamic) =>
EffectHandler_ e es -> Eff (e : es) a -> Eff es a
interpret_ \case
  Hear Immediately
i -> do
    let x :: Eff es a
x = case Immediately
i of
          Immediately
Immediately ->
            InputStream Uninterpreted -> Eff es SomeUnpack
forall (es :: [Effect]).
(IOE :> es, State ParserState :> es, NonDet :> es) =>
InputStream Uninterpreted -> Eff es SomeUnpack
handleheara_immediate Connection
cx.cxinput
              Eff es SomeUnpack -> (SomeUnpack -> a) -> Eff es a
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (SomeUnpack -> Maybe a) -> SomeUnpack -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeUnpack -> Maybe a
forall a. Typeable a => SomeUnpack -> Maybe a
castsomeunpack
          Immediately
Eventually -> InputStream Uninterpreted -> Eff es SomeUnpack
forall (es :: [Effect]).
(IOE :> es, State ParserState :> es) =>
InputStream Uninterpreted -> Eff es SomeUnpack
handleheara Connection
cx.cxinput Eff es SomeUnpack -> (SomeUnpack -> a) -> Eff es a
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Maybe a -> a
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe a -> a) -> (SomeUnpack -> Maybe a) -> SomeUnpack -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeUnpack -> Maybe a
forall a. Typeable a => SomeUnpack -> Maybe a
castsomeunpack
    Eff es a
x Eff es a -> (a -> Eff es a) -> Eff es a
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> Eff es a
forall a (es :: [Effect]). a -> Eff es a
evaluate
  HearU Immediately
i -> case Immediately
i of
    Immediately
Immediately -> InputStream Uninterpreted -> Eff es Uninterpreted
forall (es :: [Effect]).
(IOE :> es, NonDet :> es) =>
InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu_immediate Connection
cx.cxinput
    Immediately
Eventually -> InputStream Uninterpreted -> Eff es Uninterpreted
forall (es :: [Effect]).
(IOE :> es) =>
InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu Connection
cx.cxinput
  HearA Immediately
i -> case Immediately
i of
    Immediately
Immediately -> InputStream Uninterpreted -> Eff es SomeUnpack
forall (es :: [Effect]).
(IOE :> es, State ParserState :> es, NonDet :> es) =>
InputStream Uninterpreted -> Eff es SomeUnpack
handleheara_immediate Connection
cx.cxinput
    Immediately
Eventually -> InputStream Uninterpreted -> Eff es SomeUnpack
forall (es :: [Effect]).
(IOE :> es, State ParserState :> es) =>
InputStream Uninterpreted -> Eff es SomeUnpack
handleheara Connection
cx.cxinput
  -- todo: it's possible to create a stream that accepts Builder instead
  -- of ByteString for the sake of efficiency (from io-streams itself)
  -- but I haven't given it much thought yet
  Say a1
p -> TypeRep -> Builder -> Eff es Uninterpreted
forall (es :: [Effect]).
(State ParserState :> es) =>
TypeRep -> Builder -> Eff es Uninterpreted
reify (a1 -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf a1
p) (a1 -> Builder
forall a. Pack a => a -> Builder
pack a1
p) Eff es Uninterpreted -> (Uninterpreted -> Eff es a) -> Eff es a
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IO a -> Eff es a
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> Eff es a)
-> (Uninterpreted -> IO a) -> Uninterpreted -> Eff es a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OutputStream Uninterpreted -> Maybe Uninterpreted -> IO ()
forall a. OutputStream a -> Maybe a -> IO ()
writeTo Connection
cx.cxoutput (Maybe Uninterpreted -> IO a)
-> (Uninterpreted -> Maybe Uninterpreted) -> Uninterpreted -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Uninterpreted -> Maybe Uninterpreted
forall a. a -> Maybe a
Just
  Setcompression Int
th -> STM () -> Eff es ()
forall (es :: [Effect]) a. (Concurrent :> es) => STM a -> Eff es a
atomically (STM () -> Eff es ()) -> STM () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ TVar Int -> Int -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Connection
cx.cxcompth Int
th
  Setencryption ByteString
key -> STM () -> Eff es ()
forall (es :: [Effect]) a. (Concurrent :> es) => STM a -> Eff es a
atomically (STM () -> Eff es ()) -> STM () -> Eff es ()
forall a b. (a -> b) -> a -> b
$ TVar (Maybe ByteString) -> Maybe ByteString -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar Connection
cx.cxkey (ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
key)

handlehearu :: (IOE :> es) => InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu :: forall (es :: [Effect]).
(IOE :> es) =>
InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu InputStream Uninterpreted
i = IO (Maybe Uninterpreted) -> Eff es (Maybe Uninterpreted)
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (InputStream Uninterpreted -> IO (Maybe Uninterpreted)
forall a. InputStream a -> IO (Maybe a)
read InputStream Uninterpreted
i) Eff es (Maybe Uninterpreted)
-> (Maybe Uninterpreted -> Eff es Uninterpreted)
-> Eff es Uninterpreted
forall a b. Eff es a -> (a -> Eff es b) -> Eff es b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Eff es Uninterpreted
-> (Uninterpreted -> Eff es Uninterpreted)
-> Maybe Uninterpreted
-> Eff es Uninterpreted
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (EOF -> Eff es Uninterpreted
forall e (es :: [Effect]) a.
(HasCallStack, Exception e) =>
e -> Eff es a
throwIO EOF
EOF) Uninterpreted -> Eff es Uninterpreted
forall a. a -> Eff es a
forall (f :: * -> *) a. Applicative f => a -> f a
pure

handlehearu_immediate ::
  (IOE :> es, NonDet :> es) =>
  InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu_immediate :: forall (es :: [Effect]).
(IOE :> es, NonDet :> es) =>
InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu_immediate InputStream Uninterpreted
i = do
  mv <- IO (Maybe Uninterpreted) -> Eff es (Maybe Uninterpreted)
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe Uninterpreted) -> Eff es (Maybe Uninterpreted))
-> IO (Maybe Uninterpreted) -> Eff es (Maybe Uninterpreted)
forall a b. (a -> b) -> a -> b
$ InputStream Uninterpreted -> IO (Maybe Uninterpreted)
forall a. InputStream a -> IO (Maybe a)
peek InputStream Uninterpreted
i
  case mv of
    Maybe Uninterpreted
Nothing -> Eff es Uninterpreted
forall a. Eff es a
forall (f :: * -> *) a. Alternative f => f a
empty
    Just Uninterpreted
v -> IO (Maybe Uninterpreted) -> Eff es (Maybe Uninterpreted)
forall a. IO a -> Eff es a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (InputStream Uninterpreted -> IO (Maybe Uninterpreted)
forall a. InputStream a -> IO (Maybe a)
read InputStream Uninterpreted
i) Eff es (Maybe Uninterpreted)
-> Uninterpreted -> Eff es Uninterpreted
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Uninterpreted
v

handleheara ::
  (IOE :> es, State ParserState :> es) =>
  InputStream Uninterpreted -> Eff es SomeUnpack
handleheara :: forall (es :: [Effect]).
(IOE :> es, State ParserState :> es) =>
InputStream Uninterpreted -> Eff es SomeUnpack
handleheara InputStream Uninterpreted
i = do
  u <- InputStream Uninterpreted -> Eff es Uninterpreted
forall (es :: [Effect]).
(IOE :> es) =>
InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu InputStream Uninterpreted
i
  ParserState p <- get
  let v = Op SomeUnpack -> SomeUnpack
forall r. Op r -> r
p (Uninterpreted -> Op SomeUnpack
Parse Uninterpreted
u)
  pure v

handleheara_immediate ::
  (IOE :> es, State ParserState :> es, NonDet :> es) =>
  InputStream Uninterpreted -> Eff es SomeUnpack
handleheara_immediate :: forall (es :: [Effect]).
(IOE :> es, State ParserState :> es, NonDet :> es) =>
InputStream Uninterpreted -> Eff es SomeUnpack
handleheara_immediate InputStream Uninterpreted
i = do
  u <- InputStream Uninterpreted -> Eff es Uninterpreted
forall (es :: [Effect]).
(IOE :> es, NonDet :> es) =>
InputStream Uninterpreted -> Eff es Uninterpreted
handlehearu_immediate InputStream Uninterpreted
i
  ParserState p <- get
  pure $ p (Parse u)

-- | run server accepting multiple connections
withtalkingserver ::
  ( IOE :> es,
    State ParserState :> es,
    Concurrent :> es,
    NonDet :> es
  ) =>
  -- | host (Nothing = all interfaces)
  Maybe String ->
  -- | port
  String ->
  -- | per-connection handler
  Eff (Talking : es) a ->
  -- | final result
  Eff es a
withtalkingserver :: forall (es :: [Effect]) a.
(IOE :> es, State ParserState :> es, Concurrent :> es,
 NonDet :> es) =>
Maybe String -> String -> Eff (Talking : es) a -> Eff es a
withtalkingserver Maybe String
host String
port Eff (Talking : es) a
handler = do
  -- affected by the ambient unlifting strategy.
  -- set it somewhere else using withUnliftStrategy.
  let host' :: String
host'
        | Just String
h <- Maybe String
host = String
h
        | Bool
otherwise = String
"0.0.0.0"
  String -> String -> (Socket -> Eff es a) -> Eff es a
forall (m :: * -> *) b a.
MonadUnliftIO m =>
String -> String -> (Socket -> m b) -> m a
runTCPServer String
host' String
port \Socket
sock -> ((forall a. Eff es a -> IO a) -> IO a) -> Eff es a
forall b. ((forall a. Eff es a -> IO a) -> IO b) -> Eff es b
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO \forall a. Eff es a -> IO a
run -> do
    Socket -> (Connection -> IO a) -> IO a
forall (m :: * -> *) a.
MonadUnliftIO m =>
Socket -> (Connection -> m a) -> m a
withcxfromsocket Socket
sock \Connection
cx -> do
      Eff es a -> IO a
forall a. Eff es a -> IO a
run (Eff es a -> IO a) -> Eff es a -> IO a
forall a b. (a -> b) -> a -> b
$ Connection -> Eff (Talking : es) a -> Eff es a
forall (es :: [Effect]) a.
(IOE :> es, NonDet :> es, State ParserState :> es,
 Concurrent :> es) =>
Connection -> Eff (Talking : es) a -> Eff es a
runtalking0 Connection
cx Eff (Talking : es) a
handler

-- compatibility with func of same name in "network" package; just unlifted
runTCPServer ::
  (MonadUnliftIO m) =>
  String -> String -> (Socket -> m b) -> m a
runTCPServer :: forall (m :: * -> *) b a.
MonadUnliftIO m =>
String -> String -> (Socket -> m b) -> m a
runTCPServer String
host String
port Socket -> m b
client = do
  let hint :: AddrInfo_
hint =
        AddrInfo_
addrinfo0
          { ai_socktype = SOCK_STREAM,
            ai_protocol = IPPROTO_TCP,
            ai_family = AF_INET
          }
      mksocket :: m Socket
mksocket = AddrFamily -> SocketType -> Protocol -> m Socket
forall (m :: * -> *).
MonadIO m =>
AddrFamily -> SocketType -> Protocol -> m Socket
socket AddrInfo_
hint.ai_family AddrInfo_
hint.ai_socktype AddrInfo_
hint.ai_protocol
  addr <- String -> String -> Maybe AddrInfo_ -> m AddrInfo
forall (m :: * -> *).
MonadIO m =>
String -> String -> Maybe AddrInfo_ -> m AddrInfo
getaddrinfo String
host String
port (AddrInfo_ -> Maybe AddrInfo_
forall a. a -> Maybe a
Just AddrInfo_
hint)
  Unfe.bracket mksocket close \Socket
sock -> do
    AddrInfo -> (AddrLen -> m ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
AddrInfo -> (AddrLen -> m a) -> m a
withaddrlen AddrInfo
addr do Socket -> AddrLen -> m ()
forall (m :: * -> *). MonadIO m => Socket -> AddrLen -> m ()
bind Socket
sock
    Socket -> m ()
forall (m :: * -> *). MonadIO m => Socket -> m ()
listen Socket
sock
    m b -> m a
forall (f :: * -> *) a b. Applicative f => f a -> f b
forever do
      m Socket -> (Socket -> m ()) -> (Socket -> m b) -> m b
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
Unfe.bracket
        do Socket -> m Socket
forall (m :: * -> *). MonadIO m => Socket -> m Socket
accept Socket
sock -- wait happens here
        do close -- close the socket!
        do client -- gets passed the socket