<commit_before>{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving  #-}
module SecondTransfer.IOCallbacks.SocketServer(
                SocketIOCallbacks
              , TLSServerSocketIOCallbacks                          (..)
              , createAndBindListeningSocket
              , createAndBindListeningSocketNSSockAddr
              , socketIOCallbacks

              -- ** Socket server with callbacks
              , tcpServe
              , tlsServe

              -- ** Socket server with iterators
              , tcpItcli
              , tlsItcli
       ) where


import           Control.Concurrent                                 (threadDelay)
import qualified Control.Exception                                  as E
--import           Control.Lens                                       (makeLenses, (^.))
import           Control.Monad.IO.Class                             (liftIO)

import           Data.Conduit
import qualified Data.Conduit.List                                  as CL

--import qualified Data.ByteString                                    as B
--import qualified Data.ByteString.Lazy                               as LB
--import           Data.ByteString.Char8                              (pack, unpack)
--import           Data.List                                          (find)

-- import           System.Exit
--import           System.Posix.Signals
import           System.IO.Error                                    (ioeGetErrorString)

import qualified Network.Socket                                     as NS
--import qualified Network.Socket.ByteString                          as NSB


import           SecondTransfer.IOCallbacks.Types
import           SecondTransfer.IOCallbacks.WrapSocket              (socketIOCallbacks, SocketIOCallbacks, HasSocketPeer(..))
--import           SecondTransfer.Exception                           (NoMoreDataException(..))
#include "instruments.cpphs"


-- | Simple alias to SocketIOCallbacks where we expect
--   encrypted contents
newtype TLSServerSocketIOCallbacks = TLSServerSocketIOCallbacks SocketIOCallbacks
    deriving IOChannels

instance TLSEncryptedIO TLSServerSocketIOCallbacks
instance TLSServerIO TLSServerSocketIOCallbacks

instance HasSocketPeer TLSServerSocketIOCallbacks where
    getSocketPeerAddress (TLSServerSocketIOCallbacks s) = getSocketPeerAddress s

-- | Creates a listening socket at the provided network address (potentially a local interface)
--   and the given port number. It returns the socket. This result can be used by the function
--   tcpServe below
createAndBindListeningSocket :: String -> Int ->  IO NS.Socket
createAndBindListeningSocket hostname portnumber = do
    the_socket <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol
    addr_info0 : _ <- NS.getAddrInfo Nothing (Just hostname) Nothing
    addr_info1  <- return $ addr_info0 {
        NS.addrFamily = NS.AF_INET
      , NS.addrSocketType = NS.Stream
      , NS.addrAddress =
          (\ (NS.SockAddrInet _ a) -> NS.SockAddrInet (fromIntegral portnumber) a)
              (NS.addrAddress addr_info0)
        }
    host_address <- return $ NS.addrAddress addr_info1
    NS.setSocketOption the_socket NS.ReusePort 1
    NS.setSocketOption the_socket NS.RecvBuffer 32000
    NS.setSocketOption the_socket NS.SendBuffer 32000
    -- Linux honors the Low Water thingy below, and this setting is OK for HTTP/2 connections, but
    -- not very needed since the TLS wrapping will inflate the packet well beyond that size.
    -- See about this option here: http://stackoverflow.com/questions/8245937/whats-the-purpose-of-the-socket-option-so-sndlowat
    --
    -- NS.setSocketOption the_socket NS.RecvLowWater 8
    --
    NS.setSocketOption the_socket NS.NoDelay 1
    NS.bind the_socket host_address
    -- bound <- NS.isBound the_socket
    return the_socket

-- | Same as above, but it takes a pre-built address
createAndBindListeningSocketNSSockAddr :: NS.SockAddr ->  IO NS.Socket
createAndBindListeningSocketNSSockAddr host_addr = do
    the_socket <- case host_addr of
        NS.SockAddrInet _ _ -> NS.socket NS.AF_INET NS.Stream NS.defaultProtocol
        NS.SockAddrUnix _ -> NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol
        _ -> error "NetworkAddressTypeNotHandled"
    NS.setSocketOption the_socket NS.ReusePort 1
    NS.setSocketOption the_socket NS.RecvBuffer 32000
    NS.setSocketOption the_socket NS.SendBuffer 32000
    -- Linux honors the Low Water thingy below, and this setting is OK for HTTP/2 connections, but
    -- not very needed since the TLS wrapping will inflate the packet well beyond that size.
    -- See about this option here: http://stackoverflow.com/questions/8245937/whats-the-purpose-of-the-socket-option-so-sndlowat
    --
    -- NS.setSocketOption the_socket NS.RecvLowWater 8
    --
    NS.setSocketOption the_socket NS.NoDelay 1
    NS.bind the_socket host_addr
    -- bound <- NS.isBound the_socket
    return the_socket


-- | Simple TCP server. You must give a very short action, as the action
--   is run straight in the calling thread.
--   For a typical server, you would be doing a forkIO in the provided action.
--   Do prefer to use tcpItcli directly.
tcpServe :: NS.Socket -> ( NS.Socket -> IO () ) -> IO ()
tcpServe  listen_socket action =
    tcpItcli listen_socket $$ CL.mapM_  (action . fst)


-- | Itcli is a word made from "ITerate-on-CLIents". This function makes an iterated
--   listen...
tcpItcli :: NS.Socket -> Source IO (NS.Socket, NS.SockAddr)
tcpItcli listen_socket =
    -- NOTICE: The messages below should be considered traps. Whenever one
    -- of them shows up, we have hit a new abnormal condition that should
    -- be learn from
    do
        liftIO $ NS.listen listen_socket 20
        LIO_REPORT_EVENT("listening")
        let
          report_abnormality = do
              putStrLn "ERROR: TCP listen abstraction undone!!"
          -- TODO: System interrupts propagates freely!
          iterate' = do
              either_x <- liftIO . E.try $ NS.accept listen_socket
              case either_x of
                  Left e  | ioeGetErrorString e  == "resource exhausted" -> do
                              LIO_REPORT_EVENT("resource-exhausted")
                              liftIO $ threadDelay  (1000 * 1000)
                              iterate'
                          | ioeGetErrorString e == "signal" -> do
                              -- TODO: Some signals here should be processed differently, most likely!!
                              LIO_REPORT_EVENT("tcp-exit-on-signal")<commit_msg>Moved listen call to createAndBindListeningSocket<commit_after>{-# LANGUAGE TemplateHaskell, OverloadedStrings, GeneralizedNewtypeDeriving  #-}
module SecondTransfer.IOCallbacks.SocketServer(
                SocketIOCallbacks
              , TLSServerSocketIOCallbacks                          (..)
              , createAndBindListeningSocket
              , createAndBindListeningSocketNSSockAddr
              , socketIOCallbacks

              -- ** Socket server with callbacks
              , tcpServe
              , tlsServe

              -- ** Socket server with iterators
              , tcpItcli
              , tlsItcli
       ) where


import           Control.Concurrent                                 (threadDelay)
import qualified Control.Exception                                  as E
--import           Control.Lens                                       (makeLenses, (^.))
import           Control.Monad.IO.Class                             (liftIO)

import           Data.Conduit
import qualified Data.Conduit.List                                  as CL

--import qualified Data.ByteString                                    as B
--import qualified Data.ByteString.Lazy                               as LB
--import           Data.ByteString.Char8                              (pack, unpack)
--import           Data.List                                          (find)

-- import           System.Exit
--import           System.Posix.Signals
import           System.IO.Error                                    (ioeGetErrorString)

import qualified Network.Socket                                     as NS
--import qualified Network.Socket.ByteString                          as NSB


import           SecondTransfer.IOCallbacks.Types
import           SecondTransfer.IOCallbacks.WrapSocket              (socketIOCallbacks, SocketIOCallbacks, HasSocketPeer(..))
--import           SecondTransfer.Exception                           (NoMoreDataException(..))
#include "instruments.cpphs"


-- | Simple alias to SocketIOCallbacks where we expect
--   encrypted contents
newtype TLSServerSocketIOCallbacks = TLSServerSocketIOCallbacks SocketIOCallbacks
    deriving IOChannels

instance TLSEncryptedIO TLSServerSocketIOCallbacks
instance TLSServerIO TLSServerSocketIOCallbacks

instance HasSocketPeer TLSServerSocketIOCallbacks where
    getSocketPeerAddress (TLSServerSocketIOCallbacks s) = getSocketPeerAddress s

-- | Creates a listening socket at the provided network address (potentially a local interface)
--   and the given port number. It returns the socket. This result can be used by the function
--   tcpServe below
createAndBindListeningSocket :: String -> Int ->  IO NS.Socket
createAndBindListeningSocket hostname portnumber = do
    the_socket <- NS.socket NS.AF_INET NS.Stream NS.defaultProtocol
    addr_info0 : _ <- NS.getAddrInfo Nothing (Just hostname) Nothing
    addr_info1  <- return $ addr_info0 {
        NS.addrFamily = NS.AF_INET
      , NS.addrSocketType = NS.Stream
      , NS.addrAddress =
          (\ (NS.SockAddrInet _ a) -> NS.SockAddrInet (fromIntegral portnumber) a)
              (NS.addrAddress addr_info0)
        }
    host_address <- return $ NS.addrAddress addr_info1
    NS.setSocketOption the_socket NS.ReusePort 1
    NS.setSocketOption the_socket NS.RecvBuffer 32000
    NS.setSocketOption the_socket NS.SendBuffer 32000
    -- Linux honors the Low Water thingy below, and this setting is OK for HTTP/2 connections, but
    -- not very needed since the TLS wrapping will inflate the packet well beyond that size.
    -- See about this option here: http://stackoverflow.com/questions/8245937/whats-the-purpose-of-the-socket-option-so-sndlowat
    --
    -- NS.setSocketOption the_socket NS.RecvLowWater 8
    --
    NS.setSocketOption the_socket NS.NoDelay 1
    NS.bind the_socket host_address
    NS.listen the_socket 20
    putStrLn "LISTEN JUST CALLED"
    -- bound <- NS.isBound the_socket
    return the_socket

-- | Same as above, but it takes a pre-built address
createAndBindListeningSocketNSSockAddr :: NS.SockAddr ->  IO NS.Socket
createAndBindListeningSocketNSSockAddr host_addr = do
    the_socket <- case host_addr of
        NS.SockAddrInet _ _ -> NS.socket NS.AF_INET NS.Stream NS.defaultProtocol
        NS.SockAddrUnix _ -> NS.socket NS.AF_UNIX NS.Stream NS.defaultProtocol
        _ -> error "NetworkAddressTypeNotHandled"
    NS.setSocketOption the_socket NS.ReusePort 1
    NS.setSocketOption the_socket NS.RecvBuffer 32000
    NS.setSocketOption the_socket NS.SendBuffer 32000
    -- Linux honors the Low Water thingy below, and this setting is OK for HTTP/2 connections, but
    -- not very needed since the TLS wrapping will inflate the packet well beyond that size.
    -- See about this option here: http://stackoverflow.com/questions/8245937/whats-the-purpose-of-the-socket-option-so-sndlowat
    --
    -- NS.setSocketOption the_socket NS.RecvLowWater 8
    --
    NS.setSocketOption the_socket NS.NoDelay 1
    NS.bind the_socket host_addr
    NS.listen the_socket 20
    -- bound <- NS.isBound the_socket
    return the_socket


-- | Simple TCP server. You must give a very short action, as the action
--   is run straight in the calling thread.
--   For a typical server, you would be doing a forkIO in the provided action.
--   Do prefer to use tcpItcli directly.
tcpServe :: NS.Socket -> ( NS.Socket -> IO () ) -> IO ()
tcpServe  listen_socket action =
    tcpItcli listen_socket $$ CL.mapM_  (action . fst)


-- | Itcli is a word made from "ITerate-on-CLIents". This function makes an iterated
--   listen...
tcpItcli :: NS.Socket -> Source IO (NS.Socket, NS.SockAddr)
tcpItcli listen_socket =
    -- NOTICE: The messages below should be considered traps. Whenever one
    -- of them shows up, we have hit a new abnormal condition that should
    -- be learn from
    do
        LIO_REPORT_EVENT("listening")
        let
          report_abnormality = do
              putStrLn "ERROR: TCP listen abstraction undone!!"
          -- TODO: System interrupts propagates freely!
          iterate' = do
              either_x <- liftIO . E.try $ NS.accept listen_socket
              case either_x of
                  Left e  | ioeGetErrorString e  == "resource exhausted" -> do
                              LIO_REPORT_EVENT("resource-exhausted")
                              liftIO $ threadDelay  (1000 * 1000)
                              iterate'
                          | ioeGetErrorString e == "signal" -> do
                              -- TODO: Some signals here should be processed differently, most likely!!
                              LIO_REPORT_EVENT("tcp-exit-on-signal")
{'fraction_non_alphanumeric': 0.06790123456790123, 'fraction_numerical': 0.008882866606443843, 'mean_word_length': 2.0200045464878382, 'pattern_counts': {'":': 0, '<': 19, '<?xml version=': 0, '>': 29, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 20, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4620233', 'n_tokens_mistral': 3666, 'n_tokens_neox': 3499, 'n_words': 1037}