PS Client file

Client.purs

module Client
  ( Url
  , LoggerConfig
  , Logger
  , Action
  , ActionType
  , Queue
  , ClientEffects
  , defaultLoggerConfig
  , createLogger
  , flush
  , flushImmediate
  ) where

import Prelude

import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, warn)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Eff.Ref (REF, Ref, modifyRef, modifyRef', newRef, readRef)
import Control.Monad.Eff.Timer (TIMER, TimeoutId, clearTimeout, setTimeout)
import DOM (DOM)
import DOM.Event.EventTarget (addEventListener, eventListener)
import DOM.HTML (window)
import DOM.HTML.Event.EventTypes (unload)
import DOM.HTML.Types (windowToEventTarget)
import DOM.HTML.Window (requestIdleCallback)
import Data.Argonaut.Core (Json)
import Data.Array (null, snoc)
import Data.Either (Either(..))
import Data.HTTP.Method (Method(..))
import Data.Maybe (Maybe(..))
import Network.HTTP.Affjax (AJAX, AffjaxResponse, affjax', defaultRequest)
import Unsafe.Coerce (unsafeCoerce)

type Url = String

type LoggerConfig a =
  { endpoint :: Url
  , actionFilter :: Action a -> Boolean
  , actionMapper :: Action a -> Action a
  }

defaultLoggerConfig :: forall a . Url -> LoggerConfig a
defaultLoggerConfig endpoint =
  { endpoint
  , actionFilter: const true
  , actionMapper: id
  }

type ActionType = String

type Action a =
  { "type" :: ActionType
  | a
  }

type Queue a = Array (Action a)

type State a =
  { queue :: Queue a
  , timeout :: Maybe TimeoutId
  }

emptyState :: forall a . State a
emptyState = { queue: [], timeout: Nothing }

type ClientEffects eff a = Eff (ajax :: AJAX, console :: CONSOLE, dom :: DOM, ref :: REF, timer :: TIMER | eff) a

type Logger e a =
  { log :: Action a -> ClientEffects e Unit
  , getQueue :: Eff (ref :: REF | e) (Queue a)
  , flush :: ClientEffects e Unit
  , flushImmediate :: ClientEffects e Unit
  }

debounceDuration :: Int
debounceDuration = 1000

maxAttempts :: Int
maxAttempts = 3

createLogger :: forall e a
   . LoggerConfig a
  -> ClientEffects e (Logger e a)
createLogger config = do
  ref <- newRef emptyState
  addEventListener unload (eventListener \_ -> flushImmediate config ref) true =<< windowToEventTarget <$> window
  pure
    { log: logger ref
    , getQueue: _.queue <$> readRef ref
    , flush: pure unit
    , flushImmediate: pure unit
    }
  where
    logger ref action = ricb $ logger' ref action

    logger' ref action = when (config.actionFilter action) do
      newTimeout <- setTimeout debounceDuration $ flush config ref
      oldTimeout <- modifyRef' ref \state ->
        { state:
            { queue: snoc state.queue $ config.actionMapper action
            , timeout: Just newTimeout
            }
        , value: state.timeout
        }
      maybeClearTimeout oldTimeout
    
flush :: forall e a . LoggerConfig a -> Ref (State a) -> ClientEffects e Unit
flush config ref = ricb $ sendQueuedEvents config ref 0

flushImmediate :: forall e a . LoggerConfig a -> Ref (State a) -> ClientEffects e Unit
flushImmediate config ref = sendQueuedEvents config ref 0

ricb :: forall e . Eff (dom :: DOM | e) Unit -> Eff (dom :: DOM | e) Unit
ricb cb = void $ requestIdleCallback { timeout: 1000 } cb =<< window

maybeClearTimeout :: forall e . Maybe TimeoutId -> Eff (timer :: TIMER | e) Unit
maybeClearTimeout (Just timeout) = clearTimeout timeout
maybeClearTimeout Nothing = pure unit

sendQueuedEvents :: forall e a
   . LoggerConfig a
  -> Ref (State a)
  -> Int
  -> ClientEffects e Unit
sendQueuedEvents config ref attempts = do
  queue <- modifyRef' ref \{ queue, timeout } -> { state: emptyState, value: queue }
  when (not $ null queue) $ void $ affjax' (request queue) (onError queue) onSuccess
  where
    toJson :: Queue a -> Json
    toJson queue = unsafeCoerce queue

    request queue = defaultRequest
      { method = Left POST
      , url = config.endpoint
      , content = Just (toJson queue)
      }
    
    onError :: Queue a -> Error → ClientEffects e Unit
    onError attemptedQueue e = ricb $ onError' attemptedQueue e

    onError' :: Queue a -> Error → ClientEffects e Unit
    onError' attemptedQueue e = do
      if attempts >= maxAttempts
        then warn "[Client] Unable to send events -- dropping the queue"
        else do
          warn "[Client] Unable to send events -- requeuing failed events"
          timeout <- modifyRef' ref \state ->
            { state: state { queue = state.queue <> attemptedQueue }
            , value: state.timeout
            }
          when (timeout == Nothing) do
            newTimeout <- setTimeout (debounceDuration * 6) (ricb $ sendQueuedEvents config ref (attempts + 1))
            modifyRef ref \state -> state { timeout = Just newTimeout }

    onSuccess :: AffjaxResponse Unit → ClientEffects e Unit
    onSuccess _ = pure unit

Main.js

"use strict";

var ric = require("request-idle-callback");
var glbl = typeof window !== "undefined" ? window : global;

if (!glbl.requestIdleCallback) {
  glbl.requestIdleCallback = ric.requestIdleCallback;
  glbl.cancelIdleCallback = ric.cancelIdleCallback;
}

exports.assignGlobal = function(key) {
  return function(value) {
    return function() {
      glbl[key] = value;
    };
  };
};

exports.toJsFriendlyLogger = function(psCreateLogger) {
  return function(defaultLoggerConfig) {
    return {
      createLogger: function createLogger(config) {
        if (!config || !config.endpoint) {
          throw new TypeError(
            "`createLogger` requires and `endpoint` (url)."
          );
        }
        var defaults = defaultLoggerConfig(config.endpoint);
        var psLogger = psCreateLogger({
          endpoint: config.endpoint,
          actionFilter: config.actionFilter || defaults.actionFilter,
          actionMapper: config.actionMapper || defaults.actionMapper
        })();
        return {
          log: function log(action) {
            psLogger.log(action)();
          },
          getQueue: function getQueue() {
            return psLogger.getQueue();
          },
          flush: function flush() {
            psLogger.flush();
          },
          flushImmediate: function flushImmediate() {
            psLogger.flushImmediate();
          }
        };
      }
    };
  };
};

Main.purs

module Main (main) where

import Prelude

import Control.Monad.Eff (Eff)
import Data.Foreign (Foreign)
import Client (ClientEffects, Logger, LoggerConfig, Url, createLogger, defaultLoggerConfig)

main :: Eff () Unit
main = assignGlobal "Client" $ toJsFriendlyLogger createLogger defaultLoggerConfig

foreign import assignGlobal :: forall e a . String -> a -> Eff e Unit

foreign import toJsFriendlyLogger :: forall e a
   . (LoggerConfig a -> ClientEffects e (Logger e a))
  -> (Url -> LoggerConfig a)
  -> Foreign