iframe js gen

iframe js gen

module SlamData.Workspace.Deck.Dialog.Export.Component where

import SlamData.Prelude

import Control.Monad.Eff.Ref (Ref, newRef, readRef)
import Control.UI.Browser (select, locationString)
import Control.UI.ZClipboard as Z

import Data.Foldable as F
import Data.StrMap as SM
import Data.Path.Pathy as Pathy

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.CustomProps as CP
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils (raise)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Routing (mkWorkspaceHash)
import SlamData.Workspace.Action as WA
import SlamData.Workspace.AccessType as AT
import SlamData.Quasar.Auth as Auth
import SlamData.Render.Common (glyph, fadeWhen)

import Quasar.Advanced.Auth (PermissionToken(..), runPermissionToken)

import Utils.Path (DirPath)

data PresentAs = IFrame | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Slam

type State =
  { presentingAs ∷ PresentAs
  , varMap ∷ Port.VarMap
  , deckPath ∷ DirPath
  , permToken ∷ Maybe PermissionToken
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLogged ∷ Boolean
  , copyRef ∷ Maybe (Ref String)
  , copyVal ∷ String
  }

initialState ∷ DirPath → State
initialState =
  { presentingAs: URI
  , varMap: SM.empty
  , deckPath: _
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: false
  , hovered: false
  , isLogged: false
  , copyRef: Nothing
  , copyVal: ""
  }

data Query a
  = SelectElement HTMLElement a
  | Init (Maybe HTMLElement) a
  | Dismiss a
  | Revoke a
  | ToggleShouldGenerateToken a
  | TextAreaHovered a
  | TextAreaLeft a

comp ∷ H.Component State Query Slam
comp = H.component { render, eval }

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishURI state
  | otherwise = renderPublishIFrame state

renderPublishURI ∷ State → H.ComponentHTML Query
renderPublishURI state =
  HH.div [ HP.classes [ HH.className "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Publish deck" ]
    , HH.p_
        [ HH.text
          $ "Anyone has access to the following URL "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-body" ] ]
        [ HH.form
            [ CP.nonSubmit ]
            [ HH.div
                [ HP.classes [ B.inputGroup ] ]
                $ [ HH.input
                    [ HP.classes [ B.formControl ]
                    , HP.value state.copyVal
                    , HP.readonly true
                    , HP.title "Published deck URL"
                    , ARIA.label "Published deck URL"
                    , HE.onClick \e →
                        HEH.stopPropagation $> Just (H.action (SelectElement e.target))
                    ]
                  , HH.span
                      [ HP.classes [ B.inputGroupBtn ] ]
                      [ HH.button
                        [ HP.classes [ B.btn, B.btnDefault ]
                        , HE.onClick (HE.input_ Dismiss)
                        , HP.ref (H.action ∘ Init)
                        , HP.id_ "copy-button"
                        , HP.buttonType HP.ButtonButton
                        ]
                        [ glyph B.glyphiconCopy ]
                      ]
                  ]
            ]
        ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-footer" ] ]
        $ [ HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ Dismiss)
              , HP.buttonType HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLogged)
           $>  HH.button
                 [ HP.classes [ B.btn, B.btnInfo ]
                 , HE.onClick (HE.input_ Revoke)
                 , ARIA.label "Revoke access to this deck"
                 , HP.title "Revoke access to this deck"
                 , HP.buttonType HP.ButtonButton
                 , HP.enabled state.canRevoke
                 ]
                 [ HH.text "Revoke" ])
        ⊕ [ HH.a
              [ HP.classes [ B.btn, B.btnPrimary ]
              , HP.target "_blank"
              , HP.href state.copyVal
              ]
              [ HH.text "Preview" ]
          ]
      ]

renderPublishIFrame ∷ State → H.ComponentHTML Query
renderPublishIFrame state =
  HH.div [ HP.classes [ HH.className "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text  "Embed deck" ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-body" ] ]
        [ HH.form
          [ CP.nonSubmit
          , HE.onMouseOver (HE.input_ TextAreaHovered)
          , HE.onMouseOut (HE.input_ TextAreaLeft)
          ]
          [ HH.div
              [ HP.classes [ B.formGroup ] ]
              [ HH.textarea
                  [ HP.classes [ B.formControl, Rc.embedBox ]
                  , HP.readonly true
                  , HP.value state.copyVal
                  , HE.onClick \e →
                      HEH.stopPropagation $> Just (H.action (SelectElement e.target))
                  ]
              , HH.button
                  [ HP.id_ "copy-button"
                  , HP.classes
                      $ [ B.btn, B.btnDefault, B.btnXs ]
                      ⊕ [ HH.className "textarea-copy-button" ]
                      ⊕ fadeWhen (not state.hovered)
                  , HP.ref (H.action ∘ Init)
                  , HP.buttonType HP.ButtonButton
                  , HE.onClick (HE.input_ Dismiss)
                  ]
                  [ glyph B.glyphiconCopy ]
              , HH.div [ HP.classes [ B.checkbox ] ]
                  [ HH.label_
                      [ HH.input
                        [ HP.inputType HP.InputCheckbox
                        , HP.checked state.shouldGenerateToken
                        , HE.onChecked (HE.input_ ToggleShouldGenerateToken)
                        ]
                      , HH.text
                          $ "Include a permission token so the deck "
                          ⊕ "can be accessed by anyone who has the access to this script. "
                          ⊕ "You may undo this by revoking access."
                      ]
                  ]
              ]
          ]
        ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-footer" ] ]
        $ [ HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ Dismiss)
              , HP.buttonType HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLogged)
           $> HH.button
                [ HP.classes [ B.btn, B.btnInfo ]
                , HE.onClick (HE.input_ Revoke)
                , HP.title "Revoke access to this deck"
                , ARIA.label "Revoke access to this deck"
                , HP.buttonType HP.ButtonButton
                , HP.enabled state.canRevoke
                ]
                [ HH.text "Revoke" ])

        ]

eval ∷ Query ~> DSL
eval (Dismiss next) = pure next
eval (Init mbEl next) = next <$ do
  state ← H.get

  locString ← H.fromEff locationString
  let
    copyVal = renderCopyVal locString state
  copyRef ← H.fromEff $ newRef copyVal

  H.modify _{ copyRef = Just copyRef
            , copyVal = copyVal
            }

  for_ mbEl \htmlEl →
    H.fromEff
    $ Z.make (htmlElementToElement htmlEl)
    >>= Z.onCopy \z → do
      val ← readRef copyRef
      Z.setData "text/plain" val z

  -- To know if user is authed
  mbAuthToken ← H.fromEff Auth.retrieveIdToken
  case mbAuthToken of
    Nothing →
      H.modify _{ permToken = Nothing
                , canRevoke = false
                , isLogged = false
                }
    Just _ → do
      H.modify _{isLogged = true}
      tokens ← getAllTokens
      tokenForThisDeck ← H.gets makeTokenForThisDeck
      -- TODO: find by token name
      let
        foundToken =
          F.find (\x → runPermissionToken x ≡ runPermissionToken tokenForThisDeck) tokens
      case foundToken of
        Just oldToken →
          H.modify _{ permToken = Just oldToken
                    , canRevoke = true
                    }
        Nothing → do
          saveToken tokenForThisDeck
          H.modify _{ permToken = Just tokenForThisDeck
                    , canRevoke = true
                    }
  where
  renderURL ∷ String → State → String
  renderURL locationString state@{deckPath, varMap, permToken} =
    locationString
    ⊕ "/"
    ⊕ Config.workspaceUrl
    ⊕ foldMap (append "?permissionTokens=" ∘ runPermissionToken) permToken
    ⊕ mkWorkspaceHash deckPath (WA.Load AT.ReadOnly) varMap

  renderCopyVal ∷ String → State → String
  renderCopyVal locString state
    | state.presentingAs ≡ URI =
        renderURL locString state
    | otherwise =
      "<script type=\"text/javascript\">\n"
      ⊕ "(function() {\n"
      ⊕ "  var slamdataPermissionToken = "
      ⊕ maybe "window.SLAMDATA_PERMISSION_TOKEN" (\x → "\"" ⊕ runPermissionToken x ⊕ "\"") state.permToken ⊕ ";\n"
      ⊕ "  var queryString = \"?permissionTokens=\" + slamdataPermissionToken;\n"
      ⊕ "  var uri = \""
        ⊕ locString
        ⊕ "/"
        ⊕ Config.workspaceUrl
        ⊕ "\"\n    + queryString\n    + \""
        ⊕ mkWorkspaceHash state.deckPath (WA.Load AT.ReadOnly) state.varMap
        ⊕ "\";\n"
      ⊕ "  var iframe = \"<iframe width=\\\"100%\\\" height=\\\"100%\\\" frameborder=\\\"0\\\" src=\\\"\" + uri + \"\\\"></iframe>\""
      ⊕ "  document.writeln(iframe);\n"
      ⊕ "})();\n"
      ⊕ "</script>"

  -- TODO: actually get token list
  getAllTokens ∷ DSL (Array PermissionToken)
  getAllTokens = pure []

  -- TODO, update after purescript-quasar
  makeTokenForThisDeck ∷ State → PermissionToken
  makeTokenForThisDeck {deckPath} =
    -- TODO: we need only name here
    PermissionToken
      $ "publish-"
      ⊕ (Global.encodeURIComponent
         $ Global.encodeURIComponent
         $ Pathy.printPath deckPath)

  -- TODO: should actually PUT new token into quasar
  saveToken ∷ PermissionToken → DSL Unit
  saveToken _ = pure unit
eval (SelectElement el next) = next <$ H.fromEff (select el)
eval (Revoke next) = next <$ do
  permToken ← H.gets _.permToken
  for_ permToken deleteToken
  raise $ Dismiss unit
eval (ToggleShouldGenerateToken next) =
  next <$ H.modify (\x → x{shouldGenerateToken = not x.shouldGenerateToken})
eval (TextAreaHovered next) =
  next <$ H.modify _{hovered = true}
eval (TextAreaLeft next) =
  next <$ H.modify _{hovered = false}

-- TODO: actually DELETE token
deleteToken ∷ PermissionToken → DSL Unit
deleteToken _ = pure unit

module SlamData.Workspace.Deck.Dialog.Export.Component where

import SlamData.Prelude

import Control.Monad.Eff.Ref (Ref, newRef, readRef)
import Control.UI.Browser (select, locationString)
import Control.UI.ZClipboard as Z

import Data.Foldable as F
import Data.StrMap as SM
import Data.Path.Pathy as Pathy

import DOM.HTML.Types (HTMLElement, htmlElementToElement)

import Halogen as H
import Halogen.CustomProps as CP
import Halogen.HTML.Events.Handler as HEH
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.HTML.Renderer.String (renderHTML)
import Halogen.Themes.Bootstrap3 as B
import Halogen.Component.Utils (raise)

import SlamData.Config as Config
import SlamData.Effects (Slam)
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Render.CSS as Rc
import SlamData.Workspace.Routing (mkWorkspaceHash)
import SlamData.Workspace.Action as WA
import SlamData.Workspace.AccessType as AT
import SlamData.Quasar.Auth as Auth
import SlamData.Render.Common (glyph, fadeWhen)

import Quasar.Advanced.Auth (PermissionToken(..), runPermissionToken)

import Utils.Path (DirPath)

data PresentAs = IFrame | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Slam

type State =
  { presentingAs ∷ PresentAs
  , varMap ∷ Port.VarMap
  , deckPath ∷ DirPath
  , permToken ∷ Maybe PermissionToken
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLogged ∷ Boolean
  , copyRef ∷ Maybe (Ref String)
  , copyVal ∷ String
  }

initialState ∷ DirPath → State
initialState =
  { presentingAs: URI
  , varMap: SM.empty
  , deckPath: _
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: false
  , hovered: false
  , isLogged: false
  , copyRef: Nothing
  , copyVal: ""
  }

data Query a
  = SelectElement HTMLElement a
  | Init (Maybe HTMLElement) a
  | Dismiss a
  | Revoke a
  | ToggleShouldGenerateToken a
  | TextAreaHovered a
  | TextAreaLeft a

comp ∷ H.Component State Query Slam
comp = H.component { render, eval }

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishURI state
  | otherwise = renderPublishIFrame state

renderPublishURI ∷ State → H.ComponentHTML Query
renderPublishURI state =
  HH.div [ HP.classes [ HH.className "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Publish deck" ]
    , HH.p_
        [ HH.text
          $ "Anyone has access to the following URL "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-body" ] ]
        [ HH.form
            [ CP.nonSubmit ]
            [ HH.div
                [ HP.classes [ B.inputGroup ] ]
                $ [ HH.input
                    [ HP.classes [ B.formControl ]
                    , HP.value state.copyVal
                    , HP.readonly true
                    , HP.title "Published deck URL"
                    , ARIA.label "Published deck URL"
                    , HE.onClick \e →
                        HEH.stopPropagation $> Just (H.action (SelectElement e.target))
                    ]
                  , HH.span
                      [ HP.classes [ B.inputGroupBtn ] ]
                      [ HH.button
                        [ HP.classes [ B.btn, B.btnDefault ]
                        , HE.onClick (HE.input_ Dismiss)
                        , HP.ref (H.action ∘ Init)
                        , HP.id_ "copy-button"
                        , HP.buttonType HP.ButtonButton
                        ]
                        [ glyph B.glyphiconCopy ]
                      ]
                  ]
            ]
        ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-footer" ] ]
        $ [ HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ Dismiss)
              , HP.buttonType HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLogged)
           $>  HH.button
                 [ HP.classes [ B.btn, B.btnInfo ]
                 , HE.onClick (HE.input_ Revoke)
                 , ARIA.label "Revoke access to this deck"
                 , HP.title "Revoke access to this deck"
                 , HP.buttonType HP.ButtonButton
                 , HP.enabled state.canRevoke
                 ]
                 [ HH.text "Revoke" ])
        ⊕ [ HH.a
              [ HP.classes [ B.btn, B.btnPrimary ]
              , HP.target "_blank"
              , HP.href state.copyVal
              ]
              [ HH.text "Preview" ]
          ]
      ]

renderPublishIFrame ∷ State → H.ComponentHTML Query
renderPublishIFrame state =
  HH.div [ HP.classes [ HH.className "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text  "Embed deck" ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-body" ] ]
        [ HH.form
          [ CP.nonSubmit
          , HE.onMouseOver (HE.input_ TextAreaHovered)
          , HE.onMouseOut (HE.input_ TextAreaLeft)
          ]
          [ HH.div
              [ HP.classes [ B.formGroup ] ]
              [ HH.textarea
                  [ HP.classes [ B.formControl, Rc.embedBox ]
                  , HP.readonly true
                  , HP.value state.copyVal
                  , HE.onClick \e →
                      HEH.stopPropagation $> Just (H.action (SelectElement e.target))
                  ]
              , HH.button
                  [ HP.id_ "copy-button"
                  , HP.classes
                      $ [ B.btn, B.btnDefault, B.btnXs ]
                      ⊕ [ HH.className "textarea-copy-button" ]
                      ⊕ fadeWhen (not state.hovered)
                  , HP.ref (H.action ∘ Init)
                  , HP.buttonType HP.ButtonButton
                  , HE.onClick (HE.input_ Dismiss)
                  ]
                  [ glyph B.glyphiconCopy ]
              , HH.div [ HP.classes [ B.checkbox ] ]
                  [ HH.label_
                      [ HH.input
                        [ HP.inputType HP.InputCheckbox
                        , HP.checked state.shouldGenerateToken
                        , HE.onChecked (HE.input_ ToggleShouldGenerateToken)
                        ]
                      , HH.text
                          $ "Include a permission token so the deck "
                          ⊕ "can be accessed by anyone who has the access to this script. "
                          ⊕ "You may undo this by revoking access."
                      ]
                  ]
              ]
          ]
        ]
    , HH.div [ HP.classes [ HH.className "deck-dialog-footer" ] ]
        $ [ HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ Dismiss)
              , HP.buttonType HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLogged)
           $> HH.button
                [ HP.classes [ B.btn, B.btnInfo ]
                , HE.onClick (HE.input_ Revoke)
                , HP.title "Revoke access to this deck"
                , ARIA.label "Revoke access to this deck"
                , HP.buttonType HP.ButtonButton
                , HP.enabled state.canRevoke
                ]
                [ HH.text "Revoke" ])

        ]

eval ∷ Query ~> DSL
eval (Dismiss next) = pure next
eval (Init mbEl next) = next <$ do
  state ← H.get

  locString ← H.fromEff locationString
  let
    copyVal = renderCopyVal locString state
  copyRef ← H.fromEff $ newRef copyVal

  H.modify _{ copyRef = Just copyRef
            , copyVal = copyVal
            }

  for_ mbEl \htmlEl →
    H.fromEff
    $ Z.make (htmlElementToElement htmlEl)
    >>= Z.onCopy \z → do
      val ← readRef copyRef
      Z.setData "text/plain" val z

  -- To know if user is authed
  mbAuthToken ← H.fromEff Auth.retrieveIdToken
  case mbAuthToken of
    Nothing →
      H.modify _{ permToken = Nothing
                , canRevoke = false
                , isLogged = false
                }
    Just _ → do
      H.modify _{isLogged = true}
      tokens ← getAllTokens
      tokenForThisDeck ← H.gets makeTokenForThisDeck
      -- TODO: find by token name
      let
        foundToken =
          F.find (\x → runPermissionToken x ≡ runPermissionToken tokenForThisDeck) tokens
      case foundToken of
        Just oldToken →
          H.modify _{ permToken = Just oldToken
                    , canRevoke = true
                    }
        Nothing → do
          saveToken tokenForThisDeck
          H.modify _{ permToken = Just tokenForThisDeck
                    , canRevoke = true
                    }
  where
  renderURL ∷ String → State → String
  renderURL locationString state@{deckPath, varMap, permToken} =
    locationString
    ⊕ "/"
    ⊕ Config.workspaceUrl
    ⊕ foldMap (append "?permissionTokens=" ∘ runPermissionToken) permToken
    ⊕ mkWorkspaceHash deckPath (WA.Load AT.ReadOnly) varMap

  renderCopyVal ∷ String → State → String
  renderCopyVal locString state
    | state.presentingAs ≡ URI =
        renderURL locString state
    | otherwise =
        renderHTML
          $ HH.script
              [ HP.mediaType { type: "text", subtype: "javascript", parameters: [] } ]
              [ HH.text javascriptCode ]
    where
    javascriptCode ∷ String
    javascriptCode =
      "document.writeln(\"<iframe "
      ⊕ "width=\\\"100%\\\" height=\\\"100%\\\" frameborder=\\\"0\\\" "
      ⊕ "src=\\\"" ⊕ renderURL locString state ⊕ "\\\"></iframe>̈\");"

  -- TODO: actually get token list
  getAllTokens ∷ DSL (Array PermissionToken)
  getAllTokens = pure []

  -- TODO, update after purescript-quasar
  makeTokenForThisDeck ∷ State → PermissionToken
  makeTokenForThisDeck {deckPath} =
    -- TODO: we need only name here
    PermissionToken
      $ "publish-"
      ⊕ (Global.encodeURIComponent
         $ Global.encodeURIComponent
         $ Pathy.printPath deckPath)

  -- TODO: should actually PUT new token into quasar
  saveToken ∷ PermissionToken → DSL Unit
  saveToken _ = pure unit
eval (SelectElement el next) = next <$ H.fromEff (select el)
eval (Revoke next) = next <$ do
  permToken ← H.gets _.permToken
  for_ permToken deleteToken
  raise $ Dismiss unit
eval (ToggleShouldGenerateToken next) =
  next <$ H.modify (\x → x{shouldGenerateToken = not x.shouldGenerateToken})
eval (TextAreaHovered next) =
  next <$ H.modify _{hovered = true}
eval (TextAreaLeft next) =
  next <$ H.modify _{hovered = false}

-- TODO: actually DELETE token
deleteToken ∷ PermissionToken → DSL Unit
deleteToken _ = pure unit


[CSL-1016] Workaround to pass empty passphrases as last URL capture

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, _address, _ccoin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, BackupPhrase, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized, CPassPhrase, _passPhrase, CCoin, CPostVendWalletRedeem)
import Data.Array (last)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple)
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(..))

-- HELPERS

type URLPath = Array String

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

backendApi :: URLPath -> URL
backendApi path = mkUrl $ [backendPrefix, "api"] <> path <> ifEmptyEnd
  where
    -- Workaround for passing empty passphrases as last capture in URL
    ifEmptyEnd = if last path == Just "" then [""] else []

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]
                   }

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

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

-- REQUESTS
--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------
testReset :: forall eff. Aff (ajax :: AJAX | eff) Unit
testReset = postR ["test", "reset"]
--------------------------------------------------------------------------------
-- WALLETS ---------------------------------------------------------------------
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["wallets"]

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

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

newWallet :: forall eff. CPassPhrase -> CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
newWallet pass = postRBody ["wallets", _passPhrase pass]

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = deleteR ["wallets", _address addr]

importKey :: forall eff. String -> Aff (ajax :: AJAX | eff) CWallet
importKey = postRBody ["wallets", "keys"]

restoreWallet :: forall eff. CPassPhrase -> CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
restoreWallet pass = postRBody ["wallets", "restore", _passPhrase pass]
--------------------------------------------------------------------------------
-- ADDRESSSES ------------------------------------------------------------------
isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["addresses", addr, "currencies", showCCurrency cCurrency]
--------------------------------------------------------------------------------
-- PROFILES --------------------------------------------------------------------
getProfile :: forall eff. Aff (ajax :: AJAX | eff) CProfile
getProfile = getR ["profile"]

updateProfile :: forall eff. CProfile -> Aff (ajax :: AJAX | eff) CProfile
updateProfile = postRBody ["profile"]
--------------------------------------------------------------------------------
-- TRANSACTIONS ----------------------------------------------------------------
send :: forall eff. CPassPhrase -> CAddress -> CAddress -> CCoin -> Aff (ajax :: AJAX | eff) CTx
send pass addrFrom addrTo amount = postR ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount]

sendExtended :: forall eff. CPassPhrase -> CAddress -> CAddress -> CCoin -> CCurrency -> String -> String -> Aff (ajax :: AJAX | eff) CTx
sendExtended pass addrFrom addrTo amount curr title desc = postR ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount, showCCurrency curr, title, desc]

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

getHistory :: forall eff. CAddress -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
getHistory addr skip limit = getR ["txs", "histories", _address addr <> "?skip=" <> show skip <> "&limit=" <> show limit]

searchHistory :: forall eff. CAddress -> String -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
searchHistory addr search skip limit = getR ["txs", "histories", _address addr, search <> "?skip=" <> show skip <> "&limit=" <> show limit]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
nextUpdate :: forall eff. Aff (ajax :: AJAX | eff) CUpdateInfo
nextUpdate = getR ["update"]

applyUpdate :: forall eff. Aff (ajax :: AJAX | eff) Unit
applyUpdate = postR ["update"]
--------------------------------------------------------------------------------
-- REDEMPTIONS -----------------------------------------------------------------
redeemADA :: forall eff. CWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
redeemADA = postRBody ["redemptions", "ada"]

postVendRedeemADA :: forall eff. CPostVendWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
postVendRedeemADA = postRBody ["postvend", "redemptions", "ada"]
--------------------------------------------------------------------------------
-- REPORTING ---------------------------------------------------------------------
reportInit :: forall eff. CInitialized -> Aff (ajax :: AJAX | eff) Unit
reportInit = postRBody ["reporting", "initialized"]
--------------------------------------------------------------------------------
-- SETTINGS ---------------------------------------------------------------------
blockchainSlotDuration :: forall eff. Aff (ajax :: AJAX | eff) Int
blockchainSlotDuration = getR ["settings", "slots", "duration"]

systemVersion :: forall eff. Aff (ajax :: AJAX | eff) SoftwareVersion
systemVersion = getR ["settings", "version"]

syncProgress :: forall eff. Aff (ajax :: AJAX | eff) SyncProgress
syncProgress = getR ["settings", "sync", "progress"]
--------------------------------------------------------------------------------

module Daedalus.BackendApi where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Exception (error, Error)
import Control.Monad.Error.Class (throwError)
import Daedalus.Constants (backendPrefix)
import Daedalus.Types (CAddress, _address, _ccoin, CWallet, CTx, CWalletMeta, CTxId, CTxMeta, _ctxIdValue, CCurrency, WalletError, showCCurrency, CProfile, CWalletInit, BackupPhrase, CUpdateInfo, SoftwareVersion, CWalletRedeem, SyncProgress, CInitialized, CPassPhrase, _passPhrase, CCoin, CPostVendWalletRedeem)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (decodeJson, encodeJson)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Left))
import Data.Generic (class Generic, gShow)
import Data.HTTP.Method (Method(POST, PUT, DELETE))
import Data.Maybe (Maybe(Just))
import Data.MediaType.Common (applicationJSON)
import Data.String (joinWith)
import Data.Tuple (Tuple)
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(..))

-- 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]
                   }

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

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

-- REQUESTS
--------------------------------------------------------------------------------
-- TEST ------------------------------------------------------------------------
testReset :: forall eff. Aff (ajax :: AJAX | eff) Unit
testReset = postR ["test", "reset"]
--------------------------------------------------------------------------------
-- WALLETS ---------------------------------------------------------------------
getWallets :: forall eff. Aff (ajax :: AJAX | eff) (Array CWallet)
getWallets = getR ["wallets"]

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

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

newWallet :: forall eff. CPassPhrase -> CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
newWallet pass = postRBody ["wallets", _passPhrase pass]

deleteWallet :: forall eff. CAddress -> Aff (ajax :: AJAX | eff) Unit
deleteWallet addr = deleteR ["wallets", _address addr]

importKey :: forall eff. String -> Aff (ajax :: AJAX | eff) CWallet
importKey = postRBody ["wallets", "keys"]

restoreWallet :: forall eff. CPassPhrase -> CWalletInit -> Aff (ajax :: AJAX | eff) CWallet
restoreWallet pass = postRBody ["wallets", "restore", _passPhrase pass]
--------------------------------------------------------------------------------
-- ADDRESSSES ------------------------------------------------------------------
isValidAddress :: forall eff. CCurrency -> String -> Aff (ajax :: AJAX | eff) Boolean
isValidAddress cCurrency addr = getR ["addresses", addr, "currencies", showCCurrency cCurrency]
--------------------------------------------------------------------------------
-- PROFILES --------------------------------------------------------------------
getProfile :: forall eff. Aff (ajax :: AJAX | eff) CProfile
getProfile = getR ["profile"]

updateProfile :: forall eff. CProfile -> Aff (ajax :: AJAX | eff) CProfile
updateProfile = postRBody ["profile"]
--------------------------------------------------------------------------------
-- TRANSACTIONS ----------------------------------------------------------------
send :: forall eff. CPassPhrase -> CAddress -> CAddress -> CCoin -> Aff (ajax :: AJAX | eff) CTx
send pass addrFrom addrTo amount = postR ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount]

sendExtended :: forall eff. CPassPhrase -> CAddress -> CAddress -> CCoin -> CCurrency -> String -> String -> Aff (ajax :: AJAX | eff) CTx
sendExtended pass addrFrom addrTo amount curr title desc = postR ["txs", "payments", _passPhrase pass, _address addrFrom, _address addrTo, _ccoin amount, showCCurrency curr, title, desc]

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

getHistory :: forall eff. CAddress -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
getHistory addr skip limit = getR ["txs", "histories", _address addr <> "?skip=" <> show skip <> "&limit=" <> show limit]

searchHistory :: forall eff. CAddress -> String -> Int -> Int -> Aff (ajax :: AJAX | eff) (Tuple (Array CTx) Int)
searchHistory addr search skip limit = getR ["txs", "histories", _address addr, search <> "?skip=" <> show skip <> "&limit=" <> show limit]
--------------------------------------------------------------------------------
-- UPDATES ---------------------------------------------------------------------
nextUpdate :: forall eff. Aff (ajax :: AJAX | eff) CUpdateInfo
nextUpdate = getR ["update"]

applyUpdate :: forall eff. Aff (ajax :: AJAX | eff) Unit
applyUpdate = postR ["update"]
--------------------------------------------------------------------------------
-- REDEMPTIONS -----------------------------------------------------------------
redeemADA :: forall eff. CWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
redeemADA = postRBody ["redemptions", "ada"]

postVendRedeemADA :: forall eff. CPostVendWalletRedeem -> Aff (ajax :: AJAX | eff) CTx
postVendRedeemADA = postRBody ["postvend", "redemptions", "ada"]
--------------------------------------------------------------------------------
-- REPORTING ---------------------------------------------------------------------
reportInit :: forall eff. CInitialized -> Aff (ajax :: AJAX | eff) Unit
reportInit = postRBody ["reporting", "initialized"]
--------------------------------------------------------------------------------
-- SETTINGS ---------------------------------------------------------------------
blockchainSlotDuration :: forall eff. Aff (ajax :: AJAX | eff) Int
blockchainSlotDuration = getR ["settings", "slots", "duration"]

systemVersion :: forall eff. Aff (ajax :: AJAX | eff) SoftwareVersion
systemVersion = getR ["settings", "version"]

syncProgress :: forall eff. Aff (ajax :: AJAX | eff) SyncProgress
syncProgress = getR ["settings", "sync", "progress"]
--------------------------------------------------------------------------------


refine radar chart's layout algorithm

refine radar chart's layout algorithm

refine radar chart layout algorithm

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxes, colors, buildChartAxes, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

buildRadarData ∷ ChartAxes → RadarData
buildRadarData axes = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (map (A.fromFoldable
      <<< L.catMaybes
      <<< map checkDimAndTransform
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
      -- )
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
      -- )
      <<< L.catMaybes
      <<< map combineSerie
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axes.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axes.measures !! 0

  series ∷ List (Maybe String)
  series = fromMaybe Nil $ axes.series !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axes.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axes.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (a × b × c × d) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                (fromMaybe "" a)
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← fst <$> L.head x
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← fst <$> L.head x
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    map (L.catMaybes <<< map combine <<< L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)) x
    where
    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← fst <$> L.head x
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation = runAggregation (fromMaybe Sum agg)

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a =
    if (L.length $ snd a) == L.length distinctDims
      then Just $ Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
      else Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → DSL OptionI
buildRadar axes conf = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem serieNames
    E.topBottom
    E.textStyle do
      E.fontFamily "Ubuntu sans"

  E.colors colors

  E.radars
    $ traverse_ E.radar radars

  E.titles
    $ traverse_ E.title titles

  E.series
    $ traverse_ (E.radarSeries ∘ serie)
    $ A.zip (A.range 0 (A.length $ snd radarData)) (snd radarData)

  where
  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd radarData

  dupNames ∷ Array String
  dupNames = map fst $ snd radarData

  numDup ∷ Int
  numDup = A.length dupNames

  titles ∷ Array (DSL ETP.TitleI)
  titles =
    map (mkTitle numDup) (A.range 0 $ numDup - 1)
    where
    mkTitle ∷ Int → Int → DSL ETP.TitleI
    mkTitle n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = ((n - 1) / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
        rowHight = 100.0 / (toNumber nRow)
        spaceCoeff = 0.85
      E.text $ fromMaybe "" $ dupNames !! i
      E.textStyle do
        E.fontFamily "Ubuntu sans"
        E.fontSize 12
      E.left
        $ ET.Percent
        $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
          -- adjust the position to the center
          - 0.3
      E.top
        $ ET.Percent
        $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
          - (rowHight * spaceCoeff) / 2.0
      E.textCenter
      E.textBottom

  radars ∷ Array (DSL ETP.RadarI)
  radars =
    map (mkPolar numDup) (A.range 0 $ numDup - 1)
    where
    mkPolar ∷ Int → Int → DSL ETP.RadarI
    mkPolar n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = ((n - 1) / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      E.indicators
        $ traverse_ E.indicator $ mkIndicatorSet i
      E.nameGap 10.0
      E.center $ ET.Point
        { x: ET.Percent $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
        , y: ET.Percent $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
        }
      E.singleValueRadius
        $ ET.SingleValueRadius
        $ ET.Percent
        $ 75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol)

  mkIndicatorSet ∷ Int → Array (DSL ETP.IndicatorI)
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd radarData) !! i
    in
      map mkIndicator (fst radarData)

  mkIndicator ∷ String → DSL ETP.IndicatorI
  mkIndicator dim = do
    E.name $ dim
    when (isJust minVal) $ E.min $ fromMaybe zero minVal
    when (isJust maxVal) $ E.max $ fromMaybe zero maxVal

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd radarData

  minVal ∷ Maybe Number
  minVal = minimum allValues

  maxVal ∷ Maybe Number
  maxVal = maximum allValues

  radarData ∷ RadarData
  radarData = buildRadarData $ buildChartAxes axes conf

serie
  ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
  → DSL ETP.RadarSeriesI
serie (ind × (dup × a)) = do
  when (dup ≠ "") $ E.name dup
  E.radarIndex $ toNumber ind
  E.symbol ET.Circle
  if A.null a
    then E.buildItems $ E.addItem blankData
    else E.buildItems $ for_ a \x →
      E.addItem $ makeData x

makeData
  ∷ Tuple String (Array Number)
  → DSL ETP.ItemI
makeData (name × values) = do
    E.name name
    E.values values

blankData ∷ DSL ETP.ItemI
blankData = do
  -- set a value to avoid display issue
  E.values [0.0]
  E.symbol ET.None

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.Chart.BuildOptions.Radar where

import SlamData.Prelude

import Data.Argonaut (JCursor)
import Data.Foldable (minimum, maximum)
import Data.Array ((!!))
import Data.Array as A
import Data.Function (on)
import Data.List (List(..))
import Data.List as L
import Data.Map (Map)
import Data.Int (toNumber)
import Math ((%))

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import SlamData.Workspace.Card.Chart.Aggregation (Aggregation(..), runAggregation)
import SlamData.Workspace.Card.Chart.Axis as Ax
import SlamData.Workspace.Card.Chart.ChartConfiguration (ChartConfiguration)
import SlamData.Workspace.Card.Chart.BuildOptions.Common (SeriesKey, ChartAxes, colors, buildChartAxes, keyName)

--sample data:
-- Tuple ['dimA', 'dimB']
--       [ (Tuple '' [(Tuple 'series1' [1, 5]), (Tuple 'series2' [1, 5])]) ]
type RadarData = Tuple (Array String) (Array (Tuple String (Array (Tuple String (Array Number)))))

buildRadarData ∷ ChartAxes → RadarData
buildRadarData axes = Tuple (A.fromFoldable distinctDims) $
  A.fromFoldable
    $ map (map (A.fromFoldable
      <<< L.catMaybes
      <<< map checkDimAndTransform
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 5))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 5)) )
      -- )
      <<< map combineDim
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1 : Tuple 'dimB' 2 : Tuple 'dimB' 3)) )
      -- )
      <<< L.catMaybes
      <<< map combineSerie
      -- output sample:
      -- ( Tuple ''
      --         ( (Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2) : Tuple 'series1' (Tuple 'dimB' 3))
      --         : (Tuple 'series2' (Tuple 'dimA' 1) : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3)) )
      -- )
      <<< L.groupBy ((==) `on` fst)
      <<< L.sortBy (compare `on` fst)
    ))
    -- output sample:
    -- ( Tuple ''
    --         ( Tuple 'series1' (Tuple 'dimA' 1) : Tuple 'series1' (Tuple 'dimB' 2)
    --         : Tuple 'series1' (Tuple 'dimB' 3) : Tuple 'series2' (Tuple 'dimA' 1)
    --         : Tuple 'series2' (Tuple 'dimB' 2) : Tuple 'series2' (Tuple 'dimB' 3) )
    -- )
    $ L.catMaybes
    $ map combineDup
    -- output sample:
    -- (( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    --  : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    --  : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) ))
    $ L.groupBy ((==) `on` fst)
    $ L.sortBy (compare `on` fst)
    -- output sample:
    -- ( Tuple '' (Tuple 'series1' (Tuple 'dimA' 1)) : Tuple '' (Tuple 'series1' (Tuple 'dimB' 2))
    -- : Tuple '' (Tuple 'series1' (Tuple 'dimB' 3)) : Tuple '' (Tuple 'series2' (Tuple 'dimA' 1))
    -- : Tuple '' (Tuple 'series2' (Tuple 'dimB' 2)) : Tuple '' (Tuple 'series2' (Tuple 'dimB' 3)) )
    $ L.catMaybes
    $ map filterInvalid
    $ tagDuplications duplications
    $ tagSeriesKey seriesKeys
    $ L.zip dimensions values

  where
  dimensions ∷ List (Maybe String)
  dimensions = fromMaybe Nil $ axes.dimensions !! 0

  values ∷ List (Maybe Number)
  values = fromMaybe Nil $ axes.measures !! 0

  series ∷ List (Maybe String)
  series = fromMaybe Nil $ axes.series !! 0

  duplications ∷ List (Maybe String)
  duplications = fromMaybe Nil $ axes.series !! 1

  agg ∷ Maybe Aggregation
  agg = fromMaybe (Just Sum) $ join (axes.aggregations !! 0)

  distinctDims ∷ List String
  distinctDims = L.sort $ L.catMaybes $ L.nub dimensions

  tagDuplications
    ∷ List (Maybe String)
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → List (Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number))))
  tagDuplications d v = case L.null d of
    true → map (Tuple Nothing) v
    false → L.zip d v

  tagSeriesKey
    ∷ List SeriesKey
    → List (Tuple (Maybe String) (Maybe Number))
    → List (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
  tagSeriesKey k v = case L.null k of
    true → map (Tuple Nothing) v
    false → L.zip k v

  seriesKeys ∷ List SeriesKey
  seriesKeys = map (\x → mkSeriesKey x Nothing) series

  mkSeriesKey ∷ Maybe String → Maybe String → SeriesKey
  mkSeriesKey f s =
    f >>= \f → pure $ Tuple f s

  filterInvalid
    ∷ Tuple (Maybe String) (Tuple SeriesKey (Tuple (Maybe String) (Maybe Number)))
    → Maybe (Tuple String (Tuple String (Tuple String Number)))
  filterInvalid (a × b × c × d) =
    case c, d of
      Just c', Just d' →
        Just $ Tuple
                (fromMaybe "" a)
                (Tuple (keyName (Tuple "" b)) (Tuple c' d'))
      _, _ → Nothing

  combineDup
    ∷ List (Tuple String (Tuple String (Tuple String Number)))
    → Maybe (Tuple String (List (Tuple String (Tuple String Number))))
  combineDup x = do
    d ← fst <$> L.head x
    pure $ Tuple d $ map snd x

  combineSerie
    ∷ List (Tuple String (Tuple String Number))
    → Maybe (Tuple String (List (Tuple String Number)))
  combineSerie x = do
    k ← fst <$> L.head x
    pure $ Tuple k $ map snd x

  combineDim
    ∷ Tuple String (List (Tuple String Number))
    → Tuple String (List (Tuple String Number))
  combineDim x =
    map (L.catMaybes <<< map combine <<< L.groupBy ((==) `on` fst) <<< L.sortBy (compare `on` fst)) x
    where
    combine ∷ List (Tuple String Number) → Maybe (Tuple String Number)
    combine x = do
      d ← fst <$> L.head x
      pure $ Tuple d (applyAggregation $ map snd x)

  applyAggregation ∷ List Number → Number
  applyAggregation = runAggregation (fromMaybe Sum agg)

  checkDimAndTransform
    ∷ Tuple String (List (Tuple String Number))
    → Maybe (Tuple String (Array Number))
  checkDimAndTransform a =
    if (L.length $ snd a) == L.length distinctDims
      then Just $ Tuple
        (fst a)
        (A.fromFoldable $ map snd $ snd a)
      else Nothing

buildRadar
  ∷ Map JCursor Ax.Axis
  → ChartConfiguration
  → DSL OptionI
buildRadar axes conf = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu sans"
      E.fontSize 12

  E.legend do
    E.items $ map ET.strItem serieNames
    E.orient ET.Vertical
    E.leftPosition $ ET.LeftHP
    E.topTop
    E.textStyle do
      E.fontFamily "Ubuntu sans"

  E.colors colors

  E.radars
    $ traverse_ E.radar radars

  E.titles
    $ traverse_ E.title titles

  E.series
    $ traverse_ (E.radarSeries ∘ serie)
    $ A.zip (A.range 0 (A.length $ snd radarData)) (snd radarData)

  where
  serieNames ∷ Array String
  serieNames =
    A.nub
      $ A.filter (\e → e /= "")
      $ A.concat
      $ map (map fst)
      $ map snd
      $ snd radarData

  dupNames ∷ Array String
  dupNames = map fst $ snd radarData

  numDup ∷ Int
  numDup = A.length dupNames

  titles ∷ Array (DSL ETP.TitleI)
  titles =
    map (mkTitle numDup) (A.range 0 $ numDup - 1)
    where
    mkTitle ∷ Int → Int → DSL ETP.TitleI
    mkTitle n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      E.text $ fromMaybe "" $ dupNames !! i
      E.textStyle do
        E.fontFamily "Ubuntu sans"
        E.fontSize 12
      E.left
        $ ET.Percent
        $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
          -- adjust the position to the center
          - 0.3
      E.top
        $ ET.Percent
        $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
          - (75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol))
      E.textCenter
      E.textBottom

  radars ∷ Array (DSL ETP.RadarI)
  radars =
    map (mkPolar numDup) (A.range 0 $ numDup - 1)
    where
    mkPolar ∷ Int → Int → DSL ETP.RadarI
    mkPolar n i = do
      let
        -- max number of plot in one row: 4
        maxCol = 4
        nRow = (n / maxCol + 1)
        nCol = if n <= maxCol then n else maxCol
        row = toNumber (i / nCol)
        col = (toNumber i) % (toNumber nCol)
      E.indicators
        $ traverse_ E.indicator $ mkIndicatorSet i
      E.nameGap 10.0
      E.center $ ET.Point
        { x: ET.Percent $ 100.0 * (2.0 * col + 1.0) / (toNumber (nCol * 2))
        , y: ET.Percent $ 100.0 * (2.0 * row + 1.0) / (toNumber (nRow * 2))
        }
      E.singleValueRadius
        $ ET.SingleValueRadius
        $ ET.Percent
        $ 75.0 / (if nRow > nCol then toNumber nRow else toNumber nCol)

  mkIndicatorSet ∷ Int → Array (DSL ETP.IndicatorI)
  mkIndicatorSet i =
    let
      dupName = fromMaybe "" $ (map fst $ snd radarData) !! i
    in
      map mkIndicator (fst radarData)

  mkIndicator ∷ String → DSL ETP.IndicatorI
  mkIndicator dim = do
    E.name $ dim
    when (isJust minVal) $ E.min $ fromMaybe zero minVal
    when (isJust maxVal) $ E.max $ fromMaybe zero maxVal

  allValues ∷ Array Number
  allValues = A.concat
    $ map snd
    $ A.concat
    $ map snd
    $ snd radarData

  minVal ∷ Maybe Number
  minVal = minimum allValues

  maxVal ∷ Maybe Number
  maxVal = maximum allValues

  radarData ∷ RadarData
  radarData = buildRadarData $ buildChartAxes axes conf

serie
  ∷ Tuple Int (Tuple String (Array (Tuple String (Array Number))))
  → DSL ETP.RadarSeriesI
serie (ind × (dup × a)) = do
  when (dup ≠ "") $ E.name dup
  E.radarIndex $ toNumber ind
  E.symbol ET.Circle
  if A.null a
    then E.buildItems $ E.addItem blankData
    else E.buildItems $ for_ a \x →
      E.addItem $ makeData x

makeData
  ∷ Tuple String (Array Number)
  → DSL ETP.ItemI
makeData (name × values) = do
    E.name name
    E.values values

blankData ∷ DSL ETP.ItemI
blankData = do
  -- set a value to avoid display issue
  E.values [0.0]
  E.symbol ET.None


Fix IPFS source

Fix IPFS source

module Genetics.Browser.Biodalliance.Source.IPFS where

import Prelude

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (error)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (class DecodeJson, Json, decodeJson, jsonParser)
import Data.Either (Either(..))
import Data.Traversable (class Traversable, traverse)
import Genetics.Browser.Units (Bp, Chr)
import IPFS (IPFS, IPFSEff)
import IPFS.Files as Files
import IPFS.Types (IPFSPath(..))
import Node.Encoding (Encoding(..))
import Node.Stream (Readable)
import Node.Stream as Stream

affOnDataString :: Readable _ _
                -> Encoding
                -> Aff _ String
affOnDataString stream encoding =
  makeAff (\error success -> Stream.onDataString stream encoding success)

fetchIPFSFeatures :: ∀ f a.
                     Functor f
                  => DecodeJson (f Json)
                  => Traversable f
                  => IPFS
                  -> (Json -> Either String a)
                  -> String
                  -> Chr -> Bp -> Bp -> Aff _ (f a)
fetchIPFSFeatures ipfs parse path chr min max = do
  str  <- Files.cat ipfs (IPFSPathString path)
  raw  <- jsonParser <$> affOnDataString str UTF8
  case raw >>= decodeJson >>= traverse parse of
    Left err -> throwError $ error err
    Right fs -> pure fs

module Genetics.Browser.Biodalliance.Source.IPFS where

import Prelude

import Control.Monad.Aff (Aff, makeAff)
import Control.Monad.Eff.Exception (EXCEPTION, Error, error, throw)
import Control.Monad.Error.Class (throwError)
import Data.Argonaut (class DecodeJson, Json, decodeJson, jsonParser)
import Data.Either (Either(..))
import Data.Maybe (Maybe(..))
import Data.Traversable (class Traversable, traverse)
import Genetics.Browser.Biodalliance.Source (FetchFunction, Source, createSource)
import Genetics.Browser.Units (Bp(..), Chr(..))
import IPFS (IPFS, IPFSEff)
import IPFS.Files as Files
import IPFS.Types (IPFSEff, IPFSPath(..))
import Node.Encoding (Encoding, Encoding(..))
import Node.Stream (Readable)
import Node.Stream as Stream

affOnDataString :: Readable _ _
                -> Encoding
                -> Aff _ String
affOnDataString stream encoding =
  makeAff (\error success -> Stream.onDataString stream encoding success)

fetchIPFSFeatures :: ∀ f a.
                     Functor f
                  => DecodeJson f
                  => Traversable f
                  => IPFS
                  -> (Json -> Either String a)
                  -> String
                  -> Chr -> Bp -> Bp -> Aff _ (f a)
fetchIPFSFeatures ipfs parse path chr min max = do
  str  <- Files.cat ipfs (IPFSPathString path)
  raw  <- jsonParser <$> affOnDataString str UTF8
  case raw >>= decodeJson >>= traverse parse of
    Left err -> throwError $ error err
    Right fs -> pure fs


added boundary gap

added boundary gap

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.BuildChart.Bar.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Bar.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Bar.Model (Model, BarR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Bar))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Axis (Axes)
import SlamData.Workspace.Card.BuildChart.Axis as Ax
import SlamData.Workspace.Card.BuildChart.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Common.Positioning as BCP
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → Axes
  → CET.CardEvalT m Port.Port
eval Nothing _ _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource axes = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildBar conf records axes) Bar

type BarSeries =
  { name ∷ Maybe String
  , items ∷ String >> Number
  }

type BarStacks =
  { stack ∷ Maybe String
  , series ∷ Array BarSeries
  }

buildBarData ∷ BarR → JArray → Array BarStacks
buildBarData r records = series
  where
  -- | maybe stack >> maybe parallel >> category >> values
  dataMap ∷ Maybe String >> Maybe String >> String >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> Maybe String >> String >> Array Number
    → Json
    → Maybe String >> Maybe String >> String >> Array Number
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson r.category of
      Nothing → acc
      Just categoryKey →
        let
          mbStack =
            getMaybeStringFromJson =<< r.stack
          mbParallel =
            getMaybeStringFromJson =<< r.parallel
          values =
            getValuesFromJson $ pure r.value

          alterStackFn
            ∷ Maybe (Maybe String >> String >> Array Number)
            → Maybe (Maybe String >> String >> Array Number)
          alterStackFn Nothing =
            Just $ M.singleton mbParallel $ M.singleton categoryKey values
          alterStackFn (Just parallel) =
            Just $ M.alter alterParallelFn mbParallel parallel

          alterParallelFn
            ∷ Maybe (String >> Array Number)
            → Maybe (String >> Array Number)
          alterParallelFn Nothing =
            Just $ M.singleton categoryKey values
          alterParallelFn (Just category) =
            Just $ M.alter alterCategoryFn categoryKey category

          alterCategoryFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCategoryFn Nothing = Just values
          alterCategoryFn (Just arr) = Just $ arr ⊕ values
        in
          M.alter alterStackFn mbStack acc

  series ∷ Array BarStacks
  series =
    foldMap mkBarStack $ M.toList dataMap

  mkBarStack
    ∷ Maybe String × (Maybe String >> String >> Array Number)
    → Array BarStacks
  mkBarStack (stack × sers) =
    [{ stack
     , series: foldMap mkBarSeries $ M.toList sers
     }]

  mkBarSeries
    ∷ Maybe String × (String >> Array Number)
    → Array BarSeries
  mkBarSeries (name × items) =
    [{ name
     , items: map (Ag.runAggregation r.valueAggregation) items
     }]

buildBar ∷ BarR → JArray → Axes → DSL OptionI
buildBar r records axes = do
  E.tooltip E.triggerAxis

  E.colors colors

  E.xAxis do
    E.axisType xAxisConfig.axisType
    E.enabledBoundaryGap
    traverse_ E.interval xAxisConfig.interval
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxis do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle $ E.width 1
    E.splitLine $ E.lineStyle $ E.width 1

  E.legend do
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    case xAxisConfig.axisType of
      ET.Category | A.length seriesNames > 40 → E.hidden
      _ → pure unit
    E.items $ map ET.strItem seriesNames
    E.leftLeft
    E.topBottom

  E.grid BCP.cartesian

  E.series series

  where

  barData ∷ Array BarStacks
  barData = buildBarData r records

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration $ Ax.axisType r.category axes

  seriesNames ∷ Array String
  seriesNames = case r.parallel of
    Just _ →
      A.fromFoldable
      $ foldMap (_.series ⋙ foldMap (_.name ⋙ foldMap Set.singleton ))
        barData
    Nothing →
      A.catMaybes $ map _.stack barData

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (_.series
                 ⋙ foldMap (_.items
                            ⋙ M.keys
                            ⋙ Set.fromFoldable)) barData
  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType $ Ax.axisType r.category axes

  series ∷ ∀ i. DSL (bar ∷ ETP.I|i)
  series = for_ barData \stacked →
    for_ stacked.series \serie → E.bar do
      E.buildItems $ for_ xValues \key →
        case M.lookup key serie.items of
          Nothing → E.missingItem
          Just v → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue v
      case r.parallel of
        Just _ → do
          for_ stacked.stack E.stack
          for_ serie.name E.name
        Nothing → do
          E.stack "default stack"
          for_ stacked.stack E.name

{-
Copyright 2016 SlamData, Inc.

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

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

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

module SlamData.Workspace.Card.BuildChart.Bar.Eval
  ( eval
  , module SlamData.Workspace.Card.BuildChart.Bar.Model
  ) where

import SlamData.Prelude

import Data.Argonaut (JArray, Json)
import Data.Array as A
import Data.Lens ((^?))
import Data.Map as M
import Data.Set as Set

import ECharts.Monad (DSL)
import ECharts.Commands as E
import ECharts.Types as ET
import ECharts.Types.Phantom (OptionI)
import ECharts.Types.Phantom as ETP

import Quasar.Types (FilePath)

import SlamData.Quasar.Class (class QuasarDSL)
import SlamData.Quasar.Error as QE
import SlamData.Workspace.Card.BuildChart.Common.Eval (type (>>))
import SlamData.Workspace.Card.BuildChart.Common.Eval as BCE
import SlamData.Workspace.Card.BuildChart.Bar.Model (Model, BarR)
import SlamData.Workspace.Card.CardType.ChartType (ChartType(Bar))
import SlamData.Workspace.Card.BuildChart.Aggregation as Ag
import SlamData.Workspace.Card.BuildChart.Axis (Axes)
import SlamData.Workspace.Card.BuildChart.Axis as Ax
import SlamData.Workspace.Card.BuildChart.Semantics (getMaybeString, getValues)
import SlamData.Workspace.Card.BuildChart.ColorScheme (colors)
import SlamData.Workspace.Card.BuildChart.Common.Positioning as BCP
import SlamData.Workspace.Card.Eval.CardEvalT as CET
import SlamData.Workspace.Card.Port as Port

eval
  ∷ ∀ m
  . (Monad m, QuasarDSL m)
  ⇒ Model
  → FilePath
  → Axes
  → CET.CardEvalT m Port.Port
eval Nothing _ _ =
  QE.throw "Please select axis to aggregate"
eval (Just conf) resource axes = do
  records ← BCE.records resource
  pure $ Port.ChartInstructions (buildBar conf records axes) Bar

type BarSeries =
  { name ∷ Maybe String
  , items ∷ String >> Number
  }

type BarStacks =
  { stack ∷ Maybe String
  , series ∷ Array BarSeries
  }

buildBarData ∷ BarR → JArray → Array BarStacks
buildBarData r records = series
  where
  -- | maybe stack >> maybe parallel >> category >> values
  dataMap ∷ Maybe String >> Maybe String >> String >> Array Number
  dataMap =
    foldl dataMapFoldFn M.empty records

  dataMapFoldFn
    ∷ Maybe String >> Maybe String >> String >> Array Number
    → Json
    → Maybe String >> Maybe String >> String >> Array Number
  dataMapFoldFn acc js =
    let
      getMaybeStringFromJson = getMaybeString js
      getValuesFromJson = getValues js
    in case getMaybeStringFromJson r.category of
      Nothing → acc
      Just categoryKey →
        let
          mbStack =
            getMaybeStringFromJson =<< r.stack
          mbParallel =
            getMaybeStringFromJson =<< r.parallel
          values =
            getValuesFromJson $ pure r.value

          alterStackFn
            ∷ Maybe (Maybe String >> String >> Array Number)
            → Maybe (Maybe String >> String >> Array Number)
          alterStackFn Nothing =
            Just $ M.singleton mbParallel $ M.singleton categoryKey values
          alterStackFn (Just parallel) =
            Just $ M.alter alterParallelFn mbParallel parallel

          alterParallelFn
            ∷ Maybe (String >> Array Number)
            → Maybe (String >> Array Number)
          alterParallelFn Nothing =
            Just $ M.singleton categoryKey values
          alterParallelFn (Just category) =
            Just $ M.alter alterCategoryFn categoryKey category

          alterCategoryFn
            ∷ Maybe (Array Number)
            → Maybe (Array Number)
          alterCategoryFn Nothing = Just values
          alterCategoryFn (Just arr) = Just $ arr ⊕ values
        in
          M.alter alterStackFn mbStack acc

  series ∷ Array BarStacks
  series =
    foldMap mkBarStack $ M.toList dataMap

  mkBarStack
    ∷ Maybe String × (Maybe String >> String >> Array Number)
    → Array BarStacks
  mkBarStack (stack × sers) =
    [{ stack
     , series: foldMap mkBarSeries $ M.toList sers
     }]

  mkBarSeries
    ∷ Maybe String × (String >> Array Number)
    → Array BarSeries
  mkBarSeries (name × items) =
    [{ name
     , items: map (Ag.runAggregation r.valueAggregation) items
     }]

buildBar ∷ BarR → JArray → Axes → DSL OptionI
buildBar r records axes = do
  E.tooltip E.triggerAxis

  E.colors colors

  E.xAxis do
    E.axisType xAxisConfig.axisType
    traverse_ E.interval xAxisConfig.interval
    case xAxisConfig.axisType of
      ET.Category →
        E.items $ map ET.strItem xValues
      _ → pure unit
    E.axisLabel do
      E.rotate r.axisLabelAngle
      E.textStyle do
        E.fontFamily "Ubuntu, sans"

  E.yAxis do
    E.axisType ET.Value
    E.axisLabel $ E.textStyle do
      E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle $ E.width 1
    E.splitLine $ E.lineStyle $ E.width 1

  E.legend do
    E.textStyle $ E.fontFamily "Ubuntu, sans"
    case xAxisConfig.axisType of
      ET.Category | A.length seriesNames > 40 → E.hidden
      _ → pure unit
    E.items $ map ET.strItem seriesNames
    E.leftLeft
    E.topBottom

  E.grid BCP.cartesian

  E.series series

  where

  barData ∷ Array BarStacks
  barData = buildBarData r records

  xAxisConfig ∷ Ax.EChartsAxisConfiguration
  xAxisConfig = Ax.axisConfiguration $ Ax.axisType r.category axes

  seriesNames ∷ Array String
  seriesNames = case r.parallel of
    Just _ →
      A.fromFoldable
      $ foldMap (_.series ⋙ foldMap (_.name ⋙ foldMap Set.singleton ))
        barData
    Nothing →
      A.catMaybes $ map _.stack barData

  xValues ∷ Array String
  xValues =
    A.sortBy xSortFn
      $ A.fromFoldable
      $ foldMap (_.series
                 ⋙ foldMap (_.items
                            ⋙ M.keys
                            ⋙ Set.fromFoldable)) barData
  xSortFn ∷ String → String → Ordering
  xSortFn = Ax.compareWithAxisType $ Ax.axisType r.category axes

  series ∷ ∀ i. DSL (bar ∷ ETP.I|i)
  series = for_ barData \stacked →
    for_ stacked.series \serie → E.bar do
      E.buildItems $ for_ xValues \key →
        case M.lookup key serie.items of
          Nothing → E.missingItem
          Just v → E.addItem do
            E.name key
            E.buildValues do
              E.addStringValue key
              E.addValue v
      case r.parallel of
        Just _ → do
          for_ stacked.stack E.stack
          for_ serie.name E.name
        Nothing → do
          E.stack "default stack"
          for_ stacked.stack E.name