Functions for mapping intervals to screen

module Genetics.Browser.Types where
       -- ( Point
       -- , Pos
       -- , Range
       -- , Bp(..)
       -- , MBp(..)
       -- , class HCoordinate
       -- , bp
       -- , mbp
       -- , _Bp
       -- , _MBp
       -- , _BpMBp
       -- , ChrId(..)
       -- , _ChrId
       -- , toScreen
       -- , BpPerPixel(..)
       -- , bpToPixels
       -- , pixelsToBp
       -- , Chr
       -- , ChrInterval
       -- , BrowserPoint(..)
       -- , LocalPoint(..)
       -- , IntervalPoint
       -- , Interval(..)
       -- , CoordSys(..)
       -- , mkCoordSys
       -- , findInterval
       -- , localToGlobal
       -- , globalToLocal
       -- , canvasToView
       -- , globalToFrame
       -- , intervalToChr
       -- , frameToChr
       -- , intervalSize
       -- , canvasToBrowserOffset
       -- ) where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (APrism', Iso', Lens', Prism', iso, lens, prism', takeBoth, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Profunctor.Choice (fanin)
import Data.Profunctor.Strong (fanout, splitStrong)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Unsafe.Coerce (unsafeCoerce)
-- import Genetics.Browser.Units (Bp(..), ChrId(..))

type Point = { x :: Number, y :: Number}

type Pos = { chrId :: ChrId, bp :: Bp }

type Chr = { chrId :: ChrId, size :: Bp }

type Range r = { lHand :: Pos, rHand :: Pos  | r}

-- | Newtype wrapper for a basepair location
newtype Bp = Bp Number
derive instance newtypeBp :: Newtype Bp _
derive newtype instance eqBp :: Eq Bp
derive newtype instance ordBp :: Ord Bp
derive newtype instance fieldBp :: Field Bp
derive newtype instance euclideanRingBp :: EuclideanRing Bp
derive newtype instance commutativeRingBp :: CommutativeRing Bp
derive newtype instance semiringBp :: Semiring Bp
derive newtype instance ringBp :: Ring Bp
derive newtype instance encodeBp :: Encode Bp
derive newtype instance decodeBp :: Decode Bp

instance showBp :: Show Bp where
  show (Bp n) = show n <> "Bp"

_Bp :: Iso' Bp Number
_Bp = _Newtype

_MBp :: Iso' MBp Number
_MBp = _Newtype

-- probably not actually an isomorphism due to floating point inaccuracies
_BpMBp :: Iso' Bp MBp
_BpMBp = iso mbp bp

-- | Newtype wrapper for a megabasepair location
newtype MBp = MBp Number
derive instance newtypeMBp :: Newtype MBp _
derive newtype instance eqMBp :: Eq MBp
derive newtype instance ordMBp :: Ord MBp
derive newtype instance fieldMBp :: Field MBp
derive newtype instance euclideanRingMBp :: EuclideanRing MBp
derive newtype instance commutativeRingMBp :: CommutativeRing MBp
derive newtype instance semiringMBp :: Semiring MBp
derive newtype instance ringMBp :: Ring MBp
derive newtype instance encodeMBp :: Encode MBp
derive newtype instance decodeMBp :: Decode MBp

instance showMBp :: Show MBp where
  show (MBp n) = show n <> "MBp"

class Field a <= HCoordinate a where
  bp :: a -> Bp
  mbp :: a -> MBp

toScreen :: ∀ c. HCoordinate c => c -> c -> c -> Number
toScreen offset scale x = unwrap ((x' - offset') * scale')
  where offset' = bp offset
        scale' = bp scale
        x' = bp x

instance hCoordBp :: HCoordinate Bp where
  bp = id
  mbp (Bp x) = MBp (x * 0.000001)

instance hCoordMBp :: HCoordinate MBp where
  bp (MBp x) = Bp (x * 1000000.0)
  mbp  = id

-- | Newtype wrapper for a chromosome identifier
newtype ChrId = ChrId String
derive instance newtypeChrId :: Newtype ChrId _
derive newtype instance eqChrId :: Eq ChrId
derive newtype instance ordChrId :: Ord ChrId
derive newtype instance encodeChrId :: Encode ChrId
derive newtype instance decodeChrId :: Decode ChrId
derive newtype instance showChrId :: Show ChrId

_ChrId :: Iso' ChrId String
_ChrId = _Newtype

-- TODO be *really cool* and represent it as a ratio of bp and pixels
-- i.e. just a tuple!
-- also it doesn't mean anything on its own;
-- or, rather, it's implicit that it only concerns a single chr at origin

newtype BpPerPixel = BpPerPixel Number
derive instance newtypeBpPerPixel :: Newtype BpPerPixel _

bpToPixels :: BpPerPixel -> Bp -> Number
bpToPixels (BpPerPixel s) (Bp p) = p / s

pixelsToBp :: BpPerPixel -> Number -> Bp
pixelsToBp (BpPerPixel s) p = Bp $ p * s

-- newtype BpScale = BpScale (Ratio BigInt BigInt)

-- Describes a number of `a`s per `b` -- `b` is a phantom type;
-- we always assume `b` is 1 in whatever unit it represents.
data UnitRatio a b = UnitRatio a

instance eqUnitRatio :: (Eq a) => Eq (UnitRatio a b) where
  eq (UnitRatio a) (UnitRatio b) = a == b

instance ordUnitRatio :: (Ord a) => Ord (UnitRatio a b) where
  compare (UnitRatio a) (UnitRatio b) = compare a b

type BpPerPixel' = UnitRatio Number Bp

-- pretty much all my problems appear to be solved by this type. nice
-- data Local f c = Local c c (Ratio c)
-- data BrowserWide c = BrowserWide

-- toGlobal :: forall f c.
--             Ord c
--          => EuclideanRing c
--          => Local f c
--          -> Maybe c
-- toGlobal (Local l r p) =
--   let p' = p * ((r - l) % one)
--   in if Ratio.denominator p' == one
--         then pure $ Ratio.numerator p'
--         else Nothing

-- toLocal :: forall f c.
--            Ord c
--         => EuclideanRing c
--         => c
--         -> Tuple c c
--         -> Local f c
-- toLocal c (Tuple l r) = Local l r $ (c - l) % (r - l)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

-- Subsets of the global coordinate system are defined by some interval,
--

data Interval c = Interval c c

inInterval :: forall c.
              Ord c
           => c
           -> Interval c
           -> Boolean
inInterval p (Interval l r) = l <= p && p <= r

_iL :: forall c. Lens' (Interval c) c
_iL = lens (\(Interval l _) -> l) (\(Interval _ r) l -> Interval l r)

_iR :: forall c. Lens' (Interval c) c
_iR = lens (\(Interval _ r) -> r) (\(Interval l _) r -> Interval l r)

-- clunky but works for now
data LocalPoint c = Local (Interval c) (Ratio BigInt)

_lIv :: forall c. Lens' (LocalPoint c) (Interval c)
_lIv = lens (\(Local i _) -> i) (\(Local _ p) i -> Local i p)

_lP :: forall c. Lens' (LocalPoint c) (Ratio BigInt)
_lP = lens (\(Local _ p) -> p) (\(Local i _) p -> Local i p)

-- TODO This is dumb and bad, precision etc.
ratioToNumber :: Ratio BigInt
              -> Number
ratioToNumber r =
  let n = (Ratio.numerator r)
      d = (Ratio.denominator r)
  in (BigInt.toNumber n) / (BigInt.toNumber d)

-- for now we just assume that the given point is in the interval...
globalToLocal :: forall a c.
                 Newtype c BigInt
              => Interval c
              -> c
              -> LocalPoint c
globalToLocal iv@(Interval l r) p =
  let l' = unwrap l
      r' = unwrap r
      p' = ((unwrap p) - l') % (r' - l')
  in Local iv p'

localToGlobal :: forall c.
                 Newtype c BigInt
              => LocalPoint c
              -> c
localToGlobal (Local (Interval l r) p) =
  let r' = (unwrap r) % one
      l' = (unwrap l) % one
      p' = (p * (r' - l')) + l'
  in wrap $ (Ratio.numerator p') / (Ratio.denominator p')

intervalSize :: forall c a.
                Newtype c a
             => Ring a
             => Interval c
             -> a
intervalSize (Interval l r) = (unwrap r) - (unwrap l)

-- | Transform a point in some interval A to the same point in interval B
seenFrom :: forall a b c.
            Newtype c BigInt
         => Newtype b BigInt
         => LocalPoint c
         -> Interval b
         -> LocalPoint b
seenFrom p i =
  let p' = unwrap $ localToGlobal p
  in globalToLocal i (wrap p')

intervalSeenFrom :: forall a b c.
                    Newtype c BigInt
                 => Newtype b BigInt
                 => Interval c
                 -> Interval b
                 -> Interval (Ratio BigInt)
intervalSeenFrom (Interval l r) i2 =
  let pl = globalToLocal i2 (wrap $ unwrap l)
      pr = globalToLocal i2 (wrap $ unwrap r)
  in Interval (pl^._lP) (pr^._lP)

type IntervalPoint = LocalPoint BrowserPoint

type ChrInterval c = { interval :: Interval c, chrSize :: Bp }

newtype CoordSys i c =
  CoordSys { size :: c
           , padding :: c
           -- , intervals :: Array (Tuple i (Interval c))
           , intervals :: Array (Tuple i (ChrInterval c))
           }

-- TODO need to make sure the padding is correctly applied/removed
mkCoordSys :: forall i c.
              Array (Tuple i BigInt)
           -> BigInt
           -> CoordSys i BrowserPoint
mkCoordSys chrs padding = CoordSys { size, padding: wrap padding, intervals }
  where (Tuple ids sizes) = Array.unzip chrs
        os = map BPoint $ Array.scanl (\x y -> padding + x + y) zero sizes
        ivals = Array.zipWith Interval (wrap zero `Array.cons` os) os
        intervals = Array.zip ids $
                    Array.zipWith (\i s -> {interval: i, chrSize:(Bp $ BigInt.toNumber s)}) ivals sizes
        size = wrap $ (sum sizes) + (length sizes * padding)

findInterval :: forall i c.
                Ord c
             => CoordSys i c
             -> c
             -> Maybe (Tuple i (ChrInterval c))
findInterval (CoordSys s) p =
  Array.find (\(Tuple i iv) -> p `inInterval` iv.interval) s.intervals

intervals :: forall i c.
             Ord i
          => CoordSys i c
          -> i
          -> i
          -> Maybe (Array (Tuple i (ChrInterval c)))
intervals (CoordSys s) l r = do
  let l' = min l r
      r' = max l r
  lIndex <- Array.findIndex ((==) l' <<< fst) s.intervals
  rIndex <- Array.findIndex ((==) r' <<< fst) s.intervals
  pure $ Array.slice lIndex rIndex s.intervals

viewIntervals :: forall i c.
                 Ord i
              => Ord c
              => CoordSys i c
              -> Interval c
              -> Maybe (Array (Tuple i (ChrInterval c)))
viewIntervals cs (Interval l r) = do
  lIv <- fst <$> findInterval cs l
  rIv <- fst <$> findInterval cs r

  intervals cs lIv rIv

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> Ratio BigInt
canvasToView {width} x = x' % w'
  where w' = BigInt.fromInt $ Int.round width
        x' = BigInt.fromInt $ Int.round x

canvasToBrowserOffset :: forall r.
                         { width :: Number | r }
                      -> BigInt
                      -> Number
                      -> BrowserPoint
canvasToBrowserOffset w vw x =
  let x' = canvasToView w x
      p' = x' * (vw % one)
  in wrap $ (Ratio.numerator p') / (Ratio.denominator p')

globalToFrame :: forall i c.
                 Eq i
              => CoordSys i BrowserPoint
              -> BrowserPoint
              -> Maybe (Tuple i IntervalPoint)
globalToFrame cs bp@(BPoint p) = do
  (Tuple i iv) <- findInterval cs bp
  pure $ Tuple i $ globalToLocal iv.interval bp

intervalToChr :: BrowserPoint
              -> IntervalPoint
              -> Bp
              -> Maybe Bp
intervalToChr padding (Local (Interval l r) p) chrSize = do
  let padR = (unwrap padding) % (unwrap r - unwrap l)
  -- guard $ p >= padR && p <= one - padR
  let p' = p - padR
      bp = Bp $ (BigInt.toNumber $ Ratio.numerator p') / (BigInt.toNumber $ Ratio.denominator p')

  -- TODO it's dumb that Bp is still a Number newtype
  pure $ bp * chrSize

frameToChr :: forall i c.
              Eq i
           => CoordSys i BrowserPoint
           -> Tuple i IntervalPoint
           -> Maybe Bp
frameToChr (CoordSys s) (Tuple i lp) = do
  iv <- snd <$> Array.find ((==) i <<< fst) s.intervals
  intervalToChr s.padding lp iv.chrSize

intervalToScreen :: BrowserPoint
                 -> Number
                 -> Interval BrowserPoint
                 -> Interval BrowserPoint
                 -> { width :: Number, offset :: Number }
intervalToScreen pad screenWidth reference other = { width, offset }
  where screen :: BigInt
        screen = BigInt.fromInt $ Int.round screenWidth
        padL :: BrowserPoint
        padL = wrap $ (unwrap $ other^._iL) + (unwrap pad)
        padR :: BrowserPoint
        padR = wrap $ (unwrap $ other^._iR) - (unwrap pad)
        -- 1. calculate LHS and RHS of other wrt. reference
        (Interval l r) = (Interval padL padR) `intervalSeenFrom` reference
        l' = ratioToNumber $ l * (screen % one)
        r' = ratioToNumber $ r * (screen % one)
        -- 2. width is obvious
        width :: Number
        width = r' - l'
        -- 3. offset is less so
        offset :: Number
        offset = l'

module Genetics.Browser.Types where
       -- ( Point
       -- , Pos
       -- , Range
       -- , Bp(..)
       -- , MBp(..)
       -- , class HCoordinate
       -- , bp
       -- , mbp
       -- , _Bp
       -- , _MBp
       -- , _BpMBp
       -- , ChrId(..)
       -- , _ChrId
       -- , toScreen
       -- , BpPerPixel(..)
       -- , bpToPixels
       -- , pixelsToBp
       -- , Chr
       -- , ChrInterval
       -- , BrowserPoint(..)
       -- , LocalPoint(..)
       -- , IntervalPoint
       -- , Interval(..)
       -- , CoordSys(..)
       -- , mkCoordSys
       -- , findInterval
       -- , localToGlobal
       -- , globalToLocal
       -- , canvasToView
       -- , globalToFrame
       -- , intervalToChr
       -- , frameToChr
       -- , intervalSize
       -- , canvasToBrowserOffset
       -- ) where

import Prelude

import Control.Alternative (empty)
import Control.MonadPlus (guard)
import Data.Array as Array
import Data.Bifunctor (bimap)
import Data.BigInt (BigInt)
import Data.BigInt as BigInt
import Data.Foldable (length, sum)
import Data.Foreign.Class (class Decode, class Encode)
import Data.Int as Int
import Data.Lens (APrism', Iso', Lens', Prism', iso, lens, prism', takeBoth, (^.))
import Data.Lens.Iso.Newtype (_Newtype)
import Data.Lens.Types (Iso')
import Data.Maybe (Maybe(..))
import Data.Newtype (class Newtype, unwrap, wrap)
import Data.Profunctor.Choice (fanin)
import Data.Profunctor.Strong (fanout, splitStrong)
import Data.Ratio (Ratio, (%))
import Data.Ratio as Ratio
import Data.Tuple (Tuple(..), fst, snd, uncurry)
import Unsafe.Coerce (unsafeCoerce)
-- import Genetics.Browser.Units (Bp(..), ChrId(..))

type Point = { x :: Number, y :: Number}

type Pos = { chrId :: ChrId, bp :: Bp }

type Chr = { chrId :: ChrId, size :: Bp }

type Range r = { lHand :: Pos, rHand :: Pos  | r}

-- | Newtype wrapper for a basepair location
newtype Bp = Bp Number
derive instance newtypeBp :: Newtype Bp _
derive newtype instance eqBp :: Eq Bp
derive newtype instance ordBp :: Ord Bp
derive newtype instance fieldBp :: Field Bp
derive newtype instance euclideanRingBp :: EuclideanRing Bp
derive newtype instance commutativeRingBp :: CommutativeRing Bp
derive newtype instance semiringBp :: Semiring Bp
derive newtype instance ringBp :: Ring Bp
derive newtype instance encodeBp :: Encode Bp
derive newtype instance decodeBp :: Decode Bp

instance showBp :: Show Bp where
  show (Bp n) = show n <> "Bp"

_Bp :: Iso' Bp Number
_Bp = _Newtype

_MBp :: Iso' MBp Number
_MBp = _Newtype

-- probably not actually an isomorphism due to floating point inaccuracies
_BpMBp :: Iso' Bp MBp
_BpMBp = iso mbp bp

-- | Newtype wrapper for a megabasepair location
newtype MBp = MBp Number
derive instance newtypeMBp :: Newtype MBp _
derive newtype instance eqMBp :: Eq MBp
derive newtype instance ordMBp :: Ord MBp
derive newtype instance fieldMBp :: Field MBp
derive newtype instance euclideanRingMBp :: EuclideanRing MBp
derive newtype instance commutativeRingMBp :: CommutativeRing MBp
derive newtype instance semiringMBp :: Semiring MBp
derive newtype instance ringMBp :: Ring MBp
derive newtype instance encodeMBp :: Encode MBp
derive newtype instance decodeMBp :: Decode MBp

instance showMBp :: Show MBp where
  show (MBp n) = show n <> "MBp"

class Field a <= HCoordinate a where
  bp :: a -> Bp
  mbp :: a -> MBp

toScreen :: ∀ c. HCoordinate c => c -> c -> c -> Number
toScreen offset scale x = unwrap ((x' - offset') * scale')
  where offset' = bp offset
        scale' = bp scale
        x' = bp x

instance hCoordBp :: HCoordinate Bp where
  bp = id
  mbp (Bp x) = MBp (x * 0.000001)

instance hCoordMBp :: HCoordinate MBp where
  bp (MBp x) = Bp (x * 1000000.0)
  mbp  = id

-- | Newtype wrapper for a chromosome identifier
newtype ChrId = ChrId String
derive instance newtypeChrId :: Newtype ChrId _
derive newtype instance eqChrId :: Eq ChrId
derive newtype instance ordChrId :: Ord ChrId
derive newtype instance encodeChrId :: Encode ChrId
derive newtype instance decodeChrId :: Decode ChrId
derive newtype instance showChrId :: Show ChrId

_ChrId :: Iso' ChrId String
_ChrId = _Newtype

-- TODO be *really cool* and represent it as a ratio of bp and pixels
-- i.e. just a tuple!
-- also it doesn't mean anything on its own;
-- or, rather, it's implicit that it only concerns a single chr at origin

newtype BpPerPixel = BpPerPixel Number
derive instance newtypeBpPerPixel :: Newtype BpPerPixel _

bpToPixels :: BpPerPixel -> Bp -> Number
bpToPixels (BpPerPixel s) (Bp p) = p / s

pixelsToBp :: BpPerPixel -> Number -> Bp
pixelsToBp (BpPerPixel s) p = Bp $ p * s

-- newtype BpScale = BpScale (Ratio BigInt BigInt)

-- Describes a number of `a`s per `b` -- `b` is a phantom type;
-- we always assume `b` is 1 in whatever unit it represents.
data UnitRatio a b = UnitRatio a

instance eqUnitRatio :: (Eq a) => Eq (UnitRatio a b) where
  eq (UnitRatio a) (UnitRatio b) = a == b

instance ordUnitRatio :: (Ord a) => Ord (UnitRatio a b) where
  compare (UnitRatio a) (UnitRatio b) = compare a b

type BpPerPixel' = UnitRatio Number Bp

-- pretty much all my problems appear to be solved by this type. nice
-- data Local f c = Local c c (Ratio c)
-- data BrowserWide c = BrowserWide

-- toGlobal :: forall f c.
--             Ord c
--          => EuclideanRing c
--          => Local f c
--          -> Maybe c
-- toGlobal (Local l r p) =
--   let p' = p * ((r - l) % one)
--   in if Ratio.denominator p' == one
--         then pure $ Ratio.numerator p'
--         else Nothing

-- toLocal :: forall f c.
--            Ord c
--         => EuclideanRing c
--         => c
--         -> Tuple c c
--         -> Local f c
-- toLocal c (Tuple l r) = Local l r $ (c - l) % (r - l)

-- The global coordinate system works by taking the sum of the chromosome sizes;
-- we represent it using a BigInt
newtype BrowserPoint = BPoint BigInt

derive instance eqBrowserPoint :: Eq BrowserPoint
derive instance ordBrowserPoint :: Ord BrowserPoint
derive instance newtypeBrowserPoint :: Newtype BrowserPoint _

-- Subsets of the global coordinate system are defined by some interval,
--

data Interval c = Interval c c

inInterval :: forall c.
              Ord c
           => c
           -> Interval c
           -> Boolean
inInterval p (Interval l r) = l <= p && p <= r

_iL :: forall c. Lens' (Interval c) c
_iL = lens (\(Interval l _) -> l) (\(Interval _ r) l -> Interval l r)

_iR :: forall c. Lens' (Interval c) c
_iR = lens (\(Interval _ r) -> r) (\(Interval l _) r -> Interval l r)

-- clunky but works for now
data LocalPoint c = Local (Interval c) (Ratio BigInt)

_lIv :: forall c. Lens' (LocalPoint c) (Interval c)
_lIv = lens (\(Local i _) -> i) (\(Local _ p) i -> Local i p)

_lP :: forall c. Lens' (LocalPoint c) (Ratio BigInt)
_lP = lens (\(Local _ p) -> p) (\(Local i _) p -> Local i p)

-- TODO This is dumb and bad
unitRatioToNumber :: Ratio BigInt
                  -> Number
unitRatioToNumber r =
  let n = (Ratio.numerator r)
      d = (Ratio.denominator r)
  in (BigInt.toNumber n) / (BigInt.toNumber d)

-- for now we just assume that the given point is in the interval...
globalToLocal :: forall a c.
                 Newtype c BigInt
              => Interval c
              -> c
              -> LocalPoint c
globalToLocal iv@(Interval l r) p =
  let l' = unwrap l
      r' = unwrap r
      p' = ((unwrap p) - l') % (r' - l')
  in Local iv p'

localToGlobal :: forall c.
                 Newtype c BigInt
              => LocalPoint c
              -> c
localToGlobal (Local (Interval l r) p) =
  let r' = (unwrap r) % one
      l' = (unwrap l) % one
      p' = (p * (r' - l')) + l'
  in wrap $ (Ratio.numerator p') / (Ratio.denominator p')

intervalSize :: forall c a.
                Newtype c a
             => Ring a
             => Interval c
             -> a
intervalSize (Interval l r) = (unwrap r) - (unwrap l)

-- | Transform a point in some interval A to the same point in interval B
seenFrom :: forall a b c.
            Newtype c BigInt
         => Newtype b BigInt
         => LocalPoint c
         -> Interval b
         -> LocalPoint b
seenFrom p i =
  let p' = unwrap $ localToGlobal p
  in globalToLocal i (wrap p')

intervalSeenFrom :: forall a b c.
                    Newtype c BigInt
                 => Newtype b BigInt
                 => Interval c
                 -> Interval b
                 -> Interval (Ratio BigInt)
intervalSeenFrom (Interval l r) i2 =
  let pl = globalToLocal i2 (wrap $ unwrap l)
      pr = globalToLocal i2 (wrap $ unwrap r)
  in Interval (pl^._lP) (pr^._lP)

type IntervalPoint = LocalPoint BrowserPoint

type ChrInterval c = { interval :: Interval c, chrSize :: Bp }

newtype CoordSys i c =
  CoordSys { size :: c
           , padding :: c
           -- , intervals :: Array (Tuple i (Interval c))
           , intervals :: Array (Tuple i (ChrInterval c))
           }

-- TODO need to make sure the padding is correctly applied/removed
mkCoordSys :: forall i c.
              Array (Tuple i BigInt)
           -> BigInt
           -> CoordSys i BrowserPoint
mkCoordSys chrs padding = CoordSys { size, padding: wrap padding, intervals }
  where (Tuple ids sizes) = Array.unzip chrs
        os = map BPoint $ Array.scanl (\x y -> padding + x + y) zero sizes
        ivals = Array.zipWith Interval (wrap zero `Array.cons` os) os
        intervals = Array.zip ids $
                    Array.zipWith (\i s -> {interval: i, chrSize:(Bp $ BigInt.toNumber s)}) ivals sizes
        size = wrap $ (sum sizes) + (length sizes * padding)

findInterval :: forall i c.
                Ord c
             => CoordSys i c
             -> c
             -> Maybe (Tuple i (ChrInterval c))
findInterval (CoordSys s) p =
  Array.find (\(Tuple i iv) -> p `inInterval` iv.interval) s.intervals

intervals :: forall i c.
             Ord i
          => CoordSys i c
          -> i
          -> i
          -> Maybe (Array (ChrInterval c))
intervals (CoordSys s) l r = do
  let l' = min l r
      r' = max l r

  lIndex <- Array.findIndex ((==) l' <<< fst) s.intervals
  rIndex <- Array.findIndex ((==) r' <<< fst) s.intervals

  pure $ snd <$> Array.slice lIndex rIndex s.intervals

viewIntervals :: forall i c.
                 Ord i
              => Ord c
              => CoordSys i c
              -> Interval c
              -> Maybe (Array (ChrInterval c))
viewIntervals cs (Interval l r) = do
  lIv <- fst <$> findInterval cs l
  rIv <- fst <$> findInterval cs r

  intervals cs lIv rIv

  -- pure $ Tuple lIv rIv

canvasToView :: forall r.
                { width :: Number | r }
             -> Number
             -> Ratio BigInt
canvasToView {width} x = x' % w'
  where w' = BigInt.fromInt $ Int.round width
        x' = BigInt.fromInt $ Int.round x

canvasToBrowserOffset :: forall r.
                         { width :: Number | r }
                      -> BigInt
                      -> Number
                      -> BrowserPoint
canvasToBrowserOffset w vw x =
  let x' = canvasToView w x
      p' = x' * (vw % one)
  in wrap $ (Ratio.numerator p') / (Ratio.denominator p')

globalToFrame :: forall i c.
                 Eq i
              => CoordSys i BrowserPoint
              -> BrowserPoint
              -> Maybe (Tuple i IntervalPoint)
globalToFrame cs bp@(BPoint p) = do
  (Tuple i iv) <- findInterval cs bp
  pure $ Tuple i $ globalToLocal iv.interval bp

intervalToChr :: BrowserPoint
              -> IntervalPoint
              -> Bp
              -> Maybe Bp
intervalToChr padding (Local (Interval l r) p) chrSize = do
  let padR = (unwrap padding) % (unwrap r - unwrap l)
  -- guard $ p >= padR && p <= one - padR
  let p' = p - padR
      bp = Bp $ (BigInt.toNumber $ Ratio.numerator p') / (BigInt.toNumber $ Ratio.denominator p')

  -- TODO it's dumb that Bp is still a Number newtype
  pure $ bp * chrSize

frameToChr :: forall i c.
              Eq i
           => CoordSys i BrowserPoint
           -> Tuple i IntervalPoint
           -> Maybe Bp
frameToChr (CoordSys s) (Tuple i lp) = do
  iv <- snd <$> Array.find ((==) i <<< fst) s.intervals
  intervalToChr s.padding lp iv.chrSize

-- | Maps an interval to the canvas,
-- | assuming the interval coincides directly with the canvas view;
-- | i.e. does not try to map the point to the end up in [0, canvas width].
localToCanvasView :: forall i c r.
                     { width :: Number | r }
                  -> LocalPoint BrowserPoint
                  -> Interval BrowserPoint
                  -> Number
localToCanvasView {width} point view@(Interval l r) =
  let p :: Ratio BigInt
      p = point `seenFrom` view ^. _lP
  in (unitRatioToNumber p) * width

intervalSeenFromCanvas ::  forall i c r.
                           { width :: Number | r }
                       -> Interval BrowserPoint
                       -> Interval BrowserPoint
                       -> Interval Number
intervalSeenFromCanvas {width} (Interval l r) view =
  let l' = unitRatioToNumber $ globalToLocal view l ^. _lP
      r' = unitRatioToNumber $ globalToLocal view r ^. _lP
  in Interval (l' * width) (r' * width)


Fixed preview button

Fixed preview button

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

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

data PresentAs = Embed | Publish

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

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

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

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

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

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

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

data Message = Dismiss

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

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

render ∷ State → H.ComponentHTML Query
render state =
  case state.copyVal, state.presentingAs of
    Nothing, Publish →
      renderLoadingDialog "Publish deck"
    Nothing, Embed →
      renderLoadingDialog "Embed deck"
    Just (Left error), _ →
      renderErrorDialog error
    Just (Right copyVal), Publish →
      renderPublishDialog state copyVal
    Just (Right copyVal), Embed →
      renderEmbedDialog state copyVal

renderLoadingDialog ∷ String → H.ComponentHTML Query
renderLoadingDialog header =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text header ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
        [ HH.div
            [ HP.class_ $ H.ClassName "sd-dialog-loading" ]
            [ HH.img [ HP.src "img/spin.gif" ]
            , HH.p_ [ HH.text "Loading..." ]
            ]
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnPrimary ]
            , HE.onClick (HE.input_ HandleCancel)
            , HP.type_ HP.ButtonButton
            ]
            [ HH.text "Cancel" ]
        ]
    ]

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

renderErrorDialog ∷ ParseError → H.ComponentHTML Query
renderErrorDialog error =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Couldn't publish deck" ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
        [ HH.p_ [ HH.text "An error occured, please try refreshing and if the error persists then please contact SlamData." ]
        , HH.small_ [ HH.text $ "Couldn't parse URL: " <> show error ]
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        [ HH.button
          [ HP.classes [ B.btn, B.btnPrimary ]
          , HE.onClick (HE.input_ HandleCancel)
          , HP.type_ HP.ButtonButton
          ]
          [ HH.text "Ok" ]
        ]
    ]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

renderCopyVal ∷ State → URI → String
renderCopyVal state =
  case state.presentingAs of
    Publish → URI.printURI ∘ renderPublishURI state
    Embed → renderEmbedSource state

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

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

renderPublishURI ∷ State → URI → URI.URI
renderPublishURI state@{sharingInput, permToken, isLoggedIn, styleURIString} locationURI =
  URI.URI
    (URIT.uriScheme locationURI)
    (URI.HierarchicalPart
      (HierarchicalPart.authority $ URIT.hierarchicalPart locationURI)
      (Right <$> filePathFromURI locationURI))
    (Just $ URI.Query query)
    (Just fragment)
  where
  fragment ∷ String
  fragment =
    Str.drop 1
      $ mkWorkspaceHash
          (deckPath' sharingInput.workspacePath sharingInput.deckId)
          (WA.Load AT.ReadOnly)
          SM.empty

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

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

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

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

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

data PresentAs = Embed | Publish

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

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

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

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

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

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

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

data Message = Dismiss

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

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

render ∷ State → H.ComponentHTML Query
render state =
  case state.copyVal, state.presentingAs of
    Nothing, Publish →
      renderLoadingDialog "Publish deck"
    Nothing, Embed →
      renderLoadingDialog "Embed deck"
    Just (Left error), _ →
      renderErrorDialog error
    Just (Right copyVal), Publish →
      renderPublishDialog state copyVal
    Just (Right copyVal), Embed →
      renderEmbedDialog state copyVal

renderLoadingDialog ∷ String → H.ComponentHTML Query
renderLoadingDialog header =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text header ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
        [ HH.div
            [ HP.class_ $ H.ClassName "sd-dialog-loading" ]
            [ HH.img [ HP.src "img/spin.gif" ]
            , HH.p_ [ HH.text "Loading..." ]
            ]
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        [ HH.button
            [ HP.classes [ B.btn, B.btnPrimary ]
            , HE.onClick (HE.input_ HandleCancel)
            , HP.type_ HP.ButtonButton
            ]
            [ HH.text "Cancel" ]
        ]
    ]

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

renderErrorDialog ∷ ParseError → H.ComponentHTML Query
renderErrorDialog error =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Couldn't publish deck" ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
        [ HH.p_ [ HH.text "An error occured, please try refreshing and if the error persists then please contact SlamData." ]
        , HH.small_ [ HH.text $ "Couldn't parse URL: " <> show error ]
        ]
    , HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        [ HH.button
          [ HP.classes [ B.btn, B.btnPrimary ]
          , HE.onClick (HE.input_ HandleCancel)
          , HP.type_ HP.ButtonButton
          ]
          [ HH.text "Ok" ]
        ]
    ]

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

renderCopyVal ∷ State → URI → String
renderCopyVal state =
  case state.presentingAs of
    Publish → URI.printURI ∘ renderPublishURI state
    Embed → renderEmbedSource state

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

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

renderPublishURI ∷ State → URI → URI.URI
renderPublishURI state@{sharingInput, permToken, isLoggedIn, styleURIString} locationURI =
  URI.URI
    (URIT.uriScheme locationURI)
    (URI.HierarchicalPart
      (HierarchicalPart.authority $ URIT.hierarchicalPart locationURI)
      (Right <$> filePathFromURI locationURI))
    (Just $ URI.Query query)
    (Just fragment)
  where
  fragment ∷ String
  fragment =
    Str.drop 1
      $ mkWorkspaceHash
          (deckPath' sharingInput.workspacePath sharingInput.deckId)
          (WA.Load AT.ReadOnly)
          SM.empty

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

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

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


remove old tests

remove old tests

module Model.Presentation.Test (tests) where

import Prelude (Unit, not, ($), id, map, const, discard, (<<<), (#), (-), (+), negate)
import Data.List (List(..), (!!), length)
import Data.Either (Either, either, fromRight)
import Data.Maybe (Maybe(..), isJust, fromJust)
import Partial.Unsafe (unsafePartial)
import Optic.Core
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert, equal)
import Test.Unit.Console (TESTOUTPUT)

import Model.Presentation(initial, create, presentable, size, slide, next, previous, reset)
import Model.Presentation.New as P

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Model.NewPresentation" do
      test "size" do
        let actual = testPres ^. P.size
        let expected = length testSlides
        equal expected actual
      test "slide content" do
        let actual = testPres ^. P.slide .. P.content
        let expected = testSlide 0
        equal expected actual
      test "get slide number" do
        let actual = testPres ^. P.slide .. P.number
        equal 1 actual
      test "change slide number" do
        let n = 3
        let updated = testPres # P.slide .. P.number .~ n
        let actual = updated ^. P.slide .. P.content
        let expected = testSlide (n - 1)
        equal expected actual
        equal n $ updated ^. P.slide .. P.number
      test "slide number upper bound" do
        let updated = testPres # P.slide .. P.number .~ 300
        let actual = updated ^. P.slide .. P.content
        let expected = testSlide (length testSlides - 1)
        equal expected actual
        equal (length testSlides) $ updated ^. P.slide .. P.number
      test "slide number lower bound" do
        let updated = testPres # P.slide .. P.number .~ (0)
        let expected = testSlide 0
        equal (testSlide 0) $ updated ^. P.slide .. P.content
        equal 1 $ updated ^. P.slide .. P.number
      test "relative slide change" do
        let up = 2
        let down = 1
        let moved = ((testPres ^. P.slide) # P.number +~ up) # P.number -~ down
        equal (testSlide (up - down)) $ moved ^. P.content
        equal (1 + up - down) $ moved ^. P.number

testSlides :: List SlamDown
testSlides = unsafePartial fromRight $ map slides $ parseMd testSource

testSlide :: Int -> SlamDown
testSlide i = unsafePartial fromJust $ testSlides !! i

testPres :: P.Presentation
testPres = unsafePartial $ fromRight $ P.create testSource

testSource :: String
testSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""

module Model.Presentation.Test (tests) where

import Prelude (Unit, not, ($), id, map, const, discard, (<<<), (#), (-), (+), negate)
import Data.List (List(..), (!!), length)
import Data.Either (Either, either, fromRight)
import Data.Maybe (Maybe(..), isJust, fromJust)
import Partial.Unsafe (unsafePartial)
import Optic.Core
import Text.Markdown.SlamDown (SlamDown)
import Text.Markdown.SlamDown.Parser (parseMd)
import Content.Slide (slides)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Aff.AVar (AVAR)
import Test.Unit (suite, test)
import Test.Unit.Main (runTest)
import Test.Unit.Assert (assert, equal)
import Test.Unit.Console (TESTOUTPUT)

import Model.Presentation(initial, create, presentable, size, slide, next, previous, reset)
import Model.Presentation.New as P

tests :: ∀ fx. Eff ( console :: CONSOLE
                  , testOutput :: TESTOUTPUT
                  , avar :: AVAR
                  | fx
          ) Unit
tests = do
  runTest do
    suite "Model.NewPresentation" do
      test "size" do
        let actual = testPres ^. P.size
        let expected = length testSlides
        equal expected actual
      test "slide content" do
        let actual = testPres ^. P.slide .. P.content
        let expected = testSlide 0
        equal expected actual
      test "get slide number" do
        let actual = testPres ^. P.slide .. P.number
        equal 1 actual
      test "change slide number" do
        let n = 3
        let updated = testPres # P.slide .. P.number .~ n
        let actual = updated ^. P.slide .. P.content
        let expected = testSlide (n - 1)
        equal expected actual
        equal n $ updated ^. P.slide .. P.number
      test "slide number upper bound" do
        let updated = testPres # P.slide .. P.number .~ 300
        let actual = updated ^. P.slide .. P.content
        let expected = testSlide (length testSlides - 1)
        equal expected actual
        equal (length testSlides) $ updated ^. P.slide .. P.number
      test "slide number lower bound" do
        let updated = testPres # P.slide .. P.number .~ (0)
        let expected = testSlide 0
        equal (testSlide 0) $ updated ^. P.slide .. P.content
        equal 1 $ updated ^. P.slide .. P.number
      test "relative slide change" do
        let up = 2
        let down = 1
        let moved = ((testPres ^. P.slide) # P.number +~ up) # P.number -~ down
        equal (testSlide (up - down)) $ moved ^. P.content
        equal (1 + up - down) $ moved ^. P.number

    suite "Model.Presentation" do
      test "initial presentation is not presentable" do
        assert "should be not presentable" $ not $ presentable $ initial
      test "create" do
        let pres = create testSource
        let actual = size pres
        let expected = 3
        equal expected actual
      test "get slide not presentable" do
        assert "no slide" $ not $ isJust (slide initial)
      test "get presentable slide" do
        let s = slide $ create testSource
        let actualContent = map _.content s
        let actualNumber = map _.number s
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "next not presentable" do
        assert "not presentable" $ not $ presentable $ next initial
      test "previous not presentable" do
        assert "not presentable" $ not $ presentable $ previous initial
      test "reset not presentable" do
        assert "not presentable" $ not $ presentable $ reset initial
      test "next presentable" do
        let pres = create testSource
        let actual = slide $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 1) actualContent
        equal (Just 2) actualNumber
      test "previous presentable" do
        let pres = create testSource
        let actual = slide $ previous $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 1) actualContent
        equal (Just 2) actualNumber
      test "reset presentable" do
        let pres = create testSource
        let actual = slide $ reset $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "lower clamp presentable" do
        let pres = create testSource
        let actual = slide $ previous pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 0) actualContent
        equal (Just 1) actualNumber
      test "upper clamp presentable" do
        let pres = create testSource
        let actual = slide $ next $ next $ next $ next $ next pres
        let actualContent = map _.content actual
        let actualNumber = map _.number actual
        equal (testSlides !! 2) actualContent
        equal (Just 3) actualNumber

testSlides :: List SlamDown
testSlides = unsafePartial fromRight $ map slides $ parseMd testSource

testSlide :: Int -> SlamDown
testSlide i = unsafePartial fromJust $ testSlides !! i

testPres :: P.Presentation
testPres = unsafePartial $ fromRight $ P.create testSource

testSource :: String
testSource = """
# Slide One

On this slide we have lots of coolness.

---
# Slide Two

## Let me tell you

This is weird.

## Let me tell you something else

_Really_ weird.

---
# Final Slide

Wasn't that just the greatest presentation?

"""