<commit_before>{-# Language OverloadedStrings, NondecreasingIndentation #-}

{-|
Module      : Client.EventLoop
Description : Event loop for IRC client
Copyright   : (c) <NAME>, 2016
License     : ISC
Maintainer  : <EMAIL>

This module is responsible for dispatching user-input, network, and timer
events to the correct module. It renders the user interface once per event.
-}

module Client.EventLoop
  ( eventLoop
  ) where

import           Client.CApi
import           Client.Commands
import           Client.Commands.Interpolation
import           Client.Configuration.ServerSettings
import           Client.EventLoop.Errors (exceptionToLines)
import           Client.Hook
import           Client.Hooks
import           Client.Image
import           Client.Message
import           Client.Network.Async
import           Client.State
import qualified Client.State.EditBox     as Edit
import           Client.State.Focus
import           Client.State.Network
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Lens
import           Control.Monad
import           Data.ByteString (ByteString)
import           Data.Foldable
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.Ord
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as Text
import           Data.Time
import           GHC.IO.Exception (IOErrorType(..), ioe_type)
import           Graphics.Vty
import           Irc.Codes
import           Irc.Message
import           Irc.RawIrcMsg
import           LensUtils
import           Network.Connection

reconnectAttempts :: Int
reconnectAttempts = 6

-- | Sum of the three possible event types the event loop handles
data ClientEvent
  = VtyEvent Event -- ^ Key presses and resizing
  | NetworkEvent NetworkEvent -- ^ Incoming network events
  | TimerEvent NetworkId TimedAction -- ^ Timed action and the applicable network


-- | Block waiting for the next 'ClientEvent'. This function will compute
-- an appropriate timeout based on the current connections.
getEvent :: ClientState -> IO ClientEvent
getEvent st =
  do timer <- prepareTimer
     atomically $
       asum [ timer
            , VtyEvent     <$> readTChan vtyEventChannel
            , NetworkEvent <$> readTQueue (view clientEvents st)
            ]
  where
    vtyEventChannel = _eventChannel (inputIface (view clientVty st))

    prepareTimer =
      case earliestEvent st of
        Nothing -> return retry
        Just (networkId,(runAt,action)) ->
          do now <- getCurrentTime
             let microsecs = truncate (1000000 * diffUTCTime runAt now)
             var <- registerDelay (max 0 microsecs)
             return $ do ready <- readTVar var
                         unless ready retry
                         return (TimerEvent networkId action)

-- | Compute the earliest scheduled timed action for the client
earliestEvent :: ClientState -> Maybe (NetworkId, (UTCTime, TimedAction))
earliestEvent =
  minimumByOf
    (clientConnections . (ifolded <. folding nextTimedAction) . withIndex)
    (comparing (fst . snd))

-- | Apply this function to an initial 'ClientState' to launch the client.
eventLoop :: ClientState -> IO ()
eventLoop st0 =
  do let st1 = clientTick st0
         vty = view clientVty st
         (pic, st) = clientPicture st1

     -- check st0 for bell, it will be always be cleared in st1
     when (view clientBell st0) (beep vty)
     update vty pic

     event <- getEvent st
     case event of
       TimerEvent networkId action  -> doTimerEvent networkId action st
       VtyEvent vtyEvent         -> doVtyEvent vtyEvent st
       NetworkEvent networkEvent ->
         case networkEvent of
           NetworkLine  network time line -> doNetworkLine network time line st
           NetworkError network time ex   -> doNetworkError network time ex st
           NetworkOpen  network time      -> doNetworkOpen  network time st
           NetworkClose network time      -> doNetworkClose network time st

-- | Sound the terminal bell assuming that the @BEL@ control code
-- is supported.
beep :: Vty -> IO ()
beep = ringTerminalBell . outputIface

-- | Respond to a network connection successfully connecting.
doNetworkOpen ::
  NetworkId   {- ^ network id   -} ->
  ZonedTime   {- ^ event time   -} ->
  ClientState {- ^ client state -} ->
  IO ()
doNetworkOpen networkId time st =
  case view (clientConnections . at networkId) st of
    Nothing -> error "doNetworkOpen: Network missing"
    Just cs ->
      let msg = ClientMessage
                  { _msgTime    = time
                  , _msgNetwork = view csNetwork cs
                  , _msgBody    = NormalBody "connection opened"
                  }
      in eventLoop $ recordNetworkMessage msg
                   $ overStrict (clientConnections . ix networkId . csLastReceived)
                                (\old -> old `seq` Just $! zonedTimeToUTC time) st

-- | Respond to a network connection closing normally.
doNetworkClose ::
  NetworkId {- ^ network id -} ->
  ZonedTime {- ^ event time -} ->
  ClientState -> IO ()
doNetworkClose networkId time st =
  let (cs,st') = removeNetwork networkId st
      msg = ClientMessage
              { _msgTime    = time
              , _msgNetwork = view csNetwork cs
              , _msgBody    = NormalBody "connection closed"
              }
  in eventLoop $ recordNetworkMessage msg st'


-- | Respond to a network connection closing abnormally.
doNetworkError ::
  NetworkId {- ^ failed network -} ->
  ZonedTime {- ^ current time   -} ->
  SomeException {- ^ termination reason -} ->
  ClientState -> IO ()
doNetworkError networkId time ex st =
  do let (cs,st1) = removeNetwork networkId st
         st2 = foldl' (\acc msg -> recordError time cs (Text.pack msg) acc) st1
             $ exceptionToLines ex

         shouldReconnect =
           case view csPingStatus cs of
             PingConnecting n _
               | n == 0 || n > reconnectAttempts -> False

             _ | Just HostNotResolved{}   <-              fromException ex -> True
               | Just HostCannotConnect{} <-              fromException ex -> True
               | Just PingTimeout         <-              fromException ex -> True
               | Just ResourceVanished    <- ioe_type <$> fromException ex -> True
               | Just NoSuchThing         <- ioe_type <$> fromException ex -> True

               | otherwise -> False


         reconnect = do
           (attempts, mbDisconnectTime)
              <- case view csPingStatus cs of
                   PingConnecting n tm                   -> pure (n+1, tm)
                   _ | Just tm <- view csLastReceived cs -> pure (1, Just tm)
                     | otherwise -> do now <- getCurrentTime
                                       pure (1, Just now)
           addConnection attempts mbDisconnectTime (view csNetwork cs) st2

         nextAction
           | shouldReconnect = reconnect
           | otherwise       = return st2

     eventLoop =<< nextAction


-- | Respond to an IRC protocol line. This will parse the message, updated the
-- relevant connection state and update the UI buffers.
doNetworkLine ::
  NetworkId {- ^ Network ID of message -} ->
  ZonedTime {- ^ current time          -} ->
  ByteString {- ^ Raw IRC message without newlines -} ->
  ClientState -> IO ()
doNetworkLine networkId time line st =
  case view (clientConnections . at networkId) st of
    Nothing -> error "doNetworkLine: Network missing"
    Just cs ->
      let network = view csNetwork cs in
      case parseRawIrcMsg (asUtf8 line) of
        Nothing ->
          do let msg = Text.pack ("Malformed message: " ++ show line)
             eventLoop (recordError time cs msg st)

        Just raw ->
          do (st1,passed) <- clientPark st $ \ptr ->
                               notifyExtensions ptr network raw
                                 (view (clientExtensions . esActive) st)


             if not passed then eventLoop st1 else do

             let time' = computeEffectiveTime time (view msgTags raw)

                 (stateHook, viewHook)
                      = over both applyMessageHooks
                      $ partition (view messageHookStateful)
                      $ lookups
                          (view csMessageHooks cs)
                          messageHooks

             case stateHook (cookIrcMsg raw) of
               Nothing  -> eventLoop st1 -- Message ignored
               Just irc -> do traverse_ (sendMsg cs) replies
                              st3 <- clientResponse time' irc cs st2
                              eventLoop st3
                 where
                   -- state with message recorded
                   recSt = case viewHook irc of
                             Nothing   -> st1 -- Message hidden
                             Just irc' -> recordIrcMessage network target msg st1
                               where
                                 myNick = view csNick cs
                                 target = msgTarget myNick irc
                                 msg = ClientMessage<commit_msg>Extract reconnect logic to its own definition<commit_after>{-# Language OverloadedStrings, NondecreasingIndentation #-}

{-|
Module      : Client.EventLoop
Description : Event loop for IRC client
Copyright   : (c) <NAME>, 2016
License     : ISC
Maintainer  : <EMAIL>

This module is responsible for dispatching user-input, network, and timer
events to the correct module. It renders the user interface once per event.
-}

module Client.EventLoop
  ( eventLoop
  ) where

import           Client.CApi
import           Client.Commands
import           Client.Commands.Interpolation
import           Client.Configuration.ServerSettings
import           Client.EventLoop.Errors (exceptionToLines)
import           Client.Hook
import           Client.Hooks
import           Client.Image
import           Client.Message
import           Client.Network.Async
import           Client.State
import qualified Client.State.EditBox     as Edit
import           Client.State.Focus
import           Client.State.Network
import           Control.Concurrent.STM
import           Control.Exception
import           Control.Lens
import           Control.Monad
import           Data.ByteString (ByteString)
import           Data.Foldable
import           Data.List
import           Data.Maybe
import           Data.Monoid
import           Data.Ord
import           Data.Text (Text)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Text.Encoding.Error as Text
import           Data.Time
import           GHC.IO.Exception (IOErrorType(..), ioe_type)
import           Graphics.Vty
import           Irc.Codes
import           Irc.Message
import           Irc.RawIrcMsg
import           LensUtils
import           Network.Connection

reconnectAttempts :: Int
reconnectAttempts = 6

-- | Sum of the three possible event types the event loop handles
data ClientEvent
  = VtyEvent Event -- ^ Key presses and resizing
  | NetworkEvent NetworkEvent -- ^ Incoming network events
  | TimerEvent NetworkId TimedAction -- ^ Timed action and the applicable network


-- | Block waiting for the next 'ClientEvent'. This function will compute
-- an appropriate timeout based on the current connections.
getEvent :: ClientState -> IO ClientEvent
getEvent st =
  do timer <- prepareTimer
     atomically $
       asum [ timer
            , VtyEvent     <$> readTChan vtyEventChannel
            , NetworkEvent <$> readTQueue (view clientEvents st)
            ]
  where
    vtyEventChannel = _eventChannel (inputIface (view clientVty st))

    prepareTimer =
      case earliestEvent st of
        Nothing -> return retry
        Just (networkId,(runAt,action)) ->
          do now <- getCurrentTime
             let microsecs = truncate (1000000 * diffUTCTime runAt now)
             var <- registerDelay (max 0 microsecs)
             return $ do ready <- readTVar var
                         unless ready retry
                         return (TimerEvent networkId action)

-- | Compute the earliest scheduled timed action for the client
earliestEvent :: ClientState -> Maybe (NetworkId, (UTCTime, TimedAction))
earliestEvent =
  minimumByOf
    (clientConnections . (ifolded <. folding nextTimedAction) . withIndex)
    (comparing (fst . snd))

-- | Apply this function to an initial 'ClientState' to launch the client.
eventLoop :: ClientState -> IO ()
eventLoop st0 =
  do let st1 = clientTick st0
         vty = view clientVty st
         (pic, st) = clientPicture st1

     -- check st0 for bell, it will be always be cleared in st1
     when (view clientBell st0) (beep vty)
     update vty pic

     event <- getEvent st
     case event of
       TimerEvent networkId action  -> doTimerEvent networkId action st
       VtyEvent vtyEvent         -> doVtyEvent vtyEvent st
       NetworkEvent networkEvent ->
         do let h = case networkEvent of
                      NetworkLine  net time line -> doNetworkLine  net time line
                      NetworkError net time ex   -> doNetworkError net time ex
                      NetworkOpen  net time      -> doNetworkOpen  net time
                      NetworkClose net time      -> doNetworkClose net time
            eventLoop =<< h st

-- | Sound the terminal bell assuming that the @BEL@ control code
-- is supported.
beep :: Vty -> IO ()
beep = ringTerminalBell . outputIface

-- | Respond to a network connection successfully connecting.
doNetworkOpen ::
  NetworkId   {- ^ network id   -} ->
  ZonedTime   {- ^ event time   -} ->
  ClientState {- ^ client state -} ->
  IO ClientState
doNetworkOpen networkId time st =
  case view (clientConnections . at networkId) st of
    Nothing -> error "doNetworkOpen: Network missing"
    Just cs ->
      do let msg = ClientMessage
                     { _msgTime    = time
                     , _msgNetwork = view csNetwork cs
                     , _msgBody    = NormalBody "connection opened"
                     }
         return $! recordNetworkMessage msg
                 $ overStrict (clientConnections . ix networkId . csLastReceived)
                              (\old -> old `seq` Just $! zonedTimeToUTC time)
                              st

-- | Respond to a network connection closing normally.
doNetworkClose ::
  NetworkId   {- ^ network id   -} ->
  ZonedTime   {- ^ event time   -} ->
  ClientState {- ^ client state -} ->
  IO ClientState
doNetworkClose networkId time st =
  do let (cs,st') = removeNetwork networkId st
         msg = ClientMessage
                 { _msgTime    = time
                 , _msgNetwork = view csNetwork cs
                 , _msgBody    = NormalBody "connection closed"
                 }
     return (recordNetworkMessage msg st')


-- | Respond to a network connection closing abnormally.
doNetworkError ::
  NetworkId     {- ^ failed network     -} ->
  ZonedTime     {- ^ current time       -} ->
  SomeException {- ^ termination reason -} ->
  ClientState   {- ^ client state       -} ->
  IO ClientState
doNetworkError networkId time ex st =
  do let (cs,st1) = removeNetwork networkId st
         st2 = foldl' (\acc msg -> recordError time cs (Text.pack msg) acc) st1
             $ exceptionToLines ex
     reconnectLogic ex cs st2

reconnectLogic ::
  SomeException {- ^ thread failure reason -} ->
  NetworkState  {- ^ failed network        -} ->
  ClientState   {- ^ client state          -} ->
  IO ClientState
reconnectLogic ex cs st

  | shouldReconnect =
      do (attempts, mbDisconnectTime) <- computeRetryInfo
         addConnection attempts mbDisconnectTime (view csNetwork cs) st

  | otherwise = return st

  where
    computeRetryInfo =
      case view csPingStatus cs of
        PingConnecting n tm                   -> pure (n+1, tm)
        _ | Just tm <- view csLastReceived cs -> pure (1, Just tm)
          | otherwise                         -> do now <- getCurrentTime
                                                    pure (1, Just now)

    shouldReconnect =
      case view csPingStatus cs of
        PingConnecting n _ | n == 0 || n > reconnectAttempts          -> False
        _ | Just HostNotResolved{}   <-              fromException ex -> True
          | Just HostCannotConnect{} <-              fromException ex -> True
          | Just PingTimeout         <-              fromException ex -> True
          | Just ResourceVanished    <- ioe_type <$> fromException ex -> True
          | Just NoSuchThing         <- ioe_type <$> fromException ex -> True
          | otherwise                                                 -> False


-- | Respond to an IRC protocol line. This will parse the message, updated the
-- relevant connection state and update the UI buffers.
doNetworkLine ::
  NetworkId   {- ^ Network ID of message            -} ->
  ZonedTime   {- ^ current time                     -} ->
  ByteString  {- ^ Raw IRC message without newlines -} ->
  ClientState {- ^ client state                     -} ->
  IO ClientState
doNetworkLine networkId time line st =
  case view (clientConnections . at networkId) st of
    Nothing -> error "doNetworkLine: Network missing"
    Just cs ->
      let network = view csNetwork cs in
      case parseRawIrcMsg (asUtf8 line) of
        Nothing ->
          do let msg = Text.pack ("Malformed message: " ++ show line)
             return $! recordError time cs msg st

        Just raw ->
          do (st1,passed) <- clientPark st $ \ptr ->
                               notifyExtensions ptr network raw
                                 (view (clientExtensions . esActive) st)


             if not passed then return st1 else do

             let time' = computeEffectiveTime time (view msgTags raw)

                 (stateHook, viewHook)
                      = over both applyMessageHooks
                      $ partition (view messageHookStateful)
                      $ lookups
                          (view csMessageHooks cs)
                          messageHooks

             case stateHook (cookIrcMsg raw) of
               Nothing  -> return st1 -- Message ignored
               Just irc -> do traverse_ (sendMsg cs) replies
                              clientResponse time' irc cs st2
                 where
                   -- state with message recorded
                   recSt = case viewHook irc of
                             Nothing   -> st1 -- Message hidden
                             Just irc' -> recordIrcMessage network target msg st1
                               where
                                 myNick = view csNick cs
                                 target = msgTarget myNick irc
                                 msg = ClientMessage
{'fraction_non_alphanumeric': 0.066694874914053, 'fraction_numerical': 0.003861003861003861, 'mean_word_length': 1.7430726824314522, 'pattern_counts': {'":': 0, '<': 50, '<?xml version=': 0, '>': 120, 'https://': 0, 'lorem ipsum': 0, 'www.': 0, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 15, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '4404830', 'n_tokens_mistral': 4791, 'n_tokens_neox': 4584, 'n_words': 1683}