Added sign in buttons to sign in failure notifications (#1391)

{-
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
  , 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.Future (Future)
import Control.Monad.Aff.Future as Future
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 (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

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
  , keySuffix ∷ String
  }

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 (Future EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenFuture ← getIdToken message
      writeState $ Just idTokenFuture
      void $ Aff.forkAff $ reply idTokenFuture *> writeState Nothing
    Just idTokenFuture → do
      void $ Aff.forkAff $ reply idTokenFuture
  where
  writeState ∷ Maybe (Future EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

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

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

getIdTokenUsingPrompt
  ∷ ∀ eff
  . RequestIdTokenMessage
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt message = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce message.keySuffix unhashedNonce
  sequential
    $ parallel (getIdTokenFromLSOnChange message.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 message.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
  . RequestIdTokenMessage
  → Aff (AuthEffects eff) (Future EIdToken)
getIdToken message =
  Future.defer do
    eIdToken ← if message.prompt
      then
        getIdTokenUsingPrompt message
      else
        getIdTokenUsingLocalStorage message
          >>= maybe (getIdTokenSilently message) (pure ∘ Right)
    -- Store provider and idToken for future local storage gets and reauthentications
    liftEff $ case eIdToken of
      Left _ →
        AuthStore.clearProvider message.keySuffix
          *> AuthStore.clearIdToken message.keySuffix
      Right idToken →
        AuthStore.storeProvider message.keySuffix (QAT.Provider message.providerR)
          *> AuthStore.storeIdToken message.keySuffix (Right idToken)
    pure eIdToken

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

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

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

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

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
        }
    IdTokenUnavailable detail →
      Just
      { notification:
          Notification.Error
            $ "Sign in failed: Authentication provider didn't provide a token. This might happen if you aren't signed in or are signed into multiple accounts."
        , detail: Just $ Notification.Details detail
        , timeout
        , actionOptions
        }
    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
        }
    DOMError _ → Nothing
  where
  timeout = Nothing
  actionOptions =
    Just $ Notification.ActionOptions
      { message: "File listings and workspaces may appear empty or incomplete. Please sign to continue."
      , actionMessage: "Sign in"
      , action: Notification.ExpandGlobalMenu
      }

{-
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
  , 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.Future (Future)
import Control.Monad.Aff.Future as Future
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 (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

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
  , keySuffix ∷ String
  }

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 (Future EIdToken))
  → RequestIdTokenMessage
  → Aff (AuthEffects eff) Unit
authenticate stateRef message = do
  state ← liftEff $ Ref.readRef stateRef
  case state of
    Nothing → do
      idTokenFuture ← getIdToken message
      writeState $ Just idTokenFuture
      void $ Aff.forkAff $ reply idTokenFuture *> writeState Nothing
    Just idTokenFuture → do
      void $ Aff.forkAff $ reply idTokenFuture
  where
  writeState ∷ Maybe (Future EIdToken) → Aff (AuthEffects eff) Unit
  writeState = liftEff ∘ Ref.writeRef stateRef

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

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

getIdTokenUsingPrompt
  ∷ ∀ eff
  . RequestIdTokenMessage
  → Aff (AuthEffects eff) EIdToken
getIdTokenUsingPrompt message = do
  unhashedNonce ← liftEff OIDCAff.getRandomUnhashedNonce
  liftEff $ AuthStore.storeUnhashedNonce message.keySuffix unhashedNonce
  sequential
    $ parallel (getIdTokenFromLSOnChange message.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 message.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
  . RequestIdTokenMessage
  → Aff (AuthEffects eff) (Future EIdToken)
getIdToken message =
  Future.defer do
    eIdToken ← if message.prompt
      then
        getIdTokenUsingPrompt message
      else
        getIdTokenUsingLocalStorage message
          >>= maybe (getIdTokenSilently message) (pure ∘ Right)
    -- Store provider and idToken for future local storage gets and reauthentications
    liftEff $ case eIdToken of
      Left _ →
        AuthStore.clearProvider message.keySuffix
          *> AuthStore.clearIdToken message.keySuffix
      Right idToken →
        AuthStore.storeProvider message.keySuffix (QAT.Provider message.providerR)
          *> AuthStore.storeIdToken message.keySuffix (Right idToken)
    pure eIdToken

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

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

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

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

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 aren't signed in or are signed into multiple accounts."
        , 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 = Nothing


more comments in app.purs

more comments in app.purs

module DemoApp.WebStreams where

import Prelude                       (Unit, bind)
import Data.Maybe                    (..)
import Control.Monad.Eff             (Eff)
import Control.Monad.Eff.Console     (CONSOLE())
import API.Web.Streams               (..)

-- | Callback which will be passed to the effectful `read` function
-- | Every chunk from the stream will be logged to the console
callback :: forall e. Result -> Eff (console :: CONSOLE | e) Unit
callback = \result -> do
                      logRaw result

main :: forall e. Eff (console :: CONSOLE, webStreamM :: WebStreamM, anyError :: AnyError | e) Unit
main = do
       -- | Create a new TextDecoder with UTF8
       -- | See also: https://developer.mozilla.org/en-US/docs/Web/API/TextDecoder
       decoder <- getDecoder (Just "utf8") (Just { fatal : true })
       -- | Pass Callback and TextDecoder to `read`
       read "https://html.spec.whatwg.org/" callback (Just decoder)

module DemoApp.WebStreams where

import Prelude                       (Unit, bind)
import Data.Maybe                    (..)
import Control.Monad.Eff             (Eff)
import Control.Monad.Eff.Console     (CONSOLE())
import API.Web.Streams               (..)

-- | Callback which will be passed to the effectful `read` function
-- | Every chunk from the stream will be logged to the console
callback :: forall e. Result -> Eff (console :: CONSOLE | e) Unit
callback = \result -> do
                      logRaw result

main :: forall e. Eff (console :: CONSOLE, webStreamM :: WebStreamM, anyError :: AnyError | e) Unit
main = do
       decoder <- getDecoder (Just "utf8") (Just { fatal : true })
       read "https://html.spec.whatwg.org/" callback (Just decoder)


Pipe stdout directly

Pipe stdout directly

module Main where

import Prelude (Unit, pure, bind, otherwise, void, show, (>>=), (<$>), (<>), ($), (-), (||), (==))
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Array as Array
import Data.Array.Unsafe (unsafeIndex)
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Buffer as Buffer
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Psa (PsaOptions, parsePsaResult, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--lib-dir=DIR] [--psc=PSC]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --lib-dir=DIR          Distinguishing key for lib sources (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

  CODES                  Comma-separated list of psc error codes
  PSC_OPTIONS            Any extra options are passed to psc
"""

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , libDir: "bower_components"
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , psc :: String
  , showSource :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts =
  Array.foldM parse
    { extra: []
    , psc: "psc"
    , showSource: true
    , opts
    }
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--lib-dir=" arg =
      pure p { opts = p.opts { libDir = Str.drop 10 arg } }

    | isPrefix "--lib-dir=" arg =
      pure p { opts = p.opts { libDir = Str.drop 10 arg } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf s str of
      Just x | x == 0 -> true
      _               -> false

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv
  { extra, opts, psc, showSource } <- parseOptions (defaultOptions { cwd = cwd }) argv
  child <- Child.spawn psc (Array.cons "--json-errors" extra) Child.defaultSpawnOptions { stdio = stdio }
  files <- STMap.new
  buffer <- ST.newSTRef ""

  Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
    void $ ST.modifySTRef buffer (<> chunk)

  Child.onExit child \status ->
    case status of
      Child.Normally n -> do
        stderr <- Str.split "\n" <$> ST.readSTRef buffer
        for_ stderr \err ->
          case jsonParser err >>= decodeJson >>= parsePsaResult of
            Left _ -> Console.error err
            Right out -> do
              out' <- output (if showSource then loadLines files else loadNothing) opts out
              DefaultPrinter.print opts out'
        Process.exit n
      Child.BySignal s -> do
        Console.error (show s)
        Process.exit 1

  where
  stdio = [ Just Child.Pipe, unsafeIndex Child.inherit 1, Just Child.Pipe ]
  loadNothing _ _ = pure Nothing

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split "\n" <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines

    pure $ Just $ Array.slice (pos.startLine - 1) (pos.endLine) contents

module Main where

import Prelude (Unit, pure, bind, otherwise, void, show, (>>=), (<$>), (<>), ($), (-), (||), (==))
import Data.Argonaut.Parser (jsonParser)
import Data.Argonaut.Decode (decodeJson)
import Data.Array as Array
import Data.Either (Either(..))
import Data.Foldable (foldr, for_)
import Data.StrMap.ST as STMap
import Data.Maybe (Maybe(..))
import Data.Set as Set
import Data.String as Str
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console as Console
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.ST (ST)
import Control.Monad.ST as ST
import Control.Apply ((*>))
import Node.Process (PROCESS)
import Node.Process as Process
import Node.ChildProcess (CHILD_PROCESS)
import Node.ChildProcess as Child
import Node.Stream as Stream
import Node.Buffer (BUFFER)
import Node.Buffer as Buffer
import Node.Encoding as Encoding
import Node.FS (FS)
import Node.FS.Sync as File
import Psa (PsaOptions, parsePsaResult, output)
import Psa.Printer.Default as DefaultPrinter

foreign import version :: String

usage :: String
usage = """psa - Error/Warning reporting frontend for psc

Usage: psa [--censor-lib] [--censor-src]
           [--censor-codes=CODES] [--filter-codes=CODES]
           [--no-colors] [--no-source]
           [--lib-dir=DIR] [--psc=PSC]
           PSC_OPTIONS

Available options:
  -v,--version           Show the version number
  -h,--help              Show this help text
  --censor-warnings      Censor all warnings
  --censor-lib           Censor warnings from library sources
  --censor-src           Censor warnings from project sources
  --censor-codes=CODES   Censor specific error codes
  --filter-codes=CODES   Only show specific error codes
  --no-colors            Disable ANSI colors
  --no-source            Disable original source code printing
  --lib-dir=DIR          Distinguishing key for lib sources (defaults to 'bower_components')
  --psc=PSC              Name of psc executable (defaults to 'psc')

  CODES                  Comma-separated list of psc error codes
  PSC_OPTIONS            Any extra options are passed to psc
"""

defaultOptions :: PsaOptions
defaultOptions =
  { ansi: true
  , censorWarnings: false
  , censorLib: false
  , censorSrc: false
  , censorCodes: Set.empty
  , filterCodes: Set.empty
  , libDir: "bower_components"
  , cwd: ""
  }

type ParseOptions =
  { extra :: Array String
  , opts :: PsaOptions
  , psc :: String
  , showSource :: Boolean
  }

parseOptions
  :: forall eff
   . PsaOptions
  -> Array String
  -> Eff (console :: CONSOLE, process :: PROCESS | eff) ParseOptions
parseOptions opts =
  Array.foldM parse
    { extra: []
    , psc: "psc"
    , showSource: true
    , opts
    }
  where
  parse p arg
    | arg == "--version" || arg == "-v" =
      Console.log version *> Process.exit 0

    | arg == "--help" || arg == "-h" =
      Console.log usage *> Process.exit 0

    | arg == "--no-source" =
      pure p { showSource = false }

    | arg == "--no-colors" =
      pure p { opts = p.opts { ansi = false } }

    | arg == "--censor-warnings" =
      pure p { opts = p.opts { censorWarnings = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-lib" =
      pure p { opts = p.opts { censorLib = true } }

    | arg == "--censor-src" =
      pure p { opts = p.opts { censorSrc = true } }

    | isPrefix "--censor-codes=" arg =
      pure p { opts = p.opts { censorCodes = foldr Set.insert p.opts.censorCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--filter-codes=" arg =
      pure p { opts = p.opts { filterCodes = foldr Set.insert p.opts.filterCodes (Str.split "," (Str.drop 15 arg)) } }

    | isPrefix "--lib-dir=" arg =
      pure p { opts = p.opts { libDir = Str.drop 10 arg } }

    | isPrefix "--lib-dir=" arg =
      pure p { opts = p.opts { libDir = Str.drop 10 arg } }

    | isPrefix "--psc=" arg =
      pure p { psc = Str.drop 6 arg }

    | otherwise = pure p { extra = Array.snoc p.extra arg }

  isPrefix s str =
    case Str.indexOf s str of
      Just x | x == 0 -> true
      _               -> false

type MainEff h eff =
  ( process :: PROCESS
  , console :: CONSOLE
  , buffer :: BUFFER
  , err :: EXCEPTION
  , fs :: FS
  , cp :: CHILD_PROCESS
  , st :: ST h
  | eff
  )

main :: forall h eff. Eff (MainEff h eff) Unit
main = void do
  cwd <- Process.cwd
  argv <- Array.drop 2 <$> Process.argv
  { extra, opts, psc, showSource } <- parseOptions (defaultOptions { cwd = cwd }) argv
  child <- Child.spawn psc (Array.cons "--json-errors" extra) Child.defaultSpawnOptions
  files <- STMap.new
  buffer <- ST.newSTRef ""

  Stream.pipe (Child.stdout child) Process.stdout

  Stream.onDataString (Child.stderr child) Encoding.UTF8 \chunk ->
    void $ ST.modifySTRef buffer (<> chunk)

  Child.onExit child \status ->
    case status of
      Child.Normally n -> do
        stderr <- Str.split "\n" <$> ST.readSTRef buffer
        for_ stderr \err ->
          case jsonParser err >>= decodeJson >>= parsePsaResult of
            Left _ -> Console.error err
            Right out -> do
              out' <- output (if showSource then loadLines files else loadNothing) opts out
              DefaultPrinter.print opts out'
        Process.exit n
      Child.BySignal s -> do
        Console.error (show s)
        Process.exit 1

  where
  loadNothing _ _ = pure Nothing

  -- TODO: Handle exceptions
  loadLines files filename pos = do
    contents <- STMap.peek files filename >>= \cache ->
      case cache of
        Just lines -> pure lines
        Nothing -> do
          lines <- Str.split "\n" <$> File.readTextFile Encoding.UTF8 filename
          STMap.poke files filename lines
          pure lines

    pure $ Just $ Array.slice (pos.startLine - 1) (pos.endLine) contents


Update example

Update example

module Main where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Aff (liftEff', launchAff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import DOM (DOM)
import DOM.HTML.Types (HISTORY)
import Data.Maybe (fromMaybe)
import Data.Time.Duration (Milliseconds(..))
import Rout (match, lit, int, end)
import VOM (VNode, h, t, (:=), (~>), stringTo, noneTo)
import Cherry (mount)
import Cherry.Store as S
import Cherry.Renderer as R
import Cherry.Router (router, navigateTo, goBack)
import PureStyle (getStyle)
import Style (sheet, link)

-- Initialize app
main :: Eff (dom :: DOM, console :: CONSOLE, ref :: REF, exception :: EXCEPTION, history :: HISTORY) Unit
main = do
  renderer <- R.createRenderer "#app" view
  mount store renderer [ route ]

-- Initialize core

store :: forall e. S.Store (ref :: REF | e) State
store = S.createStore initialState

select :: forall e a. (State -> a) -> Eff (ref :: REF | e) a
select = S.select store

reduce :: forall e. (State -> State) -> Eff (ref :: REF | e) Unit
reduce = S.reduce store

-- Router

data Route
  = Home
  | Item Int
  | NotFound

detectRoute :: String -> Route
detectRoute url = fromMaybe NotFound $ match url $
  Home <$ end
  <|>
  Item <$> (lit "items" *> int) <* end

route :: forall e. Eff (dom :: DOM, ref :: REF | e) Unit
route = router (\url -> reduce (\s -> s { route = detectRoute url }))

-- View

view :: forall e. State -> VNode (exception :: EXCEPTION, dom :: DOM, history :: HISTORY, ref :: REF, console :: CONSOLE | e)
view state =
  h "div" []
    [ scene
    , style
    ]
  where
    scene =
      case state.route of
        Home -> home state.message
        Item id -> item id state.count
        NotFound -> notFound

style :: forall e. VNode e
style = h "style" [] [ t styleStr ]
  where
    styleStr = getStyle sheet

home :: forall e. String -> VNode (dom :: DOM, console :: CONSOLE, ref :: REF, history :: HISTORY | e)
home message =
  h "div" []
    [ h "h1" [] [ t "Home" ]
    , h "div" [] [ t message ]
    , h "input"
        [ "type" := "text"
        , "value" := message
        , "onInput" ~> stringTo changeMessage
        ]
        []
    , h "a" [ "class" := link, "onClick" ~> (noneTo $ navigateTo "/items/1") ] [ t "Item 1 " ]
    , h "a" [ "class" := link, "onClick" ~> (noneTo $ navigateTo "/items/2") ] [ t "Item 2 " ]
    , h "a" [ "class" := link, "onClick" ~> (noneTo $ navigateTo "/not_found") ] [ t "404 Not Found" ]
    ]

item :: forall e. Int -> Int -> VNode (dom :: DOM, exception :: EXCEPTION, ref :: REF, history :: HISTORY | e)
item id count =
  h "div" []
    [ h "h1" [] [ t $ "Item " <> show id ]
    , h "div" [ "onClick" ~> noneTo increment ] [ t $ show (count :: Int) ]
    , h "a" [ "onClick" ~> noneTo goBack ] [ t "Back" ]
    ]

notFound :: forall e. VNode e
notFound =
  h "div" []
    [ h "h1" [ "style" := "color: red;" ] [ t "404" ]
    , h "a" [ "href" := "https://github.com/oreshinya/purescript-cherry", "target" := "_blank" ] [ t "Github" ]
    ]

-- Action

increment :: forall e. Eff (ref :: REF, exception :: EXCEPTION | e) Unit
increment = do
  _ <- launchAff $ do
    delay $ Milliseconds 1500.0
    liftEff' $ reduce incr
  pure unit

changeMessage :: forall e. String -> Eff (console :: CONSOLE, ref :: REF | e) Unit
changeMessage content = do
  reduce $ updateMsg content
  cnt <- select _.count
  reduce \s -> s { count = cnt + 1 }
  log "bar"

-- Reducer

incr :: State -> State
incr s = s { count = s.count + 1 }

updateMsg :: String -> State -> State
updateMsg content s = s { message = content }

-- State

type State =
  { route :: Route
  , count :: Int
  , message :: String
  }

initialState :: State
initialState =
  { route: Home
  , count: 0
  , message: ""
  }

module Main where

import Prelude
import Control.Alt ((<|>))
import Control.Monad.Aff (liftEff', launchAff, delay)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import DOM (DOM)
import DOM.HTML.Types (HISTORY)
import Data.Maybe (fromMaybe)
import Data.Time.Duration (Milliseconds(..))
import Data.Tuple.Nested ((/\))
import Rout (match, lit, int, end)
import VOM (VNode, h, t, (:=), (~>), stringTo, noneTo)
import Cherry (mount)
import Cherry.Store as S
import Cherry.Renderer as R
import Cherry.Router (router, navigateTo, goBack)
import PureStyle (getStyle)
import Style (sheet, link)

-- Initialize app
main :: Eff (dom :: DOM, console :: CONSOLE, ref :: REF, exception :: EXCEPTION, history :: HISTORY) Unit
main = do
  renderer <- R.createRenderer "#app" view
  mount store renderer [ route ]

-- Initialize core

store :: forall e. S.Store (ref :: REF | e) State
store = S.createStore initialState

select :: forall e a. (State -> a) -> Eff (ref :: REF | e) a
select = S.select store

reduce :: forall e. (State -> State) -> Eff (ref :: REF | e) Unit
reduce = S.reduce store

-- Router

data Route
  = Home
  | Item Int
  | NotFound

detectRoute :: String -> Route
detectRoute url = fromMaybe NotFound $ match url $
  Home <$ end
  <|>
  Item <$> (lit "items" *> int) <* end

route :: forall e. Eff (dom :: DOM, ref :: REF | e) Unit
route = router (\url -> reduce (\s -> s { route = detectRoute url }))

-- View

view :: forall e. State -> VNode (exception :: EXCEPTION, dom :: DOM, history :: HISTORY, ref :: REF, console :: CONSOLE | e)
view state =
  h "div" []
    [ scene
    , style
    ]
  where
    scene =
      case state.route of
        Home -> home state.message
        Item id -> item id state.count
        NotFound -> notFound

style :: forall e. VNode e
style = h "style" [] [ t styleStr ]
  where
    styleStr = getStyle sheet

home :: forall e. String -> VNode (dom :: DOM, console :: CONSOLE, ref :: REF, history :: HISTORY | e)
home message =
  h "div" []
    [ h "h1" [] [ t "Home" ]
    , h "div" [] [ t message ]
    , h "input"
        [ "type" := "text"
        , "value" := message
        , "onInput" ~> stringTo changeMessage
        ]
        []
    , h "a" [ "class" := link, "onClick" ~> (noneTo $ navigateTo "/items/1") ] [ t "Item 1 " ]
    , h "a" [ "class" := link, "onClick" ~> (noneTo $ navigateTo "/items/2") ] [ t "Item 2 " ]
    , h "a" [ "class" := link, "onClick" ~> (noneTo $ navigateTo "/not_found") ] [ t "404 Not Found" ]
    ]

item :: forall e. Int -> Int -> VNode (dom :: DOM, exception :: EXCEPTION, ref :: REF, history :: HISTORY | e)
item id count =
  h "div" []
    [ h "h1" [] [ t $ "Item " <> show id ]
    , h "div" [ "onClick" ~> noneTo increment ] [ t $ show (count :: Int) ]
    , h "a" [ "onClick" ~> noneTo goBack ] [ t "Back" ]
    ]

notFound :: forall e. VNode e
notFound =
  h "div" []
    [ h "h1" [ "style" := "color: red;" ] [ t "404" ]
    , h "a" [ "href" := "https://github.com/oreshinya/purescript-cherry", "target" := "_blank" ] [ t "Github" ]
    ]

-- Action

increment :: forall e. Eff (ref :: REF, exception :: EXCEPTION | e) Unit
increment = do
  _ <- launchAff $ do
    delay $ Milliseconds 1500.0
    liftEff' $ reduce incr
  pure unit

changeMessage :: forall e. String -> Eff (console :: CONSOLE, ref :: REF | e) Unit
changeMessage content = do
  reduce $ updateMsg content
  cnt <- select _.count
  reduce \s -> s { count = cnt + 1 }
  log "bar"

-- Reducer

incr :: State -> State
incr s = s { count = s.count + 1 }

updateMsg :: String -> State -> State
updateMsg content s = s { message = content }

-- State

type State =
  { route :: Route
  , count :: Int
  , message :: String
  }

initialState :: State
initialState =
  { route: Home
  , count: 0
  , message: ""
  }


Tidy example

Tidy example

module Main where

import FRP
import FRP.Event
import FRP.Event.Time
import FRP.Behavior

import Control.Monad.Eff

foreign import display
  "function display(s) {\
  \  return function() {\
  \    document.body.innerText = s;\
  \  };\
  \}" :: forall eff. String -> Eff eff Unit

every :: Number -> Event Number
every n = fold (\_ n -> n + 1) (interval n) 0

tick :: Number -> Behavior Number
tick n = step 0 (every n)

time = toTime <$> tick millis
              <*> tick seconds
              <*> tick minutes
              <*> tick hours
  where
  millis = 1
  seconds = 1000
  minutes = seconds * 60
  hours = minutes * 60

  toTime ms ss mm hh = show hh <> ":" <>
                       show mm <> ":" <>
                       show ss <> "." <>
                       show ms

main = display `subscribe` (sample' time (every 20))

module Main where

import FRP
import FRP.Event
import FRP.Event.Time
import FRP.Behavior

import Control.Monad.Eff

foreign import display """
  function display(s) {
    return function() {
      document.body.innerText = s;
    };
  }
  """ :: forall eff. String -> Eff eff Unit

every :: Number -> Event Number
every n = fold (\_ n -> n + 1) (interval n) 0

tick :: Number -> Behavior Number
tick n = step 0 (every n)

time = toTime <$> tick millis
              <*> tick seconds
              <*> tick minutes
              <*> tick hours
  where
  millis = 1
  seconds = 1000
  minutes = seconds * 60
  hours = minutes * 60

  toTime ms ss mm hh = show hh <> ":" <>
                       show mm <> ":" <>
                       show ss <> "." <>
                       show ms

main = display `subscribe` (sample' time (every 20))


Explain why `forall proxy. proxy sym` is used instead of Proxy sym

module Data.Symbol
  ( class IsSymbol
  , reflectSymbol
  , reifySymbol
  , SProxy(..)
  ) where

import Type.Proxy (Proxy(..))

-- | A value-level proxy for a type-level symbol.
-- | **Deprecated as of v0.14.0 PureScript release**: use `Type.Proxy` instead.
data SProxy (sym :: Symbol) = SProxy

-- | A class for known symbols
class IsSymbol (sym :: Symbol) where
  -- Note: Before v0.14.0, we did not have polykinds. Thus, we needed
  -- kind-specific proxy types to pass a Symbol around.
  -- Once v0.14.0 was released, we could use the kind-generic `Proxy` type
  -- insteand. However, to reduce the code breakage, we're using
  -- `forall proxy. proxy sym` here so that `SProxy` code will still compile.
  -- When PureScript makes a new breaking release after the v0.14.0 release,
  -- this type signature will be updated to `Proxy sym -> String`.
  reflectSymbol :: forall proxy. proxy sym -> String

-- local definition for use in `reifySymbol`
foreign import unsafeCoerce :: forall a b. a -> b

reifySymbol :: forall r. String -> (forall sym. IsSymbol sym => Proxy sym -> r) -> r
reifySymbol s f = coerce f { reflectSymbol: \_ -> s } Proxy where
  coerce
    :: (forall sym1. IsSymbol sym1              => Proxy sym1 -> r)
    -> { reflectSymbol :: Proxy "" -> String } -> Proxy ""   -> r
  coerce = unsafeCoerce

module Data.Symbol
  ( class IsSymbol
  , reflectSymbol
  , reifySymbol
  , SProxy(..)
  ) where

import Type.Proxy (Proxy(..))

-- | A value-level proxy for a type-level symbol.
-- | **Deprecated as of v0.14.0 PureScript release**: use `Type.Proxy` instead.
data SProxy (sym :: Symbol) = SProxy

-- | A class for known symbols
class IsSymbol (sym :: Symbol) where
  reflectSymbol :: forall proxy. proxy sym -> String

-- local definition for use in `reifySymbol`
foreign import unsafeCoerce :: forall a b. a -> b

reifySymbol :: forall r. String -> (forall sym. IsSymbol sym => Proxy sym -> r) -> r
reifySymbol s f = coerce f { reflectSymbol: \_ -> s } Proxy where
  coerce
    :: (forall sym1. IsSymbol sym1              => Proxy sym1 -> r)
    -> { reflectSymbol :: Proxy "" -> String } -> Proxy ""   -> r
  coerce = unsafeCoerce


Exports previously un-exported constructors.

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination(Pagination)
	, limit
	, skip
	, SortOrder(Ascending, Descending)
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
		( Equals
		, NotEquals
		, LessThan
		, LessThanOrEquals
		, GreaterThan
		, GreaterThanOrEquals
		, SortBy
		, Custom
		, Negate
		)
	, clause
	, LogicConnector(And, Or)
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query(Query)
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity(..)
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right))
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

instance arrayToDBObject :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = toForeign <<< map toDBObject

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy { sortOrder :: SortOrder }
	    | Custom { name      :: String    }
	    | Negate { clause    :: Clause    }

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          =
		"SortBy ({ sortOrder: " <> show s.sortOrder <> " })"
	show (Custom n)          = "Custom ({ name: " <> show n.name <> " })"
	show (Negate c)          =
		"Negate ({ clause: " <> show c.clause <> " })"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy { sortOrder: desc }
	, custom             : getClauseType $ Custom { name: mempty }
	, negate             : getClauseType $ Negate { clause: Equals }
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(t -> Foreign)"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (ToDBObject a) =>
		  Clause                               ->
		  a                                    ->
		  (t -> a)                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right (fn >>> toDBObject)
	}

equals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		  String                           ->
		  e                                ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (ToDBObject e, Eq e) =>
	  e                                ->
	  (t -> e)                         ->
	  Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		 (t -> e)                         ->
		 e                                ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		     String                           ->
		     e                                ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (ToDBObject e, Eq e) =>
	     e                                ->
	     (t -> e)                         ->
	     Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		    (t -> e)                         ->
		    e                                ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (ToDBObject o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		    String                            ->
		    o                                 ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (ToDBObject o, Ord o) =>
	    o                                 ->
	    (t -> o)                          ->
	    Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		   (t -> o)                          ->
		   o                                 ->
		   Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
		     o                                 ->
		     String                            ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			    String                            ->
			    o                                 ->
			    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		    o                                 ->
		    (t -> o)                          ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			   (t -> o)                          ->
			   o                                 ->
			   Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (ToDBObject o, Ord o) =>
		o                                 ->
		String                            ->
		Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		       String                            ->
		       o                                 ->
		       Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (ToDBObject o, Ord o) =>
	       o                                 ->
	       (t -> o)                          ->
	       Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		     (t -> o)                           ->
		     o                                  ->
		     Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
			o                                 ->
			String                            ->
			Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			       String                            ->
			       o                                 ->
			       Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		       o                                 ->
		       (t -> o)                          ->
		       Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			      (t -> o)                          ->
			      o                                 ->
			      Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder ->
	  (t -> Ordering)               ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> toDBObject)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> toDBObject)
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database d datastore where
	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE, ref :: REF | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e t. FromDBObject t =>
		    Maybe Pagination           ->
		    Query datastore t          ->
		    Ref (Collection t)         ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t =>
		    Maybe Pagination            ->
		    Query datastore t           ->
		    Ref (Collection t)          ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t =>
		      Query datastore t          ->
		      Ref (Collection t)         ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t =>
		  t                          ->
		  Ref (Collection t)         ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t =>
		   List t                     ->
		   Ref (Collection t)         ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t =>
		       Query datastore t          ->
		       Ref (Collection t)         ->
		       Eff (db :: DATABASE, ref :: REF | e) b

module Abstract.Database
	( DATABASE
	, CollectionImpl
	, class ToDBObject
	, toDBObject
	, class FromDBObject
	, fromDBObject
	, class IsDBObject
	, Collection
	, Pagination
	, limit
	, skip
	, SortOrder
	, asc
	, desc
	, sortOrder
	, getClauseType
	, Clause
	, clause
	, LogicConnector
	, logicConnector
	, Predicate
	, SQL
	, Native
	, Query
	, ordering
	, equals'
	, equals'Flipped
	, (==..)
	, equals
	, equalsFlipped
	, (==.)
	, notEquals'
	, notEquals'Flipped
	, (/=..)
	, (!=..)
	, notEquals
	, notEqualsFlipped
	, (/=.)
	, (!=.)
	, lessThan'
	, lessThan'Flipped
	, (<..)
	, lessThan
	, lessThanFlipped
	, (<.)
	, lessThanOrEquals'
	, lessThanOrEquals'Flipped
	, (<=..)
	, lessThanOrEquals
	, lessThanOrEqualsFlipped
	, (<=.)
	, greaterThan'
	, greaterThan'Flipped
	, (>..)
	, greaterThan
	, greaterThanFlipped
	, (>.)
	, greaterThanOrEquals'
	, greaterThanOrEquals'Flipped
	, (>=..)
	, greaterThanOrEquals
	, greaterThanOrEqualsFlipped
	, (>=.)
	, sortBy'
	, sortBy
	, custom'
	, custom
	, Entity
	, class Database
	, createCollection
	, getCollection
	, deleteCollection
	, getWhere
	, getWhere'
	, countWhere
	, insert
	, insert'
	, deleteWhere
	) where

import Prelude
	( class Eq
	, class Functor
	, class Ord
	, class Semigroup
	, class Show
	, Ordering(EQ, GT, LT)
	, Unit
	, compare
	, flip
	, map
	, negate
	, show
	, zero
	, ($)
	, (&&)
	, (<>)
	, (==)
	, (>=>)
	, (<<<)
	, (>>>)
	)

import Control.Alt           (class Alt, (<|>))
import Control.Monad.Eff     (Eff)
import Control.Monad.Eff.Ref (REF, Ref)
import Control.Monad.Except  (mapExcept)
import Data.Array            (length, range, zipWith)
import Data.Foreign
	( F
	, Foreign
	, ForeignError(ErrorAtIndex)
	, readArray
	, toForeign
	)
import Data.Bifunctor        (lmap)
import Data.Foreign.Class    (read, write)
import Data.Foreign.Null     (Null(Null), readNull, writeNull)
import Data.Foreign.NullOrUndefined
	( NullOrUndefined(NullOrUndefined)
	, readNullOrUndefined
	)
import Data.Foreign.Undefined
	( Undefined(Undefined)
	, readUndefined
	, writeUndefined
	)
import Data.Either           (Either(Left, Right))
import Data.List             (List, singleton, uncons)
import Data.Maybe            (Maybe(Just, Nothing), maybe)
import Data.Monoid           (class Monoid, mempty)
import Data.Traversable      (sequence)
import Unsafe.Coerce         (unsafeCoerce)

foreign import data DATABASE       :: !
foreign import data CollectionImpl :: *

class FromDBObject a where
	fromDBObject :: Foreign -> F a

instance booleanFromDBObject :: FromDBObject Boolean where
	fromDBObject = read

instance intFromDBObject :: FromDBObject Int where
	fromDBObject = read

instance numberFromDBObject :: FromDBObject Number where
	fromDBObject = read

instance charFromDBObject :: FromDBObject Char where
	fromDBObject = read

instance stringFromDBObject :: FromDBObject String where
	fromDBObject = read

instance foreignFromDBObject :: FromDBObject Foreign where
	fromDBObject = read

instance nullFromDBObject :: FromDBObject a => FromDBObject (Null a) where
	fromDBObject = readNull fromDBObject

instance undefinedFromDBObject :: FromDBObject a => FromDBObject (Undefined a) where
	fromDBObject = readUndefined fromDBObject

instance nullOrUndefinedFromDBObject :: FromDBObject a => FromDBObject (NullOrUndefined a) where
	fromDBObject = readNullOrUndefined fromDBObject

instance arrayFromDBObject :: FromDBObject a => FromDBObject (Array a) where
	fromDBObject = readArray >=> fromDBObjectElements
		where
			fromDBObjectWith f          = mapExcept (lmap f) <<< fromDBObject
			fromDBObjectElement i value = fromDBObjectWith (map (ErrorAtIndex i)) value
			fromDBObjectElements arr    = sequence (zipWith fromDBObjectElement (range zero (length arr)) arr)

class ToDBObject a where
	toDBObject :: a -> Foreign

instance booleanToDBObject :: ToDBObject Boolean where
	toDBObject = write

instance intToDBObject :: ToDBObject Int where
	toDBObject = write

instance numberToDBObject :: ToDBObject Number where
	toDBObject = write

instance charToDBObject :: ToDBObject Char where
	toDBObject = write

instance stringToDBObject :: ToDBObject String where
	toDBObject = write

instance foreignToDBObject :: ToDBObject Foreign where
	toDBObject = write

instance nullToDBObject :: ToDBObject a => ToDBObject (Null a) where
	toDBObject (Null a) = maybe writeNull toDBObject a

instance undefinedToDBObject :: ToDBObject a => ToDBObject (Undefined a) where
	toDBObject (Undefined a) = maybe writeUndefined toDBObject a

instance nullOrUndefinedToDBObject :: ToDBObject a => ToDBObject (NullOrUndefined a) where
	toDBObject (NullOrUndefined a) = toDBObject (Null a)

instance arrayToDBObject :: ToDBObject a => ToDBObject (Array a) where
	toDBObject = toForeign <<< map toDBObject

class (FromDBObject a, ToDBObject a) <= IsDBObject a

instance booleanIsDBObject :: IsDBObject Boolean

instance intIsDBObject :: IsDBObject Int

instance numberIsDBObject :: IsDBObject Number

instance charIsDBObject :: IsDBObject Char

instance stringIsDBObject :: IsDBObject String

instance foreignIsDBObject :: IsDBObject Foreign

instance nullIsDBObject :: IsDBObject a => IsDBObject (Null a)

instance undefinedIsDBObject :: IsDBObject a => IsDBObject (Undefined a)

instance nullOrUndefinedIsDBObject :: IsDBObject a => IsDBObject (NullOrUndefined a)

instance arrayIsDBObject :: IsDBObject a => IsDBObject (Array a)

type Collection t = { collectionImpl :: CollectionImpl }

newtype Pagination = Pagination
	{ skip   :: Maybe Int
	, limit  :: Maybe Int
	}

instance showPagination :: Show Pagination where
	show (Pagination p) = "(Pagination {"
		<> " skip: "   <> show p.skip
		<> ", limit: " <> show p.limit
		<> " })"

instance eqPagination :: Eq Pagination where
	eq p1 p2 = show p1 == show p2

instance ordPagination :: Ord Pagination where
	compare p1 p2 = compare (show p1) (show p2)

instance semigroupPagination :: Semigroup Pagination where
	append (Pagination p1) (Pagination p2) = Pagination
		{ skip: p2.skip     <|> p1.skip   <|> Nothing
		, limit : p2.limit  <|> p1.limit  <|> Nothing
		}

defPagination :: { skip :: Maybe Int, limit :: Maybe Int }
defPagination =
	{ skip : Nothing
	, limit: Nothing
	}

instance monoidPagination :: Monoid Pagination where
	mempty = Pagination defPagination

limit :: Int -> Maybe Pagination
limit l = Just $ Pagination defPagination { limit = Just l }

skip :: Int -> Maybe Pagination
skip o = Just $ Pagination defPagination { skip = Just o }

data SortOrder = Ascending | Descending

instance showSortOrder :: Show SortOrder where
	show Ascending  = "Ascending"
	show Descending = "Descending"

instance eqSortOrder :: Eq SortOrder where
	eq Ascending  Ascending  = true
	eq Descending Descending = true
	eq _          _          = false

instance ordSortOrder :: Ord SortOrder where
	compare Descending Ascending  = LT
	compare Ascending  Descending = GT
	compare _          _          = EQ

asc :: SortOrder
asc = Ascending

desc :: SortOrder
desc = Descending

sortOrder:: { asc :: SortOrder, desc :: SortOrder }
sortOrder =
	{ asc : Ascending
	, desc: Descending
	}

data Clause = Equals
	    | NotEquals
	    | LessThan
	    | LessThanOrEquals
	    | GreaterThan
	    | GreaterThanOrEquals
	    | SortBy { sortOrder :: SortOrder }
	    | Custom { name      :: String    }
	    | Negate { clause    :: Clause    }

instance showClause :: Show Clause where
	show Equals              = "Equals"
	show NotEquals           = "NotEquals"
	show LessThan            = "LessThan"
	show LessThanOrEquals    = "LessThanOrEquals"
	show GreaterThan         = "GreaterThan"
	show GreaterThanOrEquals = "GreaterThanOrEquals"
	show (SortBy s)          =
		"SortBy ({ sortOrder: " <> show s.sortOrder <> " })"
	show (Custom n)          = "Custom ({ name: " <> show n.name <> " })"
	show (Negate c)          =
		"Negate ({ clause: " <> show c.clause <> " })"

instance eqClause :: Eq Clause where
	eq c1 c2 = show c1 == show c2

getClauseType :: Clause -> String
getClauseType Equals              = "Equals"
getClauseType NotEquals           = "NotEquals"
getClauseType LessThan            = "LessThan"
getClauseType LessThanOrEquals    = "LessThanOrEquals"
getClauseType GreaterThan         = "GreaterThan"
getClauseType GreaterThanOrEquals = "GreaterThanOrEquals"
getClauseType (SortBy _)          = "SortBy"
getClauseType (Custom _)          = "Custom"
getClauseType (Negate _)          = "Negate"

clause :: { equals              :: String
	  , notEquals           :: String
	  , lessThan            :: String
	  , lessThanOrEquals    :: String
	  , greaterThan         :: String
	  , greaterThanOrEquals :: String
	  , sortBy              :: String
	  , custom              :: String
	  , negate              :: String
	  }
clause =
	{ equals             : getClauseType Equals
	, notEquals          : getClauseType NotEquals
	, lessThan           : getClauseType LessThan
	, lessThanOrEquals   : getClauseType LessThanOrEquals
	, greaterThan        : getClauseType GreaterThan
	, greaterThanOrEquals: getClauseType GreaterThanOrEquals
	, sortBy             : getClauseType $ SortBy { sortOrder: desc }
	, custom             : getClauseType $ Custom { name: mempty }
	, negate             : getClauseType $ Negate { clause: Equals }
	}

data LogicConnector = And | Or

logicConnector :: { and :: LogicConnector, or :: LogicConnector }
logicConnector =
	{ and: And
	, or : Or
	}

instance showLogicConnector :: Show LogicConnector where
	show And = "And"
	show Or  = "Or"

instance eqLogicConnector :: Eq LogicConnector where
	eq And And = true
	eq Or  Or  = true
	eq _   _   = false

type Predicate t =
	{ clause         :: Clause
	, logicConnector :: LogicConnector
	, clauseValue    :: Foreign
	, predicate      :: Either String (t -> Foreign)
	}

showPredicate :: forall t. Predicate t -> String
showPredicate p = "({"
	<> " clause: "          <> show p.clause
	<> ", logicConnector: " <> show p.logicConnector
	<> ", clauseValue: "    <> "(Foreign)"
	<> ", predicate: "      <> "(t -> Foreign)"
	<> " })"

data SQL
data Native

data Query datastore t = Query (List (Predicate t))

instance showQuery :: Show (Query datastore t) where
	show (Query l) =
		"(Query (datastore) " <> show (map showPredicate l) <> ")"

instance semigroupQuery :: Semigroup (Query datastore t) where
	append (Query l1) (Query l2) = Query (l1 <> l2)

instance monoidQuery :: Monoid (Query datastore t) where
	mempty = Query mempty

instance functorQuery :: Functor (Query datastore) where
	map _ q = unsafeCoerce q -- Father, forgive me.

instance altQuery :: Alt (Query datastore) where
	alt (Query l1) (Query l2) =
		case uncons l2 of
			Just { head, tail } ->
				Query (l1 <> connectorToOr head <> tail)
			Nothing             -> Query l1
		where
			connectorToOr = singleton <<< _ { logicConnector = Or }

orderingToInt :: Ordering -> Int
orderingToInt LT = -1
orderingToInt EQ = 0
orderingToInt GT = 1

ordering :: { lt :: Int, eq :: Int, gt :: Int }
ordering =
	{ lt: orderingToInt LT
	, eq: orderingToInt EQ
	, gt: orderingToInt GT
	}

leftPredicate :: forall t a datastore. (ToDBObject a) =>
		 Clause                               ->
		 a                                    ->
		 String                               ->
		 Query datastore t
leftPredicate clause_ clauseValue fieldName = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Left fieldName
	}

rightPredicate :: forall t a datastore. (ToDBObject a) =>
		  Clause                               ->
		  a                                    ->
		  (t -> a)                             ->
		  Query datastore t
rightPredicate clause_ clauseValue fn = Query $ singleton $
	{ clause        : clause_
	, logicConnector: And
	, clauseValue   : toDBObject clauseValue
	, predicate     : Right (fn >>> toDBObject)
	}

equals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
equals' = leftPredicate Equals

equals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		  String                           ->
		  e                                ->
		  Query SQL t
equals'Flipped = flip equals'
infix 4 equals'Flipped as ==..

equals :: forall t e. (ToDBObject e, Eq e) =>
	  e                                ->
	  (t -> e)                         ->
	  Query Native t
equals = rightPredicate Equals

equalsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		 (t -> e)                         ->
		 e                                ->
		 Query Native t
equalsFlipped = flip equals
infix 4 equalsFlipped as ==.

notEquals' :: forall t e. (ToDBObject e, Eq e) => e -> String -> Query SQL t
notEquals' = leftPredicate NotEquals

notEquals'Flipped :: forall t e. (ToDBObject e, Eq e) =>
		     String                           ->
		     e                                ->
		     Query SQL t
notEquals'Flipped = flip notEquals'
infix 4 notEquals'Flipped as /=..
infix 4 notEquals'Flipped as !=..

notEquals :: forall t e. (ToDBObject e, Eq e) =>
	     e                                ->
	     (t -> e)                         ->
	     Query Native t
notEquals = rightPredicate NotEquals

notEqualsFlipped :: forall t e. (ToDBObject e, Eq e) =>
		    (t -> e)                         ->
		    e                                ->
		    Query Native t
notEqualsFlipped = flip notEquals
infix 4 notEquals' as /=.
infix 4 notEquals' as !=.

lessThan' :: forall t o. (ToDBObject o, Ord o) => o -> String -> Query SQL t
lessThan' = leftPredicate LessThan

lessThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		    String                            ->
		    o                                 ->
		    Query SQL t
lessThan'Flipped = flip lessThan'
infixl 4 lessThan'Flipped as <..

lessThan :: forall t o. (ToDBObject o, Ord o) =>
	    o                                 ->
	    (t -> o)                          ->
	    Query Native t
lessThan = rightPredicate LessThan

lessThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		   (t -> o)                          ->
		   o                                 ->
		   Query Native t
lessThanFlipped = flip lessThan
infixl 4 lessThanFlipped as <.

lessThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
		     o                                 ->
		     String                            ->
		     Query SQL t
lessThanOrEquals' = leftPredicate LessThanOrEquals

lessThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			    String                            ->
			    o                                 ->
			    Query SQL t
lessThanOrEquals'Flipped = flip lessThanOrEquals'
infixl 4 lessThanOrEquals'Flipped as <=..

lessThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		    o                                 ->
		    (t -> o)                          ->
		    Query Native t
lessThanOrEquals = rightPredicate LessThanOrEquals

lessThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			   (t -> o)                          ->
			   o                                 ->
			   Query Native t
lessThanOrEqualsFlipped = flip lessThanOrEquals
infixl 4 lessThanOrEqualsFlipped as <=.

greaterThan' :: forall t o. (ToDBObject o, Ord o) =>
		o                                 ->
		String                            ->
		Query SQL t
greaterThan' = leftPredicate GreaterThan

greaterThan'Flipped :: forall t o. (ToDBObject o, Ord o) =>
		       String                            ->
		       o                                 ->
		       Query SQL t
greaterThan'Flipped = flip greaterThan'
infixl 4 greaterThan'Flipped as >..

greaterThan :: forall t o. (ToDBObject o, Ord o) =>
	       o                                 ->
	       (t -> o)                          ->
	       Query Native t
greaterThan = rightPredicate GreaterThan

greaterThanFlipped :: forall t o. (ToDBObject o, Ord o) =>
		     (t -> o)                           ->
		     o                                  ->
		     Query Native t
greaterThanFlipped = flip greaterThan
infixl 4 greaterThanFlipped as >.

greaterThanOrEquals' :: forall t o. (ToDBObject o, Ord o) =>
			o                                 ->
			String                            ->
			Query SQL t
greaterThanOrEquals' = leftPredicate GreaterThanOrEquals

greaterThanOrEquals'Flipped :: forall t o. (ToDBObject o, Ord o) =>
			       String                            ->
			       o                                 ->
			       Query SQL t
greaterThanOrEquals'Flipped = flip greaterThanOrEquals'
infixl 4 greaterThanOrEquals'Flipped as >=..

greaterThanOrEquals :: forall t o. (ToDBObject o, Ord o) =>
		       o                                 ->
		       (t -> o)                          ->
		       Query Native t
greaterThanOrEquals = rightPredicate GreaterThanOrEquals

greaterThanOrEqualsFlipped :: forall t o. (ToDBObject o, Ord o) =>
			      (t -> o)                          ->
			      o                                 ->
			      Query Native t
greaterThanOrEqualsFlipped = flip greaterThanOrEquals
infixl 4 greaterThanOrEqualsFlipped as >=.

sortBy' :: forall datastore t. SortOrder -> String -> Query datastore t
sortBy' order fieldName = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left fieldName
	}

sortBy :: forall datastore t. SortOrder ->
	  (t -> Ordering)               ->
	  Query datastore t
sortBy order fn = Query $ singleton $
	{ clause        : SortBy { sortOrder: order }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> orderingToInt >>> toDBObject)
	}

custom' :: forall t. String -> String -> Query SQL t
custom' name p = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Left p
	}

custom :: forall t. String -> (t -> Boolean) -> Query Native t
custom name fn = Query $ singleton $
	{ clause        : Custom { name }
	, logicConnector: And
	, clauseValue   : writeUndefined
	, predicate     : Right (fn >>> toDBObject)
	}

data Entity key a = Entity key a | Entity' a

instance showEntity :: (Show key, Show a) => Show (Entity key a) where
	show (Entity key a) = "(Entity"
		<> " (" <> show key <> ")"
		<> " (" <> show a   <> ")"
		<> ")"
	show (Entity' a)     = "(Entity' (" <> show a <> "))"

instance eqEntity :: (Eq key, Eq a) => Eq (Entity key a) where
	eq (Entity k1 a1) (Entity k2 a2) = k1 == k2 && a1 == a2
	eq (Entity'   a1) (Entity'   a2) = a1 == a2
	eq              _              _ = false

instance ordEntity :: (Ord key, Ord a) => Ord (Entity key a) where
	compare (Entity k1 a1) (Entity k2 a2) = compare k1 k2 <> compare a1 a2
	compare (Entity'   a1) (Entity'   a2) = compare a1 a2
	-- I'm not entirely sure how an Entity with a key can be 'greater' than
	-- one without, but I've just decided to choose this implementation and
	-- stick with it.
	compare (Entity'    _) (Entity _   _) = LT
	compare (Entity _   _) (Entity'    _) = GT

class Database d datastore where
	createCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit
	getCollection    :: forall e t. String ->
			    Eff (db :: DATABASE, ref :: REF | e) (Ref (Collection t))
	deleteCollection :: forall e. String   -> Eff (db :: DATABASE | e) Unit

	getWhere :: forall e t. FromDBObject t =>
		    Maybe Pagination           ->
		    Query datastore t          ->
		    Ref (Collection t)         ->
		    Eff (db :: DATABASE, ref :: REF | e) (Maybe t)

	getWhere' :: forall e t. FromDBObject t =>
		    Maybe Pagination            ->
		    Query datastore t           ->
		    Ref (Collection t)          ->
		    Eff (db :: DATABASE, ref :: REF | e) (List t)

	countWhere :: forall e t. FromDBObject t =>
		      Query datastore t          ->
		      Ref (Collection t)         ->
		      Eff (db :: DATABASE, ref :: REF | e) Int

	insert :: forall e t b. ToDBObject t =>
		  t                          ->
		  Ref (Collection t)         ->
		  Eff (db :: DATABASE, ref :: REF | e) b

	insert' :: forall e t b. ToDBObject t =>
		   List t                     ->
		   Ref (Collection t)         ->
		   Eff (db :: DATABASE, ref :: REF | e) b

	deleteWhere :: forall e t b. ToDBObject t =>
		       Query datastore t          ->
		       Ref (Collection t)         ->
		       Eff (db :: DATABASE, ref :: REF | e) b