Add multiple accounts auth fail message

Add multiple accounts auth fail message

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Quasar.Auth.Authentication
  ( authentication
  , getIdTokenFromBusSilently
  , toNotificationOptions
  , AuthEffects
  , EIdToken
  , AuthenticationError(..)
  , RequestIdTokenBus
  , RequestIdTokenMessage
  ) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Rec.Class (forever)
import Control.Parallel.Class (race)
import Control.UI.Browser as Browser
import DOM (DOM)
import DOM.HTML as DOMHTML
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Window as DOMHTMLWindow
import DOM.Node.Document as DOMNodeDocument
import DOM.Node.Node as DOMNode
import DOM.Node.Types (Node, Element)
import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Nullable as Nullable
import Data.Time.Duration (Milliseconds(Milliseconds), Seconds(Seconds))
import Data.Traversable as T
import OIDC.Aff as OIDCAff
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import Quasar.Advanced.Types (ProviderR)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Notification (NotificationOptions)
import SlamData.Notification as Notification
import SlamData.Prelude
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore

import Text.Parsing.StringParser (ParseError(..))

import Utils (passover)
import Utils.LocalStorage as LocalStorage
import Utils.DOM as DOMUtils

getIdTokenFromBusSilently ∷ ∀ eff. RequestIdTokenBus → Aff (AuthEffects eff) (Either String EIdToken)
getIdTokenFromBusSilently requestIdTokenBus =
  liftEff getProviderRUsingLocalStorage
    >>= case _ of
      Right providerR → do
        idTokenVar ← AVar.makeVar
        Bus.write { idToken: idTokenVar, providerR, prompt: false } requestIdTokenBus
        idToken ← Right <$> AVar.takeVar idTokenVar
        pure idToken
      Left error → pure $ Left error

data AuthenticationError
  = IdTokenInvalid (Maybe Error)
  | IdTokenUnavailable String
  | PromptDismissed
  | DOMError String
  | ProviderError String

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenMessage = { providerR ∷ ProviderR, prompt ∷ Boolean, idToken ∷ AVar EIdToken }

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

type AuthEffects eff =
  ( now ∷ NOW
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  val ← AVar.takeVar firstValue
  pure val

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
authentication ∷ ∀ eff. Aff (AuthEffects eff) RequestIdTokenBus
authentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

-- TODO: Allow multiple concurrent auth requests with different providers
-- and prompt options. Alternatively immediately respond with an
-- "authentication already in progress" error.
--
-- Currently if a message comes in whilst authentication is in progress the
-- sender will be given the id token from the in progress auth regardless of
-- what provider they asked for.
--
-- In current use this won't happen but it could if things change.
--
-- The same thing and worse could happen before but it was obscured by the
-- "store provider in localstorage then put a message on the bus" approach.
authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← getIdToken message.providerR message.prompt
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (AuthEffects eff) Unit
  reply = AVar.putVar message.idToken <=< Promise.wait

getIdTokenSilently
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenSilently providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  appendHiddenRequestIFrameToBody unhashedNonce providerR
    >>= case _ of
      Left error → pure $ Left error
      Right iFrameNode → do
        idToken ← race (getIdTokenFromLSOnChange providerR unhashedNonce) timeout
        liftEff $ removeBodyChild iFrameNode
        pure idToken
  where
  appendHiddenRequestIFrameToBody unhashedNonce providerR =
    either
      (pure ∘ Left)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< getAuthenticationUri OIDCAff.None unhashedNonce providerR
  timeout =
    Aff.later' Config.authenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout."

getIdTokenUsingPrompt
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  race
    (getIdTokenFromLSOnChange providerR unhashedNonce)
    (prompt unhashedNonce)
  where
  popup src =
    liftEff (DOMUtils.openPopup src)
      >>= case _ of
        Just window → do
          DOMUtils.waitUntilWindowClosed window
          Aff.later' 250 (pure $ Left PromptDismissed)
        Nothing →
          pure $ Left $ DOMError "`window.open` returned null"
  prompt unhashedNonce =
    (either (pure ∘ Left) popup)
      =<< getAuthenticationUri OIDCAff.Login unhashedNonce providerR

getAuthenticationUri
  ∷ ∀ eff
  . OIDCAff.Prompt
  → UnhashedNonce
  → ProviderR
  → Aff (AuthEffects eff) (Either AuthenticationError String)
getAuthenticationUri prompt unhashedNonce providerR =
  (bimap (ProviderError ∘ runParseError) id)
    <$> (liftEff
           $ OIDCAff.getAuthenticationUri prompt unhashedNonce providerR
           =<< getRedirectUri)

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (AuthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (AuthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (AuthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (AuthEffects eff) Node
appendIFrameToNode iFrameElement node =
  passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (AuthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (AuthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (AuthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (AuthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

getIdToken
  ∷ ∀ eff
  . ProviderR
  → Boolean
  → Aff (AuthEffects eff) (Promise EIdToken)
getIdToken providerR prompt =
  Promise.defer do
    idToken ← if prompt
      then
        getIdTokenUsingPrompt providerR
      else
        getIdTokenUsingLocalStorage providerR
          >>= maybe (getIdTokenSilently providerR) (pure ∘ Right)
    -- Store provider for future local storage gets and reauthentications
    either
      (const $ liftEff $ AuthStore.clearProvider *> AuthStore.clearIdToken)
      (const $ liftEff $ AuthStore.storeProvider $ QAT.Provider providerR)
      idToken
    pure idToken

getIdTokenUsingLocalStorage ∷ ∀ eff. ProviderR → Aff (AuthEffects eff) (Maybe IdToken)
getIdTokenUsingLocalStorage providerR = do
  eitherIdToken ← getUnverifiedIdTokenUsingLocalStorage
  eitherUnhashedNonce ← getUnhashedNonceUsingLocalStorage
  case Tuple eitherIdToken eitherUnhashedNonce of
    Tuple (Right idToken) (Right unhashedNonce) →
      either (const $ Nothing) (if _ then (Just idToken) else Nothing)
        <$> (liftEff $ verify providerR unhashedNonce idToken)
    Tuple _ _ → pure Nothing

getUnverifiedIdTokenUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenUsingLocalStorage =
  flip bind (map IdToken)
    <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

getUnhashedNonceUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String UnhashedNonce)
getUnhashedNonceUsingLocalStorage =
  rmap UnhashedNonce <$> LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey

getProviderRUsingLocalStorage ∷ ∀ eff. Eff (AuthEffects eff) (Either String QAT.ProviderR)
getProviderRUsingLocalStorage =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

getIdTokenFromLSOnChange
  ∷ ∀ eff
  . ProviderR
  → UnhashedNonce
  → Aff (AuthEffects eff) EIdToken
getIdTokenFromLSOnChange providerR unhashedNonce =
  getUnverifiedIdTokenFromLSOnChange
    >>= case _ of
          Left localStorageError →
            pure $ Left $ IdTokenUnavailable localStorageError
          Right idToken →
            either
              (Left ∘ IdTokenInvalid ∘ Just )
              (if _ then Right idToken else Left $ IdTokenInvalid Nothing)
              <$> (liftEff $ verify providerR unhashedNonce idToken)

getUnverifiedIdTokenFromLSOnChange
  ∷ ∀ eff
  . Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenFromLSOnChange =
  _.newValue <$> (firstValueFromStallingProducer =<< liftEff getIdTokenStorageEvents)

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

-- TODO: Remove g
verify ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → Eff (AuthEffects eff) (Either Error Boolean)
verify providerR unhashedNonce idToken =
  F.foldl accumulateErrorsAcceptTrues (Right false)
    <$> T.traverse
          (verifyWithJwk providerR unhashedNonce idToken)
          providerR.openIDConfiguration.jwks
  where
  accumulateErrorsAcceptTrues ∷ Either Error Boolean → Either Error Boolean → Either Error Boolean
  accumulateErrorsAcceptTrues =
    case _, _ of
      _, Right true → Right true
      Right true, _ → Right true
      Left acc, Left error →
        Left $ Exception.error $ (Exception.message acc) <> " " <> (Exception.message error)
      Right false, Left error → Left error
      Right false, Right false → Right false
      Left acc, Right false → Left acc

verifyWithJwk ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → JSONWebKey → Eff (AuthEffects eff) (Either Error Boolean)
verifyWithJwk providerR unhashedNonce idToken jwk = do
  OIDCCrypt.verifyIdToken
      (Seconds 1.0)
      idToken
      providerR.openIDConfiguration.issuer
      providerR.clientID
      unhashedNonce
      jwk

getRedirectUri ∷ ∀ eff. Eff (AuthEffects eff) String
getRedirectUri = (_ <> Config.redirectURIString) <$> Browser.locationString

toNotificationOptions ∷ AuthenticationError → Maybe NotificationOptions
toNotificationOptions =
  case _ of
    IdTokenInvalid error →
      Just
        { notification: Notification.Error $ "Sign in failed: Authentication provider provided invalid id token."
        , detail: Notification.Details ∘ Exception.message <$> error
        , timeout
        , actionOptions: Nothing
        }
    IdTokenUnavailable detail →
      Just
      { notification:
          Notification.Error
            $ "Sign in failed: Authentication provider didn't provide a token. This might happen if you are signed into multiple accounts with you authentication provider."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    PromptDismissed →
      Just
        { notification: Notification.Warning $ "Sign in prompt closed."
        , detail: Nothing
        , timeout
        , actionOptions: Nothing
        }
    ProviderError detail →
      Just
        { notification: Notification.Error $ "Sign in failed: There was a problem with your provider configuration, please update your SlamData configuration and try again."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    DOMError _ → Nothing
  where
  timeout = Just $ Milliseconds 5000.0

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module SlamData.Quasar.Auth.Authentication
  ( authentication
  , getIdTokenFromBusSilently
  , toNotificationOptions
  , AuthEffects
  , EIdToken
  , AuthenticationError(..)
  , RequestIdTokenBus
  , RequestIdTokenMessage
  ) where

import Control.Coroutine as Coroutine
import Control.Coroutine.Stalling (($$?))
import Control.Coroutine.Stalling as StallingCoroutine
import Control.Monad.Aff (Aff)
import Control.Monad.Aff as Aff
import Control.Monad.Aff.AVar (AVar, AVAR, AffAVar)
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus (BusRW, BusW)
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Aff.Promise (Promise)
import Control.Monad.Aff.Promise as Promise
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (Error)
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Random (RANDOM)
import Control.Monad.Eff.Ref (Ref, REF)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Rec.Class (forever)
import Control.Parallel.Class (race)
import Control.UI.Browser as Browser
import DOM (DOM)
import DOM.HTML as DOMHTML
import DOM.HTML.Document as DOMHTMLDocument
import DOM.HTML.HTMLIFrameElement as DOMHTMLIFrameElement
import DOM.HTML.Types (HTMLIFrameElement)
import DOM.HTML.Types as DOMHTMLTypes
import DOM.HTML.Window as DOMHTMLWindow
import DOM.Node.Document as DOMNodeDocument
import DOM.Node.Node as DOMNode
import DOM.Node.Types (Node, Element)
import Data.Foldable as F
import Data.Foreign as Foreign
import Data.Nullable as Nullable
import Data.Time.Duration (Milliseconds(Milliseconds), Seconds(Seconds))
import Data.Traversable as T
import OIDC.Aff as OIDCAff
import OIDC.Crypt as OIDCCrypt
import OIDC.Crypt.JSONWebKey (JSONWebKey)
import OIDC.Crypt.Types (IdToken(..), UnhashedNonce(..))
import Quasar.Advanced.Types (ProviderR)
import Quasar.Advanced.Types as QAT
import SlamData.Config as Config
import SlamData.Notification (NotificationOptions)
import SlamData.Notification as Notification
import SlamData.Prelude
import SlamData.Quasar.Auth.IdTokenStorageEvents (getIdTokenStorageEvents)
import SlamData.Quasar.Auth.Keys as AuthKeys
import SlamData.Quasar.Auth.Store as AuthStore

import Text.Parsing.StringParser (ParseError(..))

import Utils (passover)
import Utils.LocalStorage as LocalStorage
import Utils.DOM as DOMUtils

getIdTokenFromBusSilently ∷ ∀ eff. RequestIdTokenBus → Aff (AuthEffects eff) (Either String EIdToken)
getIdTokenFromBusSilently requestIdTokenBus =
  liftEff getProviderRUsingLocalStorage
    >>= case _ of
      Right providerR → do
        idTokenVar ← AVar.makeVar
        Bus.write { idToken: idTokenVar, providerR, prompt: false } requestIdTokenBus
        idToken ← Right <$> AVar.takeVar idTokenVar
        pure idToken
      Left error → pure $ Left error

data AuthenticationError
  = IdTokenInvalid (Maybe Error)
  | IdTokenUnavailable String
  | PromptDismissed
  | DOMError String
  | ProviderError String

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

type RequestIdTokenMessage = { providerR ∷ ProviderR, prompt ∷ Boolean, idToken ∷ AVar EIdToken }

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

type AuthEffects eff =
  ( now ∷ NOW
  , avar ∷ AVAR
  , ref ∷ REF
  , dom ∷ DOM
  , random ∷ RANDOM
  | eff)

firstValueFromStallingProducer
  ∷ forall o eff
  . StallingCoroutine.StallingProducer o (Aff (avar ∷ AVAR | eff)) Unit
  → AffAVar eff o
firstValueFromStallingProducer producer = do
  firstValue ← AVar.makeVar
  Aff.forkAff
    $ StallingCoroutine.runStallingProcess
        (producer $$? (Coroutine.consumer \o → liftAff (AVar.putVar firstValue o) $> Just unit))
  val ← AVar.takeVar firstValue
  pure val

writeOnlyBus ∷ ∀ a. BusRW a → BusW a
writeOnlyBus = snd ∘ Bus.split

-- | Write an AVar to the returned bus to get a valid OIDC id token from the given provider.
authentication ∷ ∀ eff. Aff (AuthEffects eff) RequestIdTokenBus
authentication = do
  stateRef ← liftEff $ Ref.newRef Nothing
  requestBus ← Bus.make
  Aff.forkAff $ forever (authenticate stateRef =<< Bus.read requestBus)
  pure $ writeOnlyBus requestBus

-- TODO: Allow multiple concurrent auth requests with different providers
-- and prompt options. Alternatively immediately respond with an
-- "authentication already in progress" error.
--
-- Currently if a message comes in whilst authentication is in progress the
-- sender will be given the id token from the in progress auth regardless of
-- what provider they asked for.
--
-- In current use this won't happen but it could if things change.
--
-- The same thing and worse could happen before but it was obscured by the
-- "store provider in localstorage then put a message on the bus" approach.
authenticate
  ∷ ∀ eff
  . Ref (Maybe (Promise EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenPromise ← getIdToken message.providerR message.prompt
      writeState $ Just idTokenPromise
      void $ Aff.forkAff $ reply idTokenPromise *> writeState Nothing
    Just idTokenPromise → do
      void $ Aff.forkAff $ reply idTokenPromise
  where
  writeState ∷ Maybe (Promise EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

  reply ∷ Promise EIdToken → Aff (AuthEffects eff) Unit
  reply = AVar.putVar message.idToken <=< Promise.wait

getIdTokenSilently
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenSilently providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  appendHiddenRequestIFrameToBody unhashedNonce providerR
    >>= case _ of
      Left error → pure $ Left error
      Right iFrameNode → do
        idToken ← race (getIdTokenFromLSOnChange providerR unhashedNonce) timeout
        liftEff $ removeBodyChild iFrameNode
        pure idToken
  where
  appendHiddenRequestIFrameToBody unhashedNonce providerR =
    either
      (pure ∘ Left)
      (liftEff ∘ map (lmap DOMError) ∘ appendHiddenIFrameToBody)
      =<< getAuthenticationUri OIDCAff.None unhashedNonce providerR
  timeout =
    Aff.later' Config.authenticationTimeout
      $ pure $ Left $ IdTokenUnavailable "No id token received before timeout."

getIdTokenUsingPrompt
  ∷ ∀ eff
  . ProviderR
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt providerR = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce unhashedNonce
  race
    (getIdTokenFromLSOnChange providerR unhashedNonce)
    (prompt unhashedNonce)
  where
  popup src =
    liftEff (DOMUtils.openPopup src)
      >>= case _ of
        Just window → do
          DOMUtils.waitUntilWindowClosed window
          Aff.later' 250 (pure $ Left PromptDismissed)
        Nothing →
          pure $ Left $ DOMError "`window.open` returned null"
  prompt unhashedNonce =
    (either (pure ∘ Left) popup)
      =<< getAuthenticationUri OIDCAff.Login unhashedNonce providerR

getAuthenticationUri
  ∷ ∀ eff
  . OIDCAff.Prompt
  → UnhashedNonce
  → ProviderR
  → Aff (AuthEffects eff) (Either AuthenticationError String)
getAuthenticationUri prompt unhashedNonce providerR =
  (bimap (ProviderError ∘ runParseError) id)
    <$> (liftEff
           $ OIDCAff.getAuthenticationUri prompt unhashedNonce providerR
           =<< getRedirectUri)

appendHiddenIFrameToBody ∷ ∀ eff. String → Eff (AuthEffects eff) (Either String Node)
appendHiddenIFrameToBody uri =
  either
    (pure ∘ Left)
    (appendIFrameToBody <=< configureHiddenIFrame uri)
    =<< createIFrameElement

configureHiddenIFrame
  ∷ ∀ eff
  . String
  → HTMLIFrameElement
  → Eff (AuthEffects eff) HTMLIFrameElement
configureHiddenIFrame uri iFrameElement = do
  DOMHTMLIFrameElement.setSrc uri iFrameElement
  DOMHTMLIFrameElement.setWidth "0" iFrameElement
  DOMHTMLIFrameElement.setHeight "0" iFrameElement
  pure iFrameElement

appendIFrameToBody
  ∷ ∀ eff
  . HTMLIFrameElement
  → Eff (AuthEffects eff) (Either String Node)
appendIFrameToBody iFrameElement =
  traverse (appendIFrameToNode iFrameElement) =<< getBodyNode

appendIFrameToNode
  ∷ ∀ eff
  . HTMLIFrameElement
  → Node
  → Eff (AuthEffects eff) Node
appendIFrameToNode iFrameElement node =
  passover (flip DOMNode.appendChild node)
    $ DOMHTMLTypes.htmlElementToNode
    $ DOMHTMLTypes.htmlIFrameElementToHTMLElement iFrameElement

createIFrameElement ∷ ∀ eff. Eff (AuthEffects eff) (Either String HTMLIFrameElement)
createIFrameElement =
  (lmap show ∘ DOMHTMLTypes.readHTMLIFrameElement ∘ Foreign.toForeign)
    <$> createElement "iframe"

createElement ∷ ∀ eff.  String → Eff (AuthEffects eff) Element
createElement name =
  DOMNodeDocument.createElement name
    ∘ DOMHTMLTypes.htmlDocumentToDocument
    =<< DOMHTMLWindow.document
    =<< DOMHTML.window

removeBodyChild ∷ ∀ eff.  Node → Eff (AuthEffects eff) (Either String Node)
removeBodyChild child =
  either (pure ∘ Left) (map Right ∘ DOMNode.removeChild child) =<< getBodyNode

getBodyNode ∷ ∀ eff. Eff (AuthEffects eff) (Either String Node)
getBodyNode =
  toEitherStringNode
    <$> (DOMHTMLDocument.body =<< DOMHTMLWindow.document =<< DOMHTML.window)
  where
  toEitherStringNode =
    maybe
      (Left "Couldn't find body element.")
      Right
      ∘ map DOMHTMLTypes.htmlElementToNode
      ∘ Nullable.toMaybe

getIdToken
  ∷ ∀ eff
  . ProviderR
  → Boolean
  → Aff (AuthEffects eff) (Promise EIdToken)
getIdToken providerR prompt =
  Promise.defer do
    idToken ← if prompt
      then
        getIdTokenUsingPrompt providerR
      else
        getIdTokenUsingLocalStorage providerR
          >>= maybe (getIdTokenSilently providerR) (pure ∘ Right)
    -- Store provider for future local storage gets and reauthentications
    either
      (const $ liftEff $ AuthStore.clearProvider *> AuthStore.clearIdToken)
      (const $ liftEff $ AuthStore.storeProvider $ QAT.Provider providerR)
      idToken
    pure idToken

getIdTokenUsingLocalStorage ∷ ∀ eff. ProviderR → Aff (AuthEffects eff) (Maybe IdToken)
getIdTokenUsingLocalStorage providerR = do
  eitherIdToken ← getUnverifiedIdTokenUsingLocalStorage
  eitherUnhashedNonce ← getUnhashedNonceUsingLocalStorage
  case Tuple eitherIdToken eitherUnhashedNonce of
    Tuple (Right idToken) (Right unhashedNonce) →
      either (const $ Nothing) (if _ then (Just idToken) else Nothing)
        <$> (liftEff $ verify providerR unhashedNonce idToken)
    Tuple _ _ → pure Nothing

getUnverifiedIdTokenUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenUsingLocalStorage =
  flip bind (map IdToken)
    <$> LocalStorage.getLocalStorage AuthKeys.idTokenLocalStorageKey

getUnhashedNonceUsingLocalStorage ∷ ∀ eff. Aff (AuthEffects eff) (Either String UnhashedNonce)
getUnhashedNonceUsingLocalStorage =
  rmap UnhashedNonce <$> LocalStorage.getLocalStorage AuthKeys.nonceLocalStorageKey

getProviderRUsingLocalStorage ∷ ∀ eff. Eff (AuthEffects eff) (Either String QAT.ProviderR)
getProviderRUsingLocalStorage =
  map QAT.runProvider <$> LocalStorage.getLocalStorage AuthKeys.providerLocalStorageKey

getIdTokenFromLSOnChange
  ∷ ∀ eff
  . ProviderR
  → UnhashedNonce
  → Aff (AuthEffects eff) EIdToken
getIdTokenFromLSOnChange providerR unhashedNonce =
  getUnverifiedIdTokenFromLSOnChange
    >>= case _ of
          Left localStorageError →
            pure $ Left $ IdTokenUnavailable localStorageError
          Right idToken →
            either
              (Left ∘ IdTokenInvalid ∘ Just )
              (if _ then Right idToken else Left $ IdTokenInvalid Nothing)
              <$> (liftEff $ verify providerR unhashedNonce idToken)

getUnverifiedIdTokenFromLSOnChange
  ∷ ∀ eff
  . Aff (AuthEffects eff) (Either String IdToken)
getUnverifiedIdTokenFromLSOnChange =
  _.newValue <$> (firstValueFromStallingProducer =<< liftEff getIdTokenStorageEvents)

runParseError ∷ ParseError → String
runParseError (ParseError s) = s

-- TODO: Remove g
verify ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → Eff (AuthEffects eff) (Either Error Boolean)
verify providerR unhashedNonce idToken =
  F.foldl accumulateErrorsAcceptTrues (Right false)
    <$> T.traverse
          (verifyWithJwk providerR unhashedNonce idToken)
          providerR.openIDConfiguration.jwks
  where
  accumulateErrorsAcceptTrues ∷ Either Error Boolean → Either Error Boolean → Either Error Boolean
  accumulateErrorsAcceptTrues =
    case _, _ of
      _, Right true → Right true
      Right true, _ → Right true
      Left acc, Left error →
        Left $ Exception.error $ (Exception.message acc) <> " " <> (Exception.message error)
      Right false, Left error → Left error
      Right false, Right false → Right false
      Left acc, Right false → Left acc

verifyWithJwk ∷ ∀ eff. ProviderR → UnhashedNonce → IdToken → JSONWebKey → Eff (AuthEffects eff) (Either Error Boolean)
verifyWithJwk providerR unhashedNonce idToken jwk = do
  OIDCCrypt.verifyIdToken
      (Seconds 1.0)
      idToken
      providerR.openIDConfiguration.issuer
      providerR.clientID
      unhashedNonce
      jwk

getRedirectUri ∷ ∀ eff. Eff (AuthEffects eff) String
getRedirectUri = (_ <> Config.redirectURIString) <$> Browser.locationString

toNotificationOptions ∷ AuthenticationError → Maybe NotificationOptions
toNotificationOptions =
  case _ of
    IdTokenInvalid error →
      Just
        { notification: Notification.Error $ "Sign in failed: Authentication provider provided invalid id token."
        , detail: Notification.Details ∘ Exception.message <$> error
        , timeout
        , actionOptions: Nothing
        }
    IdTokenUnavailable detail →
      Just
        { notification: Notification.Error $ "Sign in failed: Authentication provider didn't provide a token."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    PromptDismissed →
      Just
        { notification: Notification.Warning $ "Sign in prompt closed."
        , detail: Nothing
        , timeout
        , actionOptions: Nothing
        }
    ProviderError detail →
      Just
        { notification: Notification.Error $ "Sign in failed: There was a problem with your provider configuration, please update your SlamData configuration and try again."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions: Nothing
        }
    DOMError _ → Nothing
  where
  timeout = Just $ Milliseconds 5000.0


renderGlyphs for Layer

renderGlyphs for Layer

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, fold, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', Traversal, Traversal', iso, lens, lens', prism', re, to, united, view, (^.), (^?))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.TraversableWithIndex (forWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, onMatch)
import Debug.Trace as Debug
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerDimensions, LayerMask(..), LayerPadding, LayerSlots, LayerType(..), layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

scrollCanvas' :: BrowserContainer
              -> Point
              -> Eff _ Unit
scrollCanvas' (BrowserContainer bc) pt = do
  layers <- Ref.readRef bc.layers

  for_ layers $ \lc -> case lc ^? _LayerCanvas <<< _Buffer of
    Nothing -> pure unit
    Just bc -> scrollCanvas bc pt

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

dragScroll' :: BrowserContainer
            -> (Point -> Eff _ Unit)
            -> Eff _ Unit
dragScroll' bc'@(BrowserContainer {element}) cb =
  canvasDrag f (unsafeCoerce element) -- actually safe
  where f = case _ of
              Left  p    -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas' bc' p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

wheelZoom' :: BrowserContainer
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom' bc cb = Debug.trace "unimplemented!" \_ -> pure unit
  -- canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

blankLayer :: LayerContainer
           -> Eff _ Unit
blankLayer (LayerContainer lc) =
  case lc.canvas of
    Buffer bc -> blankBuffer bc
    Static el -> do
      setCanvasTranslation {x: zero, y: zero} el
      ctx <- Canvas.getContext2D el
      clearCanvas ctx lc.dimensions.size

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

drawToLayer :: LayerContainer
            -> (Context2D -> Eff _ Unit)
            -> Eff _ Unit
drawToLayer (LayerContainer lc) f =
  case lc.canvas of
    Static c -> f =<< Canvas.getContext2D c
    Buffer b -> drawToBuffer b f

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

newtype BrowserContainer =
  BrowserContainer { layers      :: Ref (List LayerContainer)
                   , dimensions  :: Ref LayerDimensions -- ? is this better just kept as a function?
                   , element     :: Element
                   , glyphBuffer :: CanvasElement}

derive instance newtypeBrowserContainer :: Newtype BrowserContainer _

getDimensions :: ∀ m.
                 MonadEff _ m
              => BrowserContainer
              -> m LayerDimensions
getDimensions (BrowserContainer {dimensions}) =
  liftEff $ Ref.readRef dimensions

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

setBrowserContainerSize :: Canvas.Dimensions
                        -> BrowserContainer
                        -> Eff _ Unit
setBrowserContainerSize dim bc'@(BrowserContainer bc) = do
  -- set the container
  setContainerStyle bc.element dim
  -- set each layer
  _ <- traverseLayers (\l@(LayerContainer lc) -> resizeLayer (lc.dimensions { size = dim }) l) bc'
  -- layers <- getLayers bc
  -- traverse f layers
  pure unit

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

-- | Creates an *empty* BrowserContainer, to which layers can be added
browserContainer :: Canvas.Dimensions
                 -> LayerPadding
                 -> Element
                 -> Eff _ BrowserContainer
browserContainer size padding element = do

  setContainerStyle element size

  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  dimensions <- Ref.newRef { size, padding }
  layers     <- Ref.newRef mempty

  pure $
    BrowserContainer
      { layers, dimensions, element, glyphBuffer }

-- | Set the CSS z-indices of the Layers in the browser, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | BrowserContainer layer list is ordered)
zIndexLayers :: BrowserContainer
             -> Eff _ Unit
zIndexLayers (BrowserContainer bc) = do
  layers <- Ref.readRef bc.layers
  void $ forWithIndex layers
           (\i l -> setCanvasZIndex
                      (l ^. _LayerCanvas <<< _FrontCanvas) i)

traverseLayers :: ∀ m a.
                  MonadEff _ m
               => (LayerContainer -> m a)
               -> BrowserContainer
               -> m (List a)
traverseLayers f bc = do
  layers <- getLayers bc
  traverse f layers

getLayers :: ∀ m.
             MonadEff _ m
          => BrowserContainer
          -> m (List LayerContainer)
getLayers (BrowserContainer bc) =
  liftEff $ Ref.readRef bc.layers

resizeLayer :: ∀ m.
               MonadEff _ m
            => LayerDimensions
            -> LayerContainer
            -> m LayerContainer
resizeLayer ld' (LayerContainer lc) = liftEff do
  case lc.canvas of
    Static e -> void $ Canvas.setCanvasDimensions lc.dimensions.size e
    Buffer b -> setBufferedCanvasSize lc.dimensions.size b

  pure $ LayerContainer (lc { dimensions = ld' })

appendLayer :: BrowserContainer
            -> LayerContainer
            -> Eff _ Unit
appendLayer bc@(BrowserContainer {element}) l@(LayerContainer lc)  = do
  layers <- getLayers bc
  appendCanvasElem element (lc.canvas ^. _FrontCanvas)
  zIndexLayers bc

addLayers :: BrowserContainer
          -> List LayerContainer
          -> Eff _ Unit
addLayers bc = traverse_ (appendLayer bc)

deleteLayers :: BrowserContainer
             -> Eff _ Unit
deleteLayers (BrowserContainer bc) = do
  Ref.writeRef bc.layers mempty
  -- TODO update the DOM appropriately,
  -- by just removing the children of bc.element??? or be more specific

  -- maybe expose a function (BrowserContainer -> (LayerContainer -> Eff _ a) -> Eff _ (List a))
  -- so we can effectfully traverse all the layers.
  -- sounds useful at least~~

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

renderGlyphs' :: CanvasElement
              -- -> LayerContainer
              -> Canvas.Context2D
              -> { drawing :: Drawing, points :: Array Point }
              -> Eff _ Unit
renderGlyphs' glyphBuffer ctx {drawing, points} = do
  glyphCtx <- Canvas.getContext2D glyphBuffer

  -- ctx <- getBufferedContext tc.canvas

  -- ctx <-

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphCtx glyphBufferSize

  Drawing.render glyphCtx
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser' :: BrowserContainer
               -> Milliseconds
               -> Number
               -> List (Layer ({|LayerSlots ComponentSlot} -> LayerRenderable))
               -> Aff _ Unit
renderBrowser' bc d offset lrs = do
  layers <- getLayers bc

  let aa :: List LayerContainer
      aa = layers

      fun :: _ -> Layer (Record _ -> LayerRenderable) -> Aff _ _
      fun lct@(LayerContainer lc) l@(Layer ltype lmask c) = do

        ctx <- layerContext l lct
        let slots = layerSlots lc.dimensions

        _ <- liftEff case c of
          Full     a -> clearCanvas ctx slots.full.size
          Padded r a -> do
            let slot = { width:  slots.padded.size.width  + r * 2.0
                       , height: slots.padded.size.height + r * 2.0 }
            clearCanvas ctx slot
          Outside as -> do
            clearCanvas ctx slots.top.size
            clearCanvas ctx slots.right.size
            clearCanvas ctx slots.bottom.size
            clearCanvas ctx slots.left.size

        let fixed    :: Drawing -> Aff _ Unit
            fixed d  = liftEff do
              Drawing.render ctx d

            drawings :: Array _ -> Aff _ Unit
            drawings ds = do
              for_ ds \s -> do
                liftEff $ renderGlyphs' (unwrap bc).glyphBuffer ctx s
                delay d

            labels   :: Array _ -> Aff _ Unit
            labels ls = do
              -- TODO
              pure unit

            drawLayer :: LayerRenderable -> Aff _ Unit
            drawLayer = case_ # onMatch { fixed, drawings, labels }

        traverse_ drawLayer $ map (_ $ slots) c

        pure unit

  -- TODO these lists should be named and lined up properly -- and validated!
  void $ List.zipWithA fun layers lrs

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

-- TODO it doesn't make sense for LayerContainers to contain the
-- actual size of the element, since that can change externally.
-- however, the LayerPadding should be consistent/only changed by the
-- layer, and so should stay in the LayerContainer.
newtype LayerContainer =
  LayerContainer { dimensions  :: LayerDimensions
                 , canvas      :: LayerCanvas }

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_LayerCanvas :: Lens' LayerContainer LayerCanvas
_LayerCanvas = lens
         (\(LayerContainer lc)    -> lc.canvas)
         (\(LayerContainer lc) ct -> LayerContainer $ lc { canvas = ct })

_FrontCanvas :: Getter' LayerCanvas CanvasElement
_FrontCanvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

_Buffer :: Prism' LayerCanvas BufferedCanvas
_Buffer = prism' Buffer from
  where from (Static _) = Nothing
        from (Buffer b) = Just b

_Static :: Prism' LayerCanvas CanvasElement
_Static = prism' Static $ case _ of
  Static el -> Just el
  Buffer _  -> Nothing

_LayerBuffer :: Traversal' LayerContainer BufferedCanvas
_LayerBuffer = _LayerCanvas <<< _Buffer

layerContainer :: ∀ a.
                  LayerDimensions
               -> Layer a
               -> Eff _ LayerContainer
layerContainer lDim (Layer lt _ c) = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ _ -> let p' = lDim.padding
                      in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->      { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _FrontCanvas)

  pure $ LayerContainer { dimensions: lDim, canvas }

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

_fixed :: SProxy "fixed"
_fixed = SProxy

_drawings :: SProxy "drawings"
_drawings = SProxy

_labels :: SProxy "labels"
_labels = SProxy

runLayer' :: ∀ m.
             Monoid m
          => Layer (ComponentSlot -> m)
          -> LayerContainer
          -> m
runLayer' layer@(Layer lt lm com) c@(LayerContainer lc) =
  let slots = layerSlots lc.dimensions
  in case com of
      Full     f -> f slots.full
      Padded r f -> f slots.padded
      Outside  f -> fold [ f.top    slots.top
                         , f.right  slots.right
                         , f.bottom slots.bottom
                         , f.left   slots.left ]

layerContext :: ∀ m a.
                MonadEff _ m
             => Layer a
             -> LayerContainer
             -> m Context2D
layerContext (Layer _ lmask com) (LayerContainer lc) = liftEff do
  ctx <- Canvas.getContext2D $ lc.canvas ^. _FrontCanvas
  _ <- Canvas.transform { m11: one,  m21: zero, m31: zero
                        , m12: zero, m22: one,  m32: zero } ctx

  let whenMasked = when (lmask == Masked)

  case com of
    -- translate to 0.0, 0.0
    Full     _ -> do
      -- whenMasked do
      --   pure unit

      pure ctx
    -- translate inward by the padding
    Padded r _ -> do
      -- whenMasked do
      --   pure unit
      Canvas.translate { translateX: r, translateY: r } ctx
    Outside  _ -> do

      let size = lc.dimensions.size

      whenMasked do
      -- translate to 0.0, set mask to not draw on the padded canvas
        _ <- Canvas.beginPath ctx
        _ <- Canvas.moveTo ctx 0.0        0.0
        _ <- Canvas.lineTo ctx size.width 0.0
        _ <- Canvas.lineTo ctx size.width size.height
        _ <- Canvas.lineTo ctx 0.0        size.height
        _ <- Canvas.lineTo ctx 0.0        0.0
        void $ Canvas.clip ctx

      pure ctx

-- | This module provides a HTML5 canvas interface for the genetics browser,
-- | which wraps and optimizes all rendering calls

module Genetics.Browser.Canvas where

import Prelude

import Control.Monad.Aff (Aff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Uncurried (EffFn2, EffFn3, EffFn4, runEffFn2, runEffFn3, runEffFn4)
import DOM.Node.Types (Element)
import Data.Either (Either(..))
import Data.Foldable (any, fold, foldl, for_)
import Data.Int as Int
import Data.Lens (Getter', Lens', Prism', Traversal, Traversal', iso, lens, lens', prism', re, to, united, view, (^.), (^?))
import Data.Lens.Iso (Iso')
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Record as Lens
import Data.List (List)
import Data.List as List
import Data.Maybe (Maybe(Nothing, Just), fromMaybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype, unwrap)
import Data.Nullable (Nullable, toMaybe)
import Data.Symbol (SProxy(..))
import Data.Time.Duration (Milliseconds)
import Data.Traversable (traverse, traverse_)
import Data.TraversableWithIndex (forWithIndex)
import Data.Tuple (Tuple(Tuple), uncurry)
import Data.Variant (Variant, case_, onMatch)
import Debug.Trace as Debug
import Genetics.Browser.Layer (Component(..), ComponentSlot, Layer(..), LayerDimensions, LayerMask(..), LayerPadding, LayerSlots, LayerType(..), layerSlots)
import Graphics.Canvas (CanvasElement, Context2D)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, Point)
import Graphics.Drawing (render, translate) as Drawing
import Graphics.Drawing.Font (font, fontString) as Drawing
import Graphics.Drawing.Font (sansSerif)
import Unsafe.Coerce (unsafeCoerce)

_Element :: Iso' CanvasElement Element
_Element = iso unsafeCoerce unsafeCoerce

-- | Create a new CanvasElement, not attached to the DOM, with the provided String as its CSS class
foreign import createCanvas :: ∀ eff.
                               { width :: Number, height :: Number }
                            -> String
                            -> Eff eff CanvasElement

foreign import setElementStyleImpl :: ∀ e.
                                      EffFn3 e
                                      Element String String
                                      Unit

setElementStyle :: Element
                -> String
                -> String
                -> Eff _ Unit
setElementStyle = runEffFn3 setElementStyleImpl

setElementStyles :: Element -> Array (Tuple String String) -> Eff _ Unit
setElementStyles el =
  traverse_ (uncurry $ setElementStyle el)

setCanvasStyles :: CanvasElement -> Array (Tuple String String) -> Eff _ Unit
setCanvasStyles = setElementStyles <<< view _Element

setCanvasStyle :: CanvasElement
               -> String
               -> String
               -> Eff _ Unit
setCanvasStyle ce = setElementStyle (ce ^. _Element)

setCanvasZIndex :: CanvasElement -> Int -> Eff _ Unit
setCanvasZIndex ce i = setCanvasStyle ce "z-index" (show i)

setCanvasPosition :: ∀ r.
                     { left :: Number, top :: Number | r }
                  -> CanvasElement
                  -> Eff _ Unit
setCanvasPosition {left, top} ce =
  setCanvasStyles ce
    [ Tuple "position" "absolute"
    , Tuple "top"  (show top  <> "px")
    , Tuple "left" (show left <> "px") ]

foreign import appendCanvasElem :: ∀ e.
                                   Element
                                -> CanvasElement
                                -> Eff e Unit

-- | Sets some of the browser container's CSS to reasonable defaults
foreign import setContainerStyle :: ∀ e. Element -> Canvas.Dimensions -> Eff e Unit

foreign import drawCopies :: ∀ eff a.
                             EffFn4 eff
                             CanvasElement Canvas.Dimensions Context2D (Array Point)
                             Unit

foreign import setCanvasTranslation :: ∀ e.
                                       Point
                                    -> CanvasElement
                                    -> Eff e Unit

foreign import canvasClickImpl :: ∀ e.
                                  EffFn2 e
                                  CanvasElement (Point -> Eff e Unit)
                                  Unit

canvasClick :: CanvasElement -> (Point -> Eff _ Unit) -> Eff _ Unit
canvasClick = runEffFn2 canvasClickImpl

-- | Attaches two callbacks to the BrowserCanvas click event handler,
-- | provided with the track canvas and static overlay canvas' relative
-- | coordinates of the click, respectively.
browserOnClick :: BrowserCanvas
               -> { track   :: Point -> Eff _ Unit
                  , overlay :: Point -> Eff _ Unit }
               -> Eff _ Unit
browserOnClick (BrowserCanvas bc) {track, overlay} =
  canvasClick bc.staticOverlay \o -> do
    let t = { x: o.x - bc.trackPadding.left
            , y: o.y - bc.trackPadding.top }
    overlay o
    track t

foreign import scrollCanvasImpl :: ∀ e.
                                   EffFn3 e
                                   CanvasElement CanvasElement Point
                                   Unit

scrollCanvas :: BufferedCanvas
             -> Point
             -> Eff _ Unit
scrollCanvas (BufferedCanvas bc) = runEffFn3 scrollCanvasImpl bc.back bc.front

scrollCanvas' :: BrowserContainer
              -> Point
              -> Eff _ Unit
scrollCanvas' (BrowserContainer bc) pt = do
  layers <- Ref.readRef bc.layers

  for_ layers $ \lc -> case lc ^? _LayerCanvas <<< _Buffer of
    Nothing -> pure unit
    Just bc -> scrollCanvas bc pt

foreign import canvasDragImpl :: ∀ eff.
                                 CanvasElement
                              -> ( { during :: Nullable Point
                                   , total :: Nullable Point } -> Eff eff Unit )
                              -> Eff eff Unit

foreign import canvasWheelCBImpl :: ∀ eff.
                                    CanvasElement
                                 -> (Number -> Eff eff Unit)
                                 -> Eff eff Unit

canvasDrag :: (Either Point Point -> Eff _ Unit)
           -> CanvasElement
           -> Eff _ Unit
canvasDrag f el =
  let toEither g {during, total} = case toMaybe during of
        Just p  -> g $ Right p
        Nothing -> g $ Left $ fromMaybe {x:zero, y:zero} $ toMaybe total
  in canvasDragImpl el (toEither f)

-- | Takes a BrowserCanvas and a callback function that is called with the
-- | total dragged distance when a click & drag action is completed.
dragScroll :: BrowserCanvas
           -> (Point -> Eff _ Unit)
           -> Eff _ Unit
dragScroll (BrowserCanvas bc) cb = canvasDrag f bc.staticOverlay
  where f = case _ of
              Left  p     -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas (_.canvas $ unwrap bc.track) p'
                scrollCanvas bc.trackOverlay p'

dragScroll' :: BrowserContainer
            -> (Point -> Eff _ Unit)
            -> Eff _ Unit
dragScroll' bc'@(BrowserContainer {element}) cb =
  canvasDrag f (unsafeCoerce element) -- actually safe
  where f = case _ of
              Left  p    -> cb p
              Right {x} -> do
                let p' = {x: -x, y: 0.0}
                scrollCanvas' bc' p'

-- | Takes a BrowserCanvas and a callback function that is called with each
-- | wheel scroll `deltaY`. Callback is provided with only the sign of `deltaY`
-- | as to be `deltaMode` agnostic.
wheelZoom :: BrowserCanvas
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom (BrowserCanvas bc) cb =
  canvasWheelCBImpl bc.staticOverlay cb

wheelZoom' :: BrowserContainer
          -> (Number -> Eff _ Unit)
          -> Eff _ Unit
wheelZoom' bc cb = Debug.trace "unimplemented!" \_ -> pure unit
  -- canvasWheelCBImpl bc.staticOverlay cb

-- | Helper function for erasing the contents of a canvas context given its dimensions
clearCanvas :: Context2D -> Canvas.Dimensions -> Eff _ Unit
clearCanvas ctx {width, height} =
  void $ Canvas.clearRect ctx { x: 0.0, y: 0.0, w: width, h: height }

blankLayer :: LayerContainer
           -> Eff _ Unit
blankLayer (LayerContainer ld lc) =
  case lc of
    Buffer bc -> blankBuffer bc
    Static el -> do
      setCanvasTranslation {x: zero, y: zero} el
      ctx <- Canvas.getContext2D el
      clearCanvas ctx ld.size

-- TODO browser background color shouldn't be hardcoded
backgroundColor :: String
backgroundColor = "white"

-- TODO the back canvas should have the option of being bigger than
-- the front, to minimize redrawing
-- needs adding the offset of the front canvas, and validating that back >= front
newtype BufferedCanvas =
  BufferedCanvas { back  :: CanvasElement
                 , front :: CanvasElement
                 }

derive instance newtypeBufferedCanvas :: Newtype BufferedCanvas _

createBufferedCanvas :: Canvas.Dimensions
                     -> Eff _ BufferedCanvas
createBufferedCanvas dim = do
  back  <- createCanvas dim "buffer"
  front <- createCanvas dim "front"
  let bc = BufferedCanvas { back, front }
  blankBuffer bc
  pure bc

getBufferedContext :: BufferedCanvas
                   -> Eff _ Context2D
getBufferedContext = Canvas.getContext2D <$> _.front <<< unwrap

setBufferedCanvasSize :: Canvas.Dimensions
                      -> BufferedCanvas
                      -> Eff _ Unit
setBufferedCanvasSize dim bc@(BufferedCanvas {back, front}) = do
  _ <- Canvas.setCanvasDimensions dim back
  _ <- Canvas.setCanvasDimensions dim front
  blankBuffer bc
  pure unit

translateBuffer :: Point
                -> BufferedCanvas
                -> Eff _ Unit
translateBuffer p (BufferedCanvas bc) = do
  setCanvasTranslation p bc.back
  setCanvasTranslation p bc.front

drawToBuffer :: BufferedCanvas
             -> (Context2D -> Eff _ Unit)
             -> Eff _ Unit
drawToBuffer (BufferedCanvas {back}) f = do
  ctx <- Canvas.getContext2D back
  f ctx

drawToLayer :: LayerContainer
            -> (Context2D -> Eff _ Unit)
            -> Eff _ Unit
drawToLayer (LayerContainer ld lc) f =
  case lc of
    Static c -> f =<< Canvas.getContext2D c
    Buffer b -> drawToBuffer b f

blankBuffer :: BufferedCanvas
            -> Eff _ Unit
blankBuffer bc@(BufferedCanvas {back, front}) = do
  translateBuffer {x: zero, y: zero} bc

  dim <- Canvas.getCanvasDimensions back

  for_ [back, front]
    $ flip clearCanvas dim <=< Canvas.getContext2D

flipBuffer :: BufferedCanvas
           -> Eff _ Unit
flipBuffer (BufferedCanvas {back, front}) = do
-- NOTE this assumes back and front are the same size
  frontCtx <- Canvas.getContext2D front
  let imgSrc = Canvas.canvasElementToImageSource back

  dim <- Canvas.getCanvasDimensions front

  clearCanvas frontCtx dim
  _ <- Canvas.drawImage frontCtx imgSrc 0.0 0.0
  pure unit

-- | The `width` & `height` of the TrackCanvas is the area glyphs render to;
-- | the browser shows a `width` pixels slice of the whole coordinate system.
-- | `glyphBuffer` is what individual glyphs can be rendered to and copied from, for speed.
newtype TrackCanvas =
  TrackCanvas { canvas      :: BufferedCanvas
              , dimensions  :: Canvas.Dimensions
              , glyphBuffer :: CanvasElement
              }

-- | using hardcoded inner padding for now; makes it look a bit better
trackInnerPad :: Number
trackInnerPad = 5.0

derive instance newtypeTrackCanvas :: Newtype TrackCanvas _

_Dimensions :: ∀ n r1 r2.
               Newtype n { dimensions :: Canvas.Dimensions | r1 }
            => Lens' n Canvas.Dimensions
_Dimensions = _Newtype <<< Lens.prop (SProxy :: SProxy "dimensions")

trackTotalDimensions :: Canvas.Dimensions -> Canvas.Dimensions
trackTotalDimensions d = { width:  d.width  + extra
                         , height: d.height + extra }
  where extra = 2.0 * trackInnerPad

-- TODO calculate based on glyph bounding boxes
glyphBufferSize :: Canvas.Dimensions
glyphBufferSize = { width: 15.0, height: 300.0 }

trackCanvas :: Canvas.Dimensions
            -> Eff _ TrackCanvas
trackCanvas dim = do
  canvas <- createBufferedCanvas $ trackTotalDimensions dim
  glyphBuffer <- createCanvas glyphBufferSize "glyphBuffer"

  pure $ TrackCanvas { dimensions: dim
                     , canvas, glyphBuffer }

setTrackCanvasSize :: Canvas.Dimensions
                   -> TrackCanvas
                   -> Eff _ TrackCanvas
setTrackCanvasSize dim (TrackCanvas tc) = do
  setBufferedCanvasSize (trackTotalDimensions dim) tc.canvas
  pure $ TrackCanvas
    $ tc { dimensions = dim }

-- TODO change name to BrowserPadding
type TrackPadding =
  { left :: Number, right :: Number
  , top :: Number, bottom :: Number }

-- | A `BrowserCanvas` consists of a double-buffered `track`
-- | which is what the genetics browser view is rendered onto,
-- | and a transparent `staticOverlay` canvas the UI is rendered onto,
-- | with a (also transparent) `trackOverlay` that scrolls with the track view.

-- | The `dimensions`, `trackPadding`, and track.width/height are
-- | related such that
-- | track.width + horizontal.left + horizontal.right = dimensions.width
-- | track.height + vertical.top + vertical.bottom = dimensions.height
newtype BrowserCanvas =
  BrowserCanvas { track         :: TrackCanvas
                , trackPadding  :: TrackPadding
                , dimensions    :: Canvas.Dimensions
                , staticOverlay :: CanvasElement
                , trackOverlay  :: BufferedCanvas
                , container :: Element
                }

derive instance newtypeBrowserCanvas :: Newtype BrowserCanvas _

newtype BrowserContainer =
  BrowserContainer { layers     :: Ref (List LayerContainer)
                   , dimensions :: Ref LayerDimensions -- ? is this better just kept as a function?
                   , element    :: Element }

getDimensions :: ∀ m.
                 MonadEff _ m
              => BrowserContainer
              -> m LayerDimensions
getDimensions (BrowserContainer {dimensions}) =
  liftEff $ Ref.readRef dimensions

_Track :: Lens' BrowserCanvas TrackCanvas
_Track = _Newtype <<< Lens.prop (SProxy :: SProxy "track")

foreign import debugBrowserCanvas :: ∀ e.
                                     String
                                  -> BrowserCanvas
                                  -> Eff e Unit

subtractPadding :: Canvas.Dimensions
                -> TrackPadding
                -> Canvas.Dimensions
subtractPadding {width, height} pad =
  { width:  width - pad.left - pad.right
  , height: height - pad.top - pad.bottom }

type UISlot = { offset :: Point
              , size   :: Canvas.Dimensions }

data UISlotGravity = UILeft | UIRight | UITop | UIBottom

derive instance eqUISlotGravity :: Eq UISlotGravity
derive instance ordUISlotGravity :: Ord UISlotGravity

type UISlots = { left   :: UISlot
               , right  :: UISlot
               , top    :: UISlot
               , bottom :: UISlot }

uiSlots :: BrowserCanvas
        -> UISlots
uiSlots (BrowserCanvas bc) =
  let track   = subtractPadding bc.dimensions bc.trackPadding
      browser = bc.dimensions
      pad     = bc.trackPadding
  in { left:   { offset: { x: 0.0, y: pad.top }
               , size:   { height: track.height, width: pad.left }}
     , right:  { offset: { x: browser.width - pad.right, y: pad.top }
               , size:   { height: track.height, width: pad.right }}
     , top:    { offset: { x: pad.left, y: 0.0 }
               , size:   { height: pad.top, width: track.width }}
     , bottom: { offset: { x: browser.width  - pad.right
                         , y: browser.height - pad.bottom }
               , size:   { height: pad.bottom, width: track.width }}
    }

setBrowserCanvasSize :: Canvas.Dimensions
                     -> BrowserCanvas
                     -> Eff _ BrowserCanvas
setBrowserCanvasSize dim (BrowserCanvas bc) = do

  setContainerStyle bc.container dim
  let trackDim = subtractPadding dim bc.trackPadding

  track <- setTrackCanvasSize trackDim bc.track

  setBufferedCanvasSize dim bc.trackOverlay
  _ <- Canvas.setCanvasDimensions dim bc.staticOverlay

  pure $ BrowserCanvas
       $ bc { dimensions = dim
            , track = track }

setBrowserContainerSize :: Canvas.Dimensions
                        -> BrowserContainer
                        -> Eff _ Unit
setBrowserContainerSize dim bc'@(BrowserContainer bc) = do
  -- set the container
  setContainerStyle bc.element dim
  -- set each layer
  _ <- traverseLayers (\l@(LayerContainer ld lc) -> resizeLayer (ld { size = dim }) l) bc'
  -- layers <- getLayers bc
  -- traverse f layers
  pure unit

-- | Creates a `BrowserCanvas` and appends it to the provided element.
-- | Resizes the container element to fit.
browserCanvas :: Canvas.Dimensions
              -> TrackPadding
              -> Element
              -> Eff _ BrowserCanvas
browserCanvas dimensions trackPadding el = do

  setContainerStyle el dimensions

  let trackDim = subtractPadding dimensions trackPadding
  track   <- trackCanvas trackDim

  trackOverlay  <- createBufferedCanvas { width: trackDim.width
                                        , height: dimensions.height }

  staticOverlay <- createCanvas dimensions "staticOverlay"

  let trackEl = _.front  $ unwrap
                $ _.canvas $ unwrap $ track

      trackOverlayEl = _.front $ unwrap $ trackOverlay

  setCanvasZIndex trackEl 10
  setCanvasZIndex trackOverlayEl 20
  setCanvasZIndex staticOverlay 30

  -- TODO handle this nicer maybe idk
  let trackElPosition = { left: trackPadding.left - trackInnerPad
                        , top:  trackPadding.top  - trackInnerPad }

  setCanvasPosition trackElPosition trackEl
  setCanvasPosition { left: trackPadding.left, top: 0.0 } trackOverlayEl
  setCanvasPosition { left: 0.0, top: 0.0} staticOverlay

  appendCanvasElem el trackEl
  appendCanvasElem el trackOverlayEl
  appendCanvasElem el staticOverlay

  pure $ BrowserCanvas { dimensions
                       , track, trackPadding
                       , trackOverlay, staticOverlay
                       , container: el}

-- | Creates an *empty* BrowserContainer, to which layers can be added
browserContainer :: Canvas.Dimensions
                 -> LayerPadding
                 -> Element
                 -> Eff _ BrowserContainer
browserContainer size padding element = do

  setContainerStyle element size

  dimensions <- Ref.newRef { size, padding }
  layers     <- Ref.newRef mempty

  pure $
    BrowserContainer
      { layers, dimensions, element }

-- | Set the CSS z-indices of the Layers in the browser, so their
-- | canvases are drawn in the correct order (i.e. as the
-- | BrowserContainer layer list is ordered)
zIndexLayers :: BrowserContainer
             -> Eff _ Unit
zIndexLayers (BrowserContainer bc) = do
  layers <- Ref.readRef bc.layers
  void $ forWithIndex layers
           (\i l -> setCanvasZIndex
                      (l ^. _LayerCanvas <<< _FrontCanvas) i)

traverseLayers :: ∀ m a.
                  MonadEff _ m
               => (LayerContainer -> m a)
               -> BrowserContainer
               -> m (List a)
traverseLayers f bc = do
  layers <- getLayers bc
  traverse f layers

getLayers :: ∀ m.
             MonadEff _ m
          => BrowserContainer
          -> m (List LayerContainer)
getLayers (BrowserContainer bc) =
  liftEff $ Ref.readRef bc.layers

resizeLayer :: ∀ m.
               MonadEff _ m
            => LayerDimensions
            -> LayerContainer
            -> m LayerContainer
resizeLayer ld' (LayerContainer ld lc) = liftEff do
  case lc of
    Static e -> void $ Canvas.setCanvasDimensions ld.size e
    Buffer b -> setBufferedCanvasSize ld.size b

  pure $ LayerContainer ld' lc

appendLayer :: BrowserContainer
            -> LayerContainer
            -> Eff _ Unit
appendLayer bc@(BrowserContainer {element}) l@(LayerContainer _ cEl)  = do
  layers <- getLayers bc
  appendCanvasElem element (cEl ^. _FrontCanvas)
  zIndexLayers bc

addLayers :: BrowserContainer
          -> List LayerContainer
          -> Eff _ Unit
addLayers bc = traverse_ (appendLayer bc)

deleteLayers :: BrowserContainer
             -> Eff _ Unit
deleteLayers (BrowserContainer bc) = do
  Ref.writeRef bc.layers mempty
  -- TODO update the DOM appropriately,
  -- by just removing the children of bc.element??? or be more specific

  -- maybe expose a function (BrowserContainer -> (LayerContainer -> Eff _ a) -> Eff _ (List a))
  -- so we can effectfully traverse all the layers.
  -- sounds useful at least~~

renderGlyphs :: TrackCanvas
             -> { drawing :: Drawing, points :: Array Point }
             -> Eff _ Unit
renderGlyphs (TrackCanvas tc) {drawing, points} = do
  glyphBfr <- Canvas.getContext2D tc.glyphBuffer
  ctx <- getBufferedContext tc.canvas

  let w = glyphBufferSize.width
      h = glyphBufferSize.height
      x0 = w / 2.0
      y0 = h / 2.0

  clearCanvas glyphBfr glyphBufferSize

  Drawing.render glyphBfr
    $ Drawing.translate x0 y0 drawing

  runEffFn4 drawCopies tc.glyphBuffer glyphBufferSize ctx points

type Label = { text :: String, point :: Point, gravity :: LabelPlace }

data LabelPlace = LLeft | LCenter | LRight

derive instance eqLabelPlace :: Eq LabelPlace

-- hardcoded global label font for now
-- can't use Drawing.Font because we need raw Canvas to measure the text size,
-- but we can at least use Drawing to generate the font string

labelFontSize :: Int
labelFontSize = 14

labelFont :: String
labelFont = Drawing.fontString $ Drawing.font sansSerif labelFontSize mempty

-- | Calculate the rectangle covered by a label when it'd be rendered
-- | to a provided canvas context
labelBox :: Context2D -> Label -> Eff _ Canvas.Rectangle
labelBox ctx {text, point, gravity} = do
  {width} <- Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx
    Canvas.measureText ctx text

  -- close enough height, actually calculating it is a nightmare
  let height = Int.toNumber labelFontSize
      pad = 14.0 + width / 2.0
      x = case gravity of
        LCenter -> point.x
        LLeft   -> point.x - pad
        LRight  -> point.x + pad

  pure $ { x
         , y: point.y - height
         , w: width, h: height }

-- | Returns `true` if the input rectangles overlap
isOverlapping :: Canvas.Rectangle
              -> Canvas.Rectangle
              -> Boolean
isOverlapping r1 r2 =
     r1.x < r2.x + r2.w
  && r1.x + r1.w > r2.x
  && r1.y < r2.y + r2.h
  && r1.h + r1.y > r2.y

eqRectangle :: Canvas.Rectangle
            -> Canvas.Rectangle
            -> Boolean
eqRectangle {x,y,w,h} r =
     x == r.x && y == r.y
  && w == r.w && h == r.h

appendBoxed :: ∀ r.
               Array {rect :: Canvas.Rectangle | r}
            -> {rect :: Canvas.Rectangle | r}
            -> Array {rect :: Canvas.Rectangle | r}
appendBoxed sofar next =
  let overlapsAny :: Boolean
      overlapsAny = any overlaps sofar
        where overlaps r' = (not $ eqRectangle next.rect r'.rect)
                            && next.rect `isOverlapping` r'.rect
  in if overlapsAny then sofar else sofar <> [next]

renderLabels :: Array Label -> Context2D -> Eff _ Unit
renderLabels ls ctx = do

  boxed <- traverse (\l -> {text: l.text, rect: _} <$> labelBox ctx l) ls

  let toRender = foldl appendBoxed [] boxed

  Canvas.withContext ctx do
    _ <- Canvas.setFont labelFont ctx

    for_ toRender \box ->
      Canvas.fillText ctx box.text
        (box.rect.x - (box.rect.w / 2.0))
        box.rect.y

type Renderable r = { drawings :: Array { drawing :: Drawing
                                        , points :: Array Point }
                    , labels :: Array Label | r }

renderBrowser' :: BrowserContainer
               -> Milliseconds
               -> Number
               -> List (Layer ({|LayerSlots ComponentSlot} -> LayerRenderable))
               -> Aff _ Unit
renderBrowser' bc d offset lrs = do
  layers <- getLayers bc

  let aa :: List LayerContainer
      aa = layers

      fun :: _ -> Layer (Record _ -> LayerRenderable) -> Aff _ _
      fun lct@(LayerContainer ld lc) l@(Layer ltype lmask c) = do

        ctx <- layerContext l lct
        let slots = layerSlots ld

        let fixed    :: Drawing -> Aff _ Unit
            fixed d  = liftEff do
              clearCanvas ctx ?later
              Drawing.render ctx d
            drawings :: Array _ -> Aff _ Unit
            drawings = traverse_ \d -> pure unit
            labels   :: Array _ -> Aff _ Unit
            labels   = traverse_ \l -> pure unit

            drawLayer :: LayerRenderable -> Aff _ Unit
            drawLayer = case_ # onMatch { fixed, drawings, labels }

        traverse_ drawLayer $ map (_ $ slots) c

        pure unit

  -- TODO these lists should be named and lined up properly -- and validated!
  xxx <- List.zipWithA fun layers lrs

  let x :: List _
      x = xxx
  pure unit

renderBrowser :: ∀ a b c.
                 Milliseconds
              -> BrowserCanvas
              -> Number
              -> { tracks     :: { snps :: Renderable a
                                 , annotations :: Renderable b }
                 , relativeUI :: Drawing
                 , fixedUI :: Drawing }
             -> Aff _ Unit
renderBrowser d (BrowserCanvas bc) offset ui = do

  let
      labels = ui.tracks.snps.labels <> ui.tracks.annotations.labels

  -- Render the UI
  liftEff do
    staticOverlayCtx <- Canvas.getContext2D bc.staticOverlay

    clearCanvas staticOverlayCtx bc.dimensions
    Drawing.render staticOverlayCtx ui.fixedUI

    translateBuffer {x: zero, y: zero} bc.trackOverlay
    blankBuffer bc.trackOverlay

    translateBuffer {x: (-offset), y: zero} bc.trackOverlay
    trackOverlayCtx <- getBufferedContext bc.trackOverlay

    Drawing.render trackOverlayCtx ui.relativeUI

    translateBuffer {x: (-offset), y: bc.trackPadding.top} bc.trackOverlay
    renderLabels labels trackOverlayCtx

  -- Render the tracks
  let bfr = (unwrap bc.track).canvas
      cnv = (unwrap bfr).front

  -- TODO extract functions `clearTrack` and `translateTrack` that bake in padding
  ctx <- liftEff $ Canvas.getContext2D cnv
  liftEff do
    dim <- Canvas.getCanvasDimensions cnv

    translateBuffer {x: zero, y: zero} bfr
    clearCanvas ctx $ trackTotalDimensions dim

  liftEff $ translateBuffer { x: trackInnerPad - offset
                            , y: trackInnerPad } bfr

  let snpsTrack  = ui.tracks.snps.drawings
      annotTrack = ui.tracks.annotations.drawings

  for_ [snpsTrack, annotTrack] \t ->
    for_ t \s -> do
      liftEff $ renderGlyphs bc.track s
      delay d

-- TODO it doesn't make sense for LayerContainers to contain the
-- actual size of the element, since that can change externally.
-- however, the LayerPadding should be consistent/only changed by the
-- layer, and so should stay in the LayerContainer.
data LayerContainer =
    LayerContainer LayerDimensions LayerCanvas

data LayerCanvas =
    Static Canvas.CanvasElement
  | Buffer BufferedCanvas

_LayerCanvas :: Lens' LayerContainer LayerCanvas
_LayerCanvas = lens
         (\(LayerContainer _ ct)    -> ct)
         (\(LayerContainer ld _) ct -> LayerContainer ld ct)

_FrontCanvas :: Getter' LayerCanvas CanvasElement
_FrontCanvas = to case _ of
  Static c -> c
  Buffer c -> (unwrap c).front

_Buffer :: Prism' LayerCanvas BufferedCanvas
_Buffer = prism' Buffer from
  where from (Static _) = Nothing
        from (Buffer b) = Just b

_Static :: Prism' LayerCanvas CanvasElement
_Static = prism' Static $ case _ of
  Static el -> Just el
  Buffer _  -> Nothing

_LayerBuffer :: Traversal' LayerContainer BufferedCanvas
_LayerBuffer = _LayerCanvas <<< _Buffer

layerContainer :: ∀ a.
                  LayerDimensions
               -> Layer a
               -> Eff _ LayerContainer
layerContainer lDim (Layer lt _ c) = do

  let slots = layerSlots lDim

  let {size, pos} = case c of
        Padded _ _ -> let p' = lDim.padding
                      in { size: slots.padded.size, pos: { left: p'.left, top: p'.top } }
        _        ->      { size: slots.full.size,   pos: { left: 0.0, top: 0.0 } }

  canvas <-
    case lt of
      Fixed     -> Static <$> createCanvas         size "fixed"
      Scrolling -> Buffer <$> createBufferedCanvas size

  setCanvasPosition pos (canvas ^. _FrontCanvas)

  pure $ LayerContainer lDim canvas

type LayerRenderable =
  Variant ( fixed    :: Drawing
          , drawings :: Array { drawing :: Drawing
                              , points :: Array Point }
          , labels   :: Array Label )

runLayer' :: ∀ m.
             Monoid m
          => Layer (ComponentSlot -> m)
          -> LayerContainer
          -> m
runLayer' layer@(Layer lt lm com) c@(LayerContainer ld ct) =
  let slots = layerSlots ld
  in case com of
      Full     f -> f slots.full
      Padded r f -> f slots.padded
      Outside  f -> fold [ f.top    slots.top
                         , f.right  slots.right
                         , f.bottom slots.bottom
                         , f.left   slots.left ]

layerContext :: ∀ m a.
                MonadEff _ m
             => Layer a
             -> LayerContainer
             -> m Context2D
layerContext (Layer _ lmask com) (LayerContainer ld ct) = liftEff do
  ctx <- Canvas.getContext2D $ ct ^. _FrontCanvas
  _ <- Canvas.transform { m11: one,  m21: zero, m31: zero
                        , m12: zero, m22: one,  m32: zero } ctx

  -- let whenMasked = when (lmask == Masked)

  case com of
    -- translate to 0.0, 0.0
    Full     _ -> do
      -- whenMasked do
      --   pure unit

      pure ctx
    -- translate inward by the padding
    Padded r _ -> do
      -- whenMasked do
      --   pure unit
      Canvas.translate { translateX: r, translateY: r } ctx
    Outside  _ -> do

      -- whenMasked do
      --   pure unit
      -- translate to 0.0, set mask to not draw on the padded canvas
      _ <- Canvas.beginPath ctx
      _ <- Canvas.moveTo ctx 0.0           0.0
      _ <- Canvas.lineTo ctx ld.size.width 0.0
      _ <- Canvas.lineTo ctx ld.size.width ld.size.height
      _ <- Canvas.lineTo ctx 0.0           ld.size.height
      _ <- Canvas.lineTo ctx 0.0           0.0
      Canvas.clip ctx


Remove marginLeft from DOM utils

Remove marginLeft from DOM utils

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Utils.CSS where

import Prelude
import CSS (CSS)
import CSS.String (fromString)
import CSS.Stylesheet (key)

transition :: String -> CSS
transition = key (fromString "transition")

calc :: String -> String
calc s = "calc(" <> s <> ")"

width :: String -> CSS
width = key (fromString "width")

left :: String -> CSS
left = key (fromString "left")

transform :: String -> CSS
transform = key (fromString "transform")

translate3d :: String -> String -> String -> String
translate3d x y z = "translate3d(" <> x <> "," <> y <> "," <> z <> ")"

zIndex :: Int → CSS
zIndex = key (fromString "z-index") <<< show

{-
Copyright 2016 SlamData, Inc.

Licensed under the Apache License, Version 2.0 (the "License");
you may not use this file except in compliance with the License.
You may obtain a copy of the License at

    http://www.apache.org/licenses/LICENSE-2.0

Unless required by applicable law or agreed to in writing, software
distributed under the License is distributed on an "AS IS" BASIS,
WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
See the License for the specific language governing permissions and
limitations under the License.
-}

module Utils.CSS where

import Prelude
import CSS (CSS)
import CSS.String (fromString)
import CSS.Stylesheet (key)

transition :: String -> CSS
transition = key (fromString "transition")

calc :: String -> String
calc s = "calc(" <> s <> ")"

width :: String -> CSS
width = key (fromString "width")

left :: String -> CSS
left = key (fromString "left")

marginLeft :: String -> CSS
marginLeft = key (fromString "margin-left")

transform :: String -> CSS
transform = key (fromString "transform")

translate3d :: String -> String -> String -> String
translate3d x y z = "translate3d(" <> x <> "," <> y <> "," <> z <> ")"

zIndex :: Int → CSS
zIndex = key (fromString "z-index") <<< show