Remove unused i from QueryBox

Remove unused i from QueryBox

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.InputF (RefLabel)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)

newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

newtype UnpackQuery ps g o f b =
  UnpackQuery (forall slot m. Applicative m => (slot g o -> m b) -> SlotStorage ps slot -> m (f b))

type QueryBox' ps g o a f b =
  { unpack :: UnpackQuery ps g o f b
  , query :: g b
  , reply :: f b -> a
  }

data QueryBox (ps :: # Type) a

mkQuery' :: forall ps g o a f b. QueryBox' ps g o a f b -> QueryBox ps a
mkQuery' = unsafeCoerce

unQuery :: forall ps a r. (forall g o f b. QueryBox' ps g o a f b -> r) -> QueryBox ps a -> r
unQuery = unsafeCoerce

-- | The Halogen component algebra
data HalogenF s act ps o m a
  = State (s -> Tuple a s)
  | Subscribe (SubscriptionId -> ES.EventSource m act) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | Halt String
  | ChildQuery (QueryBox ps a)
  | Raise o a
  | Par (HalogenAp s act ps o m a)
  | Fork (FF.Fork (HalogenM' s act ps o m) a)
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s act ps o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes a -> Subscribe fes (map f a)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery (unQuery (\cq' -> mkQuery' $ cq' { reply = cq'.reply >>> f }) cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork fa -> Fork (map f fa)
    GetRef p k -> GetRef p (map f k)

newtype HalogenAp s act ps o m a = HalogenAp (FreeAp (HalogenM' s act ps o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f ps o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f ps o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f ps o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f ps o m)

newtype HalogenM' s act ps o m a = HalogenM (Free (HalogenF s act ps o m) a)

type HalogenM s act = HalogenM' s (act Unit)

instance functorHalogenM :: Functor (HalogenM' s act ps o m) where
  map f (HalogenM fa) = HalogenM (map f fa)

instance applyHalogenM :: Apply (HalogenM' s act ps o m) where
  apply (HalogenM fa) (HalogenM fb) = HalogenM (apply fa fb)

instance applicativeHalogenM :: Applicative (HalogenM' s act ps o m) where
  pure a = HalogenM (pure a)

instance bindHalogenM :: Bind (HalogenM' s act ps o m) where
  bind (HalogenM fa) f = HalogenM (fa >>= \x -> case f x of HalogenM fb -> fb)

instance monadHalogenM :: Monad (HalogenM' s act ps o m)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM' s act ps o m) where
  liftEffect eff = HalogenM $ liftF $ Lift $ liftEffect eff

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM' s act ps o m) where
  liftAff aff = HalogenM $ liftF $ Lift $ liftAff aff

instance parallelHalogenM :: Parallel (HalogenAp s act ps o m) (HalogenM' s act ps o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM' s act ps o) where
  lift m = HalogenM $ liftF $ Lift m

instance monadRecHalogenM :: MonadRec (HalogenM' s act ps o m) where
  tailRecM k a = k a >>= go
    where
    go (Loop x) = tailRecM k x
    go (Done y) = pure y

instance monadStateHalogenM :: MonadState s (HalogenM' s act ps o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM' s act ps o m) where
  ask = HalogenM $ liftF $ Lift $ ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM' s act ps o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

halt :: forall s act ps o m a. String -> HalogenM' s act ps o m a
halt msg = HalogenM $ liftF $ Halt msg

-- | Subscribes a component to an `EventSource`.
subscribe :: forall s act ps o m. ES.EventSource m act -> HalogenM' s act ps o m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
subscribe' :: forall s act ps o m. (SubscriptionId -> ES.EventSource m act) -> HalogenM' s act ps o m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

unsubscribe :: forall s act ps o m. SubscriptionId -> HalogenM' s act ps o m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> f a
  -> HalogenM' s act ps o m (Maybe a)
query sym p q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.lookup sym p >>> traverse k
  , query: q
  , reply: identity
  }

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> f a
  -> HalogenM' s act ps o m (Map p a)
queryAll sym q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.slots sym >>> traverse k
  , query: q
  , reply: identity
  }

getRef :: forall s act ps o m. RefLabel -> HalogenM' s act ps o m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

-- | Raises an output message for the component.
raise :: forall s act ps o m. o -> HalogenM' s act ps o m Unit
raise o = HalogenM $ liftF $ Raise o unit

fork :: forall s act ps o m a. MonadAff m => HalogenM' s act ps o m a -> HalogenM' s act ps o m (Error -> m Unit)
fork a = map liftAff <$> HalogenM (liftF $ Fork $ FF.fork a)

imapState
  :: forall s s' act ps o m
   . (s -> s')
  -> (s' -> s)
  -> HalogenM' s act ps o m
  ~> HalogenM' s' act ps o m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s' act ps o m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork fo -> Fork (FF.hoistFork (imapState f f') fo)
    GetRef p k -> GetRef p k

mapMessage
  :: forall s act act' ps o m
   . Functor m
  => (act -> act')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act' ps o m
mapMessage f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act' ps o m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe (map f <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapMessage f)) p)
    Fork fo -> Fork (FF.hoistFork (mapMessage f) fo)
    GetRef p k -> GetRef p k

mapOutput
  :: forall s act ps o o' m
   . (o -> o')
  -> HalogenM' s act ps o  m
  ~> HalogenM' s act ps o' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o' m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork fo -> Fork (FF.hoistFork (mapOutput f) fo)
    GetRef p k -> GetRef p k

hoist
  :: forall s act ps o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o m'
  go = case _ of
    State f -> State f
    Subscribe fes a -> Subscribe (ES.hoist nat <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork fo -> Fork (FF.hoistFork (hoist nat) fo)
    GetRef p k -> GetRef p k

module Halogen.Query.HalogenM where

import Prelude

import Control.Applicative.Free (FreeAp, liftFreeAp, hoistFreeAp)
import Control.Monad.Free (Free, hoistFree, liftF)
import Control.Monad.Reader.Class (class MonadAsk, ask)
import Control.Monad.Rec.Class (class MonadRec, tailRecM, Step(..))
import Control.Monad.State.Class (class MonadState)
import Control.Monad.Trans.Class (class MonadTrans)
import Control.Monad.Writer.Class (class MonadTell, tell)
import Control.Parallel.Class (class Parallel)
import Data.Bifunctor (lmap)
import Data.Map (Map)
import Data.Maybe (Maybe)
import Data.Newtype (class Newtype, over)
import Data.Symbol (class IsSymbol, SProxy)
import Data.Traversable (traverse)
import Data.Tuple (Tuple)
import Effect.Aff.Class (class MonadAff, liftAff)
import Effect.Class (class MonadEffect, liftEffect)
import Effect.Exception (Error)
import Halogen.Data.Slot (Slot, SlotStorage)
import Halogen.Data.Slot as Slot
import Halogen.Query.EventSource as ES
import Halogen.Query.ForkF as FF
import Halogen.Query.InputF (RefLabel)
import Prim.Row as Row
import Unsafe.Coerce (unsafeCoerce)
import Web.DOM (Element)

newtype SubscriptionId = SubscriptionId Int

derive newtype instance eqSubscriptionId :: Eq SubscriptionId
derive newtype instance ordSubscriptionId :: Ord SubscriptionId

newtype UnpackQuery ps g i o f b =
  UnpackQuery (forall slot m. Applicative m => (slot g o -> m b) -> SlotStorage ps slot -> m (f b))

type QueryBox' ps g i o a f b =
  { unpack :: UnpackQuery ps g i o f b
  , query :: g b
  , reply :: f b -> a
  }

data QueryBox (ps :: # Type) a

mkQuery' :: forall ps g i o a f b. QueryBox' ps g i o a f b -> QueryBox ps a
mkQuery' = unsafeCoerce

unQuery :: forall ps a r. (forall g i o f b. QueryBox' ps g i o a f b -> r) -> QueryBox ps a -> r
unQuery = unsafeCoerce

-- | The Halogen component algebra
data HalogenF s act ps o m a
  = State (s -> Tuple a s)
  | Subscribe (SubscriptionId -> ES.EventSource m act) (SubscriptionId -> a)
  | Unsubscribe SubscriptionId a
  | Lift (m a)
  | Halt String
  | ChildQuery (QueryBox ps a)
  | Raise o a
  | Par (HalogenAp s act ps o m a)
  | Fork (FF.Fork (HalogenM' s act ps o m) a)
  | GetRef RefLabel (Maybe Element -> a)

instance functorHalogenF :: Functor m => Functor (HalogenF s act ps o m) where
  map f = case _ of
    State k -> State (lmap f <<< k)
    Subscribe fes a -> Subscribe fes (map f a)
    Unsubscribe sid a -> Unsubscribe sid (f a)
    Lift q -> Lift (map f q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery (unQuery (\cq' -> mkQuery' $ cq' { reply = cq'.reply >>> f }) cq)
    Raise o a -> Raise o (f a)
    Par pa -> Par (map f pa)
    Fork fa -> Fork (map f fa)
    GetRef p k -> GetRef p (map f k)

newtype HalogenAp s act ps o m a = HalogenAp (FreeAp (HalogenM' s act ps o m) a)

derive instance newtypeHalogenAp :: Newtype (HalogenAp s f ps o m a) _
derive newtype instance functorHalogenAp :: Functor (HalogenAp s f ps o m)
derive newtype instance applyHalogenAp :: Apply (HalogenAp s f ps o m)
derive newtype instance applicativeHalogenAp :: Applicative (HalogenAp s f ps o m)

newtype HalogenM' s act ps o m a = HalogenM (Free (HalogenF s act ps o m) a)

type HalogenM s act = HalogenM' s (act Unit)

instance functorHalogenM :: Functor (HalogenM' s act ps o m) where
  map f (HalogenM fa) = HalogenM (map f fa)

instance applyHalogenM :: Apply (HalogenM' s act ps o m) where
  apply (HalogenM fa) (HalogenM fb) = HalogenM (apply fa fb)

instance applicativeHalogenM :: Applicative (HalogenM' s act ps o m) where
  pure a = HalogenM (pure a)

instance bindHalogenM :: Bind (HalogenM' s act ps o m) where
  bind (HalogenM fa) f = HalogenM (fa >>= \x -> case f x of HalogenM fb -> fb)

instance monadHalogenM :: Monad (HalogenM' s act ps o m)

instance monadEffectHalogenM :: MonadEffect m => MonadEffect (HalogenM' s act ps o m) where
  liftEffect eff = HalogenM $ liftF $ Lift $ liftEffect eff

instance monadAffHalogenM :: MonadAff m => MonadAff (HalogenM' s act ps o m) where
  liftAff aff = HalogenM $ liftF $ Lift $ liftAff aff

instance parallelHalogenM :: Parallel (HalogenAp s act ps o m) (HalogenM' s act ps o m) where
  parallel = HalogenAp <<< liftFreeAp
  sequential = HalogenM <<< liftF <<< Par

instance monadTransHalogenM :: MonadTrans (HalogenM' s act ps o) where
  lift m = HalogenM $ liftF $ Lift m

instance monadRecHalogenM :: MonadRec (HalogenM' s act ps o m) where
  tailRecM k a = k a >>= go
    where
    go (Loop x) = tailRecM k x
    go (Done y) = pure y

instance monadStateHalogenM :: MonadState s (HalogenM' s act ps o m) where
  state = HalogenM <<< liftF <<< State

instance monadAskHalogenM :: MonadAsk r m => MonadAsk r (HalogenM' s act ps o m) where
  ask = HalogenM $ liftF $ Lift $ ask

instance monadTellHalogenM :: MonadTell w m => MonadTell w (HalogenM' s act ps o m) where
  tell = HalogenM <<< liftF <<< Lift <<< tell

halt :: forall s act ps o m a. String -> HalogenM' s act ps o m a
halt msg = HalogenM $ liftF $ Halt msg

-- | Subscribes a component to an `EventSource`.
subscribe :: forall s act ps o m. ES.EventSource m act -> HalogenM' s act ps o m SubscriptionId
subscribe es = HalogenM $ liftF $ Subscribe (\_ -> es) identity

-- | An alternative to `subscribe`, intended for subscriptions that unsubscribe
-- | themselves. Instead of returning the `SubscriptionId` from `subscribe'`, it
-- | is passed into an `EventSource` constructor. This allows emitted queries
-- | to include the `SubscriptionId`, rather than storing it in the state of the
-- | component.
subscribe' :: forall s act ps o m. (SubscriptionId -> ES.EventSource m act) -> HalogenM' s act ps o m Unit
subscribe' esc = HalogenM $ liftF $ Subscribe esc (const unit)

unsubscribe :: forall s act ps o m. SubscriptionId -> HalogenM' s act ps o m Unit
unsubscribe sid = HalogenM $ liftF $ Unsubscribe sid unit

-- | Sends a query to a child of a component at the specified slot.
query
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> p
  -> f a
  -> HalogenM' s act ps o m (Maybe a)
query sym p q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.lookup sym p >>> traverse k
  , query: q
  , reply: identity
  }

-- | Sends a query to all children of a component at a given slot label.
queryAll
  :: forall s act o m sym px ps f o' p a
   . Row.Cons sym (Slot f o' p) px ps
  => IsSymbol sym
  => Ord p
  => SProxy sym
  -> f a
  -> HalogenM' s act ps o m (Map p a)
queryAll sym q = HalogenM $ liftF $ ChildQuery $ mkQuery'
  { unpack: UnpackQuery \k -> Slot.slots sym >>> traverse k
  , query: q
  , reply: identity
  }

getRef :: forall s act ps o m. RefLabel -> HalogenM' s act ps o m (Maybe Element)
getRef p = HalogenM $ liftF $ GetRef p identity

-- | Raises an output message for the component.
raise :: forall s act ps o m. o -> HalogenM' s act ps o m Unit
raise o = HalogenM $ liftF $ Raise o unit

fork :: forall s act ps o m a. MonadAff m => HalogenM' s act ps o m a -> HalogenM' s act ps o m (Error -> m Unit)
fork a = map liftAff <$> HalogenM (liftF $ Fork $ FF.fork a)

imapState
  :: forall s s' act ps o m
   . (s -> s')
  -> (s' -> s)
  -> HalogenM' s act ps o m
  ~> HalogenM' s' act ps o m
imapState f f' (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s' act ps o m
  go = case _ of
    State fs -> State (map f <<< fs <<< f')
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (imapState f f')) p)
    Fork fo -> Fork (FF.hoistFork (imapState f f') fo)
    GetRef p k -> GetRef p k

mapMessage
  :: forall s act act' ps o m
   . Functor m
  => (act -> act')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act' ps o m
mapMessage f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act' ps o m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe (map f <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapMessage f)) p)
    Fork fo -> Fork (FF.hoistFork (mapMessage f) fo)
    GetRef p k -> GetRef p k

mapOutput
  :: forall s act ps o o' m
   . (o -> o')
  -> HalogenM' s act ps o  m
  ~> HalogenM' s act ps o' m
mapOutput f (HalogenM h) = HalogenM (hoistFree go h)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o' m
  go = case _ of
    State fs -> State fs
    Subscribe fes a -> Subscribe fes a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift q
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise (f o) a
    Par p -> Par (over HalogenAp (hoistFreeAp (mapOutput f)) p)
    Fork fo -> Fork (FF.hoistFork (mapOutput f) fo)
    GetRef p k -> GetRef p k

hoist
  :: forall s act ps o m m'
   . Functor m'
  => (m ~> m')
  -> HalogenM' s act ps o m
  ~> HalogenM' s act ps o m'
hoist nat (HalogenM fa) = HalogenM (hoistFree go fa)
  where
  go :: HalogenF s act ps o m ~> HalogenF s act ps o m'
  go = case _ of
    State f -> State f
    Subscribe fes a -> Subscribe (ES.hoist nat <<< fes) a
    Unsubscribe sid a -> Unsubscribe sid a
    Lift q -> Lift (nat q)
    Halt msg -> Halt msg
    ChildQuery cq -> ChildQuery cq
    Raise o a -> Raise o a
    Par p -> Par (over HalogenAp (hoistFreeAp (hoist nat)) p)
    Fork fo -> Fork (FF.hoistFork (hoist nat) fo)
    GetRef p k -> GetRef p k


restore log in hoistSpec test

restore log in hoistSpec test

module Test.Spec.HoistSpec where

import Prelude

import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Data.Array.NonEmpty as NAE
import Data.Identity (Identity)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (intercalate)
import Effect.Aff (Aff, delay)
import Effect.Aff.Class (liftAff)
import Effect.Class.Console (log)
import Test.Spec (ComputationType(..), Spec, SpecM, describe, hoistSpec, it, parallel)

type Spec' t a = SpecM Identity t Unit a

hoistSpecSpec :: Spec Unit
hoistSpecSpec = describe "hoist" do
  describe "normal" $ delaySpecExample {log, delay}
  describe "reader" $ hoistSpecSpecReaderT

hoistSpecSpecReaderT :: Spec Unit
hoistSpecSpecReaderT = go $ parallel do
  delaySpecExample
    { log: \s -> ask >>= \logger -> liftAff $ logger s
    , delay: \ms -> liftAff $ delay ms
    }
  where
    go :: Spec' (ReaderT (String -> Aff Unit) Aff) ~> Spec
    go = hoistSpec \cType m ->
      let
        prefix = case cType of
          CleanUpWithContext n -> intercalate " > " n <> " (afterAll) "
          TestWithName n -> intercalate " > " $ NAE.toArray n
      in runReaderT m \logMsg -> log $ prefix  <> "| " <> logMsg

delaySpecExample
  :: forall m
  . Monad m
  =>  { log :: String -> m Unit
      , delay :: Milliseconds -> m Unit
      }
  -> Spec' m Unit
delaySpecExample opts = describe "delay" do
  it "proc 1" do
    opts.log "start 1"
    opts.delay $ Milliseconds $ 500.0 + 300.0 * 1.0
    opts.log "done 1"
  describe "some" do
    it "proc 2" do
      opts.log "start 2"
      opts.delay $ Milliseconds $ 500.0 + 300.0 * 2.0
      opts.log "done 2"
    it "proc 3" do
      opts.log "start 3"
      opts.delay $ Milliseconds $ 500.0 + 300.0 * 3.0
      opts.log "done 3"
    describe "nesting" do
      it "proc 4" do
        opts.log "start 4"
        opts.delay $ Milliseconds $ 500.0 + 300.0 * 4.0
        opts.log "done 4"
    describe "nesting" do
      it "proc 5" do
        opts.log "start 5"
        opts.delay $ Milliseconds $ 500.0 + 300.0 * 5.0
        opts.log "done 5"
      it "proc 6" do
        opts.log "start 6"
        opts.delay $ Milliseconds $ 500.0 + 300.0 * 6.0
        opts.log "done 6"

module Test.Spec.HoistSpec where

import Prelude

import Control.Monad.Reader (ReaderT, ask, runReaderT)
import Data.Array.NonEmpty as NAE
import Data.Identity (Identity)
import Data.Time.Duration (Milliseconds(..))
import Data.Traversable (intercalate)
import Effect.Aff (Aff, delay)
import Effect.Aff.Class (liftAff)
import Effect.Class.Console (log)
import Test.Spec (ComputationType(..), Spec, SpecM, describe, hoistSpec, it, parallel)

type Spec' t a = SpecM Identity t Unit a

hoistSpecSpec :: Spec Unit
hoistSpecSpec = describe "hoist" do
  describe "normal" $ delaySpecExample {log, delay}
  describe "reader" $ hoistSpecSpecReaderT

hoistSpecSpecReaderT :: Spec Unit
hoistSpecSpecReaderT = go $ parallel do
  delaySpecExample
    { log: \s -> ask >>= \logger -> liftAff $ logger s
    , delay: \ms -> liftAff $ delay ms
    }
  where
    go :: Spec' (ReaderT (String -> Aff Unit) Aff) ~> Spec
    go = hoistSpec \name m ->
      let
        prefix = case name of
          CleanUpWithContext n -> intercalate " > " n <> " (afterAll) "
          TestWithName n -> intercalate " > " $ NAE.toArray n
      in runReaderT m \logMsg -> log $ prefix  <> "| " <> logMsg

-- TODO restore `log`
delaySpecExample
  :: forall m
  . Monad m
  =>  { log :: String -> m Unit
      , delay :: Milliseconds -> m Unit
      }
  -> Spec' m Unit
delaySpecExample opts = describe "delay" do
  it "proc 1" do
    -- opts.log "start 1"
    opts.delay $ Milliseconds $ 500.0 + 300.0 * 1.0
    -- opts.log "done 1"
  describe "some" do
    it "proc 2" do
      -- opts.log "start 2"
      opts.delay $ Milliseconds $ 500.0 + 300.0 * 2.0
      -- opts.log "done 2"
    it "proc 3" do
      -- opts.log "start 3"
      opts.delay $ Milliseconds $ 500.0 + 300.0 * 3.0
      -- opts.log "done 3"
    describe "nesting" do
      it "proc 4" do
        -- opts.log "start 4"
        opts.delay $ Milliseconds $ 500.0 + 300.0 * 4.0
        -- opts.log "done 4"
    describe "nesting" do
      it "proc 5" do
        -- opts.log "start 5"
        opts.delay $ Milliseconds $ 500.0 + 300.0 * 5.0
        -- opts.log "done 5"
      it "proc 6" do
        -- opts.log "start 6"
        opts.delay $ Milliseconds $ 500.0 + 300.0 * 6.0
        -- opts.log "done 6"


initial try to implement websockets

initial try to implement websockets

module Openspace.Network.Socket where

import Control.Monad.Eff
import Data.Foreign
import Data.Either
import Rx.Observable

data Socket = Socket | EmptySocket -- TODO: remove the need for EmptySocket
data SocketError = SocketError

foreign import data Net :: !

foreign import getSocket
"""
function getSocket(url){
    return io(url);
}
""" :: String -> Socket

socketObserver' _ EmptySocket = return empty
socketObserver' str sock = socketObserver str sock

foreign import socketObserver
"""
function socketObserver(address){
  return function(protocol){
    return function(openObserver) {
      var ws = new WebSocket(address, protocol);

      var observer = Rx.Observer.create(function (data) {
        if (ws.readyState === WebSocket.OPEN) { ws.send(data); }
      });

      // Handle the data
      var observable = Rx.Observable.create (function (obs) {
        // Handle open
        if (openObserver) {
          ws.onopen = function (e) {
            openObserver.onNext(e);
            openObserver.onCompleted();
          };
        }

        // Handle messages
        ws.onmessage = obs.onNext.bind(obs);
        ws.onerror = obs.onError.bind(obs);
        ws.onclose = obs.onCompleted.bind(obs);

        // Return way to unsubscribe
        return ws.close.bind(ws);
      });

      return Rx.Subject.create(observer, observable);
    }
  }
}
""" :: forall eff. String -> Socket -> Eff (net :: Net | eff) (Observable Foreign)

foreign import emitAction
"""
function emitAction(socket){
  return function (action){
    return function(){
      socket.emit('message', action)
    }
  }
}
""" :: forall eff. Socket -> Foreign -> Eff (net :: Net | eff) Unit

foreign import emitRefresh
"""
function emitRefresh(socket){
  return function(){
    socket.emit('state')
  }
}
""" :: forall eff. Socket -> Eff ( net :: Net | eff ) Unit

module Openspace.Network.Socket where

import Control.Monad.Eff
import Data.Foreign
import Data.Either
import Rx.Observable

data Socket = Socket | EmptySocket -- TODO: remove the need for EmptySocket
data SocketError = SocketError

foreign import data Net :: !

foreign import getSocket
"""
function getSocket(url){
    return io(url);
}
""" :: String -> Socket

socketObserver' _ EmptySocket = return empty
socketObserver' str sock = socketObserver str sock

foreign import socketObserver
"""
function socketObserver(channel){
  return function(socket){
    return function(){
      var __slice = [].slice;
      var subj;
      subj = new Rx.Subject();
      subj.callback = function(msg) {
        return subj.onNext(msg);
      };
      socket.on(channel, subj.callback);
      return subj;
    }
  }
}
""" :: forall eff. String -> Socket -> Eff (net :: Net | eff) (Observable Foreign)

foreign import emitAction
"""
function emitAction(socket){
  return function (action){
    return function(){
      socket.emit('message', action)
    }
  }
}
""" :: forall eff. Socket -> Foreign -> Eff (net :: Net | eff) Unit

foreign import emitRefresh
"""
function emitRefresh(socket){
  return function(){
    socket.emit('state')
  }
}
""" :: forall eff. Socket -> Eff ( net :: Net | eff ) Unit


[Quasar.Aff] Change `move` to not fail if resource did not exist

This is to address SD-1358

{-
Copyright 2015 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 Quasar.Aff
  ( children
  , mountInfo
  , move
  , reqHeadersToJSON
  , saveMount
  , delete
  , getNewName
  , makeFile
  , ldJSON
  , getVersion

  , fields
  , templated
  , forceDelete
  , executeQuery
  , all
  , sample
  , transitiveChildrenProducer
  , query'
  , count

  , save
  , load
  , resourceExists
  , RetryEffects()
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)
import Control.Bind ((>=>), (<=<), (=<<))
import Control.Coroutine as CR
import Control.Coroutine.Aff as ACR
import Control.Monad (when)
import Control.Monad.Aff (Aff(), attempt, runAff)
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Eff.Ref (REF(), newRef, readRef, modifyRef)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.MonadPlus (guard)
import Control.UI.Browser (encodeURIComponent)

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as JS
import Data.Array as Arr
import Data.Bifunctor (bimap, lmap)
import Data.Date as Date
import Data.Either (Either(..), either, isRight)
import Data.Foldable (foldl, for_, traverse_)
import Data.Foreign (F(), parseJSON)
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign.Index (prop)
import Data.Foreign.NullOrUndefined (runNullOrUndefined)
import Data.Functor (($>))
import Data.Functor.Eff (liftEff)
import Data.Lens ((.~), (^.))
import Data.List as L
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))

import DOM (DOM())

import Network.HTTP.Affjax (Affjax(), AJAX(), AffjaxRequest(), AffjaxResponse(), RetryPolicy(), defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable, ResponseType(JSONResponse))
import Network.HTTP.Method (Method(..))
import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.MimeType.Common (applicationJSON)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))

import Quasar.Paths as Paths

-- TODO: split out a core Quasar module that only deals with the API, and
-- doesn't know about SlamData specific things.
import SlamData.Config as Config
import SlamData.FileSystem.Resource as R

import Utils.Completions (memoizeCompletionStrs)
import Utils.Path as PU

newtype Listing = Listing (Array R.Resource)

runListing :: Listing -> Array R.Resource
runListing (Listing rs) = rs

instance listingIsForeign :: IsForeign Listing where
  read f =
    read f
      >>= readProp "children"
      >>= pure
        <<< Listing
        <<< fromMaybe []
        <<< runNullOrUndefined

instance listingRespondable :: Respondable Listing where
  responseType = Tuple (Just applicationJSON) JSONResponse
  fromResponse = read

children
  :: forall e
   . PU.DirPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Array R.Resource)
children dir = do
  cs <- children' dir
  let result = (R._root .~ dir) <$> cs
  memoizeCompletionStrs dir result
  pure result

children'
  :: forall e
   . PU.DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children' dir = runListing <$> (getResponse msg $ listing dir)
  where
  msg = "Error: can not get children of resource"

listing :: forall e. PU.DirPath -> Affjax (RetryEffects e) Listing
listing p =
  case P.relativeTo p P.rootDir of
    Nothing -> throwError $ Exn.error "incorrect path"
    Just p ->
      getWithPolicy
        { shouldRetryWithStatusCode: \c -> not (succeeded c || c == notFoundStatus)
        , delayCurve: const 1000
        , timeout: Just 10000
        }
        (Paths.metadataUrl </> p)
        applicationJSON

makeFile
  :: forall e
   . PU.FilePath
   -> MimeType
   -> String
   -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
makeFile path mime content =
  getResponse msg go
  where
  msg :: String
  msg = "error while creating file"

  firstLine :: Maybe String
  firstLine = Arr.head $ S.split "\n" content

  isJson :: Either String JS.Json
  isJson = maybe (Left "empty file") Right firstLine >>= JS.jsonParser

  go :: Aff (RetryEffects (ajax :: AJAX | e)) (AffjaxResponse Unit)
  go = slamjax $ defaultRequest
   { method = PUT
   , headers = [ ContentType mime ]
   , content = Just content
   , url = fromMaybe "" $ (P.printPath <<< (Paths.dataUrl </>)) <$> P.relativeTo path P.rootDir
   }

successStatus :: StatusCode
successStatus = StatusCode 200

notFoundStatus :: StatusCode
notFoundStatus = StatusCode 404

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF, now :: Date.Now | e)

-- | A version of `affjax` with our retry policy.
slamjax
  :: forall e a b
   . (Requestable a, Respondable b)
  => AffjaxRequest a -> Affjax (RetryEffects e) b
slamjax = retry defaultRetryPolicy affjax

retryGet
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy
    { shouldRetryWithStatusCode: not <<< succeeded
    , delayCurve: const 1000
    , timeout: Just 30000
    }

mkRequest
  :: forall e fd
   . P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Aff (RetryEffects e) (AffjaxRequest Unit)
mkRequest u mime = do
  nocache <- liftEff $ Date.nowEpochMilliseconds
  pure $ defaultRequest { url = url' nocache
                        , headers = [ Accept mime ]
                        }
  where
  url' nocache = url <> symbol <> "nocache=" <> pretty nocache
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) = let s = show ms in fromMaybe s (S.stripSuffix ".0" s)
  url = P.printPath u

getOnce
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getOnce u mime = mkRequest u mime >>= affjax

getWithPolicy
  :: forall e a fd
   . (Respondable a)
  => RetryPolicy
  -> P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getWithPolicy policy u mime = mkRequest u mime >>= retry policy affjax

retryDelete
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed -> Affjax (RetryEffects e) a
retryDelete u =
  slamjax $ defaultRequest { url = P.printPath u, method = DELETE }

retryPost
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c =
  slamjax $ defaultRequest { method = POST, url = P.printPath u, content = Just c }

retryPut
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> MimeType -> Affjax (RetryEffects e) b
retryPut u c mime =
  slamjax $ defaultRequest
    { method = PUT
    , url = P.printPath u
    , content = Just c
    , headers = [ContentType mime]
    }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- attempt affjax
  case res of
    Left e -> throwError $ Exn.error msg
    Right r -> do
      if not $ succeeded r.status
        then throwError $ Exn.error msg
        else pure r.response

reqHeadersToJSON :: Array RequestHeader -> JS.Json
reqHeadersToJSON = foldl go JS.jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj

mountInfo :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) String
mountInfo res = do
  result <- getOnce mountPath applicationJSON
  if succeeded result.status
     then case parse result.response of
       Left err ->
         throwError $ Exn.error (show err)
       Right uri ->
         pure uri
     else throwError (Exn.error result.response)

  where
  mountPath :: P.Path P.Abs P.Dir P.Sandboxed
  mountPath =
    (Paths.mountUrl </> PU.rootify (R.resourceDir res)) #
      if R.resourceName res == ""
        then id
        else (</> (P.dir (R.resourceName res)))

  parse :: String -> F String
  parse = parseJSON >=> prop "mongodb" >=> readProp "connectionUri"

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  :: forall e. PU.DirPath -> String -> Aff (RetryEffects (ajax :: AJAX |e)) String
getNewName parent name = do
  items <- attempt (children' parent) <#> either (const []) id
  pure if exists' name items then getNewName' items 1 else name
  where
  getNewName' items i =
    let arr = S.split "." name
    in fromMaybe "" do
      body <- Arr.head arr
      suffixes <- Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists' newName items
           then getNewName' items (i + one)
           else newName

exists' :: String -> Array R.Resource -> Boolean
exists' name items = isJust $ Arr.findIndex (\r -> r ^. R._name == name) items

-- | Will return `Just` in case the resource was successfully moved, and
-- | `Nothing` in case no resource existed at the requested source path.
move
  :: forall e
   . R.Resource
  -> PU.AnyPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) (Maybe PU.AnyPath)
move src tgt = do
  let url = if R.isDatabase src || R.isViewMount src
            then Paths.mountUrl
            else Paths.dataUrl
  cleanViewMounts src
  result <- affjax $ defaultRequest
    { method = MOVE
    , headers = [RequestHeader "Destination" $ either P.printPath P.printPath tgt]
    , url =
        either
          (P.printPath <<< (url </>) <<< PU.rootifyFile)
          (P.printPath <<< (url </>) <<< PU.rootify)
          (R.getPath src)
    }
  if succeeded result.status
    then pure $ Just tgt
    else if result.status == notFoundStatus
      then pure Nothing
      else throwError (Exn.error result.response)

saveMount
  :: forall e. R.Resource -> String -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
saveMount res uri = do
  result <- slamjax $ defaultRequest
    { method = PUT
    , headers = [ ContentType applicationJSON ]
    , content = Just $ stringify { mongodb: {connectionUri: uri } }
    , url = P.printPath
            $ Paths.mountUrl
            </> PU.rootify (R.resourceDir res)
            </> P.dir (R.resourceName res)
    }
  if succeeded result.status
    then pure unit
    else throwError (Exn.error result.response)

foreign import stringify :: forall r. {|r} -> String

delete
  :: forall e
   . R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource || R.isViewMount resource)
  then (moveToTrash resource) <|> (forceDelete resource $> Nothing)
  else forceDelete resource $> Nothing

  where
  msg :: String
  msg = "cannot delete"

  moveToTrash
    :: R.Resource
    -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Maybe R.Resource)
  moveToTrash res = do
    let d = (res ^. R._root) </> P.dir Config.trashFolder
        path = (res # R._root .~ d) ^. R._path
    name <- getNewName d (res ^. R._name)
    move res (path # R._nameAnyPath .~ name)
    pure (Just $ R.Directory d)

  alreadyInTrash :: R.Resource -> Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left _ -> alreadyInTrash' (res ^. R._root)
      Right path -> alreadyInTrash' path

  alreadyInTrash' :: PU.DirPath -> Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

  go :: Tuple PU.DirPath (Either P.DirName P.FileName) -> Boolean
  go (Tuple d name) =
    case name of
      Right _ -> false
      Left n ->
        if n == P.DirName Config.trashFolder
        then true
        else alreadyInTrash' d

forceDelete
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) Unit
forceDelete res = do
  cleanViewMounts res
  getResponse "cannot delete"
    $  either retryDelete retryDelete
    $  pathFromResource res

  where
  pathFromResource :: R.Resource -> PU.AnyPath
  pathFromResource r = transplant (rootForResource r) (R.getPath r)

  transplant :: PU.DirPath -> PU.AnyPath -> PU.AnyPath
  transplant newRoot =
    bimap
      (\p -> newRoot </> PU.rootifyFile p)
      (\p -> newRoot </> PU.rootify p)

  rootForResource :: R.Resource -> PU.DirPath
  rootForResource r =
    if R.isDatabase r || R.isViewMount r
    then Paths.mountUrl
    else Paths.dataUrl

cleanViewMounts
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM|e)) Unit
cleanViewMounts res = for_ (R.getPath res) \dirPath ->
  children dirPath >>= Arr.filter R.isViewMount >>> traverse_ forceDelete

getVersion :: forall e. Aff (RetryEffects (ajax :: AJAX |e)) (Maybe String)
getVersion = do
  serverInfo <- retryGet Paths.serverInfoUrl applicationJSON
  return $ either (const Nothing) Just (readProp "version" serverInfo.response)

ldJSON :: MimeType
ldJSON = MimeType "application/ldjson"

-- | Produces a stream of the transitive children of a path
transitiveChildrenProducer
  :: forall e
   . PU.DirPath
  -> CR.Producer
      (Array R.Resource)
      (Aff (RetryEffects (ajax :: AJAX, err :: Exn.EXCEPTION, dom :: DOM | e)))
      Unit
transitiveChildrenProducer dirPath = do
  ACR.produce \emit -> do
    activeRequests <- newRef $ Set.singleton $ P.printPath dirPath
    runAff Exn.throwException (const (pure unit)) $ go emit activeRequests dirPath
  where
  go emit activeRequests start = do
    let strPath = P.printPath start
    eitherChildren <- attempt $ children start
    liftEff $ modifyRef activeRequests $ Set.delete strPath
    for_ eitherChildren \items -> do
      liftEff $ emit $ Left items
      let parents = Arr.mapMaybe (either (const Nothing) Just <<< R.getPath) items
      for_ parents $ \p ->
        liftEff $ modifyRef activeRequests $ Set.insert $ P.printPath p
      for_ parents $ go emit activeRequests
    remainingRequests <- liftEff $ readRef activeRequests
    if Set.isEmpty remainingRequests
      then liftEff $ emit $ Right unit
      else pure unit

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query
  :: forall e. R.Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
query res sql =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (getOnce uriPath applicationJSON)
  where
  msg = "error in query"
  uriPath = mkURI res sql

query'
  :: forall e
   . R.Resource -> SQL
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.JArray)
query' res@(R.File _) sql = do
  result <- retryGet (mkURI' res sql) applicationJSON
  pure if succeeded result.status
       then JS.decodeJson <=< JS.jsonParser $ result.response
       else Left $ readError "error in query" result.response

query' _ _ = pure $ Left "Query resource is not a file"

count :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) Int
count res = do
  result <- getOnce uriPath applicationJSON
  when (not $ succeeded result.status) raiseError
  -- See SD-1331. If user requests `count` for incorrect sql-mount
  -- it returns "[" --> throwError is used to mark non-existent and
  -- incorrect resources here.
  maybe raiseError pure $
    (JS.jsonParser result.response # either (const Nothing) Just)
    >>= JS.toArray
    >>= Arr.head
    >>= JS.toObject
    >>= SM.lookup "total"
    >>= JS.toNumber
    >>= Data.Int.fromNumber
  where
  raiseError :: forall a. Aff (RetryEffects (ajax :: AJAX |e)) a
  raiseError = throwError $ Exn.error "count query returned incorrect json"

  uriPath :: P.Path P.Abs P.File P.Sandboxed
  uriPath = mkURI res sql

  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

resourceExists :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX|e)) Boolean
resourceExists res = map isRight $ attempt $ count res

portView
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql varMap = do
  guard $ R.isFile dest
  let
    queryParams = maybe "" ("&" <>) $ renderQueryString varMap
    connectionUri = "sql2:///?q="
                    <> PU.encodeURIPath (templated res sql)
                    <> queryParams
  result <-
    slamjax $ defaultRequest
      { method = PUT
      , headers = [ ContentType applicationJSON ]
      , content = Just $ stringify { view: { connectionUri: connectionUri } }
      , url =
          P.printPath $
            Paths.mountUrl
              </> PU.rootify (R.resourceDir dest)
              </> P.file (R.resourceName dest)
      }
  if succeeded result.status
     then pure unit
     else throwError $ Exn.error $ readError result.response result.response

portQuery
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JObject
portQuery res dest sql vars = do
  guard $ R.isFile dest
  result <-
    slamjax $ defaultRequest
      { method = POST
      , headers =
          [ RequestHeader "Destination" $ R.resourcePath dest
          , ContentType ldJSON
          ]
      , url =
          P.printPath $
            Paths.queryUrl
              </> PU.rootify (R.resourceDir res)
              </> P.dir (R.resourceName res)
              </> P.file queryVars
      , content = Just (templated res sql)
      }

  if not $ succeeded result.status
    then throwError $ Exn.error $ readError result.response result.response
    else
    -- We expect result message to be valid json.
    either (throwError <<< Exn.error) pure $
      JS.jsonParser result.response >>= JS.decodeJson
  where
  queryVars :: String
  queryVars = maybe "" ("?" <>) $ renderQueryString vars

renderQueryString :: SM.StrMap String -> Maybe String
renderQueryString = map go <<< L.uncons <<< SM.toList
  where
  pair :: Tuple String String -> String
  pair (Tuple a b) = "var." <> a <> "=" <> encodeURIComponent b

  go { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) (pair h) t

readError :: String -> String -> String
readError msg input =
  let responseError = JS.jsonParser input >>= JS.decodeJson >>= (.? "error")
  in either (const msg) id responseError

sample'
  :: forall e
   . R.Resource -> Maybe Int -> Maybe Int
   -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample' res mbOffset mbLimit =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (retryGet uri applicationJSON)
  where
  msg = "error getting resource sample"
  uri =
    Paths.dataUrl
      </> PU.rootify (R.resourceDir res)
      </> P.file
            (R.resourceName res
               <> (maybe "" (("?offset=" <>) <<< show) mbOffset)
               <> (maybe "" (("&limit=" <>) <<< show ) mbLimit))

sample
  :: forall e
   . R.Resource -> Int -> Int -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
all res = sample' res Nothing Nothing

fields
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ Exn.error "empty file"
    _ -> pure $ Arr.nub $ Arr.concat (getFields <$> jarr)

mkURI :: R.Resource -> SQL -> PU.FilePath
mkURI res sql =
  Paths.queryUrl </> P.file ("?q=" <> encodeURIComponent (templated res sql))

mkURI' :: R.Resource -> SQL -> PU.FilePath
mkURI' res sql =
  Paths.queryUrl
  </> PU.rootify (R.resourceDir res)
  </> P.dir (R.resourceName res)
  </> P.file ("?q=" <> encodeURIComponent (templated res sql))

templated :: R.Resource -> SQL -> SQL
templated res = S.replace "{{path}}" ("\"" <> R.resourcePath res <> "\"")

extractJArray :: forall m. (MonadError Exn.Error m) => JS.Json -> m JS.JArray
extractJArray = either (throwError <<< Exn.error) pure <<< JS.decodeJson

getFields :: JS.Json -> Array String
getFields json = Arr.filter (/= "") $ Arr.nub $ getFields' [] json

getFields' :: Array String -> JS.Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if JS.isObject json
  then maybe acc (goObj acc) $ JS.toObject json
  else if JS.isArray json
       then maybe acc (goArr acc) $ JS.toArray json
       else acc

  where
  goArr :: Array String -> JS.JArray -> Array String
  goArr acc arr =
    Arr.concat $ getFields' (lift2 append acc $ mkArrIxs arr) <$> arr
    where
    mkArrIxs :: JS.JArray -> Array String
    mkArrIxs jarr =
      map (show >>> \x -> "[" <> x <> "]") $ Arr.range 0 $ Arr.length jarr - 1

  goObj :: Array String -> JS.JObject -> Array String
  goObj acc = Arr.concat <<< map (goTuple acc) <<< L.fromList <<< SM.toList

  goTuple :: Array String -> Tuple String JS.Json -> Array String
  goTuple acc (Tuple key json) =
    getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

executeQuery
  :: forall e
   . String
  -> Boolean
  -> SM.StrMap String
  -> R.Resource
  -> R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e))
      (Either String { outputResource :: R.Resource, plan :: Maybe String })
executeQuery sql cachingEnabled varMap inputResource outputResource = do
  when (R.isTempFile outputResource) $
    void $ attempt $ forceDelete outputResource

  ejobj <- do
    attempt $
      if cachingEnabled
         then portQuery inputResource outputResource sql varMap <#> Just
         else portView inputResource outputResource sql varMap $> Nothing

  pure $ do
    mjobj <- lmap Exn.message ejobj
    info <-
      case mjobj of
        Nothing -> do
          path <- R.getPath outputResource # either pure \_ ->
            Left "Expected output resource as file or view mount"
          sandboxedPath <- P.sandbox P.rootDir path
                           # maybe (Left "Could not sandbox output resource") pure
          pure
            { sandboxedPath
            , plan: Nothing
            }
        Just jobj -> do
          planPhases <- Arr.last <$> jobj .? "phases"
          sandboxedPath <- do
            pathString <- jobj .? "out"
            path <- P.parseAbsFile pathString
                    # maybe (Left "Invalid file from Quasar") pure
            P.sandbox P.rootDir path
              # maybe (Left "Could not sandbox Quasar file") pure
          pure
            { sandboxedPath
            , plan: planPhases >>= (.? "detail") >>> either (const Nothing) Just
            }
    pure
      { outputResource: R.mkFile $ Left $ P.rootDir </> info.sandboxedPath
      , plan: info.plan
      }

-- | Saves a JSON value to a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
save
  :: forall e
   . PU.FilePath
  -> JS.Json
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
save path json =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in getResponse "error while saving file" (retryPut apiPath json ldJSON)

-- | Loads a JSON value from a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
load
  :: forall e
   . PU.FilePath
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.Json)
load path =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in lmap Exn.message <$> attempt (getResponse "error loading notebook" (retryGet apiPath ldJSON))

{-
Copyright 2015 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 Quasar.Aff
  ( children
  , mountInfo
  , move
  , reqHeadersToJSON
  , saveMount
  , delete
  , getNewName
  , makeFile
  , ldJSON
  , getVersion

  , fields
  , templated
  , forceDelete
  , executeQuery
  , all
  , sample
  , transitiveChildrenProducer
  , query'
  , count

  , save
  , load
  , resourceExists
  , RetryEffects()
  ) where

import Prelude

import Control.Alt ((<|>))
import Control.Apply (lift2)
import Control.Bind ((>=>), (<=<), (=<<))
import Control.Coroutine as CR
import Control.Coroutine.Aff as ACR
import Control.Monad (when)
import Control.Monad.Aff (Aff(), attempt, runAff)
import Control.Monad.Aff.AVar (AVAR())
import Control.Monad.Eff.Exception as Exn
import Control.Monad.Eff.Ref (REF(), newRef, readRef, modifyRef)
import Control.Monad.Error.Class (MonadError, throwError)
import Control.MonadPlus (guard)
import Control.UI.Browser (encodeURIComponent)

import Data.Argonaut ((~>), (:=), (.?))
import Data.Argonaut as JS
import Data.Array as Arr
import Data.Bifunctor (bimap, lmap)
import Data.Date as Date
import Data.Either (Either(..), either, isRight)
import Data.Foldable (foldl, for_, traverse_)
import Data.Foreign (F(), parseJSON)
import Data.Foreign.Class (readProp, read, IsForeign)
import Data.Foreign.Index (prop)
import Data.Foreign.NullOrUndefined (runNullOrUndefined)
import Data.Functor (($>))
import Data.Functor.Eff (liftEff)
import Data.Lens ((.~), (^.))
import Data.List as L
import Data.Maybe (Maybe(..), isJust, fromMaybe, maybe)
import Data.Path.Pathy ((</>))
import Data.Path.Pathy as P
import Data.Set as Set
import Data.String as S
import Data.StrMap as SM
import Data.Time (Milliseconds(..))
import Data.Tuple (Tuple(..))

import DOM (DOM())

import Network.HTTP.Affjax (Affjax(), AJAX(), AffjaxRequest(), AffjaxResponse(), RetryPolicy(), defaultRequest, affjax, retry, defaultRetryPolicy)
import Network.HTTP.Affjax.Request (Requestable)
import Network.HTTP.Affjax.Response (Respondable, ResponseType(JSONResponse))
import Network.HTTP.Method (Method(..))
import Network.HTTP.MimeType (MimeType(..), mimeTypeToString)
import Network.HTTP.MimeType.Common (applicationJSON)
import Network.HTTP.RequestHeader (RequestHeader(..))
import Network.HTTP.StatusCode (StatusCode(..))

import Quasar.Paths as Paths

-- TODO: split out a core Quasar module that only deals with the API, and
-- doesn't know about SlamData specific things.
import SlamData.Config as Config
import SlamData.FileSystem.Resource as R

import Utils.Completions (memoizeCompletionStrs)
import Utils.Path as PU

newtype Listing = Listing (Array R.Resource)

runListing :: Listing -> Array R.Resource
runListing (Listing rs) = rs

instance listingIsForeign :: IsForeign Listing where
  read f =
    read f
      >>= readProp "children"
      >>= pure
        <<< Listing
        <<< fromMaybe []
        <<< runNullOrUndefined

instance listingRespondable :: Respondable Listing where
  responseType = Tuple (Just applicationJSON) JSONResponse
  fromResponse = read

children
  :: forall e
   . PU.DirPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Array R.Resource)
children dir = do
  cs <- children' dir
  let result = (R._root .~ dir) <$> cs
  memoizeCompletionStrs dir result
  pure result

children'
  :: forall e
   . PU.DirPath -> Aff (RetryEffects (ajax :: AJAX | e)) (Array R.Resource)
children' dir = runListing <$> (getResponse msg $ listing dir)
  where
  msg = "Error: can not get children of resource"

listing :: forall e. PU.DirPath -> Affjax (RetryEffects e) Listing
listing p =
  case P.relativeTo p P.rootDir of
    Nothing -> throwError $ Exn.error "incorrect path"
    Just p ->
      getWithPolicy
        { shouldRetryWithStatusCode: \c -> not (succeeded c || c == notFoundStatus)
        , delayCurve: const 1000
        , timeout: Just 10000
        }
        (Paths.metadataUrl </> p)
        applicationJSON

makeFile
  :: forall e
   . PU.FilePath
   -> MimeType
   -> String
   -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
makeFile path mime content =
  getResponse msg go
  where
  msg :: String
  msg = "error while creating file"

  firstLine :: Maybe String
  firstLine = Arr.head $ S.split "\n" content

  isJson :: Either String JS.Json
  isJson = maybe (Left "empty file") Right firstLine >>= JS.jsonParser

  go :: Aff (RetryEffects (ajax :: AJAX | e)) (AffjaxResponse Unit)
  go = slamjax $ defaultRequest
   { method = PUT
   , headers = [ ContentType mime ]
   , content = Just content
   , url = fromMaybe "" $ (P.printPath <<< (Paths.dataUrl </>)) <$> P.relativeTo path P.rootDir
   }

successStatus :: StatusCode
successStatus = StatusCode 200

notFoundStatus :: StatusCode
notFoundStatus = StatusCode 404

succeeded :: StatusCode -> Boolean
succeeded (StatusCode int) =
  200 <= code && code < 300
  where code = int

type RetryEffects e = (avar :: AVAR, ref :: REF, now :: Date.Now | e)

-- | A version of `affjax` with our retry policy.
slamjax
  :: forall e a b
   . (Requestable a, Respondable b)
  => AffjaxRequest a -> Affjax (RetryEffects e) b
slamjax = retry defaultRetryPolicy affjax

retryGet
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
retryGet =
  getWithPolicy
    { shouldRetryWithStatusCode: not <<< succeeded
    , delayCurve: const 1000
    , timeout: Just 30000
    }

mkRequest
  :: forall e fd
   . P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Aff (RetryEffects e) (AffjaxRequest Unit)
mkRequest u mime = do
  nocache <- liftEff $ Date.nowEpochMilliseconds
  pure $ defaultRequest { url = url' nocache
                        , headers = [ Accept mime ]
                        }
  where
  url' nocache = url <> symbol <> "nocache=" <> pretty nocache
  symbol = if S.contains "?" url then "&" else "?"
  pretty (Milliseconds ms) = let s = show ms in fromMaybe s (S.stripSuffix ".0" s)
  url = P.printPath u

getOnce
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getOnce u mime = mkRequest u mime >>= affjax

getWithPolicy
  :: forall e a fd
   . (Respondable a)
  => RetryPolicy
  -> P.Path P.Abs fd P.Sandboxed
  -> MimeType
  -> Affjax (RetryEffects e) a
getWithPolicy policy u mime = mkRequest u mime >>= retry policy affjax

retryDelete
  :: forall e a fd
   . (Respondable a)
  => P.Path P.Abs fd P.Sandboxed -> Affjax (RetryEffects e) a
retryDelete u =
  slamjax $ defaultRequest { url = P.printPath u, method = DELETE }

retryPost
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> Affjax (RetryEffects e) b
retryPost u c =
  slamjax $ defaultRequest { method = POST, url = P.printPath u, content = Just c }

retryPut
  :: forall e a b fd
   . (Requestable a, Respondable b)
  => P.Path P.Abs fd P.Sandboxed -> a -> MimeType -> Affjax (RetryEffects e) b
retryPut u c mime =
  slamjax $ defaultRequest
    { method = PUT
    , url = P.printPath u
    , content = Just c
    , headers = [ContentType mime]
    }

getResponse :: forall a e. String -> Affjax e a -> Aff (ajax :: AJAX | e) a
getResponse msg affjax = do
  res <- attempt affjax
  case res of
    Left e -> throwError $ Exn.error msg
    Right r -> do
      if not $ succeeded r.status
        then throwError $ Exn.error msg
        else pure r.response

reqHeadersToJSON :: Array RequestHeader -> JS.Json
reqHeadersToJSON = foldl go JS.jsonEmptyObject
  where
  go obj (Accept mime) = "Accept" := mimeTypeToString mime ~> obj
  go obj (ContentType mime) = "Content-Type" := mimeTypeToString mime ~> obj
  go obj (RequestHeader k v) = k := v ~> obj

mountInfo :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) String
mountInfo res = do
  result <- getOnce mountPath applicationJSON
  if succeeded result.status
     then case parse result.response of
       Left err ->
         throwError $ Exn.error (show err)
       Right uri ->
         pure uri
     else throwError (Exn.error result.response)

  where
  mountPath :: P.Path P.Abs P.Dir P.Sandboxed
  mountPath =
    (Paths.mountUrl </> PU.rootify (R.resourceDir res)) #
      if R.resourceName res == ""
        then id
        else (</> (P.dir (R.resourceName res)))

  parse :: String -> F String
  parse = parseJSON >=> prop "mongodb" >=> readProp "connectionUri"

-- | Generates a new resource name based on a directory path and a name for the
-- | resource. If the name already exists in the path a number is appended to
-- | the end of the name.
getNewName
  :: forall e. PU.DirPath -> String -> Aff (RetryEffects (ajax :: AJAX |e)) String
getNewName parent name = do
  items <- attempt (children' parent) <#> either (const []) id
  pure if exists' name items then getNewName' items 1 else name
  where
  getNewName' items i =
    let arr = S.split "." name
    in fromMaybe "" do
      body <- Arr.head arr
      suffixes <- Arr.tail arr
      let newName = S.joinWith "." $ Arr.cons (body <> " " <> show i) suffixes
      pure if exists' newName items
           then getNewName' items (i + one)
           else newName

exists' :: String -> Array R.Resource -> Boolean
exists' name items = isJust $ Arr.findIndex (\r -> r ^. R._name == name) items

move
  :: forall e
   . R.Resource
  -> PU.AnyPath
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) PU.AnyPath
move src tgt = do
  let url = if R.isDatabase src || R.isViewMount src
            then Paths.mountUrl
            else Paths.dataUrl
  cleanViewMounts src
  result <- affjax $ defaultRequest
    { method = MOVE
    , headers = [RequestHeader "Destination" $ either P.printPath P.printPath tgt]
    , url =
        either
          (P.printPath <<< (url </>) <<< PU.rootifyFile)
          (P.printPath <<< (url </>) <<< PU.rootify)
          (R.getPath src)
    }
  if succeeded result.status
    then pure tgt
    else throwError (Exn.error result.response)

saveMount
  :: forall e. R.Resource -> String -> Aff (RetryEffects (ajax :: AJAX |e)) Unit
saveMount res uri = do
  result <- slamjax $ defaultRequest
    { method = PUT
    , headers = [ ContentType applicationJSON ]
    , content = Just $ stringify { mongodb: {connectionUri: uri } }
    , url = P.printPath
            $ Paths.mountUrl
            </> PU.rootify (R.resourceDir res)
            </> P.dir (R.resourceName res)
    }
  if succeeded result.status
    then pure unit
    else throwError (Exn.error result.response)

foreign import stringify :: forall r. {|r} -> String

delete
  :: forall e
   . R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) (Maybe R.Resource)
delete resource =
  if not (R.isDatabase resource || alreadyInTrash resource || R.isViewMount resource)
  then (moveToTrash resource) <|> (forceDelete resource $> Nothing)
  else forceDelete resource $> Nothing

  where
  msg :: String
  msg = "cannot delete"

  moveToTrash
    :: R.Resource
    -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e)) (Maybe R.Resource)
  moveToTrash res = do
    let d = (res ^. R._root) </> P.dir Config.trashFolder
        path = (res # R._root .~ d) ^. R._path
    name <- getNewName d (res ^. R._name)
    move res (path # R._nameAnyPath .~ name)
    pure (Just $ R.Directory d)

  alreadyInTrash :: R.Resource -> Boolean
  alreadyInTrash res =
    case res ^. R._path of
      Left _ -> alreadyInTrash' (res ^. R._root)
      Right path -> alreadyInTrash' path

  alreadyInTrash' :: PU.DirPath -> Boolean
  alreadyInTrash' d =
    if d == P.rootDir
    then false
    else maybe false go $ P.peel d

  go :: Tuple PU.DirPath (Either P.DirName P.FileName) -> Boolean
  go (Tuple d name) =
    case name of
      Right _ -> false
      Left n ->
        if n == P.DirName Config.trashFolder
        then true
        else alreadyInTrash' d

forceDelete
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM |e)) Unit
forceDelete res = do
  cleanViewMounts res
  getResponse "cannot delete"
    $  either retryDelete retryDelete
    $  pathFromResource res

  where
  pathFromResource :: R.Resource -> PU.AnyPath
  pathFromResource r = transplant (rootForResource r) (R.getPath r)

  transplant :: PU.DirPath -> PU.AnyPath -> PU.AnyPath
  transplant newRoot =
    bimap
      (\p -> newRoot </> PU.rootifyFile p)
      (\p -> newRoot </> PU.rootify p)

  rootForResource :: R.Resource -> PU.DirPath
  rootForResource r =
    if R.isDatabase r || R.isViewMount r
    then Paths.mountUrl
    else Paths.dataUrl

cleanViewMounts
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM|e)) Unit
cleanViewMounts res = for_ (R.getPath res) \dirPath ->
  children dirPath >>= Arr.filter R.isViewMount >>> traverse_ forceDelete

getVersion :: forall e. Aff (RetryEffects (ajax :: AJAX |e)) (Maybe String)
getVersion = do
  serverInfo <- retryGet Paths.serverInfoUrl applicationJSON
  return $ either (const Nothing) Just (readProp "version" serverInfo.response)

ldJSON :: MimeType
ldJSON = MimeType "application/ldjson"

-- | Produces a stream of the transitive children of a path
transitiveChildrenProducer
  :: forall e
   . PU.DirPath
  -> CR.Producer
      (Array R.Resource)
      (Aff (RetryEffects (ajax :: AJAX, err :: Exn.EXCEPTION, dom :: DOM | e)))
      Unit
transitiveChildrenProducer dirPath = do
  ACR.produce \emit -> do
    activeRequests <- newRef $ Set.singleton $ P.printPath dirPath
    runAff Exn.throwException (const (pure unit)) $ go emit activeRequests dirPath
  where
  go emit activeRequests start = do
    let strPath = P.printPath start
    eitherChildren <- attempt $ children start
    liftEff $ modifyRef activeRequests $ Set.delete strPath
    for_ eitherChildren \items -> do
      liftEff $ emit $ Left items
      let parents = Arr.mapMaybe (either (const Nothing) Just <<< R.getPath) items
      for_ parents $ \p ->
        liftEff $ modifyRef activeRequests $ Set.insert $ P.printPath p
      for_ parents $ go emit activeRequests
    remainingRequests <- liftEff $ readRef activeRequests
    if Set.isEmpty remainingRequests
      then liftEff $ emit $ Right unit
      else pure unit

-- | This is template string where actual path is encoded like {{path}}
type SQL = String

query
  :: forall e. R.Resource -> SQL -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
query res sql =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (getOnce uriPath applicationJSON)
  where
  msg = "error in query"
  uriPath = mkURI res sql

query'
  :: forall e
   . R.Resource -> SQL
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.JArray)
query' res@(R.File _) sql = do
  result <- retryGet (mkURI' res sql) applicationJSON
  pure if succeeded result.status
       then JS.decodeJson <=< JS.jsonParser $ result.response
       else Left $ readError "error in query" result.response

query' _ _ = pure $ Left "Query resource is not a file"

count :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) Int
count res = do
  result <- getOnce uriPath applicationJSON
  when (not $ succeeded result.status) raiseError
  -- See SD-1331. If user requests `count` for incorrect sql-mount
  -- it returns "[" --> throwError is used to mark non-existent and
  -- incorrect resources here.
  maybe raiseError pure $
    (JS.jsonParser result.response # either (const Nothing) Just)
    >>= JS.toArray
    >>= Arr.head
    >>= JS.toObject
    >>= SM.lookup "total"
    >>= JS.toNumber
    >>= Data.Int.fromNumber
  where
  raiseError :: forall a. Aff (RetryEffects (ajax :: AJAX |e)) a
  raiseError = throwError $ Exn.error "count query returned incorrect json"

  uriPath :: P.Path P.Abs P.File P.Sandboxed
  uriPath = mkURI res sql

  sql :: SQL
  sql = "SELECT COUNT(*) as total FROM {{path}}"

resourceExists :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX|e)) Boolean
resourceExists res = map isRight $ attempt $ count res

portView
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
portView res dest sql varMap = do
  guard $ R.isFile dest
  let
    queryParams = maybe "" ("&" <>) $ renderQueryString varMap
    connectionUri = "sql2:///?q="
                    <> PU.encodeURIPath (templated res sql)
                    <> queryParams
  result <-
    slamjax $ defaultRequest
      { method = PUT
      , headers = [ ContentType applicationJSON ]
      , content = Just $ stringify { view: { connectionUri: connectionUri } }
      , url =
          P.printPath $
            Paths.mountUrl
              </> PU.rootify (R.resourceDir dest)
              </> P.file (R.resourceName dest)
      }
  if succeeded result.status
     then pure unit
     else throwError $ Exn.error $ readError result.response result.response

portQuery
  :: forall e
   . R.Resource
  -> R.Resource
  -> SQL
  -> SM.StrMap String
  -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JObject
portQuery res dest sql vars = do
  guard $ R.isFile dest
  result <-
    slamjax $ defaultRequest
      { method = POST
      , headers =
          [ RequestHeader "Destination" $ R.resourcePath dest
          , ContentType ldJSON
          ]
      , url =
          P.printPath $
            Paths.queryUrl
              </> PU.rootify (R.resourceDir res)
              </> P.dir (R.resourceName res)
              </> P.file queryVars
      , content = Just (templated res sql)
      }

  if not $ succeeded result.status
    then throwError $ Exn.error $ readError result.response result.response
    else
    -- We expect result message to be valid json.
    either (throwError <<< Exn.error) pure $
      JS.jsonParser result.response >>= JS.decodeJson
  where
  queryVars :: String
  queryVars = maybe "" ("?" <>) $ renderQueryString vars

renderQueryString :: SM.StrMap String -> Maybe String
renderQueryString = map go <<< L.uncons <<< SM.toList
  where
  pair :: Tuple String String -> String
  pair (Tuple a b) = "var." <> a <> "=" <> encodeURIComponent b

  go { head = h, tail = t } =
    foldl (\a v -> a <> "&" <> pair v) (pair h) t

readError :: String -> String -> String
readError msg input =
  let responseError = JS.jsonParser input >>= JS.decodeJson >>= (.? "error")
  in either (const msg) id responseError

sample'
  :: forall e
   . R.Resource -> Maybe Int -> Maybe Int
   -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample' res mbOffset mbLimit =
  if not $ R.isFile res
  then pure []
  else extractJArray =<< getResponse msg (retryGet uri applicationJSON)
  where
  msg = "error getting resource sample"
  uri =
    Paths.dataUrl
      </> PU.rootify (R.resourceDir res)
      </> P.file
            (R.resourceName res
               <> (maybe "" (("?offset=" <>) <<< show) mbOffset)
               <> (maybe "" (("&limit=" <>) <<< show ) mbLimit))

sample
  :: forall e
   . R.Resource -> Int -> Int -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
sample res offset limit = sample' res (Just offset) (Just limit)

all :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) JS.JArray
all res = sample' res Nothing Nothing

fields
  :: forall e. R.Resource -> Aff (RetryEffects (ajax :: AJAX | e)) (Array String)
fields res = do
  jarr <- sample res 0 100
  case jarr of
    [] -> throwError $ Exn.error "empty file"
    _ -> pure $ Arr.nub $ Arr.concat (getFields <$> jarr)

mkURI :: R.Resource -> SQL -> PU.FilePath
mkURI res sql =
  Paths.queryUrl </> P.file ("?q=" <> encodeURIComponent (templated res sql))

mkURI' :: R.Resource -> SQL -> PU.FilePath
mkURI' res sql =
  Paths.queryUrl
  </> PU.rootify (R.resourceDir res)
  </> P.dir (R.resourceName res)
  </> P.file ("?q=" <> encodeURIComponent (templated res sql))

templated :: R.Resource -> SQL -> SQL
templated res = S.replace "{{path}}" ("\"" <> R.resourcePath res <> "\"")

extractJArray :: forall m. (MonadError Exn.Error m) => JS.Json -> m JS.JArray
extractJArray = either (throwError <<< Exn.error) pure <<< JS.decodeJson

getFields :: JS.Json -> Array String
getFields json = Arr.filter (/= "") $ Arr.nub $ getFields' [] json

getFields' :: Array String -> JS.Json -> Array String
getFields' [] json = getFields' [""] json
getFields' acc json =
  if JS.isObject json
  then maybe acc (goObj acc) $ JS.toObject json
  else if JS.isArray json
       then maybe acc (goArr acc) $ JS.toArray json
       else acc

  where
  goArr :: Array String -> JS.JArray -> Array String
  goArr acc arr =
    Arr.concat $ getFields' (lift2 append acc $ mkArrIxs arr) <$> arr
    where
    mkArrIxs :: JS.JArray -> Array String
    mkArrIxs jarr =
      map (show >>> \x -> "[" <> x <> "]") $ Arr.range 0 $ Arr.length jarr - 1

  goObj :: Array String -> JS.JObject -> Array String
  goObj acc = Arr.concat <<< map (goTuple acc) <<< L.fromList <<< SM.toList

  goTuple :: Array String -> Tuple String JS.Json -> Array String
  goTuple acc (Tuple key json) =
    getFields' ((\x -> x <> ".\"" <> key <> "\"") <$> acc) json

executeQuery
  :: forall e
   . String
  -> Boolean
  -> SM.StrMap String
  -> R.Resource
  -> R.Resource
  -> Aff (RetryEffects (ajax :: AJAX, dom :: DOM | e))
      (Either String { outputResource :: R.Resource, plan :: Maybe String })
executeQuery sql cachingEnabled varMap inputResource outputResource = do
  when (R.isTempFile outputResource) $
    void $ attempt $ forceDelete outputResource

  ejobj <- do
    attempt $
      if cachingEnabled
         then portQuery inputResource outputResource sql varMap <#> Just
         else portView inputResource outputResource sql varMap $> Nothing

  pure $ do
    mjobj <- lmap Exn.message ejobj
    info <-
      case mjobj of
        Nothing -> do
          path <- R.getPath outputResource # either pure \_ ->
            Left "Expected output resource as file or view mount"
          sandboxedPath <- P.sandbox P.rootDir path
                           # maybe (Left "Could not sandbox output resource") pure
          pure
            { sandboxedPath
            , plan: Nothing
            }
        Just jobj -> do
          planPhases <- Arr.last <$> jobj .? "phases"
          sandboxedPath <- do
            pathString <- jobj .? "out"
            path <- P.parseAbsFile pathString
                    # maybe (Left "Invalid file from Quasar") pure
            P.sandbox P.rootDir path
              # maybe (Left "Could not sandbox Quasar file") pure
          pure
            { sandboxedPath
            , plan: planPhases >>= (.? "detail") >>> either (const Nothing) Just
            }
    pure
      { outputResource: R.mkFile $ Left $ P.rootDir </> info.sandboxedPath
      , plan: info.plan
      }

-- | Saves a JSON value to a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
save
  :: forall e
   . PU.FilePath
  -> JS.Json
  -> Aff (RetryEffects (ajax :: AJAX | e)) Unit
save path json =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in getResponse "error while saving file" (retryPut apiPath json ldJSON)

-- | Loads a JSON value from a file.
-- |
-- | Even though the path is expected to be absolute it should not include the
-- | `/data/fs` part of the path for the API.
load
  :: forall e
   . PU.FilePath
  -> Aff (RetryEffects (ajax :: AJAX | e)) (Either String JS.Json)
load path =
  let apiPath = Paths.dataUrl </> PU.rootifyFile path
  in lmap Exn.message <$> attempt (getResponse "error loading notebook" (retryGet apiPath ldJSON))