{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators #-}

-- |
--   Module     : Polysemy.Socket
--   License    : MIT
--   Stability  : experimental
--
-- Socket effect for polysemy.
module Polysemy.Socket
  ( -- * Definition
    Socket (..),
    acquire,
    bind,
    listen,
    send,
    receive,
    release,
    accept,
    close,

    -- * Adapters
    adaptSocket,
    adaptSocketSem,

    -- * Eliminators
    runSocketTcp,
    runSocketVirtual,
    Virtual,

    -- * Tracing
    traceSocket,
  )
where

import Control.Monad
import Data.ByteString (ByteString)
import Polysemy
import Polysemy.Input
import Polysemy.Resource
import Polysemy.State
import Polysemy.Trace
import qualified System.Socket as S
import qualified System.Socket.Family.Inet6 as S
import qualified System.Socket.Protocol.TCP as S
import qualified System.Socket.Type.Stream as S

-- |
--
-- @since 0.0.1.0
data Socket s k b c m a where
  Acquire :: Socket s k b c m s
  Bind :: s -> Socket s k b c m ()
  Release :: s -> Socket s k b c m ()
  Listen :: s -> Int -> Socket s k b c m ()
  Accept :: s -> Socket s k b c m (s, k)
  Send :: s -> c -> Socket s k b c m ()
  Receive :: s -> Socket s k b c m b
  Close :: s -> Socket s k b c m ()

makeSem ''Socket

-- |
--
-- @since 0.0.1.0
traceSocket :: forall s k b c r a. Members '[Socket s k b c, Trace] r => Sem r a -> Sem r a
traceSocket :: Sem r a -> Sem r a
traceSocket = forall (r :: EffectRow) a.
(Member (Socket s k b c) r,
 FirstOrder (Socket s k b c) "intercept") =>
(forall x (rInitial :: EffectRow).
 Socket s k b c (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
(Member e r, FirstOrder e "intercept") =>
(forall x (rInitial :: EffectRow). e (Sem rInitial) x -> Sem r x)
-> Sem r a -> Sem r a
intercept @(Socket s k b c) ((forall x (rInitial :: EffectRow).
  Socket s k b c (Sem rInitial) x -> Sem r x)
 -> Sem r a -> Sem r a)
-> (forall x (rInitial :: EffectRow).
    Socket s k b c (Sem rInitial) x -> Sem r x)
-> Sem r a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Socket s k b c (Sem rInitial) x
Acquire -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"acquring" Sem r () -> Sem r s -> Sem r s
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
Sem r s
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
Sem r s
acquire @s @k @b @c
  Bind s
s -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"binding" Sem r () -> Sem r () -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r ()
bind @s @k @b @c s
s
  Listen s
s Int
x -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"listening" Sem r () -> Sem r () -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> Int -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Int -> Sem r ()
listen @s @k @b @c s
s Int
x
  Receive s
s -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"receiving" Sem r () -> Sem r b -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> Sem r b
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r b
receive @s @k @b @c s
s
  Send s
s c
x -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"sending" Sem r () -> Sem r () -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> c -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> c -> Sem r ()
send @s @k @b @c s
s c
x
  Release s
s -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"releasing" Sem r () -> Sem r () -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r ()
release @s @k @b @c s
s
  Accept s
s -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"accept" Sem r () -> Sem r (s, k) -> Sem r (s, k)
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> Sem r (s, k)
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r (s, k)
accept @s @k @b @c s
s
  Close s
s -> String -> Sem r ()
forall (r :: EffectRow).
MemberWithError Trace r =>
String -> Sem r ()
trace String
"closing" Sem r () -> Sem r () -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> s -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r ()
close @s @k @b @c s
s
{-# INLINE traceSocket #-}

-- |
--
-- @since 0.0.1.0
adaptSocket :: Members '[Socket s k b' c'] r => (b' -> b) -> (c -> c') -> Sem (Socket s k b c ': r) a -> Sem r a
adaptSocket :: (b' -> b) -> (c -> c') -> Sem (Socket s k b c : r) a -> Sem r a
adaptSocket b' -> b
f c -> c'
g = (b' -> Sem r b)
-> (c -> Sem r c') -> Sem (Socket s k b c : r) a -> Sem r a
forall s k b c b' c' (r :: EffectRow) a.
Members '[Socket s k b' c'] r =>
(b' -> Sem r b)
-> (c -> Sem r c') -> Sem (Socket s k b c : r) a -> Sem r a
adaptSocketSem (b -> Sem r b
forall (f :: * -> *) a. Applicative f => a -> f a
pure (b -> Sem r b) -> (b' -> b) -> b' -> Sem r b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. b' -> b
f) (c' -> Sem r c'
forall (f :: * -> *) a. Applicative f => a -> f a
pure (c' -> Sem r c') -> (c -> c') -> c -> Sem r c'
forall b c a. (b -> c) -> (a -> b) -> a -> c
. c -> c'
g)
{-# INLINE adaptSocket #-}

-- |
--
-- @since 0.0.1.0
adaptSocketSem :: forall s k b c b' c' r a. Members '[Socket s k b' c'] r => (b' -> Sem r b) -> (c -> Sem r c') -> Sem (Socket s k b c ': r) a -> Sem r a
adaptSocketSem :: (b' -> Sem r b)
-> (c -> Sem r c') -> Sem (Socket s k b c : r) a -> Sem r a
adaptSocketSem b' -> Sem r b
f c -> Sem r c'
g = (forall (rInitial :: EffectRow) x.
 Socket s k b c (Sem rInitial) x -> Sem r x)
-> Sem (Socket s k b c : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Socket s k b c (Sem rInitial) x -> Sem r x)
 -> Sem (Socket s k b c : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Socket s k b c (Sem rInitial) x -> Sem r x)
-> Sem (Socket s k b c : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Socket s k b c (Sem rInitial) x
Acquire -> forall (r :: EffectRow).
MemberWithError (Socket s k b' c') r =>
Sem r s
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
Sem r s
acquire @s @k @b' @c'
  Bind s -> s -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r ()
bind @s @k @b' @c' s
s
  Release s -> s -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r ()
release @s @k @b' @c' s
s
  Listen s x -> s -> Int -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Int -> Sem r ()
listen @s @k @b' @c' s
s Int
x
  Accept s -> s -> Sem r (s, k)
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r (s, k)
accept @s @k @b' @c' s
s
  Send s c -> c -> Sem r c'
g c
c Sem r c' -> (c' -> Sem r ()) -> Sem r ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= s -> c' -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> c -> Sem r ()
send @s @k @b' @c' s
s
  Receive s -> s -> Sem r b'
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r b
receive @s @k @b' @c' s
s Sem r b' -> (b' -> Sem r b) -> Sem r b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= b' -> Sem r b
f
  Close s -> s -> Sem r ()
forall s k b c (r :: EffectRow).
MemberWithError (Socket s k b c) r =>
s -> Sem r ()
close @s @k @b' @c' s
s
{-# INLINE adaptSocketSem #-}

-- |
--
-- @since 0.0.1.0
runSocketTcp ::
  forall s r a.
  ( S.Socket S.Inet6 S.Stream S.TCP ~ s,
    Members '[Resource, Embed IO, Input S.Inet6Port] r
  ) =>
  Sem (Socket s (S.SocketAddress S.Inet6) ByteString ByteString ': r) a ->
  Sem r a
runSocketTcp :: Sem (Socket s (SocketAddress Inet6) ByteString ByteString : r) a
-> Sem r a
runSocketTcp = (forall (rInitial :: EffectRow) x.
 Socket
   s (SocketAddress Inet6) ByteString ByteString (Sem rInitial) x
 -> Sem r x)
-> Sem (Socket s (SocketAddress Inet6) ByteString ByteString : r) a
-> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Socket
    s (SocketAddress Inet6) ByteString ByteString (Sem rInitial) x
  -> Sem r x)
 -> Sem (Socket s (SocketAddress Inet6) ByteString ByteString : r) a
 -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Socket
      s (SocketAddress Inet6) ByteString ByteString (Sem rInitial) x
    -> Sem r x)
-> Sem (Socket s (SocketAddress Inet6) ByteString ByteString : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Socket
  s (SocketAddress Inet6) ByteString ByteString (Sem rInitial) x
Acquire -> IO (Socket Inet6 Stream TCP) -> Sem r (Socket Inet6 Stream TCP)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Socket Inet6 Stream TCP) -> Sem r (Socket Inet6 Stream TCP))
-> IO (Socket Inet6 Stream TCP) -> Sem r (Socket Inet6 Stream TCP)
forall a b. (a -> b) -> a -> b
$ IO (Socket Inet6 Stream TCP)
forall f t p. (Family f, Type t, Protocol p) => IO (Socket f t p)
S.socket
  Bind s -> do
    Inet6Port
x <- forall (r :: EffectRow).
MemberWithError (Input Inet6Port) r =>
Sem r Inet6Port
forall i (r :: EffectRow). MemberWithError (Input i) r => Sem r i
input @S.Inet6Port
    IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
Polysemy.embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ do
      Socket Inet6 Stream TCP -> ReuseAddress -> IO ()
forall o f t p. SocketOption o => Socket f t p -> o -> IO ()
S.setSocketOption Socket Inet6 Stream TCP
s (Bool -> ReuseAddress
S.ReuseAddress Bool
True)
      Socket Inet6 Stream TCP -> V6Only -> IO ()
forall o f t p. SocketOption o => Socket f t p -> o -> IO ()
S.setSocketOption Socket Inet6 Stream TCP
s (Bool -> V6Only
S.V6Only Bool
False)
      Socket Inet6 Stream TCP -> SocketAddress Inet6 -> IO ()
forall f t p. Family f => Socket f t p -> SocketAddress f -> IO ()
S.bind Socket Inet6 Stream TCP
s (Inet6Address
-> Inet6Port
-> Inet6FlowInfo
-> Inet6ScopeId
-> SocketAddress Inet6
S.SocketAddressInet6 Inet6Address
S.inet6Any Inet6Port
x Inet6FlowInfo
0 Inet6ScopeId
0)
  Listen s x -> IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> Int -> IO ()
forall f t p. Socket f t p -> Int -> IO ()
S.listen Socket Inet6 Stream TCP
s Int
x
  Receive s -> IO ByteString -> Sem r ByteString
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO ByteString -> Sem r ByteString)
-> IO ByteString -> Sem r ByteString
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> Int -> MessageFlags -> IO ByteString
forall f t p. Socket f t p -> Int -> MessageFlags -> IO ByteString
S.receive Socket Inet6 Stream TCP
s Int
1024 MessageFlags
forall a. Monoid a => a
mempty
  Send s x -> Sem r Int -> Sem r ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (Sem r Int -> Sem r ()) -> Sem r Int -> Sem r ()
forall a b. (a -> b) -> a -> b
$ IO Int -> Sem r Int
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO Int -> Sem r Int) -> IO Int -> Sem r Int
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> ByteString -> MessageFlags -> IO Int
forall f p.
Socket f Stream p -> ByteString -> MessageFlags -> IO Int
S.sendAll Socket Inet6 Stream TCP
s ByteString
x MessageFlags
S.msgNoSignal
  Release s -> IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> IO ()
forall f t p. Socket f t p -> IO ()
S.close Socket Inet6 Stream TCP
s
  Accept s -> IO (Socket Inet6 Stream TCP, SocketAddress Inet6)
-> Sem r (Socket Inet6 Stream TCP, SocketAddress Inet6)
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO (Socket Inet6 Stream TCP, SocketAddress Inet6)
 -> Sem r (Socket Inet6 Stream TCP, SocketAddress Inet6))
-> IO (Socket Inet6 Stream TCP, SocketAddress Inet6)
-> Sem r (Socket Inet6 Stream TCP, SocketAddress Inet6)
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP
-> IO (Socket Inet6 Stream TCP, SocketAddress Inet6)
forall f t p.
Family f =>
Socket f t p -> IO (Socket f t p, SocketAddress f)
S.accept Socket Inet6 Stream TCP
s
  Close s -> IO () -> Sem r ()
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO () -> Sem r ()) -> IO () -> Sem r ()
forall a b. (a -> b) -> a -> b
$ Socket Inet6 Stream TCP -> IO ()
forall f t p. Socket f t p -> IO ()
S.close Socket Inet6 Stream TCP
s
{-# INLINE runSocketTcp #-}

data Virtual = Virtual

-- |
--
-- @since 0.0.1.0
runSocketVirtual :: Members '[State p] r => (c -> p) -> (p -> b) -> Sem (Socket Virtual Virtual b c ': r) a -> Sem r a
runSocketVirtual :: (c -> p)
-> (p -> b) -> Sem (Socket Virtual Virtual b c : r) a -> Sem r a
runSocketVirtual c -> p
f p -> b
g = (forall (rInitial :: EffectRow) x.
 Socket Virtual Virtual b c (Sem rInitial) x -> Sem r x)
-> Sem (Socket Virtual Virtual b c : r) a -> Sem r a
forall (e :: Effect) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret ((forall (rInitial :: EffectRow) x.
  Socket Virtual Virtual b c (Sem rInitial) x -> Sem r x)
 -> Sem (Socket Virtual Virtual b c : r) a -> Sem r a)
-> (forall (rInitial :: EffectRow) x.
    Socket Virtual Virtual b c (Sem rInitial) x -> Sem r x)
-> Sem (Socket Virtual Virtual b c : r) a
-> Sem r a
forall a b. (a -> b) -> a -> b
$ \case
  Socket Virtual Virtual b c (Sem rInitial) x
Acquire -> Virtual -> Sem r Virtual
forall (f :: * -> *) a. Applicative f => a -> f a
pure Virtual
Virtual
  Bind _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Release _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Listen _ _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Accept _ -> (Virtual, Virtual) -> Sem r (Virtual, Virtual)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Virtual
Virtual, Virtual
Virtual)
  Send _ c -> p -> Sem r ()
forall s (r :: EffectRow).
MemberWithError (State s) r =>
s -> Sem r ()
put (c -> p
f c
c)
  Receive _ -> p -> b
g (p -> b) -> Sem r p -> Sem r b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sem r p
forall s (r :: EffectRow). MemberWithError (State s) r => Sem r s
get
  Close _ -> () -> Sem r ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
{-# INLINE runSocketVirtual #-}