truqu / purescript-workers Goto Github PK

module ServiceWorker where
  
import Prelude

import Cache (CACHE, Cache, addAll, match, openCache, put)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Eff.Uncurried (EffFn2, runEffFn2)
import Control.Monad.Error.Class (throwError)
import Control.Promise (Promise, fromAff)
import Data.Foreign (isNull, toForeign, typeOf, unsafeFromForeign)
import Data.String (null)
import Fetch (FETCH, RequestInfo, Response, fetch)
import GlobalScope.Service (caches)
import Workers (WORKER)

type WorkerEffects e =
  ( worker :: WORKER
  | e )

type CacheEffects e = WorkerEffects
  ( cache :: CACHE
  | e )

type FetchEffects e =
  ( fetch :: FETCH
  | e )
  
appResources :: Array String
appResources =
  [ "./"
  , "./dist/app.js"
  ]

prepareServiceWorker :: forall e
   . Eff
      (WorkerEffects
        (CacheEffects
          (FetchEffects ( console :: CONSOLE | e ))))
      Unit
prepareServiceWorker = do
  addEventListener "install" \evt -> do
    log "The service worker is being installed."
    waitUntil evt =<< fromAff precache
  addEventListener "fetch" \evt -> do
    log "The service worker is serving the asset."
    respondWith evt =<< fromAff (fromCache (request evt))
    waitUntil evt =<< fromAff (update (request evt))

appCache :: forall e. Aff (CacheEffects e) Cache
appCache = do
  cacheStorage <- liftEff caches
  openCache cacheStorage "app"

precache :: forall e. Aff (CacheEffects e) Unit
precache = do
  cache <- appCache
  addAll cache appResources

fromCache :: forall e. RequestInfo -> Aff (CacheEffects e)
      Response
fromCache request = do
  cache <- appCache
  m <- match cache request
  if isEmpty m
    then throwError $ error "no-match"
    else pure m
  where
    isEmpty m =
      let
        mf = toForeign m
      in
        isNull mf ||
          (typeOf mf == "string" &&
            null (unsafeFromForeign mf :: String))

update :: forall e. RequestInfo -> Aff (CacheEffects (FetchEffects e)) Unit
update request = do
  response <- fetch request
  cache <- appCache
  put cache request response


-- | FFI Helpers

foreign import data Event :: Type

type EventHandler e = forall a. Event -> Eff e Unit

foreign import request :: Event -> RequestInfo

addEventListener :: forall e
   . String
  -> EventHandler e
  -> Eff (WorkerEffects e) Unit
addEventListener = runEffFn2 addEventListener_

foreign import addEventListener_ :: forall e
   . EffFn2 (WorkerEffects e) String (EventHandler e) Unit

waitUntil :: forall e a
   . Event
  -> (Promise a)
  -> Eff (WorkerEffects e) Unit
waitUntil = runEffFn2 waitUntil_

foreign import waitUntil_ :: forall e a
   . EffFn2 (WorkerEffects e) Event (Promise a) Unit

respondWith :: forall e a
   . Event
  -> (Promise a)
  -> Eff (WorkerEffects e) Unit
respondWith = runEffFn2 waitUntil_

foreign import respondWith_ :: forall e a
   . EffFn2 (WorkerEffects e) Event (Promise a) Unit