content: --------------------------------------------------------------------------------
  -- | This module exposes connection internals
  {-# LANGUAGE OverloadedStrings #-}
  module Network.WebSockets.Connection
      ( PendingConnection (..)
      , acceptRequest
      , AcceptRequest(..)
      , defaultAcceptRequest
      , acceptRequestWith
      , rejectRequest
      , RejectRequest(..)
      , defaultRejectRequest
      , rejectRequestWith
  
      , Connection (..)
  
      , ConnectionOptions (..)
      , defaultConnectionOptions
  
      , receive
      , receiveDataMessage
      , receiveData
      , send
      , sendDataMessage
      , sendDataMessages
      , sendTextData
      , sendTextDatas
      , sendBinaryData
      , sendBinaryDatas
      , sendClose
      , sendCloseCode
      , sendPing
      , sendPong
  
      , withPingThread
      , forkPingThread
      , pingThread
  
      , CompressionOptions (..)
      , PermessageDeflate (..)
      , defaultPermessageDeflate
  
      , SizeLimit (..)
      ) where
  
  
  --------------------------------------------------------------------------------
  import           Control.Applicative                             ((<$>))
  import           Control.Concurrent                              (forkIO,
                                                                    threadDelay)
  import qualified Control.Concurrent.Async                        as Async
  import           Control.Concurrent.MVar                         (MVar, newEmptyMVar, tryPutMVar)
  import           Control.Exception                               (AsyncException,
                                                                    fromException,
                                                                    handle,
                                                                    throwIO)
  import           Control.Monad                                   (foldM, unless,
                                                                    when)
  import qualified Data.ByteString                                 as B
  import qualified Data.ByteString.Builder                         as Builder
  import qualified Data.ByteString.Char8                           as B8
  import           Data.IORef                                      (IORef,
                                                                    newIORef,
                                                                    readIORef,
                                                                    writeIORef)
  import           Data.List                                       (find)
  import           Data.Maybe                                      (catMaybes)
  import qualified Data.Text                                       as T
  import           Data.Word                                       (Word16)
  import           Prelude
  
  
  --------------------------------------------------------------------------------
  import           Network.WebSockets.Connection.Options
  import           Network.WebSockets.Extensions                   as Extensions
  import           Network.WebSockets.Extensions.PermessageDeflate
  import           Network.WebSockets.Extensions.StrictUnicode
  import           Network.WebSockets.Http
  import           Network.WebSockets.Protocol
  import           Network.WebSockets.Stream                       (Stream)
  import qualified Network.WebSockets.Stream                       as Stream
  import           Network.WebSockets.Types
  
  
  --------------------------------------------------------------------------------
  -- | A new client connected to the server. We haven't accepted the connection
  -- yet, though.
  data PendingConnection = PendingConnection
      { pendingOptions  :: !ConnectionOptions
      -- ^ Options, passed as-is to the 'Connection'
      , pendingRequest  :: !RequestHead
      -- ^ Useful for e.g. inspecting the request path.
      , pendingOnAccept :: !(Connection -> IO ())
      -- ^ One-shot callback fired when a connection is accepted, i.e., *after*
      -- the accepting response is sent to the client.
      , pendingStream   :: !Stream
      -- ^ Input/output stream
      }
  
  
  --------------------------------------------------------------------------------
  -- | This datatype allows you to set options for 'acceptRequestWith'.  It is
  -- strongly recommended to use 'defaultAcceptRequest' and then modify the
  -- various fields, that way new fields introduced in the library do not break
  -- your code.
  data AcceptRequest = AcceptRequest
      { acceptSubprotocol :: !(Maybe B.ByteString)
      -- ^ The subprotocol to speak with the client.  If 'pendingSubprotcols' is
      -- non-empty, 'acceptSubprotocol' must be one of the subprotocols from the
      -- list.
      , acceptHeaders     :: !Headers
      -- ^ Extra headers to send with the response.
      }
  
  
  --------------------------------------------------------------------------------
  defaultAcceptRequest :: AcceptRequest
  defaultAcceptRequest = AcceptRequest Nothing []
  
  
  --------------------------------------------------------------------------------
  -- | Utility
  sendResponse :: PendingConnection -> Response -> IO ()
  sendResponse pc rsp = Stream.write (pendingStream pc)
      (Builder.toLazyByteString (encodeResponse rsp))
  
  
  --------------------------------------------------------------------------------
  -- | Accept a pending connection, turning it into a 'Connection'.
  acceptRequest :: PendingConnection -> IO Connection
  acceptRequest pc = acceptRequestWith pc defaultAcceptRequest
  
  
  --------------------------------------------------------------------------------
  -- | This function is like 'acceptRequest' but allows you to set custom options
  -- using the 'AcceptRequest' datatype.
  acceptRequestWith :: PendingConnection -> AcceptRequest -> IO Connection
  acceptRequestWith pc ar = case find (flip compatible request) protocols of
      Nothing       -> do
          sendResponse pc $ response400 versionHeader ""
          throwIO NotSupported
      Just protocol -> do
  
          -- Get requested list of exceptions from client.
          rqExts <- either throwIO return $
              getRequestSecWebSocketExtensions request
  
          -- Set up permessage-deflate extension if configured.
          pmdExt <- case connectionCompressionOptions (pendingOptions pc) of
              NoCompression                     -> return Nothing
              PermessageDeflateCompression pmd0 ->
                  case negotiateDeflate (connectionMessageDataSizeLimit options) (Just pmd0) rqExts of
                      Left err   -> do
                          rejectRequestWith pc defaultRejectRequest {rejectMessage = B8.pack err}
                          throwIO NotSupported
                      Right pmd1 -> return (Just pmd1)
  
          -- Set up strict utf8 extension if configured.
          let unicodeExt =
                  if connectionStrictUnicode (pendingOptions pc)
                      then Just strictUnicode else Nothing
  
          -- Final extension list.
          let exts = catMaybes [pmdExt, unicodeExt]
  
          let subproto = maybe [] (\p -> [("Sec-WebSocket-Protocol", p)]) $ acceptSubprotocol ar
              headers = subproto ++ acceptHeaders ar ++ concatMap extHeaders exts
              response = finishRequest protocol request headers
  
          either throwIO (sendResponse pc) response
  
          parseRaw <- decodeMessages
              protocol
              (connectionFramePayloadSizeLimit options)
              (connectionMessageDataSizeLimit options)
              (pendingStream pc)
          writeRaw <- encodeMessages protocol ServerConnection (pendingStream pc)
  
          write <- foldM (\x ext -> extWrite ext x) writeRaw exts
          parse <- foldM (\x ext -> extParse ext x) parseRaw exts
  
          sentRef <- newIORef False
          heartbeat <- newEmptyMVar
          let connection = Connection
                  { connectionOptions   = options
                  , connectionType      = ServerConnection
                  , connectionProtocol  = protocol
                  , connectionParse     = parse
                  , connectionWrite     = write
                  , connectionHeartbeat = heartbeat
                  , connectionSentClose = sentRef
                  }
  
          pendingOnAccept pc connection
          return connection
    where
      options       = pendingOptions pc
      request       = pendingRequest pc
      versionHeader = [("Sec-WebSocket-Version",
          B.intercalate ", " $ concatMap headerVersions protocols)]
  
  
  --------------------------------------------------------------------------------
  -- | Parameters that allow you to tweak how a request is rejected.  Please use
  -- 'defaultRejectRequest' and modify fields using record syntax so your code
  -- will not break when new fields are added.
  data RejectRequest = RejectRequest
      { -- | The status code, 400 by default.
        rejectCode    :: !Int
      , -- | The message, "Bad Request" by default
        rejectMessage :: !B.ByteString
      , -- | Extra headers to be sent with the response.
        rejectHeaders :: Headers
      , -- | Reponse body of the rejection.
        rejectBody    :: !B.ByteString
      }
  
  
  --------------------------------------------------------------------------------
  defaultRejectRequest :: RejectRequest
  defaultRejectRequest = RejectRequest
      { rejectCode    = 400
      , rejectMessage = "Bad Request"
      , rejectHeaders = []
      , rejectBody    = ""
      }
  
  
  --------------------------------------------------------------------------------
  rejectRequestWith
      :: PendingConnection  -- ^ Connection to reject
      -> RejectRequest      -- ^ Params on how to reject the request
      -> IO ()
  rejectRequestWith pc reject = sendResponse pc $ Response
      ResponseHead
          { responseCode    = rejectCode reject
          , responseMessage = rejectMessage reject
          , responseHeaders = rejectHeaders reject
          }
      (rejectBody reject)
  
  
  --------------------------------------------------------------------------------
  -- | Requires calling 'pendingStream' and 'Stream.close'.
  rejectRequest
      :: PendingConnection  -- ^ Connection to reject
      -> B.ByteString       -- ^ Rejection response body
      -> IO ()
  rejectRequest pc body = rejectRequestWith pc
      defaultRejectRequest {rejectBody = body}
  
  
  --------------------------------------------------------------------------------
  data Connection = Connection
      { connectionOptions   :: !ConnectionOptions
      , connectionType      :: !ConnectionType
      , connectionProtocol  :: !Protocol
      , connectionHeartbeat :: !(MVar ())
      -- ^ This MVar is filled whenever a pong is received.  This is used by
      -- 'withPingPong' to timeout the connection if a pong is not received.
      , connectionParse     :: !(IO (Maybe Message))
      , connectionWrite     :: !([Message] -> IO ())
      , connectionSentClose :: !(IORef Bool)
      -- ^ According to the RFC, both the client and the server MUST send
      -- a close control message to each other.  Either party can initiate
      -- the first close message but then the other party must respond.  Finally,
      -- the server is in charge of closing the TCP connection.  This IORef tracks
      -- if we have sent a close message and are waiting for the peer to respond.
      }
  
  
  --------------------------------------------------------------------------------
  receive :: Connection -> IO Message
  receive conn = do
      mbMsg <- connectionParse conn
      case mbMsg of
          Nothing  -> throwIO ConnectionClosed
          Just msg -> return msg
  
  
  --------------------------------------------------------------------------------
  -- | Receive an application message. Automatically respond to control messages.
  --
  -- When the peer sends a close control message, an exception of type 'CloseRequest'
  -- is thrown.  The peer can send a close control message either to initiate a
  -- close or in response to a close message we have sent to the peer.  In either
  -- case the 'CloseRequest' exception will be thrown.  The RFC specifies that
  -- the server is responsible for closing the TCP connection, which should happen
  -- after receiving the 'CloseRequest' exception from this function.
  --
  -- This will throw 'ConnectionClosed' if the TCP connection dies unexpectedly.
  receiveDataMessage :: Connection -> IO DataMessage
  receiveDataMessage conn = do
      msg <- receive conn
      case msg of
          DataMessage _ _ _ am -> return am
          ControlMessage cm    -> case cm of
              Close i closeMsg -> do
                  hasSentClose <- readIORef $ connectionSentClose conn
                  unless hasSentClose $ send conn msg
                  throwIO $ CloseRequest i closeMsg
              Pong _    -> do
                  _ <- tryPutMVar (connectionHeartbeat conn) ()
                  connectionOnPong (connectionOptions conn)
                  receiveDataMessage conn
              Ping pl   -> do
                  send conn (ControlMessage (Pong pl))
                  receiveDataMessage conn
  
  
  --------------------------------------------------------------------------------
  -- | Receive a message, converting it to whatever format is needed.
  receiveData :: WebSocketsData a => Connection -> IO a
  receiveData conn = fromDataMessage <$> receiveDataMessage conn
  
  
  --------------------------------------------------------------------------------
  send :: Connection -> Message -> IO ()
  send conn = sendAll conn . return
  
  --------------------------------------------------------------------------------
  sendAll :: Connection -> [Message] -> IO ()
  sendAll _    []   = return ()
  sendAll conn msgs = do
      when (any isCloseMessage msgs) $
        writeIORef (connectionSentClose conn) True
      connectionWrite conn msgs
    where
      isCloseMessage (ControlMessage (Close _ _)) = True
      isCloseMessage _                            = False
  
  --------------------------------------------------------------------------------
  -- | Send a 'DataMessage'.  This allows you send both human-readable text and
  -- binary data.  This is a slightly more low-level interface than 'sendTextData'
  -- or 'sendBinaryData'.
  sendDataMessage :: Connection -> DataMessage -> IO ()
  sendDataMessage conn = sendDataMessages conn . return
  
  --------------------------------------------------------------------------------
  -- | Send a collection of 'DataMessage's.  This is more efficient than calling
  -- 'sendDataMessage' many times.
  sendDataMessages :: Connection -> [DataMessage] -> IO ()
  sendDataMessages conn = sendAll conn . map (DataMessage False False False)
  
  --------------------------------------------------------------------------------
  -- | Send a textual message.  The message will be encoded as UTF-8.  This should
  -- be the default choice for human-readable text-based protocols such as JSON.
  sendTextData :: WebSocketsData a => Connection -> a -> IO ()
  sendTextData conn = sendTextDatas conn . return
  
  --------------------------------------------------------------------------------
  -- | Send a number of textual messages.  This is more efficient than calling
  -- 'sendTextData' many times.
  sendTextDatas :: WebSocketsData a => Connection -> [a] -> IO ()
  sendTextDatas conn =
      sendDataMessages conn .
      map (\x -> Text (toLazyByteString x) Nothing)
  
  --------------------------------------------------------------------------------
  -- | Send a binary message.  This is useful for sending binary blobs, e.g.
  -- images, data encoded with MessagePack, images...
  sendBinaryData :: WebSocketsData a => Connection -> a -> IO ()
  sendBinaryData conn = sendBinaryDatas conn . return
  
  --------------------------------------------------------------------------------
  -- | Send a number of binary messages.  This is more efficient than calling
  -- 'sendBinaryData' many times.
  sendBinaryDatas :: WebSocketsData a => Connection -> [a] -> IO ()
  sendBinaryDatas conn = sendDataMessages conn . map (Binary . toLazyByteString)
  
  --------------------------------------------------------------------------------
  -- | Send a friendly close message.  Note that after sending this message,
  -- you should still continue calling 'receiveDataMessage' to process any
  -- in-flight messages.  The peer will eventually respond with a close control
  -- message of its own which will cause 'receiveDataMessage' to throw the
  -- 'CloseRequest' exception.  This exception is when you can finally consider
  -- the connection closed.
  sendClose :: WebSocketsData a => Connection -> a -> IO ()
  sendClose conn = sendCloseCode conn 1000
  
  
  --------------------------------------------------------------------------------
  -- | Send a friendly close message and close code.  Similar to 'sendClose',
  -- you should continue calling 'receiveDataMessage' until you receive a
  -- 'CloseRequest' exception.
  --
  -- See <http://tools.ietf.org/html/rfc6455#section-7.4> for a list of close
  -- codes.
  sendCloseCode :: WebSocketsData a => Connection -> Word16 -> a -> IO ()
  sendCloseCode conn code =
      send conn . ControlMessage . Close code . toLazyByteString
  
  
  --------------------------------------------------------------------------------
  -- | Send a ping
  sendPing :: WebSocketsData a => Connection -> a -> IO ()
  sendPing conn = send conn . ControlMessage . Ping . toLazyByteString
  
  --------------------------------------------------------------------------------
  -- | Send a pong
  sendPong :: WebSocketsData a => Connection -> a -> IO ()
  sendPong conn = send conn . ControlMessage . Pong . toLazyByteString
  
  --------------------------------------------------------------------------------
  -- | Forks a ping thread, sending a ping message every @n@ seconds over the
  -- connection.  The thread is killed when the inner IO action is finished.
  --
  -- This is useful to keep idle connections open through proxies and whatnot.
  -- Many (but not all) proxies have a 60 second default timeout, so based on that
  -- sending a ping every 30 seconds is a good idea.
  --
  -- Note that usually you want to use 'Network.WebSockets.Connection.PingPong.withPingPong'
  -- to timeout the connection if a pong is not received.
  withPingThread
      :: Connection
      -> Int    -- ^ Second interval in which pings should be sent.
      -> IO ()  -- ^ Repeat this after sending a ping.
      -> IO a   -- ^ Application to wrap with a ping thread.
      -> IO a   -- ^ Executes application and kills ping thread when done.
  withPingThread conn n action app =
      Async.withAsync (pingThread conn n action) (\_ -> app)
  
  --------------------------------------------------------------------------------
  -- | DEPRECATED: Use 'withPingThread' instead.
  --
  -- Forks a ping thread, sending a ping message every @n@ seconds over the
  -- connection.  The thread dies silently if the connection crashes or is closed.
  --
  -- This is useful to keep idle connections open through proxies and whatnot.
  -- Many (but not all) proxies have a 60 second default timeout, so based on that
  -- sending a ping every 30 seconds is a good idea.
  forkPingThread :: Connection -> Int -> IO ()
  forkPingThread conn n = do
      _ <- forkIO $ pingThread conn n (return ())
      return ()
  {-# DEPRECATED forkPingThread "Use 'withPingThread' instead" #-}
  
  
  --------------------------------------------------------------------------------
  -- | Use this if you want to run the ping thread yourself.
  --
  -- See also 'withPingThread'.
  pingThread :: Connection -> Int -> IO () -> IO ()
  pingThread conn n action
      | n <= 0    = return ()
      | otherwise = ignore `handle` go 1
    where
      go :: Int -> IO ()
      go i = do
          threadDelay (n * 1000 * 1000)
          sendPing conn (T.pack $ show i)
          action
          go (i + 1)
  
      ignore e = case fromException e of
          Just async -> throwIO (async :: AsyncException)
          Nothing    -> return ()
  