complete test cases for IDBKeyRange interface

module Test.Main where

import Prelude

import Control.Monad.Aff                 (Aff, launchAff, forkAff, delay)
import Control.Monad.Aff.AVar            (AVAR, makeVar', modifyVar, peekVar, killVar)
import Control.Monad.Eff                 (Eff)
import Control.Monad.Eff.Class           (liftEff)
import Control.Monad.Eff.Exception       (EXCEPTION)
import Data.Date                          as Date
import Data.DateTime                      as DateTime
import Data.DateTime                     (DateTime(..), Date(..), Time(..))
import Data.Enum                         (toEnum)
import Data.Maybe                        (Maybe(..), isNothing)
import Data.Time.Duration                (Milliseconds(..))
import Test.Spec                         (describe, it)
import Test.Spec.Assertions              (shouldEqual, fail)
import Test.Spec.Mocha                   (MOCHA, runMocha)

import Database.IndexedDB.Core
import Database.IndexedDB.IDBKey
import Database.IndexedDB.IDBDatabase     as IDBDatabase
import Database.IndexedDB.IDBFactory      as IDBFactory
import Database.IndexedDB.IDBObjectStore  as IDBObjectStore
import Database.IndexedDB.IDBKeyRange     as IDBKeyRange

tearDown :: forall eff. String -> Int -> Database -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Unit
tearDown name version db = do
  liftEff $ IDBDatabase.close db
  version' <- IDBFactory.deleteDatabase name
  version' `shouldEqual` version

-- main :: forall eff. Eff (mocha :: MOCHA, idb :: INDEXED_DB, exception :: EXCEPTION, avar :: AVAR | eff) Unit
main = runMocha do
  describe "IDBFactory" do
    it "open default" do
      let name    = "db-default"
          version = 1
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version" do
      let name    = "db-specific"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version -> close -> open latest" do
      let name    = "db-latest"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      liftEff $ IDBDatabase.close db
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      tearDown name version db

    it "open + onUpgradeNeed" do
      let name    = "db-upgrade-needed"
          version = 1
          callback var db = do
            _ <- launchAff $ modifyVar (const $ IDBDatabase.name db) var
            pure unit
      var <- makeVar' "-"
      db  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db

    it "open + onBlocked" do
      let name    = "db-blocked"
          version = 14
          callback var = do
            _ <- launchAff $ modifyVar (const $ "db-blocked") var
            pure unit

      var   <- makeVar' "-"
      db01  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      _ <- forkAff do
        delay (Milliseconds 100.0)
        liftEff $ IDBDatabase.close db01

      db02  <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Just (callback var)
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db02

  describe "IDBKeyRange" do
    it "only(int)" do
      let key   = 14
          range = IDBKeyRange.only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(string)" do
      let key   = "patate"
          range = IDBKeyRange.only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(float)" do
      let key   = 14.42
          range = IDBKeyRange.only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(date)" do
      let mkey = DateTime
            <$> (Date.canonicalDate <$> toEnum 2017 <*> toEnum 6 <*> toEnum 23)
            <*> (Time <$> toEnum 17 <*> toEnum 59 <*> toEnum 34 <*> toEnum 42)

      case mkey of
        Nothing ->
          fail "unable to create datetime"
        Just key -> do
          let range = IDBKeyRange.only key
          IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only([int])" do
      let key   = [14, 42]
          range = IDBKeyRange.only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only([string])" do
      let key   = ["patate", "autruche"]
          range = IDBKeyRange.only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "lowerBound(14, open)" do
      let key   = 14
          open  = true
          range = IDBKeyRange.lowerBound key open
      IDBKeyRange.includes range (toKey (key + 1)) `shouldEqual` true
      IDBKeyRange.includes range (toKey key) `shouldEqual` (not open)
      IDBKeyRange.includes range (toKey (key - 1)) `shouldEqual` false

    it "lowerBound(14, close)" do
      let key   = 14
          open  = false
          range = IDBKeyRange.lowerBound key open
      IDBKeyRange.includes range (toKey (key + 1)) `shouldEqual` true
      IDBKeyRange.includes range (toKey key) `shouldEqual` (not open)
      IDBKeyRange.includes range (toKey (key - 1)) `shouldEqual` false

    it "upperBound(14, open)" do
      let key   = 14
          open  = true
          range = IDBKeyRange.upperBound key open
      IDBKeyRange.includes range (toKey (key + 1)) `shouldEqual` false
      IDBKeyRange.includes range (toKey key) `shouldEqual` (not open)
      IDBKeyRange.includes range (toKey (key - 1)) `shouldEqual` true

    it "upperBound(14, close)" do
      let key   = 14
          open  = false
          range = IDBKeyRange.upperBound key open
      IDBKeyRange.includes range (toKey (key + 1)) `shouldEqual` false
      IDBKeyRange.includes range (toKey key) `shouldEqual` (not open)
      IDBKeyRange.includes range (toKey (key - 1)) `shouldEqual` true

    it "bound(42, 14, open, open) => Nothing" do
      let lower     = 42
          upper     = 14
          lowerOpen = true
          upperOpen = true
          mrange    = IDBKeyRange.bound { lower, upper, lowerOpen, upperOpen }
      isNothing mrange `shouldEqual` true

    it "bound(14, 42, open, open)" do
      let lower     = 14
          upper     = 42
          lowerOpen = true
          upperOpen = true
          mrange    = IDBKeyRange.bound { lower, upper, lowerOpen, upperOpen }
      case mrange of
        Nothing ->
          fail "invalid range provided"
        Just range -> do
          IDBKeyRange.includes range (toKey (lower + 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (upper - 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (lower - 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey (upper + 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey lower) `shouldEqual` (not lowerOpen)
          IDBKeyRange.includes range (toKey upper) `shouldEqual` (not upperOpen)

    it "bound(14, 42, open, close)" do
      let lower     = 14
          upper     = 42
          lowerOpen = true
          upperOpen = false
          mrange    = IDBKeyRange.bound { lower, upper, lowerOpen, upperOpen }
      case mrange of
        Nothing ->
          fail "invalid range provided"
        Just range -> do
          IDBKeyRange.includes range (toKey (lower + 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (upper - 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (lower - 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey (upper + 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey lower) `shouldEqual` (not lowerOpen)
          IDBKeyRange.includes range (toKey upper) `shouldEqual` (not upperOpen)

    it "bound(14, 42, close, open)" do
      let lower     = 14
          upper     = 42
          lowerOpen = false
          upperOpen = true
          mrange    = IDBKeyRange.bound { lower, upper, lowerOpen, upperOpen }
      case mrange of
        Nothing ->
          fail "invalid range provided"
        Just range -> do
          IDBKeyRange.includes range (toKey (lower + 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (upper - 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (lower - 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey (upper + 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey lower) `shouldEqual` (not lowerOpen)
          IDBKeyRange.includes range (toKey upper) `shouldEqual` (not upperOpen)

    it "bound(14, 42, close, close)" do
      let lower     = 14
          upper     = 42
          lowerOpen = false
          upperOpen = false
          mrange    = IDBKeyRange.bound { lower, upper, lowerOpen, upperOpen }
      case mrange of
        Nothing ->
          fail "invalid range provided"
        Just range -> do
          IDBKeyRange.includes range (toKey (lower + 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (upper - 1)) `shouldEqual` true
          IDBKeyRange.includes range (toKey (lower - 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey (upper + 1)) `shouldEqual` false
          IDBKeyRange.includes range (toKey lower) `shouldEqual` (not lowerOpen)
          IDBKeyRange.includes range (toKey upper) `shouldEqual` (not upperOpen)

    it "can access attributes of a range" do
      let range = IDBKeyRange.lowerBound 14 true
      IDBKeyRange.lower range `shouldEqual` (Just $ toKey 14)
      IDBKeyRange.upper range `shouldEqual` (Nothing :: Maybe Key)
      IDBKeyRange.lowerOpen range `shouldEqual` true
      -- NOTE Not true on Chrome 56.x  => The default value for the flag is `true`
      -- IDBKeyRange.upperOpen range `shouldEqual` false

  describe "IDBDatabase" do
    it "createObjectStore (keyPath: [], autoIncrement: true)" do
      let dbName          = "db-create-store-01"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = []
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: true)" do
      let dbName          = "db-create-store-02"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"a\", \"b\"], autoIncrement: false)" do
      let dbName          = "db-create-store-03"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["a", "b"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: false)" do
      let dbName          = "db-create-store-04"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "deleteObjectStore" do
      let dbName           = "db-delete-store"
          dbVersion        = 2
          storeName        = "store"
          keyPath          = []
          autoIncrement    = true
          callback db      = do
            _ <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            pure unit
          callback2 var db = do
            _ <- IDBDatabase.deleteObjectStore db storeName
            _ <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      liftEff $ IDBDatabase.close db
      db  <- IDBFactory.open dbName (Just dbVersion)
        { onUpgradeNeeded : Just (callback2 var)
        , onBlocked       : Nothing
      }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

  describe "IDBObjectStore" do
    it "add(\"patate\", Nothing )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 1
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" Nothing)
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just 14 )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 14
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just \"key\" )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = "key"
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just <date> )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          mkey          = DateTime
            <$> (Date.canonicalDate <$> toEnum 2017 <*> toEnum 6 <*> toEnum 23)
            <*> (Time <$> toEnum 17 <*> toEnum 59 <*> toEnum 34 <*> toEnum 42)

      case mkey of
        Nothing ->
          fail "unable to create datetime"
        Just key -> do
          let callback db   = do
                store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
                key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
                  <$> IDBObjectStore.add store "patate" (Just $ toKey key))
                pure unit

          db <- IDBFactory.open dbName Nothing
            { onUpgradeNeeded : Just callback
            , onBlocked       : Nothing
            }
          tearDown dbName dbVersion db

    it "add(\"patate\", Just [14, 42] )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = [14, 42]
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "clear()" do
      let dbName        = "db-clear"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ do
              _ <- IDBObjectStore.add store "patate" (Just $ toKey 14)
              _ <- IDBObjectStore.clear store
              v <- IDBObjectStore.get store (IDBKeyRange.only 14)
              v `shouldEqual` (Nothing :: Maybe Int)

            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

module Test.Main where

import Prelude

import Control.Monad.Aff                 (Aff, launchAff, forkAff, delay)
import Control.Monad.Aff.AVar            (AVAR, makeVar', modifyVar, peekVar, killVar)
import Control.Monad.Eff                 (Eff)
import Control.Monad.Eff.Class           (liftEff)
import Control.Monad.Eff.Exception       (EXCEPTION)
import Data.Date                          as Date
import Data.DateTime                      as DateTime
import Data.DateTime                     (DateTime(..), Date(..), Time(..))
import Data.Enum                         (toEnum)
import Data.Maybe                        (Maybe(..))
import Data.Time.Duration                (Milliseconds(..))
import Test.Spec                         (describe, it)
import Test.Spec.Assertions              (shouldEqual, fail)
import Test.Spec.Mocha                   (MOCHA, runMocha)

import Database.IndexedDB.Core
import Database.IndexedDB.IDBKey
import Database.IndexedDB.IDBDatabase     as IDBDatabase
import Database.IndexedDB.IDBFactory      as IDBFactory
import Database.IndexedDB.IDBObjectStore  as IDBObjectStore
import Database.IndexedDB.IDBKeyRange     as IDBKeyRange

tearDown :: forall eff. String -> Int -> Database -> Aff (idb :: INDEXED_DB, exception :: EXCEPTION | eff) Unit
tearDown name version db = do
  liftEff $ IDBDatabase.close db
  version' <- IDBFactory.deleteDatabase name
  version' `shouldEqual` version

-- main :: forall eff. Eff (mocha :: MOCHA, idb :: INDEXED_DB, exception :: EXCEPTION, avar :: AVAR | eff) Unit
main = runMocha do
  describe "IDBFactory" do
    it "open default" do
      let name    = "db-default"
          version = 1
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version" do
      let name    = "db-specific"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      tearDown name version db

    it "open specific version -> close -> open latest" do
      let name    = "db-latest"
          version = 14
      db <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked : Nothing
        }
      IDBDatabase.name db `shouldEqual` name
      liftEff $ IDBDatabase.close db
      db <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      tearDown name version db

    it "open + onUpgradeNeed" do
      let name    = "db-upgrade-needed"
          version = 1
          callback var db = do
            _ <- launchAff $ modifyVar (const $ IDBDatabase.name db) var
            pure unit
      var <- makeVar' "-"
      db  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db

    it "open + onBlocked" do
      let name    = "db-blocked"
          version = 14
          callback var = do
            _ <- launchAff $ modifyVar (const $ "db-blocked") var
            pure unit

      var   <- makeVar' "-"
      db01  <- IDBFactory.open name Nothing
        { onUpgradeNeeded : Nothing
        , onBlocked       : Nothing
        }
      _ <- forkAff do
        delay (Milliseconds 100.0)
        liftEff $ IDBDatabase.close db01

      db02  <- IDBFactory.open name (Just version)
        { onUpgradeNeeded : Nothing
        , onBlocked       : Just (callback var)
        }
      name <- peekVar var
      name `shouldEqual` name
      tearDown name version db02

  describe "IDBKeyRange" do
    it "only(int)" do
      let key   = 14
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(string)" do
      let key   = "patate"
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(float)" do
      let key   = 14.42
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only(date)" do
      let mkey = DateTime
            <$> (Date.canonicalDate <$> toEnum 2017 <*> toEnum 6 <*> toEnum 23)
            <*> (Time <$> toEnum 17 <*> toEnum 59 <*> toEnum 34 <*> toEnum 42)

      case mkey of
        Nothing ->
          fail "unable to create datetime"
        Just key -> do
          let range = IDBKeyRange.new $ IDBKeyRange.Only key
          IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only([int])" do
      let key   = [14, 42]
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

    it "only([string])" do
      let key   = ["patate", "autruche"]
          range = IDBKeyRange.new $ IDBKeyRange.Only key
      IDBKeyRange.includes range (toKey key) `shouldEqual` true

  describe "IDBDatabase" do
    it "createObjectStore (keyPath: [], autoIncrement: true)" do
      let dbName          = "db-create-store-01"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = []
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: true)" do
      let dbName          = "db-create-store-02"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = true
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"a\", \"b\"], autoIncrement: false)" do
      let dbName          = "db-create-store-03"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["a", "b"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "createObjectStore (keyPath: [\"field\"], autoIncrement: false)" do
      let dbName          = "db-create-store-04"
          dbVersion       = 1
          storeName       = "store"
          keyPath         = ["field"]
          autoIncrement   = false
          callback var db = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ IDBObjectStore.name store `shouldEqual` storeName
            _     <- launchAff $ IDBObjectStore.keyPath store `shouldEqual` keyPath
            _     <- launchAff $ IDBObjectStore.autoIncrement store `shouldEqual` autoIncrement
            _     <- launchAff $ IDBObjectStore.indexNames store `shouldEqual` []
            _     <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just (callback var)
        , onBlocked       : Nothing
        }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

    it "deleteObjectStore" do
      let dbName           = "db-delete-store"
          dbVersion        = 2
          storeName        = "store"
          keyPath          = []
          autoIncrement    = true
          callback db      = do
            _ <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            pure unit
          callback2 var db = do
            _ <- IDBDatabase.deleteObjectStore db storeName
            _ <- launchAff $ modifyVar (const true) var
            pure unit

      var <- makeVar' false
      db  <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      liftEff $ IDBDatabase.close db
      db  <- IDBFactory.open dbName (Just dbVersion)
        { onUpgradeNeeded : Just (callback2 var)
        , onBlocked       : Nothing
      }
      hasBeenCalled <- peekVar var
      hasBeenCalled `shouldEqual` true
      tearDown dbName dbVersion db

  describe "IDBObjectStore" do
    it "add(\"patate\", Nothing )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 1
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" Nothing)
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just 14 )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = 14
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just \"key\" )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = "key"
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "add(\"patate\", Just <date> )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          mkey          = DateTime
            <$> (Date.canonicalDate <$> toEnum 2017 <*> toEnum 6 <*> toEnum 23)
            <*> (Time <$> toEnum 17 <*> toEnum 59 <*> toEnum 34 <*> toEnum 42)

      case mkey of
        Nothing ->
          fail "unable to create datetime"
        Just key -> do
          let callback db   = do
                store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
                key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
                  <$> IDBObjectStore.add store "patate" (Just $ toKey key))
                pure unit

          db <- IDBFactory.open dbName Nothing
            { onUpgradeNeeded : Just callback
            , onBlocked       : Nothing
            }
          tearDown dbName dbVersion db

    it "add(\"patate\", Just [14, 42] )" do
      let dbName        = "db-add"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          key           = [14, 42]
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            key   <- launchAff $ ((unsafeFromKey >>> shouldEqual key)
              <$> IDBObjectStore.add store "patate" (Just $ toKey key))
            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db

    it "clear()" do
      let dbName        = "db-clear"
          dbVersion     = 1
          storeName     = "store"
          keyPath       = []
          autoIncrement = true
          callback db   = do
            store <- IDBDatabase.createObjectStore db storeName { keyPath, autoIncrement }
            _     <- launchAff $ do
              _ <- IDBObjectStore.add store "patate" (Just $ toKey 14)
              _ <- IDBObjectStore.clear store
              v <- IDBObjectStore.get store (IDBKeyRange.new $ IDBKeyRange.Only 14)
              v `shouldEqual` (Nothing :: Maybe Int)

            pure unit

      db <- IDBFactory.open dbName Nothing
        { onUpgradeNeeded : Just callback
        , onBlocked       : Nothing
        }
      tearDown dbName dbVersion db


rewrite browser backend to use new coordsys; produces a list of layers of tracks; testing new coordsys

module Genetics.Browser.Track.Backend where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (red)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array)
import Data.Array ((..))
import Data.Array as Array
import Data.BigInt (BigInt)
import Data.Either (Either(..))
import Data.Exists (Exists, runExists)
import Data.Filterable (partition, partitioned)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FoldableWithIndex (foldMapWithIndex)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', to, view, (^.), (^?))
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, isJust, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Pair (Pair(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(SProxy))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (unfoldr)
import Data.Variant (Variant, case_, inj, onMatch, prj)
import Debug.Trace as Debug
import Genetics.Browser.Types (Bp, ChrId, Point)
import Genetics.Browser.Types.Coordinates (CoordSys, Normalized(Normalized), pairSize, pairsOverlap, scaledSegments)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)
import Unsafe.Coerce (unsafeCoerce)

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

type GenomePosV = Variant ( point :: Bp
                          , range :: Pair Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Number -> Drawing )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Pair (Normalized Number) )
type HPos = Variant HorPlaceR

type Renderer a = { draw     :: a -> DrawingV
                  , horPlace :: a -> HPos
                  , verPlace :: a -> Normalized Number
                  }

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> NormalizedGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type BatchedDrawings = { drawing :: Drawing, points :: Array Point }
type SingleDrawing   = { drawing :: Drawing, point :: Point }

type Glyph = Variant ( batched :: BatchedDrawings
                     , single  :: SingleDrawing  )

type FixedUIComponent    = CanvasReadyDrawing
type RelativeUIComponent = Pair BigInt -> CanvasReadyDrawing

type Browser = { tracks     :: Array Glyph
               , relativeUI :: Array RelativeUIComponent
               , fixedUI    :: Array FixedUIComponent }

type CanvasSingleGlyph = { drawing :: Drawing, point :: Point }
type CanvasBatchGlyph  = { drawing :: Drawing, points :: Array Point }

type BatchedTrack = Array CanvasBatchGlyph

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Pair BigInt
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Number | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

_LHS :: Getter' HPos (Normalized Number)
_LHS = to $ case_
         # onMatch { point: \x -> x, range: \(Pair l _) -> l}

renderGlyphs :: forall f r a.
                Canvas.Dimensions
             -> Pair Number
             -> Array NormalizedGlyph
             -> { toBatch :: Array SingleDrawing
                , singles :: Array SingleDrawing }
renderGlyphs {height} vw@(Pair l r) gs =
    (\ {left, right} -> {toBatch: left, singles: right})
    $ partitioned $ map drawIt gs

  where drawIt {drawing, horPos, verPos} =
          let x = (r - l) * unwrap (horPos ^. _LHS)
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width: r-l} drawing
              res = { drawing: d, point: { x: (x + l), y } }
          in if isJust $ prj _point drawing
                then Left res else Right res

renderNormalizedGlyphs :: forall f r a.
                          Canvas.Dimensions
                       -> { width :: Number, offset :: Number }
                       -> Array NormalizedGlyph
                       -> { toBatch :: Array SingleDrawing
                          , singles :: Array SingleDrawing }
renderNormalizedGlyphs {height} {width, offset} gs =
    (\ {left, right} -> {toBatch: left, singles: right})
    $ partitioned $ map drawIt gs

  where drawIt {drawing, horPos, verPos} =
          let x = width * unwrap (horPos ^. _LHS)
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
              res = { drawing: d, point: { x: (x + offset), y } }
          in if isJust $ prj _point drawing
                then Left res else Right res

batchDrawings :: Array SingleDrawing
              -> Array BatchedDrawings
batchDrawings = unfoldr f
  where f gs = Array.uncons gs >>= \ {head, tail} ->
                 let { no, yes } = partition (\ {drawing} -> head.drawing == drawing) tail
                     points = Array.cons head.point $ map _.point yes
                 in pure $ Tuple { drawing: head.drawing, points } no

batchNormalizedGlyphs :: forall f r a.
                         Canvas.Dimensions
                      -> { width :: Number, offset :: Number }
                      -> Array NormalizedGlyph
                      -> Array Glyph
batchNormalizedGlyphs h wo gs =
  let {toBatch, singles} = renderNormalizedGlyphs h wo gs
      batched = inj (SProxy :: SProxy "batched") <$> batchDrawings toBatch
      single  = inj (SProxy :: SProxy "single")  <$> singles
  in batched <> single

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
horRulerTrack {min, max, sig} color f _ = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

-- chrLabelTrack :: CoordSys ChrId BigInt
--               -> Canvas.Dimensions
--               -> RelativeUIComponent
-- chrLabelTrack cs = unsafeCoerce unit
-- chrLabelTrack cs = drawRelativeUI cs (Map.fromFoldable results)
--   where mkLabel :: ChrId -> NormalizedGlyph
--         mkLabel chr = { drawing: inj _point $ chrText chr
--                       , horPos:  inj _point $ Normalized (0.5)
--                       , verPos: Normalized (0.05) }

--         font' = font sansSerif 12 mempty

--         chrText :: ChrId -> Drawing
--         chrText chr = Drawing.text font' zero zero (fillColor black) (unwrap chr)

--         results :: Array _
--         results = map (\x -> Tuple zero [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

-- boxesTrack :: Number
--            -> CoordSys ChrId BigInt
--            -> Canvas.Dimensions
--            -> Pair BigInt -> CanvasReadyDrawing
-- boxesTrack h cs = unsafeCoerce unit
-- boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ cs ^. _BrowserIntervals
--   where glyph :: NormalizedGlyph
--         glyph = { drawing: inj _range draw
--                 , horPos:  inj _range $ Normalized <$> (Pair zero one)
--                 , verPos: aone }
--         draw = \w ->
--              let rect = rectangle 0.0 0.0 w h
--              in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Pair Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Pair Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if pairsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Number
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Number
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Legend
           -> Number
           -> Drawing
drawLegend {width, entries} height =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length entries
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem ic
      d = (height - 2.0*vPad) / (length entries)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) entries
  in fold ds

type Padding = { vertical :: Number
               , horizontal :: Number
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

data Track a = Track (Map ChrId (Array a)) (Renderer a)

renderTrackNormalized :: forall a.
                         Track a
                      -> Map ChrId (Array NormalizedGlyph)
renderTrackNormalized (Track as r) = (map <<< map) (render r) as

horPlaceOnSegment :: forall r.
                     Pair Number
                  -> { horPos :: Variant HorPlaceR | r }
                  -> Number
horPlaceOnSegment segmentPixels o =
    case_
  # onMatch { point: \(Normalized x) -> x * pairSize segmentPixels
            , range: \(Pair l r)     -> unwrap l * pairSize segmentPixels }
  $ o.horPos

finalizeNormDrawing :: forall r.
                       Pair Number
                    -> { drawing :: DrawingV | r }
                    -> Drawing
finalizeNormDrawing seg o =
    case_
  # onMatch { point: \x -> x
            , range: (_ $ pairSize seg) }
  $ o.drawing

-- TODO remember to subtract LHS of view to actually move the glyphs to the screen!

-- TODO should only return SingleDrawing; let renderNormalizedTrack handle batching
renderNormalized1 :: Number
                  -> Pair Number
                  -> NormalizedGlyph
                  -> Glyph
renderNormalized1 height seg@(Pair l _) ng =
  let x = horPlaceOnSegment seg ng + l
      y = height * (one - unwrap ng.verPos)
      drawing = finalizeNormDrawing seg ng
  in inj (SProxy :: SProxy "single") { point: {x,y} , drawing }

renderNormalizedTrack :: CoordSys ChrId BigInt
                      -> Canvas.Dimensions
                      -> Pair BigInt
                      -> Map ChrId (Array NormalizedGlyph)
                      -> Map ChrId (Array Glyph)
renderNormalizedTrack cs cdim bView ngs =
  let segs :: Map ChrId (Pair Number)
      segs = let s = scaledSegments cs { screenWidth: cdim.width, viewWidth: pairSize bView }
             in Debug.traceShow s \_ -> s
      renderSeg :: ChrId -> Pair Number -> Array Glyph
      renderSeg k v = foldMap (map (renderNormalized1 cdim.height v)) $ Map.lookup k ngs
  in mapWithIndex renderSeg segs

browser :: CoordSys ChrId BigInt
        -> Canvas.Dimensions
        -> Padding
        -> { legend :: Legend, vscale :: VScale }
        -> List (Exists Track)
        -> { tracks     :: Pair BigInt -> List (Array Glyph)
           , relativeUI :: Pair BigInt -> Drawing
           , fixedUI    :: Drawing }
browser cs cdim padding ui inputTracks =
  let height = cdim.height - 2.0 * padding.vertical
      width  = cdim.width

      trackCanvas = { width: width - ui.vscale.width - ui.legend.width
                    , height }

      -- TODO make a type that corresponds to left-of-track and right-of-track to make this dynamic
      drawOverlay x w d =
        (translate x zero
         $ filled (fillColor white)
         $ rectangle zero zero w height )
        <> translate x padding.vertical
           d

      vScale = drawOverlay
                 zero
                 ui.vscale.width
                 (drawVScale ui.vscale height)

      legend = drawOverlay
                 (cdim.width - ui.legend.width)
                 ui.legend.width
                 (drawLegend ui.legend height)

      fixedUI = vScale <> legend

      normGlyphs :: List (Map ChrId (Array NormalizedGlyph))
      normGlyphs = map (runExists (\(Track as r) -> (map <<< map) (render r) as)) inputTracks

      tracks :: Pair BigInt -> List (Array Glyph)
      tracks v = fold <$> (renderNormalizedTrack cs cdim v <$> normGlyphs)

      -- chrLabels = chrLabelTrack cs trackCanvas
      -- ruler     = horRulerTrack ui.vscale red trackCanvas
      -- boxes     = boxesTrack height cs trackCanvas

      -- relativeUI = chrLabels
      --           <> translate 0.0 padding.vertical <<< (ruler <> boxes)

  in { tracks
     , relativeUI: mempty
     , fixedUI
     }

module Genetics.Browser.Track.Backend where
       -- ( demoBrowser
       -- , demoLegend
       -- , getDataDemo
       -- ) where

import Prelude

import Color (Color, black, white)
import Color.Scheme.Clrs (red)
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (Json, _Array)
import Data.Array ((..))
import Data.Array as Array
import Data.Either (Either(..))
import Data.Exists (Exists, runExists)
import Data.Filterable (partition, partitioned)
import Data.Foldable (class Foldable, fold, foldMap, foldl, length, maximum)
import Data.FunctorWithIndex (mapWithIndex)
import Data.Int as Int
import Data.Lens (Getter', to, view, (^.), (^?))
import Data.List (List)
import Data.Map (Map)
import Data.Map as Map
import Data.Maybe (Maybe(Just, Nothing), fromMaybe, isJust, maybe)
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (unwrap)
import Data.Pair (Pair(..))
import Data.Record as Record
import Data.Symbol (class IsSymbol, SProxy(..))
import Data.Traversable (class Traversable, traverse)
import Data.Tuple (Tuple(Tuple), snd, uncurry)
import Data.Unfoldable (unfoldr)
import Data.Variant (Variant, case_, inj, on, onMatch, prj)
import Genetics.Browser.Types (Bp, ChrId, Point)
import Genetics.Browser.Types.Coordinates (BrowserPoint, CoordSys, Interval, Normalized(Normalized), _BrowserIntervals, _Index, _Interval, intervalToScreen, intervalsOverlap, intervalsToMap)
import Genetics.Browser.View (Pixels)
import Graphics.Canvas as Canvas
import Graphics.Drawing (Drawing, circle, fillColor, filled, lineWidth, outlineColor, outlined, rectangle, translate)
import Graphics.Drawing as Drawing
import Graphics.Drawing.Font (font, sansSerif)
import Network.HTTP.Affjax as Affjax
import Type.Prelude (class RowLacks)

type BrowserView = Interval BrowserPoint

intersection :: forall k a b.
                Ord k
             => Map k a
             -> Map k b
             -> Map k a
intersection a b = Map.filterKeys (flip Map.member b) a

zipMaps :: forall k a b.
           Ord k
        => Map k a
        -> Map k b
        -> Map k (Tuple a b)
zipMaps a b =
  let kas = Array.unzip $ Map.toAscUnfoldable $ a `intersection` b
      kbs = Array.unzip $ Map.toAscUnfoldable $ b `intersection` a
      kabs = uncurry Array.zip $ map (Array.zip (snd kas)) kbs
  in Map.fromFoldable kabs

zipMapsWith :: forall k a b c.
               Ord k
            => (a -> b -> c)
            -> Map k a
            -> Map k b
            -> Map k c
zipMapsWith f a b = uncurry f <$> zipMaps a b

type ChrCtx r = Map ChrId (Record r)

_point = SProxy :: SProxy "point"
_range = SProxy :: SProxy "range"

type GenomePosV = Variant ( point :: Bp
                          , range :: Interval Bp )

type FeatureR r = ( position :: GenomePosV
                  , frameSize :: Bp
                  | r )
type Feature r = Record (FeatureR r)

type DrawingR  = ( point :: Drawing
                 , range :: Pixels -> Drawing )
type DrawingV  = Variant DrawingR

type HorPlaceR = ( point :: Normalized Number
                 , range :: Interval (Normalized Number) )
type HPos = Variant HorPlaceR

type Renderer a = { draw     :: a -> DrawingV
                  , horPlace :: a -> HPos
                  , verPlace :: a -> Normalized Number
                  }

type NormalizedGlyph = { drawing :: Variant DrawingR
                       , horPos  :: Variant HorPlaceR
                       , verPos  :: Normalized Number
                       }

horPlace :: forall r.
            Feature r
         -> HPos
horPlace {position, frameSize} =
  let f p = Normalized (unwrap $ p / frameSize)
  in case_
    # onMatch
      { point: inj _point <<< f
      , range: inj _range <<< (map f)
      }
    $ position

verPlace :: forall r.
            (Getter' (Feature r) (Normalized Number))
         -> Feature r
         -> Normalized Number
verPlace = view

render :: forall err a.
          Renderer a
       -> a
       -> NormalizedGlyph
render render a =
      { drawing: render.draw a
      , horPos:  render.horPlace a
      , verPos:  render.verPlace a
      }

type BatchedDrawings = { drawing :: Drawing, points :: Array Point }
type SingleDrawing   = { drawing :: Drawing, point :: Point }

type Glyph = Variant ( batched :: BatchedDrawings
                     , single  :: SingleDrawing  )

type FixedUIComponent    = CanvasReadyDrawing
type RelativeUIComponent = Interval BrowserPoint -> CanvasReadyDrawing

type Browser = { tracks     :: Array Glyph
               , relativeUI :: Array RelativeUIComponent
               , fixedUI    :: Array FixedUIComponent }

type CanvasSingleGlyph = { drawing :: Drawing, point :: Point }
type CanvasBatchGlyph  = { drawing :: Drawing, points :: Array Point }

type BatchedTrack = Array CanvasBatchGlyph

type CanvasReadyDrawing = Drawing

type BrowserTrack = Canvas.Dimensions
                 -> Interval BrowserPoint
                 -> CanvasReadyDrawing

-- Given a frame-normalized drawing, finalize it so it can be rendered to a canvas;
-- `width` is the width in pixels of the frame the drawing resides in.
resizeDrawing :: forall r.
                 { width :: Pixels | r }
              -> DrawingV
              -> Drawing
resizeDrawing {width} = case_
  # onMatch
     { point: (\x -> x)
     , range: (_ $ width) }

_LHS :: Getter' HPos (Normalized Number)
_LHS = to $ case_
         # onMatch { point: \x -> x, range: \(Pair l _) -> l}

renderNormalizedGlyphs ::  forall f r a.
                          Canvas.Dimensions
                       -> { width :: Pixels, offset :: Pixels }
                       -> Array NormalizedGlyph
                       -> { toBatch :: Array SingleDrawing
                          , singles :: Array SingleDrawing }
renderNormalizedGlyphs {height} {width, offset} gs =
    (\ {left, right} -> {toBatch: left, singles: right})
    $ partitioned $ map drawIt gs

  where drawIt {drawing, horPos, verPos} =
          let x = width * unwrap (horPos ^. _LHS)
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
              res = { drawing: d, point: { x: (x + offset), y } }
          in if isJust $ prj _point drawing
                then Left res else Right res

batchDrawings :: Array SingleDrawing
              -> Array BatchedDrawings
batchDrawings = unfoldr f
  where f gs = Array.uncons gs >>= \ {head, tail} ->
                 let { no, yes } = partition (\ {drawing} -> head.drawing == drawing) tail
                     points = Array.cons head.point $ map _.point yes
                 in pure $ Tuple { drawing: head.drawing, points } no

batchNormalizedGlyphs :: forall f r a.
                         Canvas.Dimensions
                      -> { width :: Pixels, offset :: Pixels }
                      -> Array NormalizedGlyph
                      -> Array Glyph
batchNormalizedGlyphs h wo gs =
  let {toBatch, singles} = renderNormalizedGlyphs h wo gs
      batched = inj (SProxy :: SProxy "batched") <$> batchDrawings toBatch
      single  = inj (SProxy :: SProxy "single")  <$> singles
  in batched <> single

-- TODO rewrite relative UI features to use renderNormalizedglyphs;
--      this one seems kinda broken with the horizontal shifting
drawIntervalFeature :: forall f r a.
                       Foldable f
                    => Canvas.Dimensions
                    -> { width :: Pixels, offset :: Pixels }
                    -> f NormalizedGlyph
                    -> CanvasReadyDrawing
drawIntervalFeature {height} {width, offset} = foldMap drawIt
  where drawIt {drawing, horPos, verPos} =
          let x' = case_
                    # on _point (\x -> x)
                    # on _range (\(Pair l _) -> l)
                    $ horPos
              x = width * unwrap x'
              y = height * (1.0 - unwrap verPos)
              d = resizeDrawing {width} drawing
          in translate (x + offset) y d

-- | Returns the left-hand-edge offset, and width, in pixels,
-- | of each interval (chromosome) in the provided coordinate system
viewportIntervals :: forall i a r.
                     Ord i
                  => CoordSys i BrowserPoint
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Map i { width :: Pixels, offset :: Pixels }
viewportIntervals cs cdim bView =
  intervalToScreen cdim bView <$> (view _Interval <$> intervalsToMap cs)

drawRelativeUI :: forall f i a.
                  Ord i
               => Foldable f
               => CoordSys i BrowserPoint
               -> Map i (f NormalizedGlyph)
               -> Canvas.Dimensions
               -> RelativeUIComponent
drawRelativeUI cs drawings cd v =
  fold $ zipMapsWith (drawIntervalFeature cd) (viewportIntervals cs cd v) drawings

pureTrackGlyphs :: forall f i a.
                   Ord i
                => CoordSys i BrowserPoint
                -> Map i (Array NormalizedGlyph)
                -> Canvas.Dimensions
                -> Interval BrowserPoint
                -> Map i (Array Glyph)
pureTrackGlyphs cs glyphs cd v =
  zipMapsWith (\v gs -> batchNormalizedGlyphs cd v gs) (viewportIntervals cs cd v) glyphs

renderTrackGlyphs ::  forall f i a.
                      Ord i
                  => Foldable f
                  => Traversable f
                  => CoordSys i BrowserPoint
                  -> Renderer a
                  -> Map i (f a)
                  -> Canvas.Dimensions
                  -> Interval BrowserPoint
                  -> Array Glyph
renderTrackGlyphs cs r trackData =
  let data' = map Array.fromFoldable trackData
      glyphs = (map <<< map) (render r) data'
  in \cd v -> fold $ pureTrackGlyphs cs glyphs cd v

horRulerTrack :: forall r.
                 { min :: Number, max :: Number, sig :: Number | r }
              -> Color
              -> BrowserTrack
horRulerTrack {min, max, sig} color f _ = outlined outline rulerDrawing
  where normY = (sig - min) / (max - min)
        y = f.height - (normY * f.height)
        outline = outlineColor color
        rulerDrawing = Drawing.path [{x: 0.0, y}, {x: f.width, y}]

chrLabelTrack :: CoordSys ChrId BrowserPoint
              -> Canvas.Dimensions
              -> RelativeUIComponent
chrLabelTrack cs = drawRelativeUI cs (Map.fromFoldable results)
  where mkLabel :: ChrId -> NormalizedGlyph
        mkLabel chr = { drawing: inj _point $ chrText chr
                      , horPos:  inj _point $ Normalized (0.5)
                      , verPos: Normalized (0.05) }

        font' = font sansSerif 12 mempty

        chrText :: ChrId -> Drawing
        chrText chr = Drawing.text font' zero zero (fillColor black) (unwrap chr)

        results :: Array _
        results = map (\x -> Tuple (x^._Index) [mkLabel (x^._Index)]) $ cs^._BrowserIntervals

boxesTrack :: Number
           -> CoordSys ChrId BrowserPoint
           -> Canvas.Dimensions
           -> RelativeUIComponent
boxesTrack h cs = drawRelativeUI cs $ map (const [glyph]) $ intervalsToMap cs
  where glyph :: NormalizedGlyph
        glyph = { drawing: inj _range draw
                , horPos:  inj _range $ Normalized <$> (Pair zero one)
                , verPos: Normalized one }
        draw = \w ->
             let rect = rectangle 0.0 0.0 w h
             in outlined (outlineColor black <> lineWidth 1.5) rect

featureInterval :: forall a. Feature a -> Interval Bp
featureInterval {position} = case_
  # onMatch
     { point: (\x -> Pair x x)
     , range: (\x -> x)
     }
  $ position

bumpFeatures :: forall f a l i o.
                Foldable f
             => Functor f
             => RowCons l Number (FeatureR i) (FeatureR o)
             => RowLacks l (FeatureR i)
             => IsSymbol l
             => Getter' (Feature a) Number
             -> SProxy l
             -> Bp
             -> f (Feature a)
             -> f (Feature i)
             -> f (Feature o)
bumpFeatures f l radius other = map bump
  where maxInRadius :: Interval Bp -> Number
        maxInRadius lr = fromMaybe 0.0 $ maximum
                          $ map (\g -> if intervalsOverlap (featureInterval g) lr
                                          then f `view` g else 0.0) other

        bump :: Record (FeatureR i) -> Record (FeatureR o)
        bump a =
          let y = maxInRadius (featureInterval a)
          in Record.insert l y a

groupToChrs :: forall a f rData.
               Monoid (f {chrId :: ChrId | rData})
            => Foldable f
            => Applicative f
            => f { chrId :: ChrId | rData }
            -> Map ChrId (f { chrId :: ChrId | rData })
groupToChrs = foldl (\chrs r@{chrId} -> Map.alter (add r) chrId chrs ) mempty
  where add x Nothing   = Just $ pure x
        add x (Just xs) = Just $ pure x <> xs

type VScaleRow r = ( min :: Number
                   , max :: Number
                   , sig :: Number
                   | r )

type VScale = { width :: Pixels
              , color :: Color
              | VScaleRow () }

drawVScale :: forall r.
              VScale
           -> Number
           -> Drawing
drawVScale vscale height =
  -- should have some padding here too; hardcode for now
  let hPad = vscale.width  / 5.0
      vPad = height / 10.0
      x = vscale.width / 2.0

      y1 = 0.0
      y2 = height

      n = (_ * 0.1) <<< Int.toNumber <$> (0 .. 10)

      p = Drawing.path [{x, y:y1}, {x, y:y2}]

      bar w y = Drawing.path [{x:x-w, y}, {x, y}]

      ps = foldMap (\i -> bar
                          (if i == 0.0 || i == 1.0 then 8.0 else 3.0)
                          (y1 + i*(y2-y1))) n

      ft = font sansSerif 10 mempty
      mkT y = Drawing.text ft (x-12.0) y (fillColor black)

      topLabel = mkT (y1-(0.5*vPad)) $ show vscale.max
      btmLabel = mkT (y2+vPad)       $ show vscale.min

  in outlined (outlineColor vscale.color <> lineWidth 2.0) (p <> ps)
     <> topLabel <> btmLabel

type LegendEntry = { text :: String, icon :: Drawing }

type Legend = { width :: Pixels
              , entries :: Array LegendEntry }

mkIcon :: Color -> String -> LegendEntry
mkIcon c text =
  let sh = circle (-2.5) (-2.5) 5.0
      icon = outlined (outlineColor c <> lineWidth 2.0) sh <>
             filled (fillColor c) sh
  in {text, icon}

drawLegendItem :: LegendEntry
               -> Drawing
drawLegendItem {text, icon} =
  let ft = font sansSerif 12 mempty
      t = Drawing.text ft 12.0 0.0 (fillColor black) text
  in icon <> t

drawLegend :: Legend
           -> Number
           -> Drawing
drawLegend {width, entries} height =
  let hPad = width  / 5.0
      vPad = height / 5.0
      n :: Int
      n = length entries
      x = hPad
      f :: Number -> { text :: String, icon :: Drawing } -> Drawing
      f y ic = translate x y $ drawLegendItem ic
      d = (height - 2.0*vPad) / (length entries)
      ds = mapWithIndex (\i ic -> f (vPad+(vPad*(Int.toNumber i))) ic) entries
  in fold ds

type Padding = { vertical :: Pixels
               , horizontal :: Pixels
               }

groupToMap :: forall i a f rData.
              Monoid (f a)
           => Ord i
           => Foldable f
           => Applicative f
           => (a -> i)
           -> f a
           -> Map i (f a)
groupToMap f = foldl (\grp a -> Map.alter (add a) (f a) grp ) mempty
  where add :: a -> Maybe (f a) -> Maybe (f a)
        add x xs = (pure $ pure x) <> xs

getData :: forall a i c.
           CoordSys i c
        -> (CoordSys i c -> Json -> Maybe a)
        -> String
        -> Aff _ (Array a)
getData cs p url = do
  json <- _.response <$> Affjax.get url

  maybe (throwError $ error $ "Error when parsing features from " <> url)
        pure
        $ json ^? _Array >>= traverse (p cs)

getDataGrouped :: forall a i c.
                  CoordSys ChrId c
               -> (CoordSys ChrId c -> Json -> Maybe _)
               -> String
               -> Aff _ (Map ChrId (Array _))
getDataGrouped cs p url = groupToChrs <$> getData cs p url

type TrackRow c a = ( url :: String
                    , parse :: c -> Json -> Maybe a
                    , render :: Renderer a )

type GWASTrack c a  = { vscale :: { | VScaleRow () }
                      | TrackRow c a }

type AnnotTrack c a = { getEntry :: a -> LegendEntry | TrackRow c a }

eqLegend a b = a.text == b.text

trackLegend :: forall f a.
               Foldable f
            => Functor f
            => (a -> LegendEntry)
            -> f a
            -> Array LegendEntry
trackLegend f as = Array.nubBy eqLegend $ Array.fromFoldable $ map f as

data Track a = Track (Map ChrId (Array a)) (Renderer a)

-- TODO handle vertical offsets of tracks here
renderTrack :: forall a.
               CoordSys ChrId BrowserPoint
            -> Canvas.Dimensions
            -> Interval BrowserPoint
            -> Track a
            -> Array Glyph
renderTrack cs cd v (Track as r) = renderTrackGlyphs cs r as cd v

browser :: CoordSys ChrId BrowserPoint
        -> Canvas.Dimensions
        -> Padding
        -> { legend :: Legend, vscale :: VScale }
        -> List (Exists Track)
        -> { tracks     :: Interval BrowserPoint -> Array Glyph
           , relativeUI :: Interval BrowserPoint -> Drawing
           , fixedUI    :: Drawing }
browser cs cdim padding ui inputTracks =
  let height = cdim.height - 2.0 * padding.vertical
      width  = cdim.width

      trackCanvas = { width: width - ui.vscale.width - ui.legend.width
                    , height }

      -- TODO make a type that corresponds to left-of-track and right-of-track to make this dynamic
      drawOverlay x w d =
        (translate x zero
         $ filled (fillColor white)
         $ rectangle zero zero w height )
        <> translate x padding.vertical
           d

      vScale = drawOverlay
                 zero
                 ui.vscale.width
                 (drawVScale ui.vscale height)

      legend = drawOverlay
                 (cdim.width - ui.legend.width)
                 ui.legend.width
                 (drawLegend ui.legend height)

      fixedUI = vScale <> legend

      tracks :: Interval BrowserPoint -> Array Glyph
      tracks v = foldMap (runExists (\t -> renderTrack cs trackCanvas v t)) inputTracks

      chrLabels = chrLabelTrack cs trackCanvas
      ruler     = horRulerTrack ui.vscale red trackCanvas
      boxes     = boxesTrack height cs trackCanvas

      relativeUI = chrLabels
                <> translate 0.0 padding.vertical <<< (ruler <> boxes)

  in { tracks
     , relativeUI
     , fixedUI
     }


[DAE-5] Revert last commit

[DAE-5] Revert last commit

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError, catchError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Array.Partial (last)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (split, joinWith)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult = either (Left <<< mkJSONError) (bimap mkServerError id) <<< decodeJson <<< _.response
  where
    mkJSONError = error <<< show <<< JSONDecodingError
    mkServerError = error <<< show <<< ServerError

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show $ _coin amount]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName $ gShow cCurrency, addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError, catchError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, Coin, _address, _coin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Array.Partial (last)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (split, joinWith)
import Network.HTTP.Affjax (AffjaxResponse, affjax, defaultRequest, AJAX, URL, AffjaxRequest)
import Network.HTTP.Affjax.Request (class Requestable)
import Network.HTTP.RequestHeader (RequestHeader(ContentType))
import Network.HTTP.StatusCode (StatusCode(..))
import Partial.Unsafe (unsafePartial)

-- HELPERS

type URLPath = Array String

mkUrl :: URLPath -> URL
mkUrl = joinWith "/"

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path

data ApiError
    = HTTPStatusError (AffjaxResponse Json)
    | JSONDecodingError String
    | ServerError WalletError

instance showApiError :: Show ApiError where
    show (HTTPStatusError res) =
        "HTTPStatusError: " <> show res.status <> " msg: " <> show res.response
    show (JSONDecodingError e) =
        "JSONDecodingError: " <> show e
    show (ServerError e) =
        "ServerError: " <> gShow e

-- REQUESTS HELPERS

decodeResult :: forall a eff. Generic a => {response :: Json | eff} -> Either Error a
decodeResult res = bimap (error <<< show <<< JSONDecodingError) id $ decodeJson res.response

makeRequest :: forall eff a r. (Generic a, Requestable r) => AffjaxRequest r -> URLPath -> Aff (ajax :: AJAX | eff) a
makeRequest request urlPath = do
    res <- affjax $ request { url = backendApi urlPath }
    when (isHttpError res.status) $
        throwError <<< error <<< show $ HTTPStatusError res
    either throwError pure $ decodeResult res
  where
    isHttpError (StatusCode c) = c >= 400

getR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
getR = makeRequest defaultRequest

postR :: forall eff a. Generic a => URLPath -> Aff (ajax :: AJAX | eff) a
postR = makeRequest $ defaultRequest { method = Left POST }

postRBody :: forall eff a b. (Generic a, Generic b) => URLPath -> b -> Aff (ajax :: AJAX | eff) a
postRBody urlPath content = flip makeRequest urlPath $
    defaultRequest { method = Left POST
                   , content = Just <<< show $ encodeJson content
                   , headers = [ContentType applicationJSON]
                   }

-- REQUESTS
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["get_wallets"]

getWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) CWallet
getWallet addr = getR ["get_wallet", _address addr]

getHistory :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) (Array CTx)
getHistory addr = getR ["history", _address addr]

send :: forall eff. CAddress -> CAddress -> Coin -> Aff (ajax :: AJAX | eff) CTx
send addrFrom addrTo amount = postR ["send", _address addrFrom, _address addrTo, show $ _coin amount]

newWallet :: forall eff. CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
newWallet = postRBody ["new_wallet"]

updateTransaction :: forall eff. CAddress -> CTxId -> CTxMeta -> Aff (ajax :: AJAX | eff) Unit
updateTransaction addr ctxId = postRBody ["update_transaction", _address addr, _ctxIdValue ctxId]

updateWallet :: forall eff. CAddress -> CWalletMeta -> Aff (ajax :: AJAX | eff) CWallet
updateWallet addr = postRBody ["update_wallet", _address addr]

-- FIXME: use DELETE method
deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = postR ["delete_wallet", _address addr]

isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["valid_address", dropModuleName $ gShow cCurrency, addr]
  where
    -- TODO: this is again stupid. We should derive Show for this type instead of doing this
    dropModuleName = unsafePartial last <<< split "."