Created
August 12, 2017 16:43
-
-
Save megamaddu/4a201ee4a89ae9013014b12d20b555c1 to your computer and use it in GitHub Desktop.
PS Client file
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
"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(); | |
} | |
}; | |
} | |
}; | |
}; | |
}; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
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 |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment