[CSE-68] Update `common` views for using `pux 10.x`

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , emptyView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude

import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))

import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))

import Pos.Explorer.Web.ClientTypes (CCoin, CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)

import Pux.DOM.Events (onBlur, onChange, onFocus, onKey, KeyboardEvent, MouseEvent, Target, onClick) as P
import Pux.DOM.HTML (Html) as P

import Text.Smolder.HTML (div, p, span, input, option, select)
import Text.Smolder.HTML.Attributes (className, href, value, disabled, type', min, max, defaultValue)
import Text.Smolder.Markup (text, (#!), (!), (!?))

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin "0"
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.Html Action
txHeaderView lang (TxHeaderViewProps props) =
    div ! className "transaction-header" $ do
        div ! className "hash-container"
            $ a ! href (toUrl txRoute)
                #! onClick (toUrl txRoute)
                ! className "hash"
                $ text (props ^. (txhHash <<< _CTxId <<< _CHash))
        div ! className "date"
            $ text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
        txAmountView (props ^. txhAmount) lang
    where
        txRoute = Tx $ props ^. txhHash

emptyTxHeaderView :: P.Html Action
emptyTxHeaderView =
    div ! className "transaction-header"

txAmountView :: CCoin -> Language -> P.Html Action
txAmountView coin lang =
    div ! className "amount-container"
        $ div ! className "amount bg-ada"
              $ text (formatADA coin lang)

-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin "0"
        }

txBodyView :: Language -> TxBodyViewProps -> P.Html Action
txBodyView lang (TxBodyViewProps props) =
    div ! className "transaction-body" $ do
        div ! className "from-hash-container"
            $ map txFromView (props ^. txbInputs)
        div ! className "to-hash-container bg-transaction-arrow"
            $ div ! className "to-hash-wrapper"
                  $ map txToView (props ^. txbOutputs)
        div ! className "amounts-container"
            $ map (txBodyAmountView lang) (props ^. txbOutputs)
        txAmountView (props ^. txbAmount) lang

emptyTxBodyView :: P.Html Action
emptyTxBodyView =
    div ! className "transaction-body"

txFromView :: Tuple CAddress CCoin -> P.Html Action
txFromView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    a ! href (toUrl addressRoute)
      #! onClick addressRoute
      ! className "from-hash"
      $ text cAddress

txToView :: Tuple CAddress CCoin -> P.Html Action
txToView (Tuple (CAddress cAddress) _) =
    let addressRoute = Address $ mkCAddress cAddress in
    a ! href (toUrl addressRoute)
      #! onClick (toUrl addressRoute)
      ! className "to-hash"
      $ text cAddress

txBodyAmountView :: Language -> Tuple CAddress CCoin -> P.Html Action
txBodyAmountView lang (Tuple _ coin) =
    div ! className "amount-wrapper"
        $ span ! className "plain-amount bg-ada-dark"
               $ text (formatADA coin lang)

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: PageNumber
    , minPage :: PageNumber
    , maxPage :: PageNumber
    , editable :: Boolean
    , changePageAction :: (PageNumber -> Action)
    , editableAction :: (P.Target -> Boolean -> Action)
    , invalidPageAction :: (P.Target -> Action)
    , disabled :: Boolean
    }

txPaginationView :: PaginationViewProps -> P.Html Action
txPaginationView props =
    div ! className "transaction-pagination"
        $ paginationView props

paginationView :: PaginationViewProps -> P.Html Action
paginationView props =
    div ! className "pagination-wrapper" $ do
        div ! className "pagination"
            $ div ! className "pagination__container" $ do
                  div ! className ("btn-page" <> disablePrevBtnClazz)
                      #! onClick prevClickHandler
                      $ div ! className "icon bg-triangle-left"
                  input ! className "page-number"
                        ! disabled $ props.maxPage == props.minPage
                        ! min <<< show $ unwrap props.minPage
                        ! max <<< show $ unwrap props.maxPage
                        !? props.editable value (show $ unwrap props.currentPage)
                        #! P.onFocus (\event -> props.editableAction (_.target event)) true
                        #! P.onBlur (\event -> props.editableAction (_.target event)) false
                        #! P.onKey "enter" onEnterHandler
                  p ! className "label"
                    $ text props.label
                  input ! className "page-number"
                        ! disabled true
                        ! type' "search"
                        ! value (show $ unwrap props.maxPage)
                  div ! className ("btn-page" <> disableNextBtnClazz)
                      #! P.onClick nextClickHandler
                      $ div ! className "icon bg-triangle-right"
        div ! className ("pagination-cover" <> if props.disabled then " show" else "")
            #! onClick (const NoOp) -- add click handler to hide clickes from children
          where
            disablePrevBtnClazz = if props.currentPage == props.minPage then " disabled" else ""
            disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
            nextClickHandler :: P.MouseEvent -> Action
            nextClickHandler event =
                if props.currentPage < props.maxPage then
                props.changePageAction <<< PageNumber $ (unwrap props.currentPage) + 1
                else
                NoOp

            prevClickHandler :: P.MouseEvent -> Action
            prevClickHandler _ =
                if props.currentPage > props.minPage && not props.disabled then
                props.changePageAction <<< PageNumber $ (unwrap props.currentPage) - 1
                else
                NoOp

            onEnterHandler :: P.KeyboardEvent -> Action
            onEnterHandler event =
                if props.disabled
                then NoOp
                else
                    if page >= props.minPage && page <= props.maxPage
                    then props.changePageAction page
                    else props.invalidPageAction target
                    where
                        target = _.target event
                        page = PageNumber <<< fromMaybe (unwrap props.currentPage) <<< fromString $ _.value target

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

txEmptyContentView :: String -> P.Html Action
txEmptyContentView message = P.div
                        [ P.className "tx-empty__container" ]
                        [ P.text message ]

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.Html Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route -> P.link (toUrl route)
                              Nothing -> P.div
    in
    div ! className "logo__container"
        $ div ! className "logo__wrapper"
              $ logoContentTag ! className "logo__img bg-logo"
                               ! href (toUrl Dashboard)

logoView :: P.Html Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.Html Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

-- currency

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.Html Action
langView state =
  select ! className "lang__select bg-arrow-up"
         ! defaultValue <<< show $ state ^. lang
         #! onChange $ SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< _.value <<< _.target
         $ map (langItemView state) langItems

langItemView :: State -> Language -> P.Html Action
langItemView state lang' =
  let selected = (show lang') == (show $ state ^. lang) in
  option ! value $ show lang'
         ! className $ if selected then "selected" else ""
         $ text (show lang')

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

-- | Helper to add currency classes
currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> "ada bg-ada-dark"
      Just USD -> "usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.Html Action
placeholderView label =
    div ! className "explorer-dashboard__content"
        $ text label

emptyView :: P.Html Action
emptyView = div

module Explorer.View.Common (
    placeholderView
    , txHeaderView
    , txBodyView
    , emptyTxBodyView
    , emptyTxHeaderView
    , emptyView
    , getMaxPaginationNumber
    , mkTxHeaderViewProps
    , class TxHeaderViewPropsFactory
    , mkTxBodyViewProps
    , class TxBodyViewPropsFactory
    , currencyCSSClass
    , paginationView
    , txPaginationView
    , EmptyViewProps
    , mkEmptyViewProps
    , txEmptyContentView
    , noData
    , logoView
    , clickableLogoView
    , langView
    ) where

import Prelude
import Data.Int (ceil, fromString, toNumber)
import Data.Lens ((^.))
import Data.Maybe (Maybe(..), fromMaybe)
import Data.Newtype (unwrap)
import Data.Tuple (Tuple(..))
import Explorer.I18n.Lang (Language(..), readLanguage, translate)
import Explorer.I18n.Lenses (common, cDateFormat) as I18nL
import Explorer.Lenses.State (lang)
import Explorer.Routes (Route(..), toUrl)
import Explorer.State (initialState)
import Explorer.Types.Actions (Action(..))
import Explorer.Types.State (CCurrency(..), PageNumber(..), State)
import Explorer.Util.Factory (mkCAddress, mkCTxId, mkCoin)
import Explorer.Util.String (formatADA)
import Explorer.Util.Time (prettyDate)
import Explorer.View.Lenses (txbAmount, txbInputs, txbOutputs, txhAmount, txhHash, txhTimeIssued)
import Exporer.View.Types (TxBodyViewProps(..), TxHeaderViewProps(..))
import Pos.Explorer.Web.ClientTypes (CCoin, CAddress(..), CTxBrief(..), CTxEntry(..), CTxSummary(..))
import Pos.Explorer.Web.Lenses.ClientTypes (_CHash, _CTxId, ctbId, ctbInputs, ctbOutputs, ctbOutputSum, ctbTimeIssued, cteId, cteTimeIssued, ctsBlockTimeIssued, ctsId, ctsInputs, ctsOutputs, ctsTotalOutput)
import Pux.Html (Html, text, div, p, span, input, option, select) as P
import Pux.Html.Attributes (className, href, value, disabled, type_, min, max, defaultValue) as P
import Pux.DOM.Events (onBlur, onChange, onFocus, onKey, KeyboardEvent, MouseEvent, Target, onClick) as P
import Pux.Router (link) as P

-- -----------------
-- tx header
-- -----------------

-- | Factory to create TxHeaderViewProps by a given type
class TxHeaderViewPropsFactory a where
    mkTxHeaderViewProps :: a -> TxHeaderViewProps

-- | Creates a TxHeaderViewProps by a given CTxEntry
instance cTxEntryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxEntry where
    mkTxHeaderViewProps (CTxEntry entry) = TxHeaderViewProps
        { txhHash: entry ^. cteId
        , txhTimeIssued: Just $ entry ^. cteTimeIssued
        , txhAmount: entry . cteAmount
        }

-- | Creates a TxHeaderViewProps by a given CTxBrief
instance cTxBriefTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxBrief where
    mkTxHeaderViewProps (CTxBrief txBrief) = TxHeaderViewProps
        { txhHash: txBrief ^. ctbId
        , txhTimeIssued: Just $ txBrief ^. ctbTimeIssued
        , txhAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxHeaderViewProps by a given CTxSummary
instance cTxSummaryTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory CTxSummary where
    mkTxHeaderViewProps (CTxSummary txSummary) = TxHeaderViewProps
        { txhHash: txSummary ^. ctsId
        , txhTimeIssued: txSummary ^. ctsBlockTimeIssued
        , txhAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxHeaderViewProps by a given EmptyViewProps
instance emtpyTxHeaderViewPropsFactory :: TxHeaderViewPropsFactory EmptyViewProps where
    mkTxHeaderViewProps _ = TxHeaderViewProps
        { txhHash: mkCTxId noData
        , txhTimeIssued: Nothing
        , txhAmount: mkCoin "0"
        }

txHeaderView :: Language -> TxHeaderViewProps -> P.Html Action
txHeaderView lang (TxHeaderViewProps props) =
    P.div
          [ P.className "transaction-header"]
          [ P.div
              [ P.className "hash-container" ]
              [ P.link (toUrl <<< Tx $ props ^. txhHash)
                [ P.className "hash"]
                [ P.text $ props ^. (txhHash <<< _CTxId <<< _CHash) ]
              ]
          , P.div
              [ P.className "date"]
              [ P.text $ case props ^. txhTimeIssued of
                              Just time ->
                                  let format = translate (I18nL.common <<< I18nL.cDateFormat) lang
                                  in fromMaybe noData $ prettyDate format time
                              Nothing -> noData
              ]
          , txAmountView (props ^. txhAmount) lang
          ]

emptyTxHeaderView :: P.Html Action
emptyTxHeaderView =
    P.div
        [ P.className "transaction-header"]
        [ ]

txAmountView :: CCoin -> Language -> P.Html Action
txAmountView coin lang =
    P.div
        [ P.className "amount-container" ]
        [ P.div
            [ P.className "amount bg-ada" ]
            [ P.text $ formatADA coin lang ]
        ]
-- -----------------
-- tx body
-- -----------------

-- | Factory to create TxBodyViewProps by a given type
class TxBodyViewPropsFactory a where
    mkTxBodyViewProps :: a -> TxBodyViewProps

-- | Creates a TxBodyViewProps by a given CTxSummary
instance cTxSummaryTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxSummary where
    mkTxBodyViewProps (CTxSummary txSummary) = TxBodyViewProps
        { txbInputs: txSummary ^. ctsInputs
        , txbOutputs: txSummary ^. ctsOutputs
        , txbAmount: txSummary ^. ctsTotalOutput
        }

-- | Creates a TxBodyViewProps by a given CTxBrief
instance cTxBriefTxBodyViewPropsFactory :: TxBodyViewPropsFactory CTxBrief where
    mkTxBodyViewProps (CTxBrief txBrief) = TxBodyViewProps
        { txbInputs: txBrief ^. ctbInputs
        , txbOutputs: txBrief ^. ctbOutputs
        , txbAmount: txBrief ^. ctbOutputSum
        }

-- | Creates a TxBodyViewProps by a given EmptyViewProps
instance emptyTxBodyViewPropsFactory :: TxBodyViewPropsFactory EmptyViewProps where
    mkTxBodyViewProps _ = TxBodyViewProps
        { txbInputs: []
        , txbOutputs: []
        , txbAmount: mkCoin "0"
        }

txBodyView :: Language -> TxBodyViewProps -> P.Html Action
txBodyView lang (TxBodyViewProps props) =
    P.div
        [ P.className "transaction-body" ]
        [ P.div
            [ P.className "from-hash-container" ]
            <<< map txFromView $ props ^. txbInputs
        , P.div
            [ P.className "to-hash-container bg-transaction-arrow" ]
            [ P.div
                [ P.className "to-hash-wrapper"]
                <<< map txToView $ props ^. txbOutputs
            ]
        , P.div
              [ P.className "amounts-container" ]
              <<< map (txBodyAmountView lang) $ props ^. txbOutputs
        , txAmountView (props ^. txbAmount) lang
        ]

emptyTxBodyView :: P.Html Action
emptyTxBodyView =
    P.div
        [ P.className "transaction-body" ]
        []

txFromView :: Tuple CAddress CCoin -> P.Html Action
txFromView (Tuple (CAddress cAddress) _) =
    P.link (toUrl <<< Address $ mkCAddress cAddress)
        [ P.className "from-hash" ]
        [ P.text cAddress ]

txToView :: Tuple CAddress CCoin -> P.Html Action
txToView (Tuple (CAddress cAddress) _) =
    P.link (toUrl <<< Address $ mkCAddress cAddress)
          [ P.className "to-hash"]
          [ P.text cAddress ]

txBodyAmountView :: Language -> Tuple CAddress CCoin -> P.Html Action
txBodyAmountView lang (Tuple _ coin) =
    P.div
        [ P.className "amount-wrapper" ]
        [ P.span
            [ P.className "plain-amount bg-ada-dark" ]
            [ P.text $ formatADA coin lang ]
        ]

-- -----------------
-- pagination
-- -----------------

type PaginationViewProps =
    { label :: String
    , currentPage :: PageNumber
    , minPage :: PageNumber
    , maxPage :: PageNumber
    , editable :: Boolean
    , changePageAction :: (PageNumber -> Action)
    , editableAction :: (P.Target -> Boolean -> Action)
    , invalidPageAction :: (P.Target -> Action)
    , disabled :: Boolean
    }

txPaginationView :: PaginationViewProps -> P.Html Action
txPaginationView props =
    P.div
        [ P.className "transaction-pagination"]
        [ paginationView props ]

paginationView :: PaginationViewProps -> P.Html Action
paginationView props =
    P.div
        [ P.className "pagination-wrapper"]
        [ P.div
              [ P.className "pagination" ]
              [ P.div
                  [ P.className "pagination__container" ]
                  [ P.div
                      [ P.className $ "btn-page" <> disablePrevBtnClazz
                      , P.onClick prevClickHandler ]
                      [ P.div
                          [ P.className "icon bg-triangle-left" ]
                          []
                      ]
                  , P.input
                      ([ P.className "page-number"
                      , P.disabled $ props.maxPage == props.minPage
                      , P.min <<< show $ unwrap props.minPage
                      , P.max <<< show $ unwrap props.maxPage
                      , P.onFocus \event -> props.editableAction (_.target event) true
                      , P.onBlur \event -> props.editableAction (_.target event) false
                      ]
                      <>  if props.editable
                          then [ P.onKey "enter" onEnterHandler ]
                          else [ P.value <<< show $ unwrap props.currentPage ]
                      )
                      []
                  , P.p
                      [ P.className "label" ]
                      [ P.text props.label ]
                  , P.input
                      [ P.className "page-number"
                      , P.disabled true
                      , P.type_ "search"
                      , P.value <<< show $ unwrap props.maxPage
                      ]
                      []
                  , P.div
                      [ P.className $ "btn-page" <> disableNextBtnClazz
                        , P.onClick nextClickHandler ]
                      [ P.div
                          [ P.className "icon bg-triangle-right" ]
                          []
                      ]
                  ]
              ]
          , P.div
              [ P.className $ "pagination-cover"
                    <>  if props.disabled
                        then " show"
                        else ""
              , P.onClick $ const NoOp
              ]
              []
          ]
          where
            disablePrevBtnClazz = if props.currentPage == props.minPage then " disabled" else ""
            disableNextBtnClazz = if props.currentPage == props.maxPage then " disabled" else ""
            nextClickHandler :: P.MouseEvent -> Action
            nextClickHandler event =
                if props.currentPage < props.maxPage then
                props.changePageAction <<< PageNumber $ (unwrap props.currentPage) + 1
                else
                NoOp

            prevClickHandler :: P.MouseEvent -> Action
            prevClickHandler _ =
                if props.currentPage > props.minPage && not props.disabled then
                props.changePageAction <<< PageNumber $ (unwrap props.currentPage) - 1
                else
                NoOp

            onEnterHandler :: P.KeyboardEvent -> Action
            onEnterHandler event =
                if props.disabled
                then NoOp
                else
                    if page >= props.minPage && page <= props.maxPage
                    then props.changePageAction page
                    else props.invalidPageAction target
                    where
                        target = _.target event
                        page = PageNumber <<< fromMaybe (unwrap props.currentPage) <<< fromString $ _.value target

getMaxPaginationNumber :: Int -> Int -> Int
getMaxPaginationNumber quantity max =
    ceil (toNumber quantity / toNumber max)

-- -----------------
-- txs empty view
-- -----------------

txEmptyContentView :: String -> P.Html Action
txEmptyContentView message = P.div
                        [ P.className "tx-empty__container" ]
                        [ P.text message ]

-- -----------------
-- logo
-- -----------------

logoView' :: Maybe Route -> P.Html Action
logoView' mRoute =
    let logoContentTag = case mRoute of
                              Just route -> P.link (toUrl route)
                              Nothing -> P.div
    in
    P.div
        [ P.className "logo__container"]
        [ P.div
            [ P.className "logo__wrapper"]
            [ logoContentTag
                [ P.className "logo__img bg-logo"
                , P.href "/"]
                []
            ]
        ]

logoView :: P.Html Action
logoView = logoView' Nothing

clickableLogoView :: Route -> P.Html Action
clickableLogoView = logoView' <<< Just

-- -----------------
-- lang
-- -----------------

-- currency

langItems :: Array Language
langItems =
    [ English
    , Japanese
    , German
    ]

langView :: State -> P.Html Action
langView state =
  P.select
      [ P.className "lang__select bg-arrow-up"
      , P.defaultValue <<< show $ state ^. lang
      , P.onChange $ SetLanguage <<< fromMaybe (_.lang initialState) <<< readLanguage <<< _.value <<< _.target]
      $ map (langItemView state) langItems

langItemView :: State -> Language -> P.Html Action
langItemView state lang' =
  let selected = (show lang') == (show $ state ^. lang) in
  P.option
    [ P.value $ show lang'
    , P.className $ if selected then "selected" else ""
    ]
    [ P.text $ show lang' ]

-- -----------------
-- helper
-- -----------------

newtype EmptyViewProps = EmptyViewProps {}

mkEmptyViewProps :: EmptyViewProps
mkEmptyViewProps = EmptyViewProps {}

noData :: String
noData = "--"

-- | Helper to add currency classes
currencyCSSClass :: Maybe CCurrency -> String
currencyCSSClass mCurrency =
  case mCurrency of
      Just ADA -> "ada bg-ada-dark"
      Just USD -> "usd bg-usd-dark"
      _ -> ""

-- TODO (jk) Remove placeholderView if all views are implemented
placeholderView :: String -> P.Html Action
placeholderView label =
    P.div
        [ P.className "explorer-dashboard__content" ]
        [ P.text label ]

emptyView :: P.Html Action
emptyView = P.div [] []


Return value of the correct constructor from _readEventTarget

module DOM.Event.Types
  ( Event
  , EventType(..)
  , EventTarget
  , readEventTarget
  , CustomEvent
  , customEventToEvent
  , readCustomEvent
  , UIEvent
  , uiEventToEvent
  , readUIEvent
  , FocusEvent
  , focusEventToEvent
  , readFocusEvent
  , MouseEvent
  , mouseEventToEvent
  , readMouseEvent
  , WheelEvent
  , wheelEventToEvent
  , readWheelEvent
  , TouchEvent
  , touchEventToEvent
  , readTouchEvent
  , InputEvent
  , inputEventToEvent
  , readInputEvent
  , KeyboardEvent
  , keyboardEventToEvent
  , readKeyboardEvent
  , CompositionEvent
  , compositionEventToEvent
  , readCompositionEvent
  , ProgressEvent
  , progressEventToEvent
  , readProgressEvent
  , ClipboardEvent
  , clipboardEventToEvent
  , readClipboardEvent
  ) where

import Prelude
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foreign (F, Foreign, ForeignError(ForeignError), unsafeReadTagged)
import Data.Newtype (class Newtype, wrap)
import Unsafe.Coerce as U

-- | Basic type for all DOM events.
foreign import data Event :: Type

-- | The type of strings used for event types.
newtype EventType = EventType String

derive instance newtypeEventType :: Newtype EventType _
derive newtype instance eqEventType :: Eq EventType
derive newtype instance ordEventType :: Ord EventType

-- | A DOM item that can emit events.
foreign import data EventTarget :: Type

readEventTarget :: Foreign -> F EventTarget
readEventTarget =
  wrap <<< wrap <<< lmap (pure <<< ForeignError) <<<
    _readEventTarget Left Right

foreign import _readEventTarget
  :: (forall a b. a -> Either a b)
  -> (forall a b. b -> Either a b)
  -> Foreign
  -> Either String EventTarget

foreign import data CustomEvent :: Type

customEventToEvent :: CustomEvent -> Event
customEventToEvent = U.unsafeCoerce

readCustomEvent :: Foreign -> F CustomEvent
readCustomEvent = unsafeReadTagged "CustomEvent"

foreign import data UIEvent :: Type

uiEventToEvent :: UIEvent -> Event
uiEventToEvent = U.unsafeCoerce

readUIEvent :: Foreign -> F UIEvent
readUIEvent = unsafeReadTagged "UIEvent"

foreign import data FocusEvent :: Type

focusEventToEvent :: FocusEvent -> Event
focusEventToEvent = U.unsafeCoerce

readFocusEvent :: Foreign -> F FocusEvent
readFocusEvent = unsafeReadTagged "FocusEvent"

foreign import data MouseEvent :: Type

mouseEventToEvent :: MouseEvent -> Event
mouseEventToEvent = U.unsafeCoerce

readMouseEvent :: Foreign -> F MouseEvent
readMouseEvent = unsafeReadTagged "MouseEvent"

foreign import data WheelEvent :: Type

wheelEventToEvent :: WheelEvent -> Event
wheelEventToEvent = U.unsafeCoerce

readWheelEvent :: Foreign -> F WheelEvent
readWheelEvent = unsafeReadTagged "WheelEvent"

foreign import data TouchEvent :: Type

touchEventToEvent :: TouchEvent -> Event
touchEventToEvent = U.unsafeCoerce

readTouchEvent :: Foreign -> F TouchEvent
readTouchEvent = unsafeReadTagged "TouchEvent"

foreign import data InputEvent :: Type

inputEventToEvent :: InputEvent -> Event
inputEventToEvent = U.unsafeCoerce

readInputEvent :: Foreign -> F InputEvent
readInputEvent = unsafeReadTagged "InputEvent"

foreign import data KeyboardEvent :: Type

keyboardEventToEvent :: KeyboardEvent -> Event
keyboardEventToEvent = U.unsafeCoerce

readKeyboardEvent :: Foreign -> F KeyboardEvent
readKeyboardEvent = unsafeReadTagged "KeyboardEvent"

foreign import data CompositionEvent :: Type

compositionEventToEvent :: CompositionEvent -> Event
compositionEventToEvent = U.unsafeCoerce

readCompositionEvent :: Foreign -> F CompositionEvent
readCompositionEvent = unsafeReadTagged "CompositionEvent"

foreign import data ProgressEvent :: Type

progressEventToEvent :: ProgressEvent -> Event
progressEventToEvent = U.unsafeCoerce

readProgressEvent :: Foreign -> F ProgressEvent
readProgressEvent = unsafeReadTagged "ProgressEvent"

foreign import data ClipboardEvent :: Type

clipboardEventToEvent :: ClipboardEvent -> Event
clipboardEventToEvent = U.unsafeCoerce

readClipboardEvent :: Foreign -> F ClipboardEvent
readClipboardEvent = unsafeReadTagged "ClipboardEvent"

module DOM.Event.Types
  ( Event
  , EventType(..)
  , EventTarget
  , readEventTarget
  , CustomEvent
  , customEventToEvent
  , readCustomEvent
  , UIEvent
  , uiEventToEvent
  , readUIEvent
  , FocusEvent
  , focusEventToEvent
  , readFocusEvent
  , MouseEvent
  , mouseEventToEvent
  , readMouseEvent
  , WheelEvent
  , wheelEventToEvent
  , readWheelEvent
  , TouchEvent
  , touchEventToEvent
  , readTouchEvent
  , InputEvent
  , inputEventToEvent
  , readInputEvent
  , KeyboardEvent
  , keyboardEventToEvent
  , readKeyboardEvent
  , CompositionEvent
  , compositionEventToEvent
  , readCompositionEvent
  , ProgressEvent
  , progressEventToEvent
  , readProgressEvent
  , ClipboardEvent
  , clipboardEventToEvent
  , readClipboardEvent
  ) where

import Prelude
import Data.Either (Either(..))
import Data.Foreign (F, Foreign, unsafeReadTagged)
import Data.Newtype (class Newtype)
import Unsafe.Coerce as U

-- | Basic type for all DOM events.
foreign import data Event :: Type

-- | The type of strings used for event types.
newtype EventType = EventType String

derive instance newtypeEventType :: Newtype EventType _
derive newtype instance eqEventType :: Eq EventType
derive newtype instance ordEventType :: Ord EventType

-- | A DOM item that can emit events.
foreign import data EventTarget :: Type

readEventTarget :: Foreign -> F EventTarget
readEventTarget = _readEventTarget Left Right

foreign import _readEventTarget
  :: (forall a b. a -> Either a b)
  -> (forall a b. b -> Either a b)
  -> Foreign
  -> F EventTarget

foreign import data CustomEvent :: Type

customEventToEvent :: CustomEvent -> Event
customEventToEvent = U.unsafeCoerce

readCustomEvent :: Foreign -> F CustomEvent
readCustomEvent = unsafeReadTagged "CustomEvent"

foreign import data UIEvent :: Type

uiEventToEvent :: UIEvent -> Event
uiEventToEvent = U.unsafeCoerce

readUIEvent :: Foreign -> F UIEvent
readUIEvent = unsafeReadTagged "UIEvent"

foreign import data FocusEvent :: Type

focusEventToEvent :: FocusEvent -> Event
focusEventToEvent = U.unsafeCoerce

readFocusEvent :: Foreign -> F FocusEvent
readFocusEvent = unsafeReadTagged "FocusEvent"

foreign import data MouseEvent :: Type

mouseEventToEvent :: MouseEvent -> Event
mouseEventToEvent = U.unsafeCoerce

readMouseEvent :: Foreign -> F MouseEvent
readMouseEvent = unsafeReadTagged "MouseEvent"

foreign import data WheelEvent :: Type

wheelEventToEvent :: WheelEvent -> Event
wheelEventToEvent = U.unsafeCoerce

readWheelEvent :: Foreign -> F WheelEvent
readWheelEvent = unsafeReadTagged "WheelEvent"

foreign import data TouchEvent :: Type

touchEventToEvent :: TouchEvent -> Event
touchEventToEvent = U.unsafeCoerce

readTouchEvent :: Foreign -> F TouchEvent
readTouchEvent = unsafeReadTagged "TouchEvent"

foreign import data InputEvent :: Type

inputEventToEvent :: InputEvent -> Event
inputEventToEvent = U.unsafeCoerce

readInputEvent :: Foreign -> F InputEvent
readInputEvent = unsafeReadTagged "InputEvent"

foreign import data KeyboardEvent :: Type

keyboardEventToEvent :: KeyboardEvent -> Event
keyboardEventToEvent = U.unsafeCoerce

readKeyboardEvent :: Foreign -> F KeyboardEvent
readKeyboardEvent = unsafeReadTagged "KeyboardEvent"

foreign import data CompositionEvent :: Type

compositionEventToEvent :: CompositionEvent -> Event
compositionEventToEvent = U.unsafeCoerce

readCompositionEvent :: Foreign -> F CompositionEvent
readCompositionEvent = unsafeReadTagged "CompositionEvent"

foreign import data ProgressEvent :: Type

progressEventToEvent :: ProgressEvent -> Event
progressEventToEvent = U.unsafeCoerce

readProgressEvent :: Foreign -> F ProgressEvent
readProgressEvent = unsafeReadTagged "ProgressEvent"

foreign import data ClipboardEvent :: Type

clipboardEventToEvent :: ClipboardEvent -> Event
clipboardEventToEvent = U.unsafeCoerce

readClipboardEvent :: Foreign -> F ClipboardEvent
readClipboardEvent = unsafeReadTagged "ClipboardEvent"


Use type field to parse

Use type field to parse

-- | A basic wrapper for the `webidl2` library, and some ADT sugar on top.

module WebIDL
  ( NodeView(..)
  , Type(..)
  , parse
  , toView
  , toViewWith
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Generic
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.NullOrUndefined

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

-- | Parse a WebIDL string. This function can throw exceptions.
foreign import parse :: String -> Foreign

newtype Type = Type
  { idlType   :: String
  , sequence  :: Boolean
  , generic   :: Maybe String
  , nullable  :: Boolean
  , array     :: Boolean
  , union     :: Boolean
  }

derive instance genericType :: Generic Type

instance showType :: Show Type where
  show = gShow

-- | A node represented as a PureScript data type.
data NodeView node
  = InterfaceNode
    { name        :: String
    , partial     :: Boolean
    , members     :: Array node
    , inheritance :: Maybe String
    }
  | ImplementsNode
    { target      :: String
    , implements  :: String
    }
  | TypeDefNode
  | CallbackNode
  | DictionaryNode
  | ExceptionNode
  | OperationMember
    { name            :: String
    , arguments       :: Array node
    , idlType         :: Type
    , getter          :: Boolean
    , setter          :: Boolean
    , creator         :: Boolean
    , deleter         :: Boolean
    , legacycaller    :: Boolean
    , static          :: Boolean
    , stringifier     :: Boolean
    }
  | ArgumentMember
    { name           :: String
    , idlType        :: Type
    , static         :: Boolean
    , stringifier    :: Boolean
    , inherit        :: Boolean
    , readonly       :: Boolean
    }
  | ConstantMember
  | SerializerMember
  | IteratorMember
  | OtherNode

derive instance genericNodeView :: (Generic node) => Generic (NodeView node)

instance showNodeView :: (Generic node) => Show (NodeView node) where
  show = gShow

-- | Unwrap the top level of a node.
toView :: Foreign -> NodeView Foreign
toView = toViewWith id

-- | Unwrap the top level of a node.
toViewWith :: forall node. (Foreign -> node) -> Foreign -> NodeView node
toViewWith fromForeign = fromRight <<< readView <<< toForeign
  where
  readView :: Foreign -> F (NodeView node)
  readView f = do
    _type <- readProp "type" f
    case _type of
      "interface" -> InterfaceNode <$> readInterfaceNode f
      _ -> pure OtherNode

  readInterfaceNode :: Foreign -> F { inheritance :: Maybe String
                                    , members :: Array node
                                    , partial :: Boolean
                                    , name :: String
                                    }
  readInterfaceNode f = do
    name <- readProp "name" f
    partial <- readProp "partial" f
    members <- map fromForeign <$> readProp "members" f
    inheritance <- runNullOrUndefined <$> readProp "inheritance" f
    return { name, partial, members, inheritance }

  fromRight (Right view) = view
  fromRight (Left err) = unsafeThrow $ "Unable to parse node: " <> show err

-- | A basic wrapper for the `webidl2` library, and some ADT sugar on top.

module WebIDL
  ( NodeView(..)
  , Type(..)
  , parse
  , toView
  , toViewWith
  ) where

import Prelude

import Data.Maybe
import Data.Either
import Data.Generic
import Data.Foreign
import Data.Foreign.Class
import Data.Foreign.NullOrUndefined

import Control.Alt ((<|>))

import Control.Monad.Eff.Exception.Unsafe (unsafeThrow)

-- | Parse a WebIDL string. This function can throw exceptions.
foreign import parse :: String -> Foreign

newtype Type = Type
  { idlType   :: String
  , sequence  :: Boolean
  , generic   :: Maybe String
  , nullable  :: Boolean
  , array     :: Boolean
  , union     :: Boolean
  }

derive instance genericType :: Generic Type

instance showType :: Show Type where
  show = gShow

-- | A node represented as a PureScript data type.
data NodeView node
  = InterfaceNode
    { name        :: String
    , partial     :: Boolean
    , members     :: Array node
    , inheritance :: Maybe String
    }
  | ImplementsNode
    { target      :: String
    , implements  :: String
    }
  | TypeDefNode
  | CallbackNode
  | DictionaryNode
  | ExceptionNode
  | OperationMember
    { name            :: String
    , arguments       :: Array node
    , idlType         :: Type
    , getter          :: Boolean
    , setter          :: Boolean
    , creator         :: Boolean
    , deleter         :: Boolean
    , legacycaller    :: Boolean
    , static          :: Boolean
    , stringifier     :: Boolean
    }
  | ArgumentMember
    { name           :: String
    , idlType        :: Type
    , static         :: Boolean
    , stringifier    :: Boolean
    , inherit        :: Boolean
    , readonly       :: Boolean
    }
  | ConstantMember
  | SerializerMember
  | IteratorMember
  | OtherNode

derive instance genericNodeView :: (Generic node) => Generic (NodeView node)

instance showNodeView :: (Generic node) => Show (NodeView node) where
  show = gShow

-- | Unwrap the top level of a node.
toView :: Foreign -> NodeView Foreign
toView = toViewWith id

-- | Unwrap the top level of a node.
toViewWith :: forall node. (Foreign -> node) -> Foreign -> NodeView node
toViewWith fromForeign = fromRight <<< readView <<< toForeign
  where
  readView :: Foreign -> F (NodeView node)
  readView f =
    InterfaceNode <$> readInterfaceNode f
    <|> pure OtherNode

  readInterfaceNode :: Foreign -> F { inheritance :: Maybe String
                                    , members :: Array node
                                    , partial :: Boolean
                                    , name :: String
                                    }
  readInterfaceNode f = do
    name <- readProp "name" f
    partial <- readProp "partial" f
    members <- map fromForeign <$> readProp "members" f
    inheritance <- runNullOrUndefined <$> readProp "inheritance" f
    return { name, partial, members, inheritance }

  fromRight (Right view) = view
  fromRight (Left err) = unsafeThrow $ "Unable to parse node: " <> show err


add IDBKey instance to Key

add IDBKey instance to Key

module Database.IndexedDB.IDBKey.Internal
    ( Key(..)
    , class IDBKey, toKey , fromKey , unsafeFromKey
    , extractForeign
    ) where

import Prelude

import Control.Alt                 ((<|>))
import Control.Monad.Except        (ExceptT(..), runExceptT)
import Data.Date                    as Date
import Data.DateTime               (DateTime(..), Time(..))
import Data.Enum                   (fromEnum, toEnum)
import Data.Foreign                 as Foreign
import Data.Foreign                (Foreign, F)
import Data.Function.Uncurried      as Fn
import Data.Function.Uncurried     (Fn2, Fn4, Fn7)
import Data.List.NonEmpty          (NonEmptyList(..))
import Data.List.Types             (List(..))
import Data.NonEmpty               (NonEmpty(..))
import Data.Either                 (Either(..), either, isRight)
import Data.Identity               (Identity(..))
import Data.Nullable               (Nullable, toNullable)
import Data.Time                    as Time
import Data.Traversable            (traverse)

newtype Key = Key Foreign

extractForeign :: Key -> Foreign
extractForeign (Key f) =
  f

--------------------
-- INTERFACES
--
class IDBKey a where
  toKey         :: a -> Key
  fromKey       :: Key -> F a
  unsafeFromKey :: Key -> a

--------------------
-- INSTANCES
--
instance eqKey :: Eq Key where
  eq a b = (runExceptT >>> runIdentity >>> isRight) $
      eq <$> ((fromKey a) :: F Int) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F Number) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F String) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F DateTime) <*> fromKey b
    where
      runIdentity :: forall a. Identity a -> a
      runIdentity (Identity x) = x

instance ordKey :: Ord Key where
  compare a b = (runExceptT >>> runIdentity >>> either (const LT) id) $
      compare <$> ((fromKey a) :: F Int) <*> fromKey b
    <|>
      compare <$> ((fromKey a) :: F Number) <*> fromKey b
    <|>
      compare <$> ((fromKey a) :: F String) <*> fromKey b
    <|>
      compare <$> ((fromKey a) :: F DateTime) <*> fromKey b
    where
      runIdentity :: forall a. Identity a -> a
      runIdentity (Identity x) = x

instance showKey :: Show Key where
  show a = (runExceptT >>> format) $
      (show <$> (fromKey a :: F Int))
    <|>
      (show <$> (fromKey a :: F Number))
    <|>
      (show <$> (fromKey a :: F String))
    <|>
      (show <$> (fromKey a :: F DateTime))
    where
      format :: forall a. Identity (Either a String) -> String
      format (Identity x) =
        either (const "(Key)") (\s -> "(Key " <> s <> ")") x

instance idbKeyKey :: IDBKey Key where
  toKey         = id
  fromKey       = pure
  unsafeFromKey = id

instance idbKeyInt :: IDBKey Int where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readInt f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyNumber :: IDBKey Number where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readNumber f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyString :: IDBKey String where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readString f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyDate :: IDBKey DateTime where
  toKey (DateTime d t)  = Key $ Fn.runFn7 _dateTimeToForeign
    (fromEnum $ Date.year d)
    (fromEnum $ Date.month d)
    (fromEnum $ Date.day d)
    (fromEnum $ Time.hour t)
    (fromEnum $ Time.minute t)
    (fromEnum $ Time.second t)
    (fromEnum $ Time.millisecond t)
  fromKey (Key f)       = Fn.runFn4 _readDateTime dateTime dateTimeF dateTimeE f
  unsafeFromKey (Key f) = Fn.runFn2 _unsafeReadDateTime dateTime f

instance idbKeyArray :: IDBKey a => IDBKey (Array a) where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readArray f >>= traverse (Key >>> fromKey)
  unsafeFromKey (Key f) = map unsafeFromKey (Foreign.unsafeFromForeign f)

dateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime
dateTime y m d h mi s ms =
  toNullable $ DateTime
  <$> (Date.canonicalDate <$> toEnum y <*> toEnum m <*> toEnum d)
  <*> (Time <$> toEnum h <*> toEnum mi <*> toEnum s <*> toEnum ms)

dateTimeF :: DateTime -> F DateTime
dateTimeF =
  Right >>> Identity >>> ExceptT

dateTimeE :: String -> F DateTime
dateTimeE =
  Foreign.TypeMismatch "Date" >>> flip NonEmpty Nil >>> NonEmptyList >>> Left >>> Identity >>> ExceptT

--------------------
-- FFI
--
foreign import _dateTimeToForeign  :: Fn7 Int Int Int Int Int Int Int Foreign

foreign import _readDateTime :: Fn4 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) (DateTime -> F DateTime) (String -> F DateTime) Foreign (F DateTime)

foreign import _unsafeReadDateTime :: Fn2 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) Foreign DateTime

module Database.IndexedDB.IDBKey.Internal
    ( Key(..)
    , class IDBKey, toKey , fromKey , unsafeFromKey
    , extractForeign
    ) where

import Prelude

import Control.Alt                 ((<|>))
import Control.Monad.Except        (ExceptT(..), runExceptT)
import Data.Date                    as Date
import Data.DateTime               (DateTime(..), Time(..))
import Data.Enum                   (fromEnum, toEnum)
import Data.Foreign                 as Foreign
import Data.Foreign                (Foreign, F)
import Data.Function.Uncurried      as Fn
import Data.Function.Uncurried     (Fn2, Fn4, Fn7)
import Data.List.NonEmpty          (NonEmptyList(..))
import Data.List.Types             (List(..))
import Data.NonEmpty               (NonEmpty(..))
import Data.Either                 (Either(..), either, isRight)
import Data.Identity               (Identity(..))
import Data.Nullable               (Nullable, toNullable)
import Data.Time                    as Time
import Data.Traversable            (traverse)

newtype Key = Key Foreign

extractForeign :: Key -> Foreign
extractForeign (Key f) =
  f

--------------------
-- INTERFACES
--
class IDBKey a where
  toKey         :: a -> Key
  fromKey       :: Key -> F a
  unsafeFromKey :: Key -> a

--------------------
-- INSTANCES
--
instance eqKey :: Eq Key where
  eq a b = (runExceptT >>> runIdentity >>> isRight) $
      eq <$> ((fromKey a) :: F Int) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F Number) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F String) <*> fromKey b
    <|>
      eq <$> ((fromKey a) :: F DateTime) <*> fromKey b
    where
      runIdentity :: forall a. Identity a -> a
      runIdentity (Identity x) = x

instance ordKey :: Ord Key where
  compare a b = (runExceptT >>> runIdentity >>> either (const LT) id) $
      compare <$> ((fromKey a) :: F Int) <*> fromKey b
    <|>
      compare <$> ((fromKey a) :: F Number) <*> fromKey b
    <|>
      compare <$> ((fromKey a) :: F String) <*> fromKey b
    <|>
      compare <$> ((fromKey a) :: F DateTime) <*> fromKey b
    where
      runIdentity :: forall a. Identity a -> a
      runIdentity (Identity x) = x

instance showKey :: Show Key where
  show a = (runExceptT >>> format) $
      (show <$> (fromKey a :: F Int))
    <|>
      (show <$> (fromKey a :: F Number))
    <|>
      (show <$> (fromKey a :: F String))
    <|>
      (show <$> (fromKey a :: F DateTime))
    where
      format :: forall a. Identity (Either a String) -> String
      format (Identity x) =
        either (const "(Key)") (\s -> "(Key " <> s <> ")") x

instance idbKeyInt :: IDBKey Int where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readInt f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyNumber :: IDBKey Number where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readNumber f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyString :: IDBKey String where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readString f
  unsafeFromKey (Key f) = Foreign.unsafeFromForeign f

instance idbKeyDate :: IDBKey DateTime where
  toKey (DateTime d t)  = Key $ Fn.runFn7 _dateTimeToForeign
    (fromEnum $ Date.year d)
    (fromEnum $ Date.month d)
    (fromEnum $ Date.day d)
    (fromEnum $ Time.hour t)
    (fromEnum $ Time.minute t)
    (fromEnum $ Time.second t)
    (fromEnum $ Time.millisecond t)
  fromKey (Key f)       = Fn.runFn4 _readDateTime dateTime dateTimeF dateTimeE f
  unsafeFromKey (Key f) = Fn.runFn2 _unsafeReadDateTime dateTime f

instance idbKeyArray :: IDBKey a => IDBKey (Array a) where
  toKey                 = Foreign.toForeign >>> Key
  fromKey (Key f)       = Foreign.readArray f >>= traverse (Key >>> fromKey)
  unsafeFromKey (Key f) = map unsafeFromKey (Foreign.unsafeFromForeign f)

dateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime
dateTime y m d h mi s ms =
  toNullable $ DateTime
  <$> (Date.canonicalDate <$> toEnum y <*> toEnum m <*> toEnum d)
  <*> (Time <$> toEnum h <*> toEnum mi <*> toEnum s <*> toEnum ms)

dateTimeF :: DateTime -> F DateTime
dateTimeF =
  Right >>> Identity >>> ExceptT

dateTimeE :: String -> F DateTime
dateTimeE =
  Foreign.TypeMismatch "Date" >>> flip NonEmpty Nil >>> NonEmptyList >>> Left >>> Identity >>> ExceptT

--------------------
-- FFI
--
foreign import _dateTimeToForeign  :: Fn7 Int Int Int Int Int Int Int Foreign

foreign import _readDateTime :: Fn4 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) (DateTime -> F DateTime) (String -> F DateTime) Foreign (F DateTime)

foreign import _unsafeReadDateTime :: Fn2 (Int -> Int -> Int -> Int -> Int -> Int -> Int -> Nullable DateTime) Foreign DateTime


Fix parallel races in auth

Fix parallel races in auth

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

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

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

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

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

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

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

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

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

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

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

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

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

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

instance semigroupAuthenticationError ∷ Semigroup AuthenticationError where
  append x y = y

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

type RequestIdTokenBus = BusW RequestIdTokenMessage

type EIdToken = Either AuthenticationError IdToken

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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


Redo events again!! With Variants this time

module Genetics.Browser.Events
       ( Event(..)
       , handleLocation
       , handleRange
       , _eventLocation
       , _eventRange
       , _eventScore
       , EventLocation(..)
       , EventRange(..)
       , EventScore(..)
       , Location(..)
       , Range(..)
       , Score(..)
       )
       where

import Prelude
import Data.Symbol (SProxy(..))
import Data.Variant (Variant, on)
import Genetics.Browser.Units (Bp, Chr)

newtype Event r = Event (Variant r)

type Location = { chr :: Chr
                , pos :: Bp
                }
_eventLocation = (SProxy :: SProxy "location")
type EventLocation r = ( location :: Location | r)
handleLocation :: forall r a.
                  (Location -> a)
               -> (Variant r -> a)
               -> Variant (EventLocation r)
               -> a
handleLocation = on _eventLocation

type Range = { chr :: Chr
             , minPos :: Bp
             , maxPos :: Bp
             }
_eventRange = (SProxy :: SProxy "range")
type EventRange r = ( range :: Range | r)
handleRange :: forall r a.
                  (Range -> a)
               -> (Variant r -> a)
               -> Variant (EventRange r)
               -> a
handleRange = on _eventRange

type Score = { score :: Number }
_eventScore = (SProxy :: SProxy "score")
type EventScore r = ( score :: Score | r)

module Genetics.Browser.Events
       ( JsonEvent(..)
       , EventLocation(..)
       , EventRange(..)
       , EventScore(..)
       )
       where

import Prelude
import Data.Argonaut (Json, _Number, _Object, _String)
import Data.Array (foldMap)
import Data.Foldable (class Foldable)
import Data.Foreign (Foreign)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Foreign.Generic (defaultOptions, genericDecode, genericEncode)
import Data.Generic.Rep (class Generic)
import Data.Lens (re, (^?))
import Data.Lens.Index (ix)
import Data.Maybe (Maybe)
import Data.Maybe.First (First(..))
import Data.Newtype (class Newtype, unwrap)
import Genetics.Browser.Units (Bp, Chr, _Bp, _Chr)

-- An Event comes from some track, and carries some information.
-- depending on the track (?), the information may differ.
-- can a single track send multiple types of events?
-- yes -- e.g. cytoscape can, at the *least*, have both nodes and edges,
-- and they carry different data.
{-
The data flow should be
(Cy.js|BD|w/e) -> PS (Halogen) -> Parse into Event -> Send in coroutine/pipeline
-> Main container receives Event
-> Main container resends Events to relevant subscribers
-> Subscriber receives Event and acts accordingly

Thus, it will be parsed from JSON into a PS data structure at the very outer edge,
and remain type safe like that.
-}

-- so, source track and event types are orthogonal.

newtype JsonEvent = JsonEvent Foreign

derive instance newtypeJsonEvent :: Newtype JsonEvent _

newtype EventLocation = EventLocation { chr :: Chr
                                      , pos :: Bp
                                      }

derive instance genericEventLocation :: Generic EventLocation _

instance encodeEventLocation :: Encode EventLocation where
  encode = genericEncode defaultOptions

instance decodeEventLocation :: Decode EventLocation where
  decode = genericDecode defaultOptions

parseEventLocation :: ∀ f r.
                      Foldable f
                   => Functor f
                   => { posKeys :: f String, chrKeys :: f String | r }
                   -> Json
                   -> Maybe EventLocation
parseEventLocation {chrKeys, posKeys} obj = do
    chr <- unwrap $ foldMap First $ (\k -> obj ^?
                                           _Object <<< ix k <<<
                                           _String <<< re _Chr) <$> chrKeys
    pos <- unwrap $ foldMap First $ (\k -> obj ^?
                                           _Object <<< ix k <<<
                                           _Number <<< re _Bp) <$> posKeys
    pure $ EventLocation { chr, pos }

newtype EventRange = EventRange { chr :: Chr
                                , minPos :: Bp
                                , maxPos :: Bp
                                }

derive instance genericEventRange :: Generic EventRange _

instance encodeEventRange :: Encode EventRange where
  encode = genericEncode defaultOptions

instance decodeEventRange :: Decode EventRange where
  decode = genericDecode defaultOptions

parseEventRange :: ∀ f r.
                      Foldable f
                   => Functor f
                   => { chrKeys :: f String, minPosKeys :: f String , maxPosKeys :: f String | r }
                   -> Json
                   -> Maybe EventRange
parseEventRange {chrKeys, minPosKeys, maxPosKeys} obj = do
    chr <- unwrap $ foldMap First $ (\k -> obj ^?
                                           _Object <<< ix k <<<
                                           _String <<< re _Chr) <$> chrKeys
    minPos <- unwrap $ foldMap First $ (\k -> obj ^?
                                           _Object <<< ix k <<<
                                           _Number <<< re _Bp) <$> minPosKeys
    maxPos <- unwrap $ foldMap First $ (\k -> obj ^?
                                           _Object <<< ix k <<<
                                           _Number <<< re _Bp) <$> maxPosKeys
    pure $ EventRange { chr, minPos, maxPos }

newtype EventScore = EventScore Number


Added type signature for encodeURLPiece

Added type signature for encodeURLPiece

module Servant.PureScript.Util where

import Prelude
import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (ForeignError, Foreign, readString)
import Data.Generic (class Generic)
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AffjaxResponse)
import Network.HTTP.StatusCode (StatusCode(..))
import Servant.PureScript.Affjax (AjaxError(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.PureScript.Settings (SPSettings_(SPSettings_))
import Unsafe.Coerce (unsafeCoerce)

getResult :: forall a m. (Generic a, MonadError AjaxError m) => (Json -> Either String a) -> AffjaxResponse String -> m a
getResult decode resp = do
  let stCode = case resp.status of StatusCode code -> code
  fVal <- if stCode >= 200 && stCode < 300
            then pure resp.response
            else throwError $ UnexpectedHTTPStatus resp
  jVal <- throwLeft <<< lmap (reportError ParsingError fVal) <<< jsonParser $ fVal
  throwLeft <<< lmap (reportError DecodingError (show jVal)) <<< decode $ jVal

throwLeft :: forall a e m. MonadError e m => Either e a -> m a
throwLeft (Left e) = throwError e
throwLeft (Right a) = pure a

-- encodeListQuery :: forall a b. Generic a => Settings b -> String -> Array a -> String
encodeListQuery opts'@(SPSettings_ opts) fName = intercalate "&" <<< map (encodeQueryItem opts' fName)

-- | The given name is assumed to be already escaped.
-- encodeQueryItem :: forall a b. Generic a => SPSettings_ b -> String -> a -> String
encodeQueryItem opts'@(SPSettings_ opts) fName val = fName <> "=" <> encodeURLPiece opts' val

-- | Call opts.toURLPiece and encode the resulting string with encodeURIComponent.
encodeURLPiece :: forall a params. Generic a => SPSettings_ params -> a -> String
encodeURLPiece (SPSettings_ opts) = encodeURIComponent <<< unsafeCoerce opts.toURLPiece

reportError :: (String -> AjaxError) -> String -> String  -> AjaxError
reportError err source msg = err $ msg <> ", source: '" <> source <> "'"

module Servant.PureScript.Util where

import Prelude
import Control.Monad.Error.Class (class MonadError, throwError)
import Data.Argonaut.Core (Json)
import Data.Argonaut.Parser (jsonParser)
import Data.Bifunctor (lmap)
import Data.Either (Either(..))
import Data.Foldable (intercalate)
import Data.Foreign (ForeignError, Foreign, readString)
import Data.Generic (class Generic)
import Global (encodeURIComponent)
import Network.HTTP.Affjax (AffjaxResponse)
import Network.HTTP.StatusCode (StatusCode(..))
import Servant.PureScript.Affjax (AjaxError(DecodingError, ParsingError, UnexpectedHTTPStatus))
import Servant.PureScript.Settings (SPSettings_(SPSettings_))
import Unsafe.Coerce (unsafeCoerce)

getResult :: forall a m. (Generic a, MonadError AjaxError m) => (Json -> Either String a) -> AffjaxResponse String -> m a
getResult decode resp = do
  let stCode = case resp.status of StatusCode code -> code
  fVal <- if stCode >= 200 && stCode < 300
            then pure resp.response
            else throwError $ UnexpectedHTTPStatus resp
  jVal <- throwLeft <<< lmap (reportError ParsingError fVal) <<< jsonParser $ fVal
  throwLeft <<< lmap (reportError DecodingError (show jVal)) <<< decode $ jVal

throwLeft :: forall a e m. MonadError e m => Either e a -> m a
throwLeft (Left e) = throwError e
throwLeft (Right a) = pure a

-- encodeListQuery :: forall a b. Generic a => Settings b -> String -> Array a -> String
encodeListQuery opts'@(SPSettings_ opts) fName = intercalate "&" <<< map (encodeQueryItem opts' fName)

-- | The given name is assumed to be already escaped.
-- encodeQueryItem :: forall a b. Generic a => SPSettings_ b -> String -> a -> String
encodeQueryItem opts'@(SPSettings_ opts) fName val = fName <> "=" <> encodeURLPiece opts' val

-- | Call opts.toURLPiece and encode the resulting string with encodeURIComponent.
-- toEscapedURLPiece :: forall a params. Generic a => SPSettings_ params -> a -> String
encodeURLPiece (SPSettings_ opts) = encodeURIComponent <<< unsafeCoerce opts.toURLPiece

reportError :: (String -> AjaxError) -> String -> String  -> AjaxError
reportError err source msg = err $ msg <> ", source: '" <> source <> "'"