Use `runEffectRec` to avoid stack overflows

module Test.Spec.Runner
       ( RunnerEffects
       , run
       , run'
       , runSpec
       , runSpec'
       , defaultConfig
       , timeout
       , Config
       , TestEvents
       , Reporter
       ) where

import Prelude
import Control.Monad.Eff.Exception as Error
import Node.Process as Process
import Test.Spec as Spec
import Test.Spec.Runner.Event as Event
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, makeAff, runAff, forkAff, cancelWith, attempt)
import Control.Monad.Aff.AVar (makeVar, killVar, putVar, takeVar, AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (logShow)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Eff.Timer (TIMER, setTimeout)
import Control.Monad.Trans.Class (lift)
import Data.Array (singleton)
import Data.Either (either)
import Data.Foldable (foldl)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Traversable (for)
import Node.Process (PROCESS)
import Pipes ((>->), yield)
import Pipes (for) as P
import Pipes.Core (Pipe, Producer, (//>))
import Pipes.Core (runEffectRec) as P
import Test.Spec (Spec, Group(..), Result(..), SpecEffects, collect)
import Test.Spec.Console (withAttrs)
import Test.Spec.Runner.Event (Event)
import Test.Spec.Speed (speedOf)
import Test.Spec.Summary (successful)

type RunnerEffects e = SpecEffects (process :: PROCESS | e)

foreign import dateNow :: ∀ e. Eff e Int

type Config = {
  slow :: Int
, timeout :: Maybe Int
}

defaultConfig :: Config
defaultConfig = {
  slow: 75
, timeout: Just 2000
}

trim :: ∀ r. Array (Group r) -> Array (Group r)
trim xs = fromMaybe xs (singleton <$> findJust findOnly xs)
  where
  findOnly :: Group r -> Maybe (Group r)
  findOnly g@(It true _ _) = pure g
  findOnly g@(Describe o _ gs) = findJust findOnly gs <|> if o then pure g else Nothing
  findOnly _ = Nothing

  findJust :: forall a. (a -> Maybe a) -> Array a -> Maybe a
  findJust f = foldl go Nothing
    where
    go Nothing x = f x
    go acc _ = acc

pickFirst
  :: ∀ e
   . Aff (avar :: AVAR | e) Unit
  -> Aff (avar :: AVAR | e) Unit
  -> Aff (avar :: AVAR | e) Unit
pickFirst t1 t2 = do
  va <- makeVar
  c1 <- forkAff $ attempt t1 >>= either (killVar va) (putVar va)
  c2 <- forkAff $ attempt t2 >>= either (killVar va) (putVar va)
  (takeVar va) `cancelWith` (c1 <> c2)

makeTimeout
  :: ∀ e
   . Int
  -> Aff (timer :: TIMER | e) Unit
makeTimeout time = makeAff \fail _ -> void do
  setTimeout time $ fail $ error $ "test timed out after " <> show time <> "ms"

timeout
  :: ∀ e
   . Int
  -> Aff (RunnerEffects e) Unit
  -> Aff (RunnerEffects e) Unit
timeout time t = t `pickFirst` (makeTimeout time)

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: ∀ e
   . Config
  -> Spec (RunnerEffects e) Unit
  -> Producer Event (Aff (RunnerEffects e)) (Array (Group Result))
_run config spec = do
  yield (Event.Start (Spec.countTests spec))
  r <- for (trim $ collect spec) runGroup
  yield (Event.End r)
  pure r

  where
  runGroup (It only name test) = do
    yield Event.Test
    start    <- lift $ liftEff dateNow
    e        <- lift $ attempt case config.timeout of
                                      Just t -> timeout t test
                                      _      -> test
    duration <- lift $ (_ - start) <$> liftEff dateNow
    yield $ either
      (\err ->
        let msg = Error.message err
            stack = Error.stack err
         in Event.Fail name msg stack)
      (const $ Event.Pass name (speedOf config.slow duration) duration)
      e
    yield Event.TestEnd
    pure $ It only name $ either Failure (const Success) e

  runGroup (Pending name) = do
    yield $ Event.Pending name
    pure $ Pending name

  runGroup (Describe only name xs) = do
    yield $ Event.Suite name
    Describe only name <$> (for xs runGroup)
    <* yield Event.SuiteEnd

-- Run a spec, returning the results, without any reporting
runSpec'
  :: ∀ e
   . Config
  -> Spec (RunnerEffects e) Unit
  -> Aff (RunnerEffects e) (Array (Group Result))
runSpec' config spec = P.runEffectRec $ _run config spec //> const (pure unit)

runSpec
  :: ∀ e
   . Spec (RunnerEffects e) Unit
  -> Aff (RunnerEffects e) (Array (Group Result))
runSpec spec = P.runEffectRec $ _run defaultConfig spec //> const (pure unit)

type TestEvents e = Producer Event (Aff e) (Array (Group Result))

type Reporter e = Pipe Event Event (Aff e) (Array (Group Result))

-- Run the spec, report results and exit the program upon completion
run'
  :: ∀ e
   . Config
  -> Array (Reporter (RunnerEffects e))
  -> Spec (RunnerEffects e) Unit
  -> Eff  (RunnerEffects e) Unit
run' config reporters spec = void do
  let events = foldl (>->) (_run config spec) reporters
  runAff onError onSuccess (P.runEffectRec (P.for events onEvent))

  where
    onEvent _ = pure unit

    onError :: Error -> Eff (RunnerEffects e) Unit
    onError err = do withAttrs [31] $ logShow err
                     Process.exit 1

    onSuccess :: Array (Group Result) -> Eff (RunnerEffects e) Unit
    onSuccess results = if successful results
                        then Process.exit 0
                        else Process.exit 1

run
  :: ∀ e
   . Array (Reporter (RunnerEffects e))
  -> Spec (RunnerEffects e) Unit
  -> Eff  (RunnerEffects e) Unit
run = run' defaultConfig

module Test.Spec.Runner
       ( RunnerEffects
       , run
       , run'
       , runSpec
       , runSpec'
       , defaultConfig
       , timeout
       , Config
       , TestEvents
       , Reporter
       ) where

import Prelude
import Control.Monad.Eff.Exception as Error
import Node.Process as Process
import Test.Spec as Spec
import Test.Spec.Runner.Event as Event
import Control.Alternative ((<|>))
import Control.Monad.Aff (Aff, makeAff, runAff, forkAff, cancelWith, attempt)
import Control.Monad.Aff.AVar (makeVar, killVar, putVar, takeVar, AVAR)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (logShow)
import Control.Monad.Eff.Exception (Error, error)
import Control.Monad.Eff.Timer (TIMER, setTimeout)
import Control.Monad.Trans.Class (lift)
import Data.Array (singleton)
import Data.Either (either)
import Data.Foldable (foldl)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Traversable (for)
import Node.Process (PROCESS)
import Pipes ((>->), yield)
import Pipes (for) as P
import Pipes.Core (Pipe, Producer, (//>))
import Pipes.Core (runEffect) as P
import Test.Spec (Spec, Group(..), Result(..), SpecEffects, collect)
import Test.Spec.Console (withAttrs)
import Test.Spec.Runner.Event (Event)
import Test.Spec.Speed (speedOf)
import Test.Spec.Summary (successful)

type RunnerEffects e = SpecEffects (process :: PROCESS | e)

foreign import dateNow :: ∀ e. Eff e Int

type Config = {
  slow :: Int
, timeout :: Maybe Int
}

defaultConfig :: Config
defaultConfig = {
  slow: 75
, timeout: Just 2000
}

trim :: ∀ r. Array (Group r) -> Array (Group r)
trim xs = fromMaybe xs (singleton <$> findJust findOnly xs)
  where
  findOnly :: Group r -> Maybe (Group r)
  findOnly g@(It true _ _) = pure g
  findOnly g@(Describe o _ gs) = findJust findOnly gs <|> if o then pure g else Nothing
  findOnly _ = Nothing

  findJust :: forall a. (a -> Maybe a) -> Array a -> Maybe a
  findJust f = foldl go Nothing
    where
    go Nothing x = f x
    go acc _ = acc

pickFirst
  :: ∀ e
   . Aff (avar :: AVAR | e) Unit
  -> Aff (avar :: AVAR | e) Unit
  -> Aff (avar :: AVAR | e) Unit
pickFirst t1 t2 = do
  va <- makeVar
  c1 <- forkAff $ attempt t1 >>= either (killVar va) (putVar va)
  c2 <- forkAff $ attempt t2 >>= either (killVar va) (putVar va)
  (takeVar va) `cancelWith` (c1 <> c2)

makeTimeout
  :: ∀ e
   . Int
  -> Aff (timer :: TIMER | e) Unit
makeTimeout time = makeAff \fail _ -> void do
  setTimeout time $ fail $ error $ "test timed out after " <> show time <> "ms"

timeout
  :: ∀ e
   . Int
  -> Aff (RunnerEffects e) Unit
  -> Aff (RunnerEffects e) Unit
timeout time t = t `pickFirst` (makeTimeout time)

-- Run the given spec as `Producer` in the underlying `Aff` monad.
-- This producer has two responsibilities:
--      1) emit events for key moments in the runner's lifecycle
--      2) collect the tst output into an array of results
-- This allows downstream consumers to report about the tests even before the
-- prodocer has completed and still benefit from the array of results the way
-- the runner sees it.
_run
  :: ∀ e
   . Config
  -> Spec (RunnerEffects e) Unit
  -> Producer Event (Aff (RunnerEffects e)) (Array (Group Result))
_run config spec = do
  yield (Event.Start (Spec.countTests spec))
  r <- for (trim $ collect spec) runGroup
  yield (Event.End r)
  pure r

  where
  runGroup (It only name test) = do
    yield Event.Test
    start    <- lift $ liftEff dateNow
    e        <- lift $ attempt case config.timeout of
                                      Just t -> timeout t test
                                      _      -> test
    duration <- lift $ (_ - start) <$> liftEff dateNow
    yield $ either
      (\err ->
        let msg = Error.message err
            stack = Error.stack err
         in Event.Fail name msg stack)
      (const $ Event.Pass name (speedOf config.slow duration) duration)
      e
    yield Event.TestEnd
    pure $ It only name $ either Failure (const Success) e

  runGroup (Pending name) = do
    yield $ Event.Pending name
    pure $ Pending name

  runGroup (Describe only name xs) = do
    yield $ Event.Suite name
    Describe only name <$> (for xs runGroup)
    <* yield Event.SuiteEnd

-- Run a spec, returning the results, without any reporting
runSpec'
  :: ∀ e
   . Config
  -> Spec (RunnerEffects e) Unit
  -> Aff (RunnerEffects e) (Array (Group Result))
runSpec' config spec = P.runEffect $ _run config spec //> const (pure unit)

runSpec
  :: ∀ e
   . Spec (RunnerEffects e) Unit
  -> Aff (RunnerEffects e) (Array (Group Result))
runSpec spec = P.runEffect $ _run defaultConfig spec //> const (pure unit)

type TestEvents e = Producer Event (Aff e) (Array (Group Result))

type Reporter e = Pipe Event Event (Aff e) (Array (Group Result))

-- Run the spec, report results and exit the program upon completion
run'
  :: ∀ e
   . Config
  -> Array (Reporter (RunnerEffects e))
  -> Spec (RunnerEffects e) Unit
  -> Eff  (RunnerEffects e) Unit
run' config reporters spec = void do
  let events = foldl (>->) (_run config spec) reporters
  runAff onError onSuccess (P.runEffect (P.for events onEvent))

  where
    onEvent _ = pure unit

    onError :: Error -> Eff (RunnerEffects e) Unit
    onError err = do withAttrs [31] $ logShow err
                     Process.exit 1

    onSuccess :: Array (Group Result) -> Eff (RunnerEffects e) Unit
    onSuccess results = if successful results
                        then Process.exit 0
                        else Process.exit 1

run
  :: ∀ e
   . Array (Reporter (RunnerEffects e))
  -> Spec (RunnerEffects e) Unit
  -> Eff  (RunnerEffects e) Unit
run = run' defaultConfig


[CSM-233] Finish client-api client endpoints for tls

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, mkCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn5, mkEffFn5, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, EffFn8, mkEffFn8)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto
import Daedalus.TLS (TLSOptions, FS, initTLS)
import Node.HTTP (HTTP)

-- TLS

tlsInit :: forall eff. EffFn1 (fs :: FS, err :: EXCEPTION | eff) String TLSOptions
tlsInit = mkEffFn1 initTLS

getLocale :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Json)
getLocale = mkEffFn1 \tls -> fromAff $ map encodeJson (getProfileLocale <$> B.getProfile tls)

updateLocale :: forall eff. EffFn2 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String (Promise Json)
updateLocale = mkEffFn2 \tls locale -> fromAff <<< map encodeJson <<< B.updateProfile tls $ mkCProfile locale

getWallets :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Json)
getWallets = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallets

getWallet :: forall eff. EffFn2 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String (Promise Json)
getWallet = mkEffFn2 \tls -> fromAff <<< map encodeJson <<< B.getWallet tls <<< mkCAddress

getHistory :: forall eff. EffFn4 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String Int Int (Promise Json)
getHistory = mkEffFn4 \tls addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        tls
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn5 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String Int Int (Promise Json)
searchHistory = mkEffFn5 \tls addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        tls
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn5 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String String String (Promise Json)
send = mkEffFn5 \tls addrFrom addrTo amount spendingPassword -> fromAff <<< map encodeJson $
    B.send
        tls
        (mkCPassPhrase spendingPassword)
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn8 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String String String String String String (Promise Json)
sendExtended = mkEffFn8 \tls addrFrom addrTo amount curr title desc spendingPassword -> fromAff <<< map encodeJson $
    B.sendExtended
        tls
        (mkCPassPhrase spendingPassword)
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn6 (http :: HTTP, err :: EXCEPTION, crypto :: Crypto.CRYPTO | eff) TLSOptions String String String String String
  (Promise Json)
newWallet = mkEffFn6 \tls wType wCurrency wName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet tls $ mkCPassPhrase spendingPassword) $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(http :: HTTP, err :: EXCEPTION, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn7 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String String String String Int (Promise Json)
updateWallet = mkEffFn7 \tls addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        tls
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn7 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String String String String Number (Promise Unit)
updateTransaction = mkEffFn7 \tls addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        tls
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn2 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String (Promise Unit)
deleteWallet = mkEffFn2 \tls -> fromAff <<< B.deleteWallet tls <<< mkCAddress

isValidAddress :: forall eff. EffFn3 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String (Promise Boolean)
isValidAddress = mkEffFn3 \tls currency -> fromAff <<< B.isValidAddress tls (mkCCurrency currency)

-- FIXME: notify is not behind TLS yet - we will probably have to modify purescript-websocket-simple
notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Int)
blockchainSlotDuration = mkEffFn1 $ fromAff <<< B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn6 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String String String String (Promise Json)
restoreWallet = mkEffFn6 \tls wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet tls $ mkCPassPhrase spendingPassword) <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn6 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn6 \tls wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet tls $ mkCPassPhrase spendingPassword) <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Json)
nextUpdate = mkEffFn1 $ fromAff <<< map encodeJson <<< B.nextUpdate

applyUpdate :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Unit)
applyUpdate = mkEffFn1 $ fromAff <<< B.applyUpdate

systemVersion :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Json)
systemVersion = mkEffFn1 $ fromAff <<< map encodeJson <<< B.systemVersion

redeemAda :: forall eff. EffFn3 (http :: HTTP, err :: EXCEPTION, crypto :: Crypto.CRYPTO | eff) TLSOptions String String (Promise Json)
redeemAda = mkEffFn3 \tls seed -> fromAff <<< map encodeJson <<< B.redeemAda tls <<< mkCWalletRedeem seed

redeemAdaPaperVend :: forall eff. EffFn4 (http :: HTTP, err :: EXCEPTION, crypto :: Crypto.CRYPTO | eff) TLSOptions String String String (Promise Json)
redeemAdaPaperVend = mkEffFn4 \tls seed mnemonic -> fromAff <<< map encodeJson <<< either throwError (B.redeemAdaPaperVend tls) <<< mkCPaperVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn3 (http :: HTTP, err :: EXCEPTION, crypto :: Crypto.CRYPTO | eff) TLSOptions Int Int (Promise Unit)
reportInit = mkEffFn3 \tls total -> fromAff <<< B.reportInit tls <<< mkCInitialized total

importKey :: forall eff. EffFn2 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions String (Promise Json)
importKey = mkEffFn2 \tls -> fromAff <<< map encodeJson <<< B.importKey tls

syncProgress :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Json)
syncProgress = mkEffFn1 $ fromAff <<< map encodeJson <<< B.syncProgress

testReset :: forall eff. EffFn1 (http :: HTTP, err :: EXCEPTION | eff) TLSOptions (Promise Unit)
testReset = mkEffFn1 $ fromAff <<< B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedemptionKey :: String -> Boolean
isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid paper vend key is base58 encoded 32byte data
isValidPaperVendRedemptionKey :: String -> Boolean
isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, mkCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn5, mkEffFn5, EffFn3, mkEffFn3, EffFn6, mkEffFn6, EffFn7, mkEffFn7, EffFn8, mkEffFn8)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto
import Daedalus.TLS as TLS

-- TLS

initTLS :: forall eff. EffFn1 (fs :: TLS.FS, err :: EXCEPTION | eff) String TLS.TLSOptions
initTLS = mkEffFn1 TLS.initTLS
--
-- getLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Json)
-- getLocale = mkEffFn1 \tls -> fromAff $ map encodeJson (getProfileLocale <$> B.getProfile tls)
--
-- updateLocale :: forall eff. EffFn2 (ajax :: AJAX | eff) TLSOptions String (Promise Json)
-- updateLocale = mkEffFn2 \tls locale -> fromAff <<< map encodeJson <<< B.updateProfile tls $ mkCProfile locale
--
-- getWallets :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Json)
-- getWallets = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallets
--
-- getWallet :: forall eff. EffFn2 (ajax :: AJAX | eff) TLSOptions String (Promise Json)
-- getWallet = mkEffFn2 \tls -> fromAff <<< map encodeJson <<< B.getWallet tls <<< mkCAddress
--
-- getHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) TLSOptions String Int Int (Promise Json)
-- getHistory = mkEffFn4 \tls addr skip limit -> fromAff <<< map encodeJson $
--     B.getHistory
--         tls
--         (mkCAddress addr)
--         skip
--         limit
--
-- searchHistory :: forall eff. EffFn5 (ajax :: AJAX | eff) TLSOptions String String Int Int (Promise Json)
-- searchHistory = mkEffFn5 \tls addr search skip limit -> fromAff <<< map encodeJson $
--     B.searchHistory
--         tls
--         (mkCAddress addr)
--         search
--         skip
--         limit
--
-- send :: forall eff. EffFn5 (ajax :: AJAX | eff) TLSOptions String String String String (Promise Json)
-- send = mkEffFn5 \tls addrFrom addrTo amount spendingPassword -> fromAff <<< map encodeJson $
--     B.send
--         tls
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--
-- sendExtended :: forall eff. EffFn8 (ajax :: AJAX | eff) TLSOptions String String String String String String String (Promise Json)
-- sendExtended = mkEffFn8 \tls addrFrom addrTo amount curr title desc spendingPassword -> fromAff <<< map encodeJson $
--     B.sendExtended
--         tls
--         (mkCPassPhrase spendingPassword)
--         (mkCAddress addrFrom)
--         (mkCAddress addrTo)
--         (mkCCoin amount)
--         (mkCCurrency curr)
--         title
--         desc
--
-- generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
-- generateMnemonic = Crypto.generateMnemonic
--
-- -- | bip39.validateMnemonic and has at least len words
-- isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
-- isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len
--
-- newWallet :: forall eff . EffFn6 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) TLSOptions String String String String String
--   (Promise Json)
-- newWallet = mkEffFn6 \tls wType wCurrency wName mnemonic spendingPassword -> fromAff <<< map encodeJson <<<
--     either throwError (B.newWallet tls $ mkCPassPhrase spendingPassword) $ mkCWalletInit wType wCurrency wName mnemonic
--
-- -- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- -- Daedalus.ClientApi.newWallet(
-- --     'CWTPersonal'
-- --   , 'ADA'
-- --   , 'wallet name'
-- --   , function(mnemonics) {
-- --     // if this function finishes we will send request for wallet
-- --     // creation to the backend. That means user validated and
-- --     // stored mnemonics.
-- --     // if an exception is thrown new wallet request will be aborted
-- --     // and promise should return thrown error
-- --     if(userSavedMnemonics) {
-- --       // do nothing
-- --     } else {
-- --       throw new Error("Wallet canceled")
-- --     }
-- --   }
-- --   )()
-- --   .then(function(value) {
-- --     console.log('SUCCESS', value);
-- --   }, function(reason) {
-- --     console.log('ERROR', reason);
-- --   })
-- -- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
-- --   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- -- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
-- --
-- --     mnemonic <- liftEff Crypto.generateMnemonic
-- --     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
-- --     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
-- --     either throwError B.newWallet $ do
-- --         isConfirmed
-- --         mkCWalletInit wType wCurrency wName mnemonic
--
-- updateWallet :: forall eff. EffFn7 (ajax :: AJAX | eff) TLSOptions String String String String String Int (Promise Json)
-- updateWallet = mkEffFn7 \tls addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
--     B.updateWallet
--         tls
--         (mkCAddress addr)
--         $ mkCWalletMeta wType wCurrency wName wAssurance wUnit
--
-- updateTransaction :: forall eff. EffFn7 (ajax :: AJAX | eff) TLSOptions String String String String String Number (Promise Unit)
-- updateTransaction = mkEffFn7 \tls addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
--     B.updateTransaction
--         tls
--         (mkCAddress addr)
--         (mkCTxId ctxId)
--         $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate
--
-- deleteWallet :: forall eff. EffFn2 (ajax :: AJAX | eff) TLSOptions String (Promise Unit)
-- deleteWallet = mkEffFn2 \tls -> fromAff <<< B.deleteWallet tls <<< mkCAddress
--
-- isValidAddress :: forall eff. EffFn3 (ajax :: AJAX | eff) TLSOptions String String (Promise Boolean)
-- isValidAddress = mkEffFn3 \tls currency -> fromAff <<< B.isValidAddress tls (mkCCurrency currency)
--
-- -- FIXME: notify is not behind TLS yet - we will probably have to modify purescript-websocket-simple
-- notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
-- notify = mkEffFn3 \messageCb errorCb -> do
--     -- TODO (akegalj) grab global (mutable) state of  here
--     -- instead of creating newRef
--     conn <- newRef WSNotConnected
--     openConn $ mkWSState conn messageCb errorCb
--
-- blockchainSlotDuration :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Int)
-- blockchainSlotDuration = mkEffFn1 $ fromAff <<< B.blockchainSlotDuration
--
-- restoreWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) TLSOptions String String String String String (Promise Json)
-- restoreWallet = mkEffFn6 \tls wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet tls $ mkCPassPhrase spendingPassword) <<< mkCWalletInit wType wCurrency wName
--
-- restoreWalletIgnoreChecksum :: forall eff. EffFn6 (ajax :: AJAX | eff) TLSOptions String String String String String (Promise Json)
-- restoreWalletIgnoreChecksum = mkEffFn6 \tls wType wCurrency wName spendingPassword -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet tls $ mkCPassPhrase spendingPassword) <<< mkCWalletInitIgnoreChecksum wType wCurrency wName
--
-- nextUpdate :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Json)
-- nextUpdate = mkEffFn1 $ fromAff <<< map encodeJson <<< B.nextUpdate
--
-- applyUpdate :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Unit)
-- applyUpdate = mkEffFn1 $ fromAff <<< B.applyUpdate
--
-- systemVersion :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Json)
-- systemVersion = mkEffFn1 $ fromAff <<< map encodeJson <<< B.systemVersion
--
-- redeemAda :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) TLSOptions String String (Promise Json)
-- redeemAda = mkEffFn3 \tls seed -> fromAff <<< map encodeJson <<< B.redeemAda tls <<< mkCWalletRedeem seed
--
-- redeemAdaPaperVend :: forall eff. EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) TLSOptions String String String (Promise Json)
-- redeemAdaPaperVend = mkEffFn4 \tls seed mnemonic -> fromAff <<< map encodeJson <<< either throwError (B.redeemAdaPaperVend tls) <<< mkCPaperVendWalletRedeem seed mnemonic
--
-- reportInit :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) TLSOptions Int Int (Promise Unit)
-- reportInit = mkEffFn3 \tls total -> fromAff <<< B.reportInit tls <<< mkCInitialized total
--
-- importKey :: forall eff. EffFn2 (ajax :: AJAX | eff) TLSOptions String (Promise Json)
-- importKey = mkEffFn2 \tls -> fromAff <<< map encodeJson <<< B.importKey tls
--
-- syncProgress :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Json)
-- syncProgress = mkEffFn1 $ fromAff <<< map encodeJson <<< B.syncProgress
--
-- testReset :: forall eff. EffFn1 (ajax :: AJAX | eff) TLSOptions (Promise Unit)
-- testReset = mkEffFn1 $ fromAff <<< B.testReset
--
-- -- Valid redeem code is base64 encoded 32byte data
-- -- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
-- isValidRedemptionKey :: String -> Boolean
-- isValidRedemptionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
--   where
--     -- Because it is 32byte base64 encoded
--     endsWithEqual = isJust $ stripSuffix (Pattern "=") code
--
-- -- Valid paper vend key is base58 encoded 32byte data
-- isValidPaperVendRedemptionKey :: String -> Boolean
-- isValidPaperVendRedemptionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code


refactor

refactor

module Graphics.Babylon.Example.Sandbox.Main (main) where

import Control.Alt (void)
import Control.Alternative (pure)
import Control.Bind (bind, when, (>>=))
import Control.Monad (join)
import Control.Monad.Eff (Eff, forE)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (error, log)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import Control.MonadPlus (guard)
import DOM (DOM)
import Data.Array (fromFoldable, head, (..))
import Data.Array.ST (emptySTArray, pushSTArray, runSTArray)
import Data.BooleanAlgebra (not)
import Data.Foldable (for_)
import Data.Int (toNumber) as Int
import Data.Maybe (Maybe(Just, Nothing), isNothing)
import Data.Nullable (toMaybe)
import Data.Ord (abs, min)
import Data.Ring (negate)
import Data.Show (show)
import Data.ShowMap (delete, insert, isEmpty)
import Data.Traversable (for, sequence)
import Data.Unit (Unit, unit)
import Graphics.Babylon (BABYLON, Canvas, onDOMContentLoaded, querySelectorCanvas)
import Graphics.Babylon.AbstractMesh (abstractMeshToNode, setCheckCollisions, setIsPickable) as AbstractMesh
import Graphics.Babylon.Camera (getPosition) as Camera
import Graphics.Babylon.Color3 (createColor3)
import Graphics.Babylon.CubeTexture (createCubeTexture, cubeTextureToTexture)
import Graphics.Babylon.DebugLayer (show, hide) as DebugLayer
import Graphics.Babylon.DirectionalLight (createDirectionalLight, directionalLightToLight)
import Graphics.Babylon.Engine (createEngine, runRenderLoop)
import Graphics.Babylon.Example.Sandbox.Block (Block(..))
import Graphics.Babylon.Example.Sandbox.BlockIndex (BlockIndex, runBlockIndex)
import Graphics.Babylon.Example.Sandbox.BlockType (grassBlock)
import Graphics.Babylon.Example.Sandbox.Chunk (Chunk(..))
import Graphics.Babylon.Example.Sandbox.ChunkIndex (chunkIndex, chunkIndexRange, runChunkIndex)
import Graphics.Babylon.Example.Sandbox.Event (onButtonClick, onMouseClick, onMouseMove)
import Graphics.Babylon.Example.Sandbox.Generation (chunkSize, createBlockMap)
import Graphics.Babylon.Example.Sandbox.MeshBuilder (createTerrainGeometry)
import Graphics.Babylon.Example.Sandbox.MiniMap (renderMiniMap)
import Graphics.Babylon.Example.Sandbox.Request (generateMesh, postProcess)
import Graphics.Babylon.Example.Sandbox.Terrain (chunkCount, disposeChunk, emptyTerrain, getChunkMap, globalIndexToChunkIndex, globalPositionToChunkIndex, globalPositionToGlobalIndex, insertChunk, lookupBlock, lookupChunk)
import Graphics.Babylon.Example.Sandbox.Types (Mode(Move, Remove, Put), State(State), Effects)
import Graphics.Babylon.Example.Sandbox.VertexDataPropsData (VertexDataPropsData(..))
import Graphics.Babylon.FreeCamera (attachControl, createFreeCamera, freeCameraToCamera, freeCameraToTargetCamera, setCheckCollisions)
import Graphics.Babylon.HemisphericLight (createHemisphericLight, hemisphericLightToLight)
import Graphics.Babylon.Light (setDiffuse)
import Graphics.Babylon.Material (setFogEnabled, setWireframe, setZOffset)
import Graphics.Babylon.Mesh (getTotalIndices, createBox, meshToAbstractMesh, setInfiniteDistance, setMaterial, setPosition, setRenderingGroupId)
import Graphics.Babylon.Node (getName)
import Graphics.Babylon.PickingInfo (getHit, getPickedPoint)
import Graphics.Babylon.Scene (createScene, fOGMODE_EXP, getDebugLayer, pick, render, setCollisionsEnabled, setFogColor, setFogDensity, setFogEnd, setFogMode, setFogStart)
import Graphics.Babylon.ShadowGenerator (createShadowGenerator, getShadowMap, setBias, setRenderList)
import Graphics.Babylon.StandardMaterial (createStandardMaterial, setBackFaceCulling, setDiffuseColor, setDiffuseTexture, setDisableLighting, setReflectionTexture, setSpecularColor, standardMaterialToMaterial)
import Graphics.Babylon.TargetCamera (getRotation, setSpeed, setTarget)
import Graphics.Babylon.Texture (createTexture, sKYBOX_MODE, setCoordinatesMode)
import Graphics.Babylon.Types (AbstractMesh)
import Graphics.Babylon.Vector3 (createVector3, runVector3)
import Graphics.Canvas (CanvasElement, createImageData, getCanvasElementById, getContext2D)
import Math (round)
import Prelude (otherwise, (#), ($), (+), (-), (/=), (<$>), (<=), (<>), (==), (<))

shadowMapSize :: Int
shadowMapSize = 4096

loadDistance :: Int
loadDistance = 4

unloadDistance :: Int
unloadDistance = 8

skyBoxRenderingGruop :: Int
skyBoxRenderingGruop = 0

terrainRenderingGroup :: Int
terrainRenderingGroup = 1

collesionEnabledRange :: Int
collesionEnabledRange = 1

runApp :: forall eff. Canvas -> CanvasElement -> CanvasElement -> Eff (Effects eff) Unit
runApp canvas canvas2d minimap = do

    context <- getContext2D canvas2d

    engine <- createEngine canvas true

    imageMap <- createImageData context 256.0 256.0

    -- create a basic BJS Scene object
    scene <- do
        sce <- createScene engine
        setFogMode fOGMODE_EXP sce
        setFogDensity 0.01 sce
        setFogStart 250.0 sce
        setFogEnd 1000.0 sce
        fogColor <- createColor3 0.8 0.8 1.0
        setFogColor fogColor sce
        setCollisionsEnabled true sce
        pure sce

    camera <- do
        cameraPosition <- createVector3 30.0 30.0 30.0

        cam <- createFreeCamera "free-camera" cameraPosition scene
        setCheckCollisions true cam

        -- target the camera to scene origin
        cameraTarget <- createVector3 5.0 3.0 5.0
        setTarget cameraTarget (freeCameraToTargetCamera cam)

        -- attach the camera to the canvas
        attachControl canvas false cam
        setSpeed 0.3 (freeCameraToTargetCamera cam)

        pure cam

    do
        hemiPosition <- createVector3 0.0 1.0 0.0
        hemiLight <- createHemisphericLight "Hemi0" hemiPosition scene
        diffuse <- createColor3 0.6 0.6 0.6
        setDiffuse diffuse (hemisphericLightToLight hemiLight)

    shadowMap <- do
        -- create a basic light, aiming 0,1,0 - meaning, to the sky
        lightDirection <- createVector3 (negate 0.4) (negate 0.8) (negate 0.4)
        light <- createDirectionalLight "light1" lightDirection scene
        dirColor <- createColor3 0.8 0.8 0.8
        setDiffuse dirColor (directionalLightToLight light)

        -- shadow
        shadowGenerator <- createShadowGenerator shadowMapSize light
        setBias 0.000005 shadowGenerator
        -- setBias 0.000002 shadowGenerator
        --setBias 0.0 shadowGenerator
        getShadowMap shadowGenerator

    cursor <- do
        cursorbox <- createBox "cursor" 1.0 scene
        setRenderingGroupId 1 cursorbox
        AbstractMesh.setIsPickable false (meshToAbstractMesh cursorbox)

        mat <- createStandardMaterial "cursormat" scene
        setWireframe true (standardMaterialToMaterial mat)
        setZOffset (negate 0.01) (standardMaterialToMaterial mat)
        setMaterial (standardMaterialToMaterial mat) cursorbox
        pure cursorbox

    -- skybox
    do
        skyBoxCubeTex <- createCubeTexture "skybox/skybox" scene
        setCoordinatesMode sKYBOX_MODE (cubeTextureToTexture skyBoxCubeTex)

        skyboxMaterial <- createStandardMaterial "skyBox/skybox" scene
        setFogEnabled false (standardMaterialToMaterial skyboxMaterial)
        setBackFaceCulling false skyboxMaterial
        setDisableLighting true skyboxMaterial
        skyDiffuse <- createColor3 0.0 0.0 0.0
        setDiffuseColor skyDiffuse skyboxMaterial
        skySpec <- createColor3 0.0 0.0 0.0
        setSpecularColor skySpec skyboxMaterial
        setReflectionTexture (cubeTextureToTexture skyBoxCubeTex) skyboxMaterial

        skybox <- createBox "skybox" 1000.0 scene
        setRenderingGroupId skyBoxRenderingGruop skybox
        setMaterial (standardMaterialToMaterial skyboxMaterial) skybox
        setInfiniteDistance true skybox

    ref <- newRef $ State {
        mode: Move,
        terrain: emptyTerrain,
        mousePosition: { x: 0, y: 0 },
        debugLayer: false,
        yaw: 0.0,
        pitch: 0.0,
        velocity: { x: 0.0, y: 0.0, z: 0.0 }
    }

    onMouseMove \e -> do
        modifyRef ref \(State s) -> State s {
            mousePosition = {
                x: e.offsetX,
                y: e.offsetY
            }
        }

    let prepareModeButton id value = onButtonClick id do
            modifyRef ref (\(State state) -> State state { mode = value })

    prepareModeButton "move" Move
    prepareModeButton "add" Put
    prepareModeButton "remove" Remove

    onButtonClick "debuglayer" do
        modifyRef ref (\(State state) -> State state { debugLayer = not state.debugLayer })
        State state <- readRef ref
        if state.debugLayer
            then getDebugLayer scene >>= DebugLayer.show true true Nothing
            else getDebugLayer scene >>= DebugLayer.hide

    let
        pickBlock :: forall e. State -> Int -> Int -> Eff (dom :: DOM, ref :: REF, babylon :: BABYLON | e) (Maybe BlockIndex)
        pickBlock (State state) screenX screenY = do
            let predicate mesh = do
                    let name = getName (AbstractMesh.abstractMeshToNode mesh)
                    pure (name /= "cursor")

            pickingInfo <- pick screenX screenY predicate false scene

            let pickup = do
                    let point = getPickedPoint pickingInfo
                    p <- runVector3 point
                    let dx = abs (p.x - round p.x)
                    let dy = abs (p.y - round p.y)
                    let dz = abs (p.z - round p.z)
                    let minDelta = min dx (min dy dz)
                    let lookupBlock' x y z = lookupBlock { x, y, z } state.terrain

                    let putCursor bi = do
                            let rbi = runBlockIndex bi
                            r <- createVector3 (Int.toNumber rbi.x + 0.5) (Int.toNumber rbi.y + 0.5) (Int.toNumber rbi.z + 0.5)
                            setPosition r cursor

                    case state.mode of
                        Put -> if minDelta == dx then do
                                case lookupBlock' (p.x + 0.5) p.y p.z, lookupBlock' (p.x - 0.5) p.y p.z of
                                    Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex (p.x - 0.5) p.y p.z
                                    Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex (p.x + 0.5) p.y p.z
                                    _, _ -> pure Nothing
                                else if minDelta == dy then do
                                        case lookupBlock' p.x (p.y + 0.5) p.z, lookupBlock' p.x (p.y - 0.5) p.z of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y - 0.5) p.z
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y + 0.5) p.z
                                            _, _ -> pure Nothing
                                    else do
                                        case lookupBlock' p.x p.y (p.z + 0.5), lookupBlock' p.x p.y (p.z - 0.5) of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z - 0.5)
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z + 0.5)
                                            _, _ -> pure Nothing

                        Remove -> if minDelta == dx then do
                                case lookupBlock' (p.x + 0.5) p.y p.z, lookupBlock' (p.x - 0.5) p.y p.z of
                                    Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex (p.x + 0.5) p.y p.z
                                    Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex (p.x - 0.5) p.y p.z
                                    _, _ -> pure Nothing
                                else if minDelta == dy then do
                                        case lookupBlock' p.x (p.y + 0.5) p.z, lookupBlock' p.x (p.y - 0.5) p.z of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y + 0.5) p.z
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y - 0.5) p.z
                                            _, _ -> pure Nothing
                                    else do
                                        case lookupBlock' p.x p.y (p.z + 0.5), lookupBlock' p.x p.y (p.z - 0.5) of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z + 0.5)
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z - 0.5)
                                            _, _ -> pure Nothing

                        Move -> pure Nothing

            if getHit pickingInfo then pickup else pure Nothing

    -- prepare materials
    materials <- do
        boxTex <- createTexture "grass-block.png" scene
        boxMat <- createStandardMaterial "grass-block" scene
        grassSpecular <- createColor3 0.0 0.0 0.0
        setSpecularColor grassSpecular boxMat
        -- setSpecularPower 0.0 boxMat
        setDiffuseTexture boxTex boxMat

        waterBoxTex <- createTexture "water-block.png" scene
        waterBoxMat <- createStandardMaterial "water-block" scene
        setDiffuseTexture waterBoxTex waterBoxMat

        pure { boxMat, waterBoxMat }

    onMouseClick \e -> do

        State state <- readRef ref

        picked <- pickBlock (State state) state.mousePosition.x state.mousePosition.y
        case picked of
            Nothing -> pure unit
            Just blockIndex -> do
                let chunkIndex = globalIndexToChunkIndex blockIndex
                case lookupChunk chunkIndex state.terrain of
                    Nothing -> pure unit
                    Just chunkData@{ blocks: Chunk { index, map } } -> void do
                        let chunk' = chunkData {
                                blocks = Chunk { index, map: case state.mode of
                                    Put -> insert blockIndex (Block { index: blockIndex, blockType: grassBlock }) map
                                    Remove -> delete blockIndex map
                                    Move -> map
                                }
                            }

                        mesh <- postProcess ref materials scene (createTerrainGeometry chunk'.blocks)

                        liftEff $ writeRef ref $ State state {
                            terrain = insertChunk mesh state.terrain
                        }

    engine # runRenderLoop do

        State state <- readRef ref

        -- update camera position
        cameraPosition <- Camera.getPosition (freeCameraToCamera camera) >>= runVector3
        let cameraPositionChunkIndex = globalPositionToChunkIndex cameraPosition.x cameraPosition.y cameraPosition.z

        -- picking
        do
            case state.mode of
                Move -> pure unit
                _ -> do
                    picked <- pickBlock (State state) state.mousePosition.x state.mousePosition.y
                    case picked of
                        Nothing -> pure unit
                        Just bi -> do
                            let rbi = runBlockIndex bi
                            r <- createVector3 (Int.toNumber rbi.x + 0.5) (Int.toNumber rbi.y + 0.5) (Int.toNumber rbi.z + 0.5)
                            setPosition r cursor

        -- update shadow rendering list

        do
            let ci = runChunkIndex cameraPositionChunkIndex
            chunks <- runSTArray do
                list <- emptySTArray
                forE (ci.x - 2) (ci.x + 2) \dx -> do
                    forE (ci.y - 2) (ci.y + 2) \dy -> do
                        forE (ci.z - 2) (ci.z + 2) \dz -> do
                            case lookupChunk (chunkIndex dx dy dz) state.terrain of
                                Nothing -> pure unit
                                Just chunkData@{ blocks: Chunk chunk } | isEmpty chunk.map -> pure unit
                                                                       | otherwise -> do
                                                                            let f m = do
                                                                                n <- getTotalIndices m
                                                                                when (0 < n) $ void do
                                                                                pushSTArray list (meshToAbstractMesh m)
                                                                            f chunkData.grassBlockMesh
                                                                            f chunkData.waterBlockMesh
                pure list

            setRenderList chunks shadowMap

        -- load chunk
        do
            let indices = do
                    let ci = runChunkIndex cameraPositionChunkIndex
                    x <- (ci.x - loadDistance) .. (ci.x + loadDistance)
                    y <- (ci.y - 1) .. (ci.y + 1)
                    z <- (ci.z - loadDistance) .. (ci.z + loadDistance)
                    guard (isNothing (lookupChunk (chunkIndex x y z) state.terrain))
                    pure (chunkIndex x y z)

            case head indices of
                Nothing -> pure unit
                Just index -> do
                    let boxMap = createBlockMap index 0
                    case createTerrainGeometry boxMap of
                        VertexDataPropsData verts -> void do
                            case lookupChunk index state.terrain of
                                Nothing -> pure unit
                                Just chunkData -> disposeChunk chunkData
                            grassBlockMesh <- generateMesh index verts.grassBlocks materials.boxMat scene
                            waterBlockMesh <- generateMesh index verts.waterBlocks materials.waterBoxMat scene
                            let result = { blocks: verts.terrain, grassBlockMesh, waterBlockMesh }
                            modifyRef ref \(State state) -> State state {
                                terrain = insertChunk result state.terrain
                            }
                            log $ "load chunk: " <> show index
                            log $ "total chunks:" <> show (chunkCount state.terrain + 1)

        -- set collesion

        do
            State st <- readRef ref
            for_ (getChunkMap st.terrain) \(dat@{ blocks: Chunk chunk }) -> do
                let r = chunkIndexRange chunk.index cameraPositionChunkIndex
                let enabled = r <= collesionEnabledRange
                AbstractMesh.setCheckCollisions enabled (meshToAbstractMesh dat.grassBlockMesh)
                AbstractMesh.setCheckCollisions enabled (meshToAbstractMesh dat.waterBlockMesh)

        do
            pos <- Camera.getPosition (freeCameraToCamera camera) >>= runVector3
            cameraRot <- getRotation (freeCameraToTargetCamera camera) >>= runVector3
            renderMiniMap state.terrain pos cameraRot minimap

        render scene

main :: forall eff. Eff (Effects eff) Unit
main = onDOMContentLoaded do
    canvasM <- toMaybe <$> querySelectorCanvas "#renderCanvas"
    canvas2dM <- getCanvasElementById "canvas2d"
    minimapM <- getCanvasElementById "minimap"
    case canvasM, canvas2dM, minimapM of
        Just canvas, Just canvas2d, Just minimap -> runApp canvas canvas2d minimap
        _, _, _ -> error "canvas not found"

module Graphics.Babylon.Example.Sandbox.Main (main) where

import Control.Alt (void)
import Control.Alternative (pure)
import Control.Bind (bind, (>>=))
import Control.Monad (join)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Console (error, log)
import Control.Monad.Eff.Ref (REF, modifyRef, newRef, readRef, writeRef)
import Control.MonadPlus (guard)
import DOM (DOM)
import Data.Array (fromFoldable, head, (..))
import Data.BooleanAlgebra (not)
import Data.Foldable (for_)
import Data.Int (toNumber) as Int
import Data.Maybe (Maybe(Just, Nothing), isNothing)
import Data.Nullable (toMaybe)
import Data.Ord (abs, min)
import Data.Ring (negate)
import Data.Show (show)
import Data.ShowMap (delete, insert, isEmpty)
import Data.Traversable (for, sequence)
import Data.Unit (Unit, unit)
import Graphics.Babylon (BABYLON, Canvas, onDOMContentLoaded, querySelectorCanvas)
import Graphics.Babylon.AbstractMesh (abstractMeshToNode, setCheckCollisions, setIsPickable) as AbstractMesh
import Graphics.Babylon.Camera (getPosition) as Camera
import Graphics.Babylon.Color3 (createColor3)
import Graphics.Babylon.CubeTexture (createCubeTexture, cubeTextureToTexture)
import Graphics.Babylon.DebugLayer (show, hide) as DebugLayer
import Graphics.Babylon.DirectionalLight (createDirectionalLight, directionalLightToLight)
import Graphics.Babylon.Engine (createEngine, runRenderLoop)
import Graphics.Babylon.Example.Sandbox.Block (Block(..))
import Graphics.Babylon.Example.Sandbox.BlockIndex (BlockIndex, runBlockIndex)
import Graphics.Babylon.Example.Sandbox.BlockType (grassBlock)
import Graphics.Babylon.Example.Sandbox.Chunk (Chunk(..))
import Graphics.Babylon.Example.Sandbox.ChunkIndex (chunkIndex, chunkIndexRange, runChunkIndex)
import Graphics.Babylon.Example.Sandbox.Event (onButtonClick, onMouseClick, onMouseMove)
import Graphics.Babylon.Example.Sandbox.Generation (chunkSize, createBlockMap)
import Graphics.Babylon.Example.Sandbox.MeshBuilder (createTerrainGeometry)
import Graphics.Babylon.Example.Sandbox.MiniMap (renderMiniMap)
import Graphics.Babylon.Example.Sandbox.Request (generateMesh, postProcess)
import Graphics.Babylon.Example.Sandbox.Terrain (chunkCount, disposeChunk, emptyTerrain, getChunkMap, globalIndexToChunkIndex, globalPositionToChunkIndex, globalPositionToGlobalIndex, insertChunk, lookupBlock, lookupChunk)
import Graphics.Babylon.Example.Sandbox.Types (Mode(Move, Remove, Put), State(State), Effects)
import Graphics.Babylon.Example.Sandbox.VertexDataPropsData (VertexDataPropsData(..))
import Graphics.Babylon.FreeCamera (attachControl, createFreeCamera, freeCameraToCamera, freeCameraToTargetCamera, setCheckCollisions)
import Graphics.Babylon.HemisphericLight (createHemisphericLight, hemisphericLightToLight)
import Graphics.Babylon.Light (setDiffuse)
import Graphics.Babylon.Material (setFogEnabled, setWireframe, setZOffset)
import Graphics.Babylon.Mesh (getTotalIndices, createBox, meshToAbstractMesh, setInfiniteDistance, setMaterial, setPosition, setRenderingGroupId)
import Graphics.Babylon.Node (getName)
import Graphics.Babylon.PickingInfo (getHit, getPickedPoint)
import Graphics.Babylon.Scene (createScene, fOGMODE_EXP, getDebugLayer, pick, render, setCollisionsEnabled, setFogColor, setFogDensity, setFogEnd, setFogMode, setFogStart)
import Graphics.Babylon.ShadowGenerator (createShadowGenerator, getShadowMap, setBias, setRenderList)
import Graphics.Babylon.StandardMaterial (createStandardMaterial, setBackFaceCulling, setDiffuseColor, setDiffuseTexture, setDisableLighting, setReflectionTexture, setSpecularColor, standardMaterialToMaterial)
import Graphics.Babylon.TargetCamera (getRotation, setSpeed, setTarget)
import Graphics.Babylon.Texture (createTexture, sKYBOX_MODE, setCoordinatesMode)
import Graphics.Babylon.Types (AbstractMesh)
import Graphics.Babylon.Vector3 (createVector3, runVector3)
import Graphics.Canvas (CanvasElement, createImageData, getCanvasElementById, getContext2D)
import Math (round)
import Prelude (otherwise, (#), ($), (+), (-), (/=), (<$>), (<=), (<>), (==), (<))

shadowMapSize :: Int
shadowMapSize = 4096

loadDistance :: Int
loadDistance = 2

unloadDistance :: Int
unloadDistance = 8

skyBoxRenderingGruop :: Int
skyBoxRenderingGruop = 0

terrainRenderingGroup :: Int
terrainRenderingGroup = 1

collesionEnabledRange :: Int
collesionEnabledRange = 1

runApp :: forall eff. Canvas -> CanvasElement -> CanvasElement -> Eff (Effects eff) Unit
runApp canvas canvas2d minimap = do

    context <- getContext2D canvas2d

    engine <- createEngine canvas true

    imageMap <- createImageData context 256.0 256.0

    -- create a basic BJS Scene object
    scene <- do
        sce <- createScene engine
        setFogMode fOGMODE_EXP sce
        setFogDensity 0.01 sce
        setFogStart 250.0 sce
        setFogEnd 1000.0 sce
        fogColor <- createColor3 0.9 0.9 0.9
        setFogColor fogColor sce
        setCollisionsEnabled true sce
        pure sce

    camera <- do
        cameraPosition <- createVector3 30.0 30.0 30.0

        cam <- createFreeCamera "free-camera" cameraPosition scene
        setCheckCollisions true cam

        -- target the camera to scene origin
        cameraTarget <- createVector3 5.0 3.0 5.0
        setTarget cameraTarget (freeCameraToTargetCamera cam)

        -- attach the camera to the canvas
        attachControl canvas false cam
        setSpeed 0.3 (freeCameraToTargetCamera cam)

        pure cam

    do
        hemiPosition <- createVector3 0.0 1.0 0.0
        hemiLight <- createHemisphericLight "Hemi0" hemiPosition scene
        diffuse <- createColor3 0.6 0.6 0.6
        setDiffuse diffuse (hemisphericLightToLight hemiLight)

    shadowMap <- do
        -- create a basic light, aiming 0,1,0 - meaning, to the sky
        lightDirection <- createVector3 (negate 0.4) (negate 0.8) (negate 0.4)
        light <- createDirectionalLight "light1" lightDirection scene
        dirColor <- createColor3 0.8 0.8 0.8
        setDiffuse dirColor (directionalLightToLight light)

        -- shadow
        shadowGenerator <- createShadowGenerator shadowMapSize light
        setBias 0.000005 shadowGenerator
        -- setBias 0.000002 shadowGenerator
        --setBias 0.0 shadowGenerator
        getShadowMap shadowGenerator

    cursor <- do
        cursorbox <- createBox "cursor" 1.0 scene
        setRenderingGroupId 1 cursorbox
        AbstractMesh.setIsPickable false (meshToAbstractMesh cursorbox)

        mat <- createStandardMaterial "cursormat" scene
        setWireframe true (standardMaterialToMaterial mat)
        setZOffset (negate 0.01) (standardMaterialToMaterial mat)
        setMaterial (standardMaterialToMaterial mat) cursorbox
        pure cursorbox

    -- skybox
    do
        skyBoxCubeTex <- createCubeTexture "skybox/skybox" scene
        setCoordinatesMode sKYBOX_MODE (cubeTextureToTexture skyBoxCubeTex)

        skyboxMaterial <- createStandardMaterial "skyBox/skybox" scene
        setFogEnabled false (standardMaterialToMaterial skyboxMaterial)
        setBackFaceCulling false skyboxMaterial
        setDisableLighting true skyboxMaterial
        skyDiffuse <- createColor3 0.0 0.0 0.0
        setDiffuseColor skyDiffuse skyboxMaterial
        skySpec <- createColor3 0.0 0.0 0.0
        setSpecularColor skySpec skyboxMaterial
        setReflectionTexture (cubeTextureToTexture skyBoxCubeTex) skyboxMaterial

        skybox <- createBox "skybox" 1000.0 scene
        setRenderingGroupId skyBoxRenderingGruop skybox
        setMaterial (standardMaterialToMaterial skyboxMaterial) skybox
        setInfiniteDistance true skybox

    ref <- newRef $ State {
        mode: Move,
        terrain: emptyTerrain,
        mousePosition: { x: 0, y: 0 },
        debugLayer: false,
        yaw: 0.0,
        pitch: 0.0,
        velocity: { x: 0.0, y: 0.0, z: 0.0 }
    }

    onMouseMove \e -> do
        modifyRef ref \(State s) -> State s {
            mousePosition = {
                x: e.offsetX,
                y: e.offsetY
            }
        }

    let prepareModeButton id value = onButtonClick id do
            modifyRef ref (\(State state) -> State state { mode = value })

    prepareModeButton "move" Move
    prepareModeButton "add" Put
    prepareModeButton "remove" Remove

    onButtonClick "debuglayer" do
        modifyRef ref (\(State state) -> State state { debugLayer = not state.debugLayer })
        State state <- readRef ref
        if state.debugLayer
            then getDebugLayer scene >>= DebugLayer.show true true Nothing
            else getDebugLayer scene >>= DebugLayer.hide

    let
        pickBlock :: forall e. State -> Int -> Int -> Eff (dom :: DOM, ref :: REF, babylon :: BABYLON | e) (Maybe BlockIndex)
        pickBlock (State state) screenX screenY = do
            let predicate mesh = do
                    let name = getName (AbstractMesh.abstractMeshToNode mesh)
                    pure (name /= "cursor")

            pickingInfo <- pick screenX screenY predicate false scene

            let pickup = do
                    let point = getPickedPoint pickingInfo
                    p <- runVector3 point
                    let dx = abs (p.x - round p.x)
                    let dy = abs (p.y - round p.y)
                    let dz = abs (p.z - round p.z)
                    let minDelta = min dx (min dy dz)
                    let lookupBlock' x y z = lookupBlock { x, y, z } state.terrain

                    let putCursor bi = do
                            let rbi = runBlockIndex bi
                            r <- createVector3 (Int.toNumber rbi.x + 0.5) (Int.toNumber rbi.y + 0.5) (Int.toNumber rbi.z + 0.5)
                            setPosition r cursor

                    case state.mode of
                        Put -> if minDelta == dx then do
                                case lookupBlock' (p.x + 0.5) p.y p.z, lookupBlock' (p.x - 0.5) p.y p.z of
                                    Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex (p.x - 0.5) p.y p.z
                                    Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex (p.x + 0.5) p.y p.z
                                    _, _ -> pure Nothing
                                else if minDelta == dy then do
                                        case lookupBlock' p.x (p.y + 0.5) p.z, lookupBlock' p.x (p.y - 0.5) p.z of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y - 0.5) p.z
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y + 0.5) p.z
                                            _, _ -> pure Nothing
                                    else do
                                        case lookupBlock' p.x p.y (p.z + 0.5), lookupBlock' p.x p.y (p.z - 0.5) of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z - 0.5)
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z + 0.5)
                                            _, _ -> pure Nothing

                        Remove -> if minDelta == dx then do
                                case lookupBlock' (p.x + 0.5) p.y p.z, lookupBlock' (p.x - 0.5) p.y p.z of
                                    Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex (p.x + 0.5) p.y p.z
                                    Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex (p.x - 0.5) p.y p.z
                                    _, _ -> pure Nothing
                                else if minDelta == dy then do
                                        case lookupBlock' p.x (p.y + 0.5) p.z, lookupBlock' p.x (p.y - 0.5) p.z of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y + 0.5) p.z
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x (p.y - 0.5) p.z
                                            _, _ -> pure Nothing
                                    else do
                                        case lookupBlock' p.x p.y (p.z + 0.5), lookupBlock' p.x p.y (p.z - 0.5) of
                                            Just block, Nothing -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z + 0.5)
                                            Nothing, Just block -> pure $ Just $ globalPositionToGlobalIndex p.x p.y (p.z - 0.5)
                                            _, _ -> pure Nothing

                        Move -> pure Nothing

            if getHit pickingInfo then pickup else pure Nothing

    -- prepare materials
    materials <- do
        boxTex <- createTexture "grass-block.png" scene
        boxMat <- createStandardMaterial "grass-block" scene
        grassSpecular <- createColor3 0.0 0.0 0.0
        setSpecularColor grassSpecular boxMat
        -- setSpecularPower 0.0 boxMat
        setDiffuseTexture boxTex boxMat

        waterBoxTex <- createTexture "water-block.png" scene
        waterBoxMat <- createStandardMaterial "water-block" scene
        setDiffuseTexture waterBoxTex waterBoxMat

        pure { boxMat, waterBoxMat }

    onMouseClick \e -> do

        State state <- readRef ref

        picked <- pickBlock (State state) state.mousePosition.x state.mousePosition.y
        case picked of
            Nothing -> pure unit
            Just blockIndex -> do
                let chunkIndex = globalIndexToChunkIndex blockIndex
                case lookupChunk chunkIndex state.terrain of
                    Nothing -> pure unit
                    Just chunkData@{ blocks: Chunk { index, map } } -> void do
                        let chunk' = chunkData {
                                blocks = Chunk { index, map: case state.mode of
                                    Put -> insert blockIndex (Block { index: blockIndex, blockType: grassBlock }) map
                                    Remove -> delete blockIndex map
                                    Move -> map
                                }
                            }

                        mesh <- postProcess ref materials scene (createTerrainGeometry chunk'.blocks)

                        liftEff $ writeRef ref $ State state {
                            terrain = insertChunk mesh state.terrain
                        }

    engine # runRenderLoop do

        State state <- readRef ref

        -- update camera position
        cameraPosition <- Camera.getPosition (freeCameraToCamera camera) >>= runVector3
        let cameraPositionChunkIndex = globalPositionToChunkIndex cameraPosition.x cameraPosition.y cameraPosition.z

        -- picking
        do
            case state.mode of
                Move -> pure unit
                _ -> do
                    picked <- pickBlock (State state) state.mousePosition.x state.mousePosition.y
                    case picked of
                        Nothing -> pure unit
                        Just bi -> do
                            let rbi = runBlockIndex bi
                            r <- createVector3 (Int.toNumber rbi.x + 0.5) (Int.toNumber rbi.y + 0.5) (Int.toNumber rbi.z + 0.5)
                            setPosition r cursor

        -- update shadow rendering list

        do
            chunks :: Array (Array AbstractMesh) <- sequence do
                    let ci = runChunkIndex cameraPositionChunkIndex
                    dx <- (ci.x - 2) .. (ci.x + 2)
                    dy <- (ci.y - 2) .. (ci.y + 2)
                    dz <- (ci.z - 2) .. (ci.z + 2)
                    case lookupChunk (chunkIndex dx dy dz) state.terrain of
                        Nothing -> [pure []]
                        Just chunkData@{ blocks: Chunk chunk } | isEmpty chunk.map -> [pure []]
                                   | otherwise -> pure do
                                        let f m = do
                                                n <- getTotalIndices m
                                                pure if 0 < n then [meshToAbstractMesh m] else []
                                        g <- f chunkData.grassBlockMesh
                                        w <- f chunkData.waterBlockMesh
                                        pure (g <> w)

            -- log $ "shodow render list: " <> show (length chunks)
            setRenderList (join chunks) shadowMap

        -- load chunk
        do
            let indices = do
                    let ci = runChunkIndex cameraPositionChunkIndex
                    x <- (ci.x + loadDistance) .. (ci.x - loadDistance)
                    y <- (ci.y - 1) .. (ci.y + 1)
                    z <- (ci.z + loadDistance) .. (ci.z - loadDistance)
                    guard (isNothing (lookupChunk (chunkIndex x y z) state.terrain))
                    pure (chunkIndex x y z)

            case head indices of
                Nothing -> pure unit
                Just index -> do
                    let boxMap = createBlockMap index 0
                    case createTerrainGeometry boxMap of
                        VertexDataPropsData verts -> void do
                            case lookupChunk index state.terrain of
                                Nothing -> pure unit
                                Just chunkData -> disposeChunk chunkData
                            grassBlockMesh <- generateMesh index verts.grassBlocks materials.boxMat scene
                            waterBlockMesh <- generateMesh index verts.waterBlocks materials.waterBoxMat scene
                            let result = { blocks: verts.terrain, grassBlockMesh, waterBlockMesh }
                            modifyRef ref \(State state) -> State state {
                                terrain = insertChunk result state.terrain
                            }
                            log $ "load chunk: " <> show index
                            log $ "total chunks:" <> show (chunkCount state.terrain + 1)

        -- set collesion

        do
            State st <- readRef ref
            for_ (getChunkMap st.terrain) \(dat@{ blocks: Chunk chunk }) -> do
                let r = chunkIndexRange chunk.index cameraPositionChunkIndex
                let enabled = r <= collesionEnabledRange
                AbstractMesh.setCheckCollisions enabled (meshToAbstractMesh dat.grassBlockMesh)
                AbstractMesh.setCheckCollisions enabled (meshToAbstractMesh dat.waterBlockMesh)

        do
            pos <- Camera.getPosition (freeCameraToCamera camera) >>= runVector3
            cameraRot <- getRotation (freeCameraToTargetCamera camera) >>= runVector3
            renderMiniMap state.terrain pos cameraRot minimap

        render scene

main :: forall eff. Eff (Effects eff) Unit
main = onDOMContentLoaded do
    canvasM <- toMaybe <$> querySelectorCanvas "#renderCanvas"
    canvas2dM <- getCanvasElementById "canvas2d"
    minimapM <- getCanvasElementById "minimap"
    case canvasM, canvas2dM, minimapM of
        Just canvas, Just canvas2d, Just minimap -> runApp canvas canvas2d minimap
        _, _, _ -> error "canvas not found"