Fixed warnings

Fixed warnings

{-
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.Deck.Dialog.Export.Component where

import SlamData.Prelude
import Clipboard as C
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Exception as Exception
import Data.Foldable as F
import Data.Map as Map
import Data.List (List)
import Data.Path.Pathy as Pathy
import Data.Path.Pathy (Path, Abs, File, Sandboxed)
import Data.StrMap as SM
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import OIDC.Crypt as OIDC
import Quasar.Advanced.Types as QTA
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Security as Q
import SlamData.Render.CSS as Rc
import SlamData.Render.Icon as I
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Deck.DeckId as DID
import Utils.DOM as DOM
import Utils.Path as UP
import Control.UI.Browser (select, getHref)
import DOM.Classy.Element (toElement)
import DOM.HTML.Types (readHTMLElement)
import Data.Argonaut (encodeJson)
import Data.Foreign (toForeign)
import Data.URI (AbsoluteURI, URI)
import Data.URI as URI
import Data.URI.Types.AbsoluteURI as AbsoluteURI
import Data.URI.Types.URI as URIT
import Data.URI.Types.HierarchicalPart as HierarchicalPart
import SlamData.Monad (Slam)
import SlamData.Workspace.Deck.DeckPath (deckPath')
import SlamData.Workspace.Deck.Dialog.Share.Model (sharingActions, ShareResume(..), SharingInput)
import SlamData.Workspace.Routing (mkWorkspaceHash, varMapsForURL)
import Utils (hush, prettyJson)

data PresentAs = Embed | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

type State =
  { presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  , sharingInput ∷ SharingInput
  , permToken ∷ Maybe QTA.TokenR
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLoggedIn ∷ Boolean
  , copyVal ∷ String
  , noNetworkAccessToAdvancedError ∷ Boolean
  , presentStyleURIInput :: Boolean
  , styleURIString :: String
  , submitting ∷ Boolean
  , loading ∷ Boolean
  , clipboard ∷ Maybe C.Clipboard
  }

initialState ∷ Input → State
initialState input =
  { presentingAs: input.presentingAs
  , varMaps: input.varMaps
  , sharingInput: input.sharingInput
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: true
  , hovered: false
  , isLoggedIn: false
  , copyVal: ""
  , noNetworkAccessToAdvancedError: false
  , presentStyleURIInput: false
  , styleURIString: ""
  , submitting: false
  , loading: true
  , clipboard: Nothing
  }

toggleStyleURIInput :: State -> State
toggleStyleURIInput state =
   state {presentStyleURIInput = not state.presentStyleURIInput}

parseStyleURI :: String -> Maybe AbsoluteURI
parseStyleURI styleURI = do
  validAbsoluteURI ← hush $ URI.runParseAbsoluteURI styleURI
  if isJust $ styleURIPath validAbsoluteURI
    then Just validAbsoluteURI
    else Nothing
  where
  styleURIPath ∷ AbsoluteURI → Maybe (Path Abs File Sandboxed)
  styleURIPath =
    hush
      <=< HierarchicalPart.uriPathAbs
      <<< AbsoluteURI.hierarchicalPart

type Input =
  { sharingInput ∷ SharingInput
  , presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  }

data Query a
  = SelectElement DOM.Event a
  | Init a
  | Revoke a
  | ToggleShouldGenerateToken a
  | ToggleStyleURIInput a
  | UpdateStyleURI String a
  | PreventDefault DOM.Event a
  | HandleCancel a

data Message = Dismiss

copyButtonRef ∷ H.RefLabel
copyButtonRef = H.RefLabel "copy"

component ∷ H.Component HH.HTML Query Input Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishDialog state
  | otherwise = renderEmbedDialog state

renderStyleURIInput ∷ State → H.ComponentHTML Query
renderStyleURIInput state =
  HH.div_ $ fold $
    [ pure $ HH.div_
        [ HH.a
            [ HE.onClick (HE.input_ ToggleStyleURIInput) ]
            [ HH.text "Add a stylesheet URI to customize look/feel."]
        ]
    , guard state.presentStyleURIInput $> HH.div
        (fold [ guard (isJust $ parseStyleURI state.styleURIString) $> HP.classes validInputClasses ])
        (fold
           [ pure $ HH.input
               [ HP.classes [ B.formControl ]
               , HE.onValueInput (HE.input UpdateStyleURI)
               ]
           , guard (isJust $ parseStyleURI state.styleURIString) $> HH.span
               [ HP.classes [ B.glyphicon, B.glyphiconOk, B.formControlFeedback ] ]
               []
           ])
    ]
  where
  validInputClasses = [ B.hasSuccess, B.hasFeedback ]

renderPublishDialog ∷ State → H.ComponentHTML Query
renderPublishDialog state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    $ fold
        [ pure $ HH.h4_ [ HH.text "Publish deck" ]
        , guard state.loading $> HH.div
            [ HP.classes [ B.alert, B.alertInfo, HH.ClassName "share-loading" ] ]
            [ HH.img [ HP.src "img/blue-spin.svg" ]
            , HH.text "Loading"
            ]
        , guard (not state.loading) $> HH.div
            [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
            [ HH.p_ renderAccessMessage
            , HH.form
                [ HE.onSubmit (HE.input PreventDefault) ]
                $ fold
                    [ pure renderPublishUrl
                    , pure $ renderStyleURIInput state
                    ]
            ]
        , pure renderPublishFooter
        ]
  where
  renderPublishUrl =
    HH.div
      [ HP.classes [ B.inputGroup ] ]
      [ HH.input
          [ HP.classes [ B.formControl ]
          , HP.value state.copyVal
          , HP.readOnly true
          , HP.disabled state.submitting
          , HP.title "Published deck URL"
          , ARIA.label "Published deck URL"
          , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
          ]
      , HH.span
          [ HP.classes [ B.inputGroupBtn ] ]
          [ HH.button
            [ HP.classes [ B.btn, B.btnDefault ]
            , HE.onClick (HE.input_ HandleCancel)
            , HP.ref copyButtonRef
            , HP.id_ "copy-button"
            , HP.type_ HP.ButtonButton
            , HP.disabled state.submitting
            ]
            [ I.copySm ]
          ]
      ]

  renderPublishFooter =
    HH.div
      [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
      $ fold
          [ guard state.noNetworkAccessToAdvancedError $> HH.div
              [ HP.classes [ B.alert, B.alertDanger ] ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , pure $ HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          , guard state.isLoggedIn $> 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.type_ HP.ButtonButton
              , HP.enabled $ state.canRevoke ∧ not state.submitting
              ]
              [ HH.text "Revoke" ]
          , pure $ HH.a
              (fold
                 [ pure $ HP.classes $ fold
                     [ pure B.btn
                     , pure B.btnPrimary
                     , guard state.submitting $> B.disabled
                     ]
                 , pure $ HP.target "_blank"
                 , guard state.submitting $> HP.href state.copyVal
                 ])
              [ HH.text "Preview" ]
          ]

  renderAccessMessage
    | state.isLoggedIn =
        [ HH.text
          $ "Anyone has access to the following link "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this link may be able to view this deck. "
            ⊕ "They may also be able to modify the link to view or edit any deck "
            ⊕ "in this workspace. Please see "
        , HH.a
            [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
            , HP.target  "_blank"
            ]
            [ HH.text "Securing SlamData Community Edition" ]
            , HH.text " for more information."
            ]

renderEmbedDialog ∷ State → H.ComponentHTML Query
renderEmbedDialog state =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text  "Embed deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.form
          [ HE.onSubmit (HE.input PreventDefault) ]
          [ HH.div
              [ HP.classes [ B.formGroup ] ]
                [ HH.textarea
                  [ HP.classes [ B.formControl, Rc.embedBox ]
                  , HP.readOnly true
                  , HP.value state.copyVal
                  , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                  ]
                , HH.button
                  [ HP.id_ "copy-button"
                  , HP.classes
                      $ [ B.btn, B.btnDefault, B.btnXs ]
                      ⊕ [ HH.ClassName "textarea-copy-button" ]
                  , HP.ref copyButtonRef
                  , HP.type_ HP.ButtonButton
                  , HP.disabled state.submitting
                  ]
                  [ I.copySm ]
                , HH.div [ HP.classes [ B.checkbox ] ]
                  [ (if state.isLoggedIn then HH.label_ else HH.p_)
                    $ ((guard state.isLoggedIn)
                       $> HH.input
                           [ HP.type_ HP.InputCheckbox
                           , HP.checked state.shouldGenerateToken
                           , HP.disabled state.submitting
                           , HE.onChecked (HE.input_ ToggleShouldGenerateToken)
                           ])
                    ⊕ message
                  ]
                , renderStyleURIInput state
                ]
          ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.noNetworkAccessToAdvancedError then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $> 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.type_ HP.ButtonButton
                , HP.enabled $ state.canRevoke ∧ not state.submitting
                ]
                [ HH.text "Revoke" ])

        ]
  where
  message
    | state.isLoggedIn =
        [ 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."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this script may be able to view this deck. "
            ⊕ "They may also be able to modify the script to view or edit any "
            ⊕ "deck in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target "_blank"]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

eval ∷ Query ~> DSL
eval (Init next) = next <$ do
  state ← H.get
  -- To know if user is authed
  mbAuthToken ← H.lift Auth.getIdToken
  case mbAuthToken of
    Nothing →
      H.modify _{ permToken = Nothing
                , canRevoke = false
                , isLoggedIn = false
                , loading = false
                }
    Just oidcToken → do
      H.modify _{isLoggedIn = true, canRevoke = true}
      tokensRes ← Q.tokenList
      H.modify _{loading = false}
      case tokensRes of
        Left _ → H.modify _{noNetworkAccessToAdvancedError = true}
        Right tokens →
          let
            tokenName =
              Just $ workspaceTokenName state.sharingInput.workspacePath oidcToken
            oldToken =
              F.find (\x → x.name ≡ tokenName) tokens
          in case oldToken of
            Just token → do
              H.modify _{ permToken = Just token
                        , noNetworkAccessToAdvancedError = false
                        }
            Nothing → do
              isURI ← (_ ≡ URI) <$> H.gets _.presentingAs
              when (state.shouldGenerateToken ∨ isURI) do
                H.modify _{submitting = true}
                createdRes ←
                  Q.createToken
                    tokenName
                    (sharingActions state.sharingInput View)
                H.modify _{submitting = false}
                H.modify case createdRes of
                  Left _ →  _{noNetworkAccessToAdvancedError = true}
                  Right newToken →
                     _{ noNetworkAccessToAdvancedError = false
                      , permToken = Just newToken
                      }
  updateCopyVal

eval (SelectElement ev next) = do
  st ← H.get
  H.liftEff do
    DOM.stopPropagation ev
    when (not st.submitting) do
      DOM.currentTarget ev
        # readHTMLElement ∘ toForeign
        # runExcept
        # traverse_ select
  pure next

eval (Revoke next) = do
  mbPermToken ← H.gets _.permToken
  for_ mbPermToken \tok → do
    H.modify _{submitting = true}
    deleteRes ← Q.deleteToken tok.id
    H.modify _{submitting = false}
    case deleteRes of
      Left _ → H.modify _{ noNetworkAccessToAdvancedError = true }
      Right _ → H.raise Dismiss
  pure next

eval (ToggleShouldGenerateToken next) = next <$ do
  state ← H.get
  case state.permToken of
    Nothing →
      unless state.shouldGenerateToken do
        mbOIDC ← H.lift Auth.getIdToken
        workspacePath ← H.gets (_.workspacePath ∘ _.sharingInput)
        for_ mbOIDC \oidc → do
          let
            actions = sharingActions state.sharingInput View
            tokenName = Just $ workspaceTokenName workspacePath oidc
          H.modify _{submitting = true}
          recreatedRes ← Q.createToken tokenName actions
          H.modify _{submitting = false}
          H.modify case recreatedRes of
            Left _ →
              _ { permToken = Nothing
                , noNetworkAccessToAdvancedError = true
                }
            Right token →
              _ { permToken = Just token
                , noNetworkAccessToAdvancedError = false
                }
    Just tok → do
      H.modify _{submitting = true}
      deleteRes ← Q.deleteToken tok.id
      H.modify _{submitting = false}
      H.modify case deleteRes of
        Left _ → _ { noNetworkAccessToAdvancedError = true }
        Right _ → _ { noNetworkAccessToAdvancedError = false, permToken = Nothing }
  H.modify _{shouldGenerateToken = not state.shouldGenerateToken}
  updateCopyVal

eval (ToggleStyleURIInput next) =
  H.modify toggleStyleURIInput $> next

eval (UpdateStyleURI styleURI next) =
  H.modify (_ { styleURIString = styleURI }) *> updateCopyVal $> next

eval (PreventDefault ev next) =
  H.liftEff (DOM.preventDefault ev) $> next

eval (HandleCancel next) =
  H.raise Dismiss $> next

workspaceTokenName ∷ UP.DirPath → OIDC.IdToken → QTA.TokenName
workspaceTokenName workspacePath idToken =
  let
    payload =
      hush $ Eff.runPure $ Exception.try $ OIDC.readPayload idToken
    email =
      fromMaybe "unknown user" $ unwrap <$> (OIDC.pluckEmail =<< payload)
    workspace =
      Pathy.printPath workspacePath
  in
    QTA.TokenName
      $ "publish permission granted by "
      ⊕ email
      ⊕ " for "
      ⊕ workspace

updateCopyVal ∷ DSL Unit
updateCopyVal = do
  locString ← H.liftEff getHref
  state ← H.get
  case renderCopyVal locString state of
    Right copyVal → do
      H.modify _{ copyVal = copyVal }
      clipboard ← H.gets _.clipboard
      case clipboard of
        Just c -> H.liftEff $ C.destroy c
        Nothing -> pure unit
      H.getHTMLElementRef copyButtonRef >>= traverse_ \htmlEl → do
        newClipboard ← H.liftEff $ C.fromElement (toElement htmlEl) (pure copyVal)
        H.modify _ { clipboard = Just newClipboard }
    Left error →
      pure unit

renderCopyVal ∷ String → State → Either String String
renderCopyVal locString state
  | state.presentingAs ≡ URI =
    URI.printURI <$> renderURI locString state
  | otherwise
      = Right $ Str.joinWith "\n"
          [ """<!-- This is the DOM element that the deck will be inserted into. -->"""
          , """<!-- You can change the width and height and use a stylesheet to apply styling. -->"""
          , """<iframe frameborder="0" width="100%" height="800" id=""" ⊕ quoted deckDOMId ⊕ """></iframe>"""
          , """"""
          , """<!-- To change a deck's variables after it has been inserted please use window.slamDataDeckUrl to create an new URI then update the deck iframe's src parameter. -->"""
          , """<script type="text/javascript">"""
          , """  window.slamDataDeckUrl = function (options) {"""
          , """    var queryParts = function () {"""
          , """      var parts = [];"""
          , """      if (options.echartTheme) {"""
          , """        parts.push("echartTheme=" + encodeURIComponent(options.echartTheme));"""
          , """      }"""
          , """      if (options.permissionTokens && options.permissionTokens.length) {"""
          , """        parts.push("permissionTokens=" + options.permissionTokens.join(","));"""
          , """      }"""
          , """      if (options.stylesheetUrls && options.stylesheetUrls.length) {"""
          , """        parts.push("stylesheets=" + options.stylesheetUrls.map(encodeURIComponent).join(","));"""
          , """      }"""
          , """      return parts;"""
          , """    };"""
          , """    var queryString = "?" + queryParts().join("&");"""
          , """    var varsParam = options.vars ? "/?vars=" + encodeURIComponent(JSON.stringify(options.vars)) : "";"""
          , """    return options.slamDataUrl + queryString + "#" + options.deckPath + options.deckId + "/view" + varsParam;"""
          , """  };"""
          , """</script>"""
          , """"""
          , """<!-- This is the script which performs SlamData deck insertion. -->"""
          , """<script type="text/javascript">"""
          , """  (function () {"""
          , """    var options = {"""
          , """      slamDataUrl: """ ⊕ quoted workspaceURI ⊕ ""","""
          , """      deckPath: """ ⊕ quoted deckPath ⊕ ""","""
          , """      deckId: """ ⊕ quoted deckId ⊕ ""","""
          , """      permissionTokens: [""" ⊕ maybe "" quoted token ⊕ """],"""
          , """      stylesheetUrls: [""" ⊕ maybe "" quoted stylesheet ⊕ """], // An array of custom stylesheet URIs."""
          , """      echartTheme: undefined,"""
          , """      vars: """ ⊕ renderVarMaps state.varMaps
          , """    };"""
          , """"""
          , """    var deckSelector = "iframe#sd-deck-" + options.deckId;"""
          , """    var deckElement = document.querySelector(deckSelector);"""
          , """"""
          , """    if (deckElement) {"""
          , """      deckElement.src = window.slamDataDeckUrl(options);"""
          , """    } else {"""
          , """      throw("SlamData: Couldn't locate " + deckSelector);"""
          , """    }"""
          , """  })();"""
          , """</script>"""
          ]
    where
    line = (_ ⊕ "\n")
    quoted s = "\"" ⊕ s ⊕ "\""
    workspaceURI =
      either id URI.printURI
        $ case hush $ URI.runParseURI locString of
          Nothing →
            Left "Bad SlamData config: workspacePath was not a valid absolute URI."
          Just loc →
            Right $ URI.URI
              (URIT.uriScheme loc)
              (URI.HierarchicalPart
                (HierarchicalPart.authority $ URIT.hierarchicalPart loc)
                (Right <$> filePathFromURI loc))
              Nothing
              Nothing
    deckId = DID.toString state.sharingInput.deckId
    deckDOMId = "sd-deck-" ⊕ deckId
    deckPath = UP.encodeURIPath (Pathy.printPath state.sharingInput.workspacePath)
    token = QTA.runTokenHash <<< _.secret <$> state.permToken
    stylesheet = parseStyleURI state.styleURIString $> state.styleURIString

renderVarMaps ∷ Map.Map CID.CardId Port.VarMap → String
renderVarMaps = indent <<< prettyJson <<< encodeJson <<< varMapsForURL
  where
  indent = RX.replace (unsafePartial fromRight $ RX.regex "(\n\r?)" RXF.global) "$1      "

renderURI ∷ String → State → Either String URI.URI
renderURI locationString state@{sharingInput, permToken, isLoggedIn, styleURIString} =
  case hush $ URI.runParseURI locationString of
    Nothing →
      Left "Bad SlamData config: workspacePath was not a valid absolute URI."
    Just loc →
      Right $ URI.URI
        (URIT.uriScheme loc)
        (URI.HierarchicalPart
          (HierarchicalPart.authority $ URIT.hierarchicalPart loc)
          (Right <$> filePathFromURI loc))
        (Just $ URI.Query query)
        (Just fragment)
  where
  fragment ∷ String
  fragment =
    Str.drop 1
      $ mkWorkspaceHash
          (deckPath' sharingInput.workspacePath sharingInput.deckId)
          (WA.Load AT.ReadOnly)
          SM.empty

  query ∷ List (Tuple String (Maybe String))
  query =
    (guard (isJust $ parseStyleURI styleURIString) $> (Tuple "stylesheets" $ Just styleURIString))
      ⊕ (guard isLoggedIn $> (Tuple "permissionTokens" token))

  token ∷ Maybe String
  token =
    QTA.runTokenHash ∘ _.secret <$> permToken

filePathFromURI ∷ URI → Maybe (Path Abs File Sandboxed)
filePathFromURI =
  hush
    <=< HierarchicalPart.uriPathAbs
    <<< URIT.hierarchicalPart

{-
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.Deck.Dialog.Export.Component where

import SlamData.Prelude
import Clipboard as C
import Control.Apply (lift2)
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Exception as Exception
import Data.Foldable as F
import Data.Map as Map
import Data.List (List)
import Data.Path.Pathy as Pathy
import Data.Path.Pathy (Path, Abs, File, Sandboxed, (</>))
import Data.StrMap as SM
import Data.String as Str
import Data.String.Regex as RX
import Data.String.Regex.Flags as RXF
import Halogen as H
import Halogen.HTML as HH
import Halogen.HTML.Events as HE
import Halogen.HTML.Properties as HP
import Halogen.HTML.Properties.ARIA as ARIA
import Halogen.Themes.Bootstrap3 as B
import OIDC.Crypt as OIDC
import Quasar.Advanced.Types as QTA
import SlamData.Config as Config
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Security as Q
import SlamData.Render.CSS as Rc
import SlamData.Render.Icon as I
import SlamData.Workspace.AccessType as AT
import SlamData.Workspace.Action as WA
import SlamData.Workspace.Card.CardId as CID
import SlamData.Workspace.Card.Port.VarMap as Port
import SlamData.Workspace.Deck.DeckId as DID
import Utils.DOM as DOM
import Utils.Path as UP
import Control.UI.Browser (select, getHref)
import DOM.Classy.Element (toElement)
import DOM.HTML.Types (readHTMLElement)
import Data.Argonaut (encodeJson)
import Data.Foreign (toForeign)
import Data.URI (AbsoluteURI, URI)
import Data.URI as URI
import Data.URI.Types.AbsoluteURI as AbsoluteURI
import Data.URI.Types.URI as URIT
import Data.URI.Types.HierarchicalPart as HierarchicalPart
import SlamData.Monad (Slam)
import SlamData.Workspace.Deck.DeckPath (deckPath')
import SlamData.Workspace.Deck.Dialog.Share.Model (sharingActions, ShareResume(..), SharingInput)
import SlamData.Workspace.Routing (mkWorkspaceHash, varMapsForURL)
import Utils (hush, prettyJson)

data PresentAs = Embed | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

type State =
  { presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  , sharingInput ∷ SharingInput
  , permToken ∷ Maybe QTA.TokenR
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLoggedIn ∷ Boolean
  , copyVal ∷ String
  , noNetworkAccessToAdvancedError ∷ Boolean
  , presentStyleURIInput :: Boolean
  , styleURIString :: String
  , submitting ∷ Boolean
  , loading ∷ Boolean
  , clipboard ∷ Maybe C.Clipboard
  }

initialState ∷ Input → State
initialState input =
  { presentingAs: input.presentingAs
  , varMaps: input.varMaps
  , sharingInput: input.sharingInput
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: true
  , hovered: false
  , isLoggedIn: false
  , copyVal: ""
  , noNetworkAccessToAdvancedError: false
  , presentStyleURIInput: false
  , styleURIString: ""
  , submitting: false
  , loading: true
  , clipboard: Nothing
  }

toggleStyleURIInput :: State -> State
toggleStyleURIInput state =
   state {presentStyleURIInput = not state.presentStyleURIInput}

parseStyleURI :: String -> Maybe AbsoluteURI
parseStyleURI styleURI = do
  validAbsoluteURI ← hush $ URI.runParseAbsoluteURI styleURI
  if isJust $ styleURIPath validAbsoluteURI
    then Just validAbsoluteURI
    else Nothing
  where
  styleURIPath ∷ AbsoluteURI → Maybe (Path Abs File Sandboxed)
  styleURIPath =
    hush
      <=< HierarchicalPart.uriPathAbs
      <<< AbsoluteURI.hierarchicalPart

type Input =
  { sharingInput ∷ SharingInput
  , presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  }

data Query a
  = SelectElement DOM.Event a
  | Init a
  | Revoke a
  | ToggleShouldGenerateToken a
  | ToggleStyleURIInput a
  | UpdateStyleURI String a
  | PreventDefault DOM.Event a
  | HandleCancel a

data Message = Dismiss

copyButtonRef ∷ H.RefLabel
copyButtonRef = H.RefLabel "copy"

component ∷ H.Component HH.HTML Query Input Message Slam
component =
  H.lifecycleComponent
    { initialState
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishDialog state
  | otherwise = renderEmbedDialog state

renderStyleURIInput ∷ State → H.ComponentHTML Query
renderStyleURIInput state =
  HH.div_ $ fold $
    [ pure $ HH.div_
        [ HH.a
            [ HE.onClick (HE.input_ ToggleStyleURIInput) ]
            [ HH.text "Add a stylesheet URI to customize look/feel."]
        ]
    , guard state.presentStyleURIInput $> HH.div
        (fold [ guard (isJust $ parseStyleURI state.styleURIString) $> HP.classes validInputClasses ])
        (fold
           [ pure $ HH.input
               [ HP.classes [ B.formControl ]
               , HE.onValueInput (HE.input UpdateStyleURI)
               ]
           , guard (isJust $ parseStyleURI state.styleURIString) $> HH.span
               [ HP.classes [ B.glyphicon, B.glyphiconOk, B.formControlFeedback ] ]
               []
           ])
    ]
  where
  validInputClasses = [ B.hasSuccess, B.hasFeedback ]

renderPublishDialog ∷ State → H.ComponentHTML Query
renderPublishDialog state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    $ fold
        [ pure $ HH.h4_ [ HH.text "Publish deck" ]
        , guard state.loading $> HH.div
            [ HP.classes [ B.alert, B.alertInfo, HH.ClassName "share-loading" ] ]
            [ HH.img [ HP.src "img/blue-spin.svg" ]
            , HH.text "Loading"
            ]
        , guard (not state.loading) $> HH.div
            [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
            [ HH.p_ renderAccessMessage
            , HH.form
                [ HE.onSubmit (HE.input PreventDefault) ]
                $ fold
                    [ pure renderPublishUrl
                    , pure $ renderStyleURIInput state
                    ]
            ]
        , pure renderPublishFooter
        ]
  where
  renderPublishUrl =
    HH.div
      [ HP.classes [ B.inputGroup ] ]
      [ HH.input
          [ HP.classes [ B.formControl ]
          , HP.value state.copyVal
          , HP.readOnly true
          , HP.disabled state.submitting
          , HP.title "Published deck URL"
          , ARIA.label "Published deck URL"
          , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
          ]
      , HH.span
          [ HP.classes [ B.inputGroupBtn ] ]
          [ HH.button
            [ HP.classes [ B.btn, B.btnDefault ]
            , HE.onClick (HE.input_ HandleCancel)
            , HP.ref copyButtonRef
            , HP.id_ "copy-button"
            , HP.type_ HP.ButtonButton
            , HP.disabled state.submitting
            ]
            [ I.copySm ]
          ]
      ]

  renderPublishFooter =
    HH.div
      [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
      $ fold
          [ guard state.noNetworkAccessToAdvancedError $> HH.div
              [ HP.classes [ B.alert, B.alertDanger ] ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , pure $ HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          , guard state.isLoggedIn $> 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.type_ HP.ButtonButton
              , HP.enabled $ state.canRevoke ∧ not state.submitting
              ]
              [ HH.text "Revoke" ]
          , pure $ HH.a
              (fold
                 [ pure $ HP.classes $ fold
                     [ pure B.btn
                     , pure B.btnPrimary
                     , guard state.submitting $> B.disabled
                     ]
                 , pure $ HP.target "_blank"
                 , guard state.submitting $> HP.href state.copyVal
                 ])
              [ HH.text "Preview" ]
          ]

  renderAccessMessage
    | state.isLoggedIn =
        [ HH.text
          $ "Anyone has access to the following link "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this link may be able to view this deck. "
            ⊕ "They may also be able to modify the link to view or edit any deck "
            ⊕ "in this workspace. Please see "
        , HH.a
            [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
            , HP.target  "_blank"
            ]
            [ HH.text "Securing SlamData Community Edition" ]
            , HH.text " for more information."
            ]

renderEmbedDialog ∷ State → H.ComponentHTML Query
renderEmbedDialog state =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-embed" ] ]
    [ HH.h4_ [ HH.text  "Embed deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.form
          [ HE.onSubmit (HE.input PreventDefault) ]
          [ HH.div
              [ HP.classes [ B.formGroup ] ]
                [ HH.textarea
                  [ HP.classes [ B.formControl, Rc.embedBox ]
                  , HP.readOnly true
                  , HP.value state.copyVal
                  , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                  ]
                , HH.button
                  [ HP.id_ "copy-button"
                  , HP.classes
                      $ [ B.btn, B.btnDefault, B.btnXs ]
                      ⊕ [ HH.ClassName "textarea-copy-button" ]
                  , HP.ref copyButtonRef
                  , HP.type_ HP.ButtonButton
                  , HP.disabled state.submitting
                  ]
                  [ I.copySm ]
                , HH.div [ HP.classes [ B.checkbox ] ]
                  [ (if state.isLoggedIn then HH.label_ else HH.p_)
                    $ ((guard state.isLoggedIn)
                       $> HH.input
                           [ HP.type_ HP.InputCheckbox
                           , HP.checked state.shouldGenerateToken
                           , HP.disabled state.submitting
                           , HE.onChecked (HE.input_ ToggleShouldGenerateToken)
                           ])
                    ⊕ message
                  ]
                , renderStyleURIInput state
                ]
          ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.noNetworkAccessToAdvancedError then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $> 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.type_ HP.ButtonButton
                , HP.enabled $ state.canRevoke ∧ not state.submitting
                ]
                [ HH.text "Revoke" ])

        ]
  where
  message
    | state.isLoggedIn =
        [ 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."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this script may be able to view this deck. "
            ⊕ "They may also be able to modify the script to view or edit any "
            ⊕ "deck in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target "_blank"]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

eval ∷ Query ~> DSL
eval (Init next) = next <$ do
  state ← H.get
  -- To know if user is authed
  mbAuthToken ← H.lift Auth.getIdToken
  case mbAuthToken of
    Nothing →
      H.modify _{ permToken = Nothing
                , canRevoke = false
                , isLoggedIn = false
                , loading = false
                }
    Just oidcToken → do
      H.modify _{isLoggedIn = true, canRevoke = true}
      tokensRes ← Q.tokenList
      H.modify _{loading = false}
      case tokensRes of
        Left _ → H.modify _{noNetworkAccessToAdvancedError = true}
        Right tokens →
          let
            tokenName =
              Just $ workspaceTokenName state.sharingInput.workspacePath oidcToken
            oldToken =
              F.find (\x → x.name ≡ tokenName) tokens
          in case oldToken of
            Just token → do
              H.modify _{ permToken = Just token
                        , noNetworkAccessToAdvancedError = false
                        }
            Nothing → do
              isURI ← (_ ≡ URI) <$> H.gets _.presentingAs
              when (state.shouldGenerateToken ∨ isURI) do
                H.modify _{submitting = true}
                createdRes ←
                  Q.createToken
                    tokenName
                    (sharingActions state.sharingInput View)
                H.modify _{submitting = false}
                H.modify case createdRes of
                  Left _ →  _{noNetworkAccessToAdvancedError = true}
                  Right newToken →
                     _{ noNetworkAccessToAdvancedError = false
                      , permToken = Just newToken
                      }
  updateCopyVal

eval (SelectElement ev next) = do
  st ← H.get
  H.liftEff do
    DOM.stopPropagation ev
    when (not st.submitting) do
      DOM.currentTarget ev
        # readHTMLElement ∘ toForeign
        # runExcept
        # traverse_ select
  pure next

eval (Revoke next) = do
  mbPermToken ← H.gets _.permToken
  for_ mbPermToken \tok → do
    H.modify _{submitting = true}
    deleteRes ← Q.deleteToken tok.id
    H.modify _{submitting = false}
    case deleteRes of
      Left _ → H.modify _{ noNetworkAccessToAdvancedError = true }
      Right _ → H.raise Dismiss
  pure next

eval (ToggleShouldGenerateToken next) = next <$ do
  state ← H.get
  case state.permToken of
    Nothing →
      unless state.shouldGenerateToken do
        mbOIDC ← H.lift Auth.getIdToken
        workspacePath ← H.gets (_.workspacePath ∘ _.sharingInput)
        for_ mbOIDC \oidc → do
          let
            actions = sharingActions state.sharingInput View
            tokenName = Just $ workspaceTokenName workspacePath oidc
          H.modify _{submitting = true}
          recreatedRes ← Q.createToken tokenName actions
          H.modify _{submitting = false}
          H.modify case recreatedRes of
            Left _ →
              _ { permToken = Nothing
                , noNetworkAccessToAdvancedError = true
                }
            Right token →
              _ { permToken = Just token
                , noNetworkAccessToAdvancedError = false
                }
    Just tok → do
      H.modify _{submitting = true}
      deleteRes ← Q.deleteToken tok.id
      H.modify _{submitting = false}
      H.modify case deleteRes of
        Left _ → _ { noNetworkAccessToAdvancedError = true }
        Right _ → _ { noNetworkAccessToAdvancedError = false, permToken = Nothing }
  H.modify _{shouldGenerateToken = not state.shouldGenerateToken}
  updateCopyVal

eval (ToggleStyleURIInput next) =
  H.modify toggleStyleURIInput $> next

eval (UpdateStyleURI styleURI next) =
  H.modify (_ { styleURIString = styleURI }) *> updateCopyVal $> next

eval (PreventDefault ev next) =
  H.liftEff (DOM.preventDefault ev) $> next

eval (HandleCancel next) =
  H.raise Dismiss $> next

workspaceTokenName ∷ UP.DirPath → OIDC.IdToken → QTA.TokenName
workspaceTokenName workspacePath idToken =
  let
    payload =
      hush $ Eff.runPure $ Exception.try $ OIDC.readPayload idToken
    email =
      fromMaybe "unknown user" $ unwrap <$> (OIDC.pluckEmail =<< payload)
    workspace =
      Pathy.printPath workspacePath
  in
    QTA.TokenName
      $ "publish permission granted by "
      ⊕ email
      ⊕ " for "
      ⊕ workspace

updateCopyVal ∷ DSL Unit
updateCopyVal = do
  locString ← H.liftEff getHref
  state ← H.get
  case renderCopyVal locString state of
    Right copyVal → do
      H.modify _{ copyVal = copyVal }
      clipboard ← H.gets _.clipboard
      case clipboard of
        Just c -> H.liftEff $ C.destroy c
        Nothing -> pure unit
      H.getHTMLElementRef copyButtonRef >>= traverse_ \htmlEl → do
        newClipboard ← H.liftEff $ C.fromElement (toElement htmlEl) (pure copyVal)
        H.modify _ { clipboard = Just newClipboard }
    Left error →
      pure unit

renderCopyVal ∷ String → State → Either String String
renderCopyVal locString state
  | state.presentingAs ≡ URI =
    URI.printURI <$> renderURI locString state
  | otherwise
      = Right $ Str.joinWith "\n"
          [ """<!-- This is the DOM element that the deck will be inserted into. -->"""
          , """<!-- You can change the width and height and use a stylesheet to apply styling. -->"""
          , """<iframe frameborder="0" width="100%" height="800" id=""" ⊕ quoted deckDOMId ⊕ """></iframe>"""
          , """"""
          , """<!-- To change a deck's variables after it has been inserted please use window.slamDataDeckUrl to create an new URI then update the deck iframe's src parameter. -->"""
          , """<script type="text/javascript">"""
          , """  window.slamDataDeckUrl = function (options) {"""
          , """    var queryParts = function () {"""
          , """      var parts = [];"""
          , """      if (options.echartTheme) {"""
          , """        parts.push("echartTheme=" + encodeURIComponent(options.echartTheme));"""
          , """      }"""
          , """      if (options.permissionTokens && options.permissionTokens.length) {"""
          , """        parts.push("permissionTokens=" + options.permissionTokens.join(","));"""
          , """      }"""
          , """      if (options.stylesheetUrls && options.stylesheetUrls.length) {"""
          , """        parts.push("stylesheets=" + options.stylesheetUrls.map(encodeURIComponent).join(","));"""
          , """      }"""
          , """      return parts;"""
          , """    };"""
          , """    var queryString = "?" + queryParts().join("&");"""
          , """    var varsParam = options.vars ? "/?vars=" + encodeURIComponent(JSON.stringify(options.vars)) : "";"""
          , """    return options.slamDataUrl + queryString + "#" + options.deckPath + options.deckId + "/view" + varsParam;"""
          , """  };"""
          , """</script>"""
          , """"""
          , """<!-- This is the script which performs SlamData deck insertion. -->"""
          , """<script type="text/javascript">"""
          , """  (function () {"""
          , """    var options = {"""
          , """      slamDataUrl: """ ⊕ quoted workspaceURI ⊕ ""","""
          , """      deckPath: """ ⊕ quoted deckPath ⊕ ""","""
          , """      deckId: """ ⊕ quoted deckId ⊕ ""","""
          , """      permissionTokens: [""" ⊕ maybe "" quoted token ⊕ """],"""
          , """      stylesheetUrls: [""" ⊕ maybe "" quoted stylesheet ⊕ """], // An array of custom stylesheet URIs."""
          , """      echartTheme: undefined,"""
          , """      vars: """ ⊕ renderVarMaps state.varMaps
          , """    };"""
          , """"""
          , """    var deckSelector = "iframe#sd-deck-" + options.deckId;"""
          , """    var deckElement = document.querySelector(deckSelector);"""
          , """"""
          , """    if (deckElement) {"""
          , """      deckElement.src = window.slamDataDeckUrl(options);"""
          , """    } else {"""
          , """      throw("SlamData: Couldn't locate " + deckSelector);"""
          , """    }"""
          , """  })();"""
          , """</script>"""
          ]
    where
    line = (_ ⊕ "\n")
    quoted s = "\"" ⊕ s ⊕ "\""
    workspaceURI =
      either id URI.printURI
        $ case hush $ URI.runParseURI locString of
          Nothing →
            Left "Bad SlamData config: workspacePath was not a valid absolute URI."
          Just loc →
            Right $ URI.URI
              (URIT.uriScheme loc)
              (URI.HierarchicalPart
                (HierarchicalPart.authority $ URIT.hierarchicalPart loc)
                (Right <$> filePathFromURI loc))
              Nothing
              Nothing
    deckId = DID.toString state.sharingInput.deckId
    deckDOMId = "sd-deck-" ⊕ deckId
    deckPath = UP.encodeURIPath (Pathy.printPath state.sharingInput.workspacePath)
    token = QTA.runTokenHash <<< _.secret <$> state.permToken
    stylesheet = parseStyleURI state.styleURIString $> state.styleURIString

renderVarMaps ∷ Map.Map CID.CardId Port.VarMap → String
renderVarMaps = indent <<< prettyJson <<< encodeJson <<< varMapsForURL
  where
  indent = RX.replace (unsafePartial fromRight $ RX.regex "(\n\r?)" RXF.global) "$1      "

renderURI ∷ String → State → Either String URI.URI
renderURI locationString state@{sharingInput, permToken, isLoggedIn, styleURIString} =
  case hush $ URI.runParseURI locationString of
    Nothing →
      Left "Bad SlamData config: workspacePath was not a valid absolute URI."
    Just loc →
      Right $ URI.URI
        (URIT.uriScheme loc)
        (URI.HierarchicalPart
          (HierarchicalPart.authority $ URIT.hierarchicalPart loc)
          (Right <$> filePathFromURI loc))
        (Just $ URI.Query query)
        (Just fragment)
  where
  fragment ∷ String
  fragment =
    Str.drop 1
      $ mkWorkspaceHash
          (deckPath' sharingInput.workspacePath sharingInput.deckId)
          (WA.Load AT.ReadOnly)
          SM.empty

  query ∷ List (Tuple String (Maybe String))
  query =
    (guard (isJust $ parseStyleURI styleURIString) $> (Tuple "stylesheets" $ Just styleURIString))
      ⊕ (guard isLoggedIn $> (Tuple "permissionTokens" token))

  token ∷ Maybe String
  token =
    QTA.runTokenHash ∘ _.secret <$> permToken

filePathFromURI ∷ URI → Maybe (Path Abs File Sandboxed)
filePathFromURI =
  hush
    <=< HierarchicalPart.uriPathAbs
    <<< URIT.hierarchicalPart


fix boxplot

fix boxplot

{-
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.Setups.Chart.Boxplot.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Boxplot.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (JArray, Json, decodeJson, (.?))
import Data.Array ((!!))
import Data.Array as A
import Data.List as L
import Data.List ((:))
import Data.Lens ((.~))
import Data.Map as M
import Data.Int as Int
import Data.Set as Set
import Data.NonEmpty as NE

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.CardType.ChartType (ChartType(Boxplot))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.Boxplot.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning (rectangularGrids, rectangularTitles, adjustRectangularPositions)
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquared as Sql

import Utils.Foldable (enumeratedFor_)

type Item =
  { dimension ∷ String
  , value ∷ Number
  , series ∷ Maybe String
  , parallel ∷ Maybe String
  }

type OnOneBoxplot =
  { name ∷ Maybe String
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , fontSize ∷ Maybe Int
  , series ∷ Array BoxplotSeries
  }

type BoxplotSeries =
  { name ∷ Maybe String
  , items ∷ String >> (Array Number × BoxplotItem)
  }

type BoxplotItem = Maybe
  { low ∷ Number
  , q1 ∷ Number
  , q2 ∷ Number
  , q3 ∷ Number
  , high ∷ Number
  }

boundIQR ∷ Maybe Number
boundIQR = Just 1.5

decodeItem ∷ Json → String ⊹ Item
decodeItem = decodeJson >=> \obj → do
  dimension ← map (fromMaybe "" ∘ Sem.maybeString) $ obj .? "dimension"
  value ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "value"
  series ← map Sem.maybeString $ obj .? "series"
  parallel ← map Sem.maybeString $ obj .? "parallel"
  pure { dimension
       , value
       , series
       , parallel
       }

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval m =
  BCE.chartSetupEval
    (\md fp →
      addOrderBy $ SCC.buildBasicSql buildProjections (const Nothing) md fp
    ) buildBoxplot m
  where
  fields ∷ ModelR → L.List Sql.Sql
  fields r =
    L.fromFoldable $ A.catMaybes
      [ r.parallel <#> SCC.jcursorSql
      , r.series <#> SCC.jcursorSql
      , Just $ r.dimension # SCC.jcursorSql
      ]
  orderBy ∷ Maybe (Sql.OrderBy Sql.Sql)
  orderBy = m >>= \r → case fields r of
    L.Nil → Nothing
    x : xs → Just $ Sql.OrderBy $ Tuple Sql.ASC <$> NE.NonEmpty x xs

  addOrderBy ∷ Sql.Sql → Sql.Sql
  addOrderBy =
    (Sql._Select ∘ Sql._orderBy .~ orderBy)
    ∘ (Sql._Select ∘ Sql._isDistinct .~ true)

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.value # SCC.jcursorPrj # Sql.as "value"
  , r.dimension # SCC.jcursorPrj # Sql.as "dimension"
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  , r.parallel # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "parallel"
  ]

buildBoxplot ∷ ModelR → Axes → Port.Port
buildBoxplot m axes =
  Port.ChartInstructions
    { options: boxplotOptions m axes ∘ buildBoxplotData
    , chartType: Boxplot
    }

buildBoxplotData ∷ JArray → Array OnOneBoxplot
buildBoxplotData =
  adjustRectangularPositions
  ∘ oneBoxplots
  ∘ foldMap (foldMap A.singleton ∘ decodeItem)
  where
  oneBoxplots ∷ Array Item → Array OnOneBoxplot
  oneBoxplots =
    BCE.groupOn _.parallel
      ⋙ map \(name × is) →
        { name
        , x: Nothing
        , y: Nothing
        , w: Nothing
        , h: Nothing
        , fontSize: Nothing
        , series: boxplotSeries is
        }

  boxplotSeries ∷ Array Item → Array BoxplotSeries
  boxplotSeries =
    BCE.groupOn _.series
      ⋙ map \(name × is) →
        { name
        , items: boxplotPoints is
        }

  boxplotPoints ∷ Array Item → String >> (Array Number × BoxplotItem)
  boxplotPoints =
    M.fromFoldable
    ∘ map (map analyzeBoxplot)
    ∘ BCE.groupOn _.dimension

  analyzeBoxplot ∷ Array Item → Array Number × BoxplotItem
  analyzeBoxplot is
    | A.null is = [] × Nothing
    | otherwise =
      let
        arr ∷ Array Number
        arr = map _.value is

        sortedArr ∷ Array Number
        sortedArr = A.sort arr

        quantile ∷ Array Number → Number → Maybe Number
        quantile inp p =
          let
            quantileItemIxNum =
              Int.toNumber (A.length inp - one) * p + one
            quantileItemIxInt =
              Int.floor quantileItemIxNum
            quantileItemBottom =
              inp !! (quantileItemIxInt - one)
            quantileItemTop =
              inp !! quantileItemIxInt
            ixesDiff =
              quantileItemIxNum - Int.toNumber quantileItemIxInt
          in if ixesDiff > 0.0
             then case quantileItemBottom × quantileItemTop of
               Just bItem × Just tItem → Just $ bItem + ixesDiff * (tItem - bItem)
               _ → Nothing
             else quantileItemBottom

        q1 = fromMaybe zero $ quantile sortedArr 0.25
        q2 = fromMaybe zero $ quantile sortedArr 0.5
        q3 = fromMaybe zero $ quantile sortedArr 0.75
        iqr = q3 - q1
        low = case boundIQR of
          Just b → q1 - b * iqr
          _ → fromMaybe zero $ A.head sortedArr
        high = case boundIQR of
          Just b → q3 + b * iqr
          _ → fromMaybe zero $ A.last sortedArr
        outliers ∷ Array Number
        outliers = A.filter (\x → x < low ∨ x > high) sortedArr
      in
       outliers × Just {low, q1, q2, q3, high}

boxplotOptions ∷ ModelR → Axes → Array OnOneBoxplot → DSL OptionI
boxplotOptions r axes boxplotData = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12

  rectangularTitles boxplotData
    $ maybe "" D.jcursorLabel r.parallel

  rectangularGrids boxplotData

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

  E.xAxes xAxes

  E.yAxes yAxes

  E.series series

  where
  serieNames ∷ Array String
  serieNames =
    A.fromFoldable
    $ flip foldMap boxplotData
    $ foldMap (Set.fromFoldable ∘ _.name)
    ∘ _.series

  series = enumeratedFor_ boxplotData \(ix × onOnePlot) → for_ onOnePlot.series \serie → do
    E.boxPlot $ boxplotSerie $ ix × serie
    E.scatter $ scatterSerie $ ix × serie

  boxplotSerie (ix × serie) = do
    for_ serie.name E.name

    E.xAxisIndex ix
    E.yAxisIndex ix

    E.itemStyle $ E.normal do
      E.borderWidth 2
      E.borderColor
        $ fromMaybe (C.rgba 0 0 0 0.5)
        $ serie.name
        >>= flip A.elemIndex serieNames
        >>= (colors !! _)

    E.tooltip $ E.formatterItem \item →
      CCT.tableRows
        [ D.jcursorLabel r.dimension × item.name
        , "Upper" × CCT.formatNumberValueIx 4 item
        , "Q3" × CCT.formatNumberValueIx 3 item
        , "Median" × CCT.formatNumberValueIx 2 item
        , "Q1" × CCT.formatNumberValueIx 1 item
        , "Lower" × CCT.formatNumberValueIx 0 item
        ]

    E.buildItems
      $ for_ xAxisLabels \key → case M.lookup key serie.items of
        Nothing → E.missingItem
        Just (_ × mbBP) → for_ mbBP \item → E.addItem $ E.buildValues do
          E.addValue item.low
          E.addValue item.q1
          E.addValue item.q2
          E.addValue item.q3
          E.addValue item.high

  scatterSerie (ix × serie) = do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix
    E.symbolSize
      if isNothing serie.name ∨ serie.name ≡ Just ""
        then 5
        else 0
    E.itemStyle $ E.normal
      $ E.color
      $ fromMaybe (C.rgba 0 0 0 0.5)
      $ serie.name
      >>= flip A.elemIndex serieNames
      >>= (colors !! _)

    E.tooltip $ E.formatterItem\param →
      param.name ⊕ "<br/>"
      ⊕ CCT.formatNumberValueIx 0 param

    E.buildItems
      $ enumeratedFor_ serie.items \(ox × (outliers × _)) →
          for_ outliers \outlier → E.addItem $ E.buildValues do
            E.addValue $ Int.toNumber ox
            E.addValue outlier

  grids ∷ Array (DSL ETP.GridI)
  grids = boxplotData <#> \{x, y, w, h} → do
    for_ x $ E.left ∘ ET.Percent
    for_ y $ E.top ∘ ET.Percent
    for_ w E.widthPct
    for_ h E.heightPct

  titles ∷ Array (DSL ETP.TitleI)
  titles = boxplotData <#> \{x, y, name, fontSize} → do
    for_ name E.text
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      for_ fontSize E.fontSize
    for_ x $ E.left ∘ ET.Percent
    for_ y $ E.top ∘ ET.Percent
    E.textCenter
    E.textMiddle

  xAxisLabels ∷ Array String
  xAxisLabels =
    A.fromFoldable
    $ flip foldMap boxplotData
    $ foldMap (Set.fromFoldable ∘ M.keys ∘ _.items)
    ∘ _.series

  xAxes = enumeratedFor_ boxplotData \(ix × _) → E.addXAxis do
    E.gridIndex ix
    E.axisType ET.Category
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden
    E.items $ map ET.strItem xAxisLabels

  yAxes = enumeratedFor_ boxplotData \(ix × _) → E.addYAxis do
    E.gridIndex ix
    E.axisType ET.Value
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden

{-
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.Setups.Chart.Boxplot.Eval
  ( eval
  , module SlamData.Workspace.Card.Setups.Chart.Boxplot.Model
  ) where

import SlamData.Prelude

import Color as C

import Data.Argonaut (JArray, Json, decodeJson, (.?))
import Data.Array ((!!))
import Data.Array as A
import Data.List as L
import Data.List ((:))
import Data.Lens ((.~))
import Data.Map as M
import Data.Int as Int
import Data.Set as Set
import Data.NonEmpty as NE

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.CardType.ChartType (ChartType(Boxplot))
import SlamData.Workspace.Card.Port as Port
import SlamData.Workspace.Card.Setups.Axis (Axes)
import SlamData.Workspace.Card.Setups.Chart.Boxplot.Model (Model, ModelR)
import SlamData.Workspace.Card.Setups.Chart.ColorScheme (colors)
import SlamData.Workspace.Card.Setups.Chart.Common as SCC
import SlamData.Workspace.Card.Setups.Chart.Common.Positioning (rectangularGrids, rectangularTitles, adjustRectangularPositions)
import SlamData.Workspace.Card.Setups.Chart.Common.Tooltip as CCT
import SlamData.Workspace.Card.Setups.Common.Eval (type (>>))
import SlamData.Workspace.Card.Setups.Common.Eval as BCE
import SlamData.Workspace.Card.Setups.Dimension as D
import SlamData.Workspace.Card.Setups.Semantics as Sem

import SqlSquared as Sql

import Utils.Foldable (enumeratedFor_)

type Item =
  { dimension ∷ String
  , value ∷ Number
  , series ∷ Maybe String
  , parallel ∷ Maybe String
  }

type OnOneBoxplot =
  { name ∷ Maybe String
  , w ∷ Maybe Number
  , h ∷ Maybe Number
  , x ∷ Maybe Number
  , y ∷ Maybe Number
  , fontSize ∷ Maybe Int
  , series ∷ Array BoxplotSeries
  }

type BoxplotSeries =
  { name ∷ Maybe String
  , items ∷ String >> (Array Number × BoxplotItem)
  }

type BoxplotItem = Maybe
  { low ∷ Number
  , q1 ∷ Number
  , q2 ∷ Number
  , q3 ∷ Number
  , high ∷ Number
  }

boundIQR ∷ Maybe Number
boundIQR = Just 1.5

decodeItem ∷ Json → String ⊹ Item
decodeItem = decodeJson >=> \obj → do
  dimension ← map (fromMaybe "" ∘ Sem.maybeString) $ obj .? "dimension"
  value ← map (fromMaybe zero ∘ Sem.maybeNumber) $ obj .? "value"
  series ← map Sem.maybeString $ obj .? "series"
  parallel ← map Sem.maybeString $ obj .? "parallel"
  pure { dimension
       , value
       , series
       , parallel
       }

eval ∷ ∀ m. BCE.ChartSetupEval ModelR m
eval m =
  BCE.chartSetupEval
    (\md fp →
      addOrderBy $ SCC.buildBasicSql buildProjections (const Nothing) md fp
    ) buildBoxplot m
  where
  fields ∷ ModelR → L.List Sql.Sql
  fields r =
    L.fromFoldable $ A.catMaybes
      [ r.parallel <#> SCC.jcursorSql
      , r.series <#> SCC.jcursorSql
      , Just $ r.dimension # SCC.jcursorSql
      ]
  orderBy ∷ Maybe (Sql.OrderBy Sql.Sql)
  orderBy = m >>= \r → case fields r of
    L.Nil → Nothing
    x : xs → Just $ Sql.OrderBy $ Tuple Sql.ASC <$> NE.NonEmpty x xs

  addOrderBy ∷ Sql.Sql → Sql.Sql
  addOrderBy =
    (Sql._Select ∘ Sql._orderBy .~ orderBy)
    ∘ (Sql._Select ∘ Sql._isDistinct .~ true)

buildProjections ∷ ModelR → L.List (Sql.Projection Sql.Sql)
buildProjections r = L.fromFoldable
  [ r.value # SCC.jcursorPrj # Sql.as "value"
  , r.dimension # SCC.jcursorPrj # Sql.as "dimension"
  , r.series # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "series"
  , r.parallel # maybe SCC.nullPrj SCC.jcursorPrj # Sql.as "parallel"
  ]

buildBoxplot ∷ ModelR → Axes → Port.Port
buildBoxplot m axes =
  Port.ChartInstructions
    { options: boxplotOptions m axes ∘ buildBoxplotData
    , chartType: Boxplot
    }

buildBoxplotData ∷ JArray → Array OnOneBoxplot
buildBoxplotData =
  adjustRectangularPositions
  ∘ oneBoxplots
  ∘ foldMap (foldMap A.singleton ∘ decodeItem)
  where
  oneBoxplots ∷ Array Item → Array OnOneBoxplot
  oneBoxplots =
    BCE.groupOn _.parallel
      ⋙ map \(name × is) →
        { name
        , x: Nothing
        , y: Nothing
        , w: Nothing
        , h: Nothing
        , fontSize: Nothing
        , series: boxplotSeries is
        }

  boxplotSeries ∷ Array Item → Array BoxplotSeries
  boxplotSeries =
    BCE.groupOn _.series
      ⋙ map \(name × is) →
        { name
        , items: boxplotPoints is
        }

  boxplotPoints ∷ Array Item → String >> (Array Number × BoxplotItem)
  boxplotPoints =
    M.fromFoldable
    ∘ map (map analyzeBoxplot)
    ∘ BCE.groupOn _.dimension

  analyzeBoxplot ∷ Array Item → Array Number × BoxplotItem
  analyzeBoxplot is
    | A.null is = [] × Nothing
    | otherwise =
      let
        arr ∷ Array Number
        arr = map _.value is

        sortedArr ∷ Array Number
        sortedArr = A.sort arr

        quantile ∷ Array Number → Number → Maybe Number
        quantile inp p = do
          let
            h = Int.toNumber (A.length inp - one) * p + one
            h' = Int.floor h
            v = arr !! (h' - one)
            v' = inp !! h'
            e = h - Int.toNumber h'
          if e > 0.0
            then case v × v' of
              Just jv × Just jv' → Just $ jv + e * (jv' - jv)
              _ → Nothing
            else v

        q1 = fromMaybe zero $ quantile sortedArr 0.25
        q2 = fromMaybe zero $ quantile sortedArr 0.5
        q3 = fromMaybe zero $ quantile sortedArr 0.75
        iqr = q3 - q1
        low = case boundIQR of
          Just b → q1 - b * iqr
          _ → fromMaybe zero $ A.head sortedArr
        high = case boundIQR of
          Just b → q3 + b * iqr
          _ → fromMaybe zero $ A.last sortedArr
        outliers ∷ Array Number
        outliers = A.filter (\x → x < low ∨ x > high) sortedArr
      in
       outliers × Just {low, q1, q2, q3, high}

boxplotOptions ∷ ModelR → Axes → Array OnOneBoxplot → DSL OptionI
boxplotOptions r axes boxplotData = do
  E.tooltip do
    E.triggerItem
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      E.fontSize 12

  rectangularTitles boxplotData
    $ maybe "" D.jcursorLabel r.parallel

  rectangularGrids boxplotData

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

  E.xAxes xAxes

  E.yAxes yAxes

  E.series series

  where
  serieNames ∷ Array String
  serieNames =
    A.fromFoldable
    $ flip foldMap boxplotData
    $ foldMap (Set.fromFoldable ∘ _.name)
    ∘ _.series

  series = enumeratedFor_ boxplotData \(ix × onOnePlot) → for_ onOnePlot.series \serie → do
    E.boxPlot $ boxplotSerie $ ix × serie
    E.scatter $ scatterSerie $ ix × serie

  boxplotSerie (ix × serie) = do
    for_ serie.name E.name

    E.xAxisIndex ix
    E.yAxisIndex ix

    E.itemStyle $ E.normal do
      E.borderWidth 2
      E.borderColor
        $ fromMaybe (C.rgba 0 0 0 0.5)
        $ serie.name
        >>= flip A.elemIndex serieNames
        >>= (colors !! _)

    E.tooltip $ E.formatterItem \item →
      CCT.tableRows
        [ D.jcursorLabel r.dimension × item.name
        , "Upper" × CCT.formatNumberValueIx 4 item
        , "Q3" × CCT.formatNumberValueIx 3 item
        , "Median" × CCT.formatNumberValueIx 2 item
        , "Q2" × CCT.formatNumberValueIx 1 item
        , "Lower" × CCT.formatNumberValueIx 0 item
        ]

    E.buildItems
      $ for_ xAxisLabels \key → case M.lookup key serie.items of
        Nothing → E.missingItem
        Just (_ × mbBP) → for_ mbBP \item → E.addItem $ E.buildValues do
          E.addValue item.low
          E.addValue item.q1
          E.addValue item.q2
          E.addValue item.q3
          E.addValue item.high

  scatterSerie (ix × serie) = do
    for_ serie.name E.name
    E.xAxisIndex ix
    E.yAxisIndex ix
    E.symbolSize
      if isNothing serie.name ∨ serie.name ≡ Just ""
        then 5
        else 0
    E.itemStyle $ E.normal
      $ E.color
      $ fromMaybe (C.rgba 0 0 0 0.5)
      $ serie.name
      >>= flip A.elemIndex serieNames
      >>= (colors !! _)

    E.tooltip $ E.formatterItem\param →
      param.name ⊕ "<br/>"
      ⊕ CCT.formatNumberValueIx 0 param

    E.buildItems
      $ enumeratedFor_ serie.items \(ox × (outliers × _)) →
          for_ outliers \outlier → E.addItem $ E.buildValues do
            E.addValue $ Int.toNumber ox
            E.addValue outlier

  grids ∷ Array (DSL ETP.GridI)
  grids = boxplotData <#> \{x, y, w, h} → do
    for_ x $ E.left ∘ ET.Percent
    for_ y $ E.top ∘ ET.Percent
    for_ w E.widthPct
    for_ h E.heightPct

  titles ∷ Array (DSL ETP.TitleI)
  titles = boxplotData <#> \{x, y, name, fontSize} → do
    for_ name E.text
    E.textStyle do
      E.fontFamily "Ubuntu, sans"
      for_ fontSize E.fontSize
    for_ x $ E.left ∘ ET.Percent
    for_ y $ E.top ∘ ET.Percent
    E.textCenter
    E.textMiddle

  xAxisLabels ∷ Array String
  xAxisLabels =
    A.fromFoldable
    $ flip foldMap boxplotData
    $ foldMap (Set.fromFoldable ∘ M.keys ∘ _.items)
    ∘ _.series

  xAxes = enumeratedFor_ boxplotData \(ix × _) → E.addXAxis do
    E.gridIndex ix
    E.axisType ET.Category
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden
    E.items $ map ET.strItem xAxisLabels

  yAxes = enumeratedFor_ boxplotData \(ix × _) → E.addYAxis do
    E.gridIndex ix
    E.axisType ET.Value
    E.axisLabel do
      E.textStyle do
        E.fontFamily "Ubuntu, sans"
    E.axisLine $ E.lineStyle do
      E.width 1
    E.splitLine $ E.lineStyle do
      E.width 1
    E.splitArea E.hidden


Semigroup instance for [a]

Semigroup instance for [a]

module Data.Array where

import Prelude
import Data.Maybe

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _ = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _ = Nothing

map :: forall a b. (a -> b) -> [a] -> [b]
map _ [] = []
map f (x:xs) = f x : map f xs

foreign import length
  "function length(xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import indexOf
  "function indexOf(l) {\
  \  return function (e) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import lastIndexOf
  "function lastIndexOf(l) {\
  \  return function (e) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import concat
  "function concat(l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import joinS
  "function joinS(l) {\
  \  return l.join();\
  \}" :: [String] -> String

foreign import joinWith
  "function joinWith(l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String

foreign import push
  "function push(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

foreign import reverse
  "function reverse(l) {\
  \  var l1 = l.slice();\
  \  l1.reverse(); \
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import shift
  "function shift(l) {\
  \  var l1 = l.slice();\
  \  l1.shift();\
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import slice
  "function slice(s) {\
  \  return function(e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import sort
  "function sort(l) {\
  \  var l1 = l.slice();\
  \  l1.sort();\
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import insertAt
  "function insertAt(index) {\
  \  return function(a) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt(index) {\
  \  return function(n) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt(index) {\
  \  return function(a) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1[index] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

infixr 6 :

(:) :: forall a. a -> [a] -> [a]
(:) a = concat [a]

singleton :: forall a. a -> [a]
singleton a = [a]

concatMap :: forall a b. (a -> [b]) -> [a] -> [b]
concatMap _ [] = []
concatMap f (a:as) = f a `concat` concatMap f as

filter :: forall a. (a -> Boolean) -> [a] -> [a]
filter _ [] = []
filter p (x:xs) | p x = x : filter p xs
filter p (_:xs) = filter p xs

isEmpty :: forall a. [a] -> Boolean
isEmpty [] = true
isEmpty _ = false

range :: Number -> Number -> [Number]
range lo hi | lo > hi = []
range lo hi = lo : range (lo + 1) hi

zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
zipWith _ _ _ = []

drop :: forall a. Number -> [a] -> [a]
drop 0 xs = xs
drop _ [] = []
drop n (x:xs) = drop (n - 1) xs

take :: forall a. Number -> [a] -> [a]
take 0 _ = []
take _ [] = []
take n (x:xs) = x : take (n - 1) xs

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

instance showArray :: (Show a) => Show [a] where
  show xs = "[" ++ joinWith (map show xs) "," ++ "]"

instance eqArray :: (Eq a) => Eq [a] where
  (==) [] [] = true
  (==) (x:xs) (y:ys) = x == y && xs == ys
  (==) _ _ = false
  (/=) xs ys = not (xs == ys)

instance semigroupArray :: Semigroup [a] where
  (<>) = concat

instance monadArray :: Monad [] where
  return = singleton
  (>>=) = flip concatMap

instance functorArray :: Functor [] where
  (<$>) = map

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = concat

module Data.Array where

import Prelude
import Data.Maybe

head :: forall a. [a] -> Maybe a
head (x : _) = Just x
head _ = Nothing

tail :: forall a. [a] -> Maybe [a]
tail (_ : xs) = Just xs
tail _ = Nothing

map :: forall a b. (a -> b) -> [a] -> [b]
map _ [] = []
map f (x:xs) = f x : map f xs

foreign import length
  "function length(xs) {\
  \  return xs.length;\
  \}" :: forall a. [a] -> Number

foreign import indexOf
  "function indexOf(l) {\
  \  return function (e) {\
  \    return l.indexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import lastIndexOf
  "function lastIndexOf(l) {\
  \  return function (e) {\
  \    return l.lastIndexOf(e);\
  \  };\
  \}" :: forall a. [a] -> a -> Number

foreign import concat
  "function concat(l1) {\
  \  return function (l2) {\
  \    return l1.concat(l2);\
  \  };\
  \}" :: forall a. [a] -> [a] -> [a]

foreign import joinS
  "function joinS(l) {\
  \  return l.join();\
  \}" :: [String] -> String

foreign import joinWith
  "function joinWith(l) {\
  \  return function (s) {\
  \    return l.join(s);\
  \  };\
  \}" :: [String] -> String -> String

foreign import push
  "function push(l) {\
  \  return function (e) {\
  \    var l1 = l.slice();\
  \    l1.push(e); \
  \    return l1;\
  \  };\
  \}" :: forall a. [a] -> a -> [a]

foreign import reverse
  "function reverse(l) {\
  \  var l1 = l.slice();\
  \  l1.reverse(); \
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import shift
  "function shift(l) {\
  \  var l1 = l.slice();\
  \  l1.shift();\
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import slice
  "function slice(s) {\
  \  return function(e) {\
  \    return function (l) {\
  \      return l.slice(s, e);\
  \    };\
  \  };\
  \}" :: forall a. Number -> Number -> [a] -> [a]

foreign import sort
  "function sort(l) {\
  \  var l1 = l.slice();\
  \  l1.sort();\
  \  return l1;\
  \}" :: forall a. [a] -> [a]

foreign import insertAt
  "function insertAt(index) {\
  \  return function(a) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, 0, a);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

foreign import deleteAt
  "function deleteAt(index) {\
  \  return function(n) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1.splice(index, n);\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> Number -> [a] -> [a]

foreign import updateAt
  "function updateAt(index) {\
  \  return function(a) {\
  \    return function(l) {\
  \      var l1 = l.slice();\
  \      l1[index] = a;\
  \      return l1;\
  \    }; \
  \  };\
  \}":: forall a. Number -> a -> [a] -> [a]

infixr 6 :

(:) :: forall a. a -> [a] -> [a]
(:) a = concat [a]

singleton :: forall a. a -> [a]
singleton a = [a]

concatMap :: forall a b. (a -> [b]) -> [a] -> [b]
concatMap _ [] = []
concatMap f (a:as) = f a `concat` concatMap f as

filter :: forall a. (a -> Boolean) -> [a] -> [a]
filter _ [] = []
filter p (x:xs) | p x = x : filter p xs
filter p (_:xs) = filter p xs

isEmpty :: forall a. [a] -> Boolean
isEmpty [] = true
isEmpty _ = false

range :: Number -> Number -> [Number]
range lo hi | lo > hi = []
range lo hi = lo : range (lo + 1) hi

zipWith :: forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith f (a:as) (b:bs) = f a b : zipWith f as bs
zipWith _ _ _ = []

drop :: forall a. Number -> [a] -> [a]
drop 0 xs = xs
drop _ [] = []
drop n (x:xs) = drop (n - 1) xs

take :: forall a. Number -> [a] -> [a]
take 0 _ = []
take _ [] = []
take n (x:xs) = x : take (n - 1) xs

nub :: forall a. (Eq a) => [a] -> [a]
nub = nubBy (==)

nubBy :: forall a. (a -> a -> Boolean) -> [a] -> [a]
nubBy _ [] = []
nubBy (==) (x:xs) = x : nubBy (==) (filter (\y -> not (x == y)) xs)

instance showArray :: (Show a) => Show [a] where
  show xs = "[" ++ joinWith (map show xs) "," ++ "]"

instance eqArray :: (Eq a) => Eq [a] where
  (==) [] [] = true
  (==) (x:xs) (y:ys) = x == y && xs == ys
  (==) _ _ = false
  (/=) xs ys = not (xs == ys)

instance monadArray :: Monad [] where
  return = singleton
  (>>=) = flip concatMap

instance functorArray :: Functor [] where
  (<$>) = map

instance alternativeArray :: Alternative [] where
  empty = []
  (<|>) = concat


Remove mempty' workaround

Remove mempty' workaround

module Control.Monad.Writer.Trans where

import Prelude
import Control.Monad.Trans
import Data.Monoid

type WriterData a w = { value :: a, output :: w }

data WriterT w m a = WriterT (m (WriterData a w))

runWriterT :: forall w m a. WriterT w m a -> m (WriterData a w)
runWriterT (WriterT x) = x

mapWriterT :: forall w1 w2 m1 m2 a b. (m1 (WriterData a w1) -> m2 (WriterData b w2)) -> WriterT w1 m1 a -> WriterT w2 m2 b
mapWriterT f m = WriterT $ f (runWriterT m)

instance monadWriterT :: (Monoid w, Monad m) => Monad (WriterT w m) where
  return a = WriterT $ return { value: a, output: mempty }
  (>>=) m k  = WriterT $ do
    { value = a, output = w } <- runWriterT m
    { value = b, output = w' } <- runWriterT (k a)
    return { value: b, output: w <> w' }

instance appWriterT :: (Monoid w, Applicative m) => Applicative (WriterT w m) where
  pure a = WriterT $ pure { value: a, output: mempty }
  (<*>) f v = WriterT $
    let k x y = { value: x.value y.value, output: x.output <> y.output }
    in k <$> (runWriterT f) <*> (runWriterT v)

instance altWriterT :: (Monoid w, Alternative m) => Alternative (WriterT w m) where
  empty = WriterT empty
  (<|>) m n = WriterT $ runWriterT m <|> runWriterT n

instance functorWriterT :: (Functor m) => Functor (WriterT w m) where
  (<$>) f = mapWriterT $ (<$>) \x -> { value: f x.value, output: x.output }

instance monadTransWriterT :: (Monoid w) => MonadTrans (WriterT w) where
  lift m = WriterT $ do
    a <- m
    return { value: a, output: mempty }

module Control.Monad.Writer.Trans where

import Prelude
import Control.Monad.Trans
import Data.Monoid

type WriterData a w = { value :: a, output :: w }

data WriterT w m a = WriterT (m (WriterData a w))

runWriterT :: forall w m a. WriterT w m a -> m (WriterData a w)
runWriterT (WriterT x) = x

mapWriterT :: forall w1 w2 m1 m2 a b. (m1 (WriterData a w1) -> m2 (WriterData b w2)) -> WriterT w1 m1 a -> WriterT w2 m2 b
mapWriterT f m = WriterT $ f (runWriterT m)

-- This is needed due to a limitation in the type checker that prevents
-- unification of constrained types
mempty' :: forall w. (Monoid w) => {} -> w
mempty' _ = mempty

instance monadWriterT :: (Monoid w, Monad m) => Monad (WriterT w m) where
  return a = WriterT $ return { value: a, output: mempty' {} }
  (>>=) m k  = WriterT $ do
    { value = a, output = w } <- runWriterT m
    { value = b, output = w' } <- runWriterT (k a)
    return { value: b, output: w <> w' }

instance appWriterT :: (Monoid w, Applicative m) => Applicative (WriterT w m) where
  pure a = WriterT $ pure { value: a, output: mempty' {} }
  (<*>) f v = WriterT $
    let k x y = { value: x.value y.value, output: x.output <> y.output }
    in k <$> (runWriterT f) <*> (runWriterT v)

instance altWriterT :: (Monoid w, Alternative m) => Alternative (WriterT w m) where
  empty = WriterT empty
  (<|>) m n = WriterT $ runWriterT m <|> runWriterT n

instance functorWriterT :: (Functor m) => Functor (WriterT w m) where
  (<$>) f = mapWriterT $ (<$>) \x -> { value: f x.value, output: x.output }

instance monadTransWriterT :: (Monoid w) => MonadTrans (WriterT w) where
  lift m = WriterT $ do
    a <- m
    return { value: a, output: mempty' {} }


Rewrite TrackSource

Rewrite TrackSource

module Genetics.Browser.Events.TrackSource where
       -- ( TrackSource
       -- , emptyTrackSource
       -- , mkTrackSource
       -- , appendTrackSources
       -- , applyTrackSource
       -- ) where

import Prelude

import Data.Argonaut (JCursor(JField), Json, JsonPrim, cursorGet, cursorSet, jsonEmptyObject, primToJson)
import Data.Argonaut as Json
import Data.Foldable (foldMap, foldr)
import Data.List (List, singleton)
import Data.Maybe (Maybe(..))
import Data.Monoid (class Monoid, mempty)
import Data.Newtype (class Newtype)
import Data.StrMap (StrMap)
import Data.StrMap as StrMap
import Data.Traversable (traverse)
import Data.Tuple (Tuple(..))
import Genetics.Browser.Events.Types (Event)

{-
TrackSources are defined with two parts:
1. A JSON structure defining what the event to be produced looks like,
where the leaves are all singleton maps with Strings denoting the types of the respective leaf

2. A JSON structure defining what the raw event looks like,
and how to map it to the produced event.

-}

-- TODO keep track of which event names have been used
newtype TrackSource a = TrackSource (List (Json -> Maybe a))

derive instance functorTrackSource :: Functor TrackSource
derive instance newtypeTrackSource :: Newtype (TrackSource a) _

instance semigroupTrackSource :: Semigroup (TrackSource a) where
  append (TrackSource s1) (TrackSource s2) = TrackSource (s1 <> s2)

instance monoidTrackSource :: Monoid (TrackSource a) where
  mempty = TrackSource mempty

emptyTrackSource :: ∀ a. TrackSource a
emptyTrackSource = TrackSource mempty

type SourceConfig = { eventName :: String
                    , eventTemplate :: Json
                    , rawTemplate :: Json
                    }

type ValueCursor = { cursor :: JCursor
                   , name :: String
                   , vType :: String
                   }

type RawCursor = { cursor :: JCursor
                 , name :: String
                 }

parseTemplatePath :: Tuple JCursor JsonPrim
                  -> Maybe ValueCursor
parseTemplatePath (Tuple cursor t) = do
  vType <- Json.toString $ primToJson t
  name <- case Json.insideOut cursor of
    JField s _ -> Just s
    _          -> Nothing
  pure { cursor, name, vType }

parseTemplateConfig :: Json -> Maybe (List ValueCursor)
parseTemplateConfig = traverse parseTemplatePath <<< Json.toPrims

parseRawTemplatePath :: Tuple JCursor JsonPrim
                     -> Maybe RawCursor
parseRawTemplatePath (Tuple cursor t) = do
  name <- Json.toString $ primToJson t
  pure { cursor, name }

parseRawTemplateConfig :: Json
                       -> Maybe (List RawCursor)
parseRawTemplateConfig = traverse parseRawTemplatePath <<< Json.toPrims

fillTemplate :: List ValueCursor -> StrMap Json -> Maybe Json
fillTemplate t vs = foldr f (Just jsonEmptyObject) t
  where f :: ValueCursor -> Maybe Json -> Maybe Json
        f _ Nothing  = Nothing
        f ec (Just j) = do
          val <- StrMap.lookup ec.name vs
          cursorSet ec.cursor val j

parseRawEvent :: List RawCursor -> Json -> Maybe (StrMap Json)
parseRawEvent paths json = do
  vals <- traverse (\path -> map (Tuple path.name) (cursorGet path.cursor json)) paths
  pure $ StrMap.fromFoldable vals

makeTrackSource :: SourceConfig -> Maybe (TrackSource Event)
makeTrackSource sc = do
  -- parse the templates
  eventTemplate <- parseTemplateConfig sc.eventTemplate
  rawTemplate <- parseRawTemplateConfig sc.rawTemplate
  let parseRaw = parseRawEvent rawTemplate
      fillEvent = fillTemplate eventTemplate

  pure $ TrackSource $ singleton $ \rawEvent -> do
    vals <- parseRaw rawEvent
    evData <- fillEvent vals
    pure $ { name: sc.eventName, evData }

makeTrackSources :: List SourceConfig -> Maybe (TrackSource Event)
makeTrackSources scs = foldMap makeTrackSource scs

module Genetics.Browser.Events.TrackSource
       ( TrackSource
       , emptyTrackSource
       , mkTrackSource
       , appendTrackSources
       , applyTrackSource
       ) where

import Prelude

import Data.Argonaut (Json)
import Data.List (List, mapMaybe, singleton)
import Data.Maybe (Maybe)
import Data.Monoid (mempty)
import Genetics.Browser.Events.Types (Event)

newtype TrackSource = TrackSource (List (Json -> Maybe Event))

emptyTrackSource :: TrackSource
emptyTrackSource = TrackSource mempty

mkTrackSource :: String
              -> (Json -> Maybe Json)
              -> TrackSource
mkTrackSource l f = TrackSource $
                    singleton $ map { eventType: l, event: _ } <<< f

appendTrackSources :: TrackSource
                   -> TrackSource
                   -> TrackSource
appendTrackSources (TrackSource s1) (TrackSource s2) = TrackSource (s1 <> s2)

applyTrackSource :: TrackSource
                 -> Json
                 -> List Event
applyTrackSource (TrackSource h) json = mapMaybe (\f -> f json) h


Internal cleanup

Internal cleanup

module OutWatch.Helpers.Helpers where

import Control.Apply ((<*>))
import Control.Monad.Eff (Eff)
import Data.Foldable (foldl, sequence_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe)
import Data.Tuple (Tuple(..))
import Prelude (Unit, (<$>))
import RxJS.Observable (Observable, combineLatest, just)

forEachMaybe :: forall e. Maybe (Eff e Unit) -> Eff e Unit
forEachMaybe m = sequence_ m

tupleMaybes :: forall a b. Maybe a -> Maybe b -> Maybe (Tuple a b)
tupleMaybes ma mb = Tuple <$> ma <*> mb

combineLatestAll :: forall a. List (Observable a) -> Observable (List a)
combineLatestAll list = foldl (\acc cur -> combineLatest (\x y -> y : x) acc cur) (just Nil) list

module OutWatch.Helpers.Helpers where

import Control.Apply ((<*>))
import Control.Monad.Eff (Eff)
import Data.Foldable (foldl, traverse_)
import Data.List (List(..), (:))
import Data.Maybe (Maybe(..))
import Data.Tuple (Tuple(..))
import Prelude (Unit, id, map, (#))
import RxJS.Observable (Observable, combineLatest, just)

maybeToArr :: forall a. Maybe a -> Array a
maybeToArr m = case m of
  (Just val) -> [val]
  Nothing -> []

forEachMaybe :: forall e. Maybe (Eff e Unit) -> Eff e Unit
forEachMaybe m = traverse_ id (maybeToArr m)

tupleMaybes :: forall a b. Maybe a -> Maybe b -> Maybe (Tuple a b)
tupleMaybes ma mb = (ma # map Tuple) <*> mb

combineLatestAll :: forall a. List (Observable a) -> Observable (List a)
combineLatestAll list = foldl (\acc cur -> combineLatest (\x y -> y : x) acc cur) (just Nil) list