adding runSlidesWithMoves

adding runSlidesWithMoves

-- | A tiny EDSL for creating presentations

module Slides
  ( runSlides
  , runSlidesWithMoves
  , mkSlides
  , Move(..)
  , Slides()
  , Slide()
  , Element()
  , (<+>)
  , appendPlus
  , slide
  , empty
  , title
  , text
  , code
  , image
  , link
  , valign
  , halign
  , ulist
  , group
  , center
  , withClass
  , withId
  , bold
  , italic
  ) where

import Prelude
import Data.List.Zipper as Z
import Signal (Signal)
import Slides.Internal.Input as I
import Control.Comonad (extract)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Array ((:), uncons, singleton)
import Data.Foldable (foldMap, fold, foldr)
import Data.Generic (class Generic, gShow)
import Data.List (List(..), length)
import Data.Maybe (Maybe(..), fromMaybe)
import Signal (foldp, runSignal) as S
import Text.Smolder.HTML (p, div, img, a, h2, ul, li, span, pre) as H
import Text.Smolder.HTML.Attributes (className, id, src, href) as H
import Text.Smolder.Markup (Markup, text) as H
import Text.Smolder.Markup ((!))
import Text.Smolder.Renderer.String (render) as H

-------------
-- Running --
-------------

-- | run a component for a presentation
runSlides :: forall e. Slides -> Eff ( dom :: DOM | e ) Unit
runSlides slides = do
  inn <- I.input
  runSlidesWithMoves (inputToMove <$> inn) slides

-- | run a component for a presentation with a custom Move
-- | Signal to determine when the slides should move and to which
-- | Slide.
runSlidesWithMoves :: forall e. Signal Move -> Slides -> Eff ( dom :: DOM | e ) Unit
runSlidesWithMoves move (Slides slides) = do
  let ui = S.foldp moveSlides slides move
  S.runSignal (setHtml <<< H.render <<< render <$> ui)

-- Rendering

render :: forall a. SlidesInternal -> H.Markup a
render slides =
  H.div ! H.id "main" $ do
    H.span ! H.className "counter" $
      H.text $ show (position slides + 1) <> " / " <> show (zipLength slides)
    renderSlides (extract slides)

foreign import setHtml :: forall e. String -> Eff ( dom :: DOM | e ) Unit

-- | Which way should the slides move:
-- | - `Back`: Go back one slide. If at the beginning will do nothing
-- | - `Next`: Go to next slide. If at the end will do nothing
-- | - `Start`: Go to the start
-- | - `End`: Go to the end
-- | - `BackOrEnd`: Like `Back` but will wrap around
-- | - `NextOrEnd`: Like `Next` but will wrap around
data Move
  = Back
  | Next
  | Start
  | End
  | BackOrEnd
  | NextOrStart
  | None

inputToMove :: I.Input -> Move
inputToMove i
  | I.clickOrHold (i.arrows.right) = Next
  | I.clickOrHold (i.arrows.left)  = Back
  | I.clickOrHold (i.arrows.down)  = Start
  | I.clickOrHold (i.arrows.up)    = End
  | otherwise = None

moveSlides :: Move -> SlidesInternal -> SlidesInternal
moveSlides m slides = case m of
  NextOrStart ->
    fromMaybe (moveSlides Start slides) (Z.up slides)

  BackOrEnd ->
    fromMaybe (moveSlides End slides) (Z.up slides)

  Next ->
    fromMaybe slides (Z.down slides)

  Back ->
    fromMaybe slides (Z.up slides)

  Start ->
    Z.beginning slides

  End ->
    Z.end slides

  None ->
    slides

position :: forall a. Z.Zipper a -> Int
position (Z.Zipper b _ _) = length b

zipLength :: forall a. Z.Zipper a -> Int
zipLength (Z.Zipper b _ a) = 1 + length b + length a

-----------
-- Model --
-----------

-- | Slides state for a component
data Slides = Slides SlidesInternal

type SlidesInternal
  = Z.Zipper Slide

-- | A single slide
data Slide
  = Slide Element

-- | A data type defining the AST
data Element
  = Empty
  | Title  String
  | Text   String
  | Code   String
  | Image  String
  | Link   String Element
  | HAlign (Array Element)
  | VAlign (Array Element)
  | UList  (Array Element)
  | Group  (Array Element)
  | Class String Element
  | Id    String Element

derive instance genericElement :: Generic Element

-- | A Show instance for testing
instance showElement :: Show Element where
  show = gShow

instance semigroupElement :: Semigroup Element where
  append e1 e2 = Group [e1, e2]

-- | Append two elements with some padding in between
appendPlus :: Element -> Element -> Element
appendPlus e1 e2 = e1 <> Class "padapp" Empty <> e2

-- | Append two elements with some padding in between
infixr 5 appendPlus as <+>

-----------
-- Utils --
-----------

-- | Create slides component from an array of slides
mkSlides :: Array Slide -> Slides
mkSlides sl = case uncons sl of
  Just {head, tail} ->
    Slides $ Z.Zipper Nil head (foldr Cons Nil tail)

  Nothing ->
    Slides $ Z.Zipper Nil empty Nil

-- | Create a slide from a title and an element
slide :: String -> Element -> Slide
slide ttl el = Slide (valign [title ttl, el])

-- | An empty slide
empty :: Slide
empty = Slide Empty

-- | A title
title :: String -> Element
title ttl = halign [valign [text ""], Title ttl, valign [text ""]]

-- | Turn an element into a link to url
link :: String -> Element -> Element
link = Link

-- | A text element
text :: String -> Element
text = Text

-- | An image element
image :: String -> Element
image = Image

-- | A <pre> element
code :: String -> Element
code = Code

-- | Group elements as a unit
group :: Array Element -> Element
group = Group

-- | Horizontally align elements in array
halign :: Array Element -> Element
halign = HAlign

-- | Vertically align elements in array
valign :: Array Element -> Element
valign = VAlign

-- | An unordered list of element from an array of elements
ulist :: Array Element -> Element
ulist = UList

-- | Add an Html class to an element
withClass :: String -> Element -> Element
withClass = Class

-- | Add an Html id to an element
withId :: String -> Element -> Element
withId = Id

-- | Position an element at the center of its parent
center :: Element -> Element
center = withClass "center" <<< group <<< singleton

-- | Format text with bold in this element
bold :: Element -> Element
bold = withClass "boldEl" <<< group <<< singleton

-- | Format text with italic in this element
italic :: Element -> Element
italic = withClass "italicEl" <<< group <<< singleton

---------------
-- Rendering --
---------------

renderSlides :: forall a. Slide -> H.Markup a
renderSlides (Slide el) =
  H.div ! H.className "slide" $ renderE el

renderE :: forall a. Element -> H.Markup a
renderE element =
  case element of
    Empty ->
      H.span (H.text "")

    Title tl ->
      H.span ! H.className "title" $ H.h2 (H.text tl)

    Link l el ->
      H.a ! H.href l $ renderE el

    Text str ->
      H.p ! H.className "marwid" $ H.text str

    Code c ->
      H.pre ! H.className "marwid" $ H.text c

    Image url ->
      H.img ! H.className "marwid" ! H.src url

    VAlign els ->
      H.span ! H.className "colflex" $ fold $ applyRest block $ map renderE els

    HAlign els ->
      H.span ! H.className "rowflex" $ foldMap renderE els

    UList els ->
      H.span $ H.ul $ foldMap (H.li <<< renderE) els

    Group els ->
      H.span $ foldMap renderE els

    Class c e ->
      renderE e ! H.className c

    Id i e ->
      renderE e ! H.id i

block :: forall a. H.Markup a -> H.Markup a
block = H.span ! H.className "block"

applyRest :: forall a. (a -> a) -> Array a -> Array a
applyRest f xs =
  case uncons xs of
    Nothing -> xs
    Just list -> list.head : map f list.tail

-- | A tiny EDSL for creating presentations

module Slides
  ( runSlides
  , mkSlides
  , Move()
  , Slides()
  , Slide()
  , Element()
  , (<+>)
  , appendPlus
  , slide
  , empty
  , title
  , text
  , code
  , image
  , link
  , valign
  , halign
  , ulist
  , group
  , center
  , withClass
  , withId
  , bold
  , italic
  ) where

import Prelude
import Data.List.Zipper as Z
import Slides.Internal.Input as I
import Control.Comonad (extract)
import Control.Monad.Eff (Eff)
import DOM (DOM)
import Data.Array ((:), uncons, singleton)
import Data.Foldable (foldMap, fold, foldr)
import Data.Generic (class Generic, gShow)
import Data.List (List(..), length)
import Data.Maybe (Maybe(..), fromMaybe)
import Signal (foldp, runSignal) as S
import Text.Smolder.HTML (p, div, img, a, h2, ul, li, span, pre) as H
import Text.Smolder.HTML.Attributes (className, id, src, href) as H
import Text.Smolder.Markup (Markup, text) as H
import Text.Smolder.Markup ((!))
import Text.Smolder.Renderer.String (render) as H

-------------
-- Running --
-------------

-- | run a component for a presentation
runSlides :: forall e. Slides -> Eff ( dom :: DOM | e ) Unit
runSlides (Slides slides) = do
  inn <- I.input
  let ui = S.foldp update slides inn
  S.runSignal (setHtml <<< H.render <<< render <$> ui)

-- Rendering

render :: forall a. SlidesInternal -> H.Markup a
render slides =
  H.div ! H.id "main" $ do
    H.span ! H.className "counter" $
      H.text $ show (position slides + 1) <> " / " <> show (zipLength slides)
    renderSlides (extract slides)

foreign import setHtml :: forall e. String -> Eff ( dom :: DOM | e ) Unit

-- Update

update :: I.Input -> SlidesInternal -> SlidesInternal
update i slides
  | I.clickOrHold (i.arrows.right) = moveSlides Next  slides
  | I.clickOrHold (i.arrows.left)  = moveSlides Back  slides
  | I.clickOrHold (i.arrows.down)  = moveSlides Start slides
  | I.clickOrHold (i.arrows.up)    = moveSlides End   slides
  | otherwise = slides

data Move
  = Back
  | Next
  | Start
  | End

moveSlides :: Move -> SlidesInternal -> SlidesInternal
moveSlides Back slides =
  fromMaybe slides (Z.up slides)

moveSlides Next slides =
  fromMaybe slides (Z.down slides)

moveSlides Start slides =
  Z.beginning slides

moveSlides End slides =
  Z.end slides

position :: forall a. Z.Zipper a -> Int
position (Z.Zipper b _ _) = length b

zipLength :: forall a. Z.Zipper a -> Int
zipLength (Z.Zipper b _ a) = 1 + length b + length a

-----------
-- Model --
-----------

-- | Slides state for a component
data Slides = Slides SlidesInternal

type SlidesInternal
  = Z.Zipper Slide

-- | A single slide
data Slide
  = Slide Element

-- | A data type defining the AST
data Element
  = Empty
  | Title  String
  | Text   String
  | Code   String
  | Image  String
  | Link   String Element
  | HAlign (Array Element)
  | VAlign (Array Element)
  | UList  (Array Element)
  | Group  (Array Element)
  | Class String Element
  | Id    String Element

derive instance genericElement :: Generic Element

-- | A Show instance for testing
instance showElement :: Show Element where
  show = gShow

instance semigroupElement :: Semigroup Element where
  append e1 e2 = Group [e1, e2]

-- | Append two elements with some padding in between
appendPlus :: Element -> Element -> Element
appendPlus e1 e2 = e1 <> Class "padapp" Empty <> e2

-- | Append two elements with some padding in between
infixr 5 appendPlus as <+>

-----------
-- Utils --
-----------

-- | Create slides component from an array of slides
mkSlides :: Array Slide -> Slides
mkSlides sl = case uncons sl of
  Just {head, tail} ->
    Slides $ Z.Zipper Nil head (foldr Cons Nil tail)

  Nothing ->
    Slides $ Z.Zipper Nil empty Nil

-- | Create a slide from a title and an element
slide :: String -> Element -> Slide
slide ttl el = Slide (valign [title ttl, el])

-- | An empty slide
empty :: Slide
empty = Slide Empty

-- | A title
title :: String -> Element
title ttl = halign [valign [text ""], Title ttl, valign [text ""]]

-- | Turn an element into a link to url
link :: String -> Element -> Element
link = Link

-- | A text element
text :: String -> Element
text = Text

-- | An image element
image :: String -> Element
image = Image

-- | A <pre> element
code :: String -> Element
code = Code

-- | Group elements as a unit
group :: Array Element -> Element
group = Group

-- | Horizontally align elements in array
halign :: Array Element -> Element
halign = HAlign

-- | Vertically align elements in array
valign :: Array Element -> Element
valign = VAlign

-- | An unordered list of element from an array of elements
ulist :: Array Element -> Element
ulist = UList

-- | Add an Html class to an element
withClass :: String -> Element -> Element
withClass = Class

-- | Add an Html id to an element
withId :: String -> Element -> Element
withId = Id

-- | Position an element at the center of its parent
center :: Element -> Element
center = withClass "center" <<< group <<< singleton

-- | Format text with bold in this element
bold :: Element -> Element
bold = withClass "boldEl" <<< group <<< singleton

-- | Format text with italic in this element
italic :: Element -> Element
italic = withClass "italicEl" <<< group <<< singleton

---------------
-- Rendering --
---------------

renderSlides :: forall a. Slide -> H.Markup a
renderSlides (Slide el) =
  H.div ! H.className "slide" $ renderE el

renderE :: forall a. Element -> H.Markup a
renderE element =
  case element of
    Empty ->
      H.span (H.text "")

    Title tl ->
      H.span ! H.className "title" $ H.h2 (H.text tl)

    Link l el ->
      H.a ! H.href l $ renderE el

    Text str ->
      H.p ! H.className "marwid" $ H.text str

    Code c ->
      H.pre ! H.className "marwid" $ H.text c

    Image url ->
      H.img ! H.className "marwid" ! H.src url

    VAlign els ->
      H.span ! H.className "colflex" $ fold $ applyRest block $ map renderE els

    HAlign els ->
      H.span ! H.className "rowflex" $ foldMap renderE els

    UList els ->
      H.span $ H.ul $ foldMap (H.li <<< renderE) els

    Group els ->
      H.span $ foldMap renderE els

    Class c e ->
      renderE e ! H.className c

    Id i e ->
      renderE e ! H.id i

block :: forall a. H.Markup a -> H.Markup a
block = H.span ! H.className "block"

applyRest :: forall a. (a -> a) -> Array a -> Array a
applyRest f xs =
  case uncons xs of
    Nothing -> xs
    Just list -> list.head : map f list.tail


no history when nothing erased

no history when nothing erased

module App.Events where

import Prelude
import App.Background (Background)
import App.Cycle (Cycle, findCycles)
import App.Geometry (Point, Stroke(Line, Arc), closeToPoint)
import App.Graph (applyIntersections, edges, findIntersections, removeMultiple)
import App.Snap (snapToPoint, snapPoints)
import App.State (State, Tool(..))
import CSS.Color (Color)
import Data.List (List(..), filter, singleton, (:))
import Data.Map (keys, lookup)
import Data.Map (update) as Map
import Data.Maybe (Maybe(..))
import KeyDown (KeyData)
import Mouse (MouseData(..))
import Prelude ((==))
import Pux (EffModel, noEffects)

data Event
  = Select Tool
  | SelectCycle Cycle
  | ApplyColor Cycle Color
  | WindowResize Int Int
  | ChangeBackground Background
  | Key KeyData
  | Mouse MouseData
  | NoOp

foldp :: forall fx. Event -> State -> EffModel State Event fx
foldp evt st = noEffects $ update evt st

update :: Event -> State -> State
update (Mouse (MouseDown p)) s =
  case s.tool of LineTool -> drawPoint s p
                 ArcTool -> drawPoint s p
                 EraserTool opts -> erase s {tool = EraserTool opts {down=true, pt=p}}
                 _ -> s

update (Mouse (MouseMove p)) s =
  case s.tool of LineTool -> updateSnapPoint s p
                 ArcTool -> updateSnapPoint s p
                 EraserTool opts -> erase s {tool = EraserTool opts {pt=p}}
                 _ -> s

update (Mouse (MouseUp pt)) s =
  case s.tool of EraserTool opts -> s {tool = EraserTool opts {down=false, pt=pt}}
                 _ -> s

update (Mouse (Wheel delta)) s =
  case s.tool of
    EraserTool opts -> s {
      tool = EraserTool opts {size = clamp 5.0 405.0 (opts.size + if delta < 0.0 then 10.0 else -10.0)}
    }
    _ -> s

update (Select tool) s
  = s { tool = tool
      , click = Nothing
      , hover = Nothing
      , snapPoint = Nothing
      , currentStroke = Nothing
      , selection = Nil
      }

update (ApplyColor cycle color) s =
  s { drawing { cycles = Map.update (\c -> (Just color)) cycle s.drawing.cycles }
    , undos = s.drawing : s.undos
    , redos = Nil
    }

update (WindowResize w h) s =
  s {windowWidth = w, windowHeight = h}

update (ChangeBackground b) s =
  s {background = b, snapPoint = Nothing}

update (Key k) s =
  let undoState = case s.undos of Nil -> s
                                  lastDrawing : rest -> s { drawing = lastDrawing
                                                          , undos = rest
                                                          , redos = s.drawing : s.redos
                                                          }

      redoState = case s.redos of Nil -> s
                                  nextDrawing : rest -> s { drawing = nextDrawing
                                                          , undos = s.drawing : s.undos
                                                          , redos = rest
                                                          }

   in case k of {code: "KeyZ", meta: true, shift: false} -> undoState
                {code: "KeyZ", ctrl: true, shift: false} -> undoState
                {code: "KeyZ", meta: true, shift: true} -> redoState
                {code: "KeyZ", ctrl: true, shift: true} -> redoState
                _ -> s

update (SelectCycle cycle) state = state {selection = singleton cycle}

update NoOp s = s

drawPoint :: State -> Point -> State
drawPoint s p =
  let newPt = case snapToPoint p s.background s.drawing.snapPoints of
                   Just sp -> sp
                   _ -> p
   in case s.click of
       Nothing -> s { click = Just newPt }
       Just c ->
         case newStroke s newPt of
              Nothing -> s
              Just stroke -> (updateForStroke s stroke) { click = Nothing
                                                        , currentStroke = Nothing
                                                        , hover = Nothing
                                                        , snapPoint = Nothing
                                                        }

updateSnapPoint :: State -> Point -> State
updateSnapPoint s p =
  let sp = snapToPoint p s.background s.drawing.snapPoints
      newPt = case sp of Just sp' -> sp'
                         _ -> p
   in s { hover = Just p
        , currentStroke = newStroke s newPt
        , snapPoint = sp
        }

newStroke :: State -> Point -> Maybe Stroke
newStroke s p =
  case s.click of
       Just c ->
          case s.tool of
               ArcTool -> Just $ (Arc c p p true)
               LineTool -> Just $ Line c p
               _ -> Nothing

       Nothing -> Nothing

-- erase around the given point
erase :: State -> State
erase s@{tool: EraserTool {down: true, pt, size}} =
  case filter (closeToPoint pt size) $ edges s.drawing.graph of
       Nil -> s
       erasedStrokes ->
         let newGraph = if erasedStrokes == Nil then s.drawing.graph else removeMultiple erasedStrokes s.drawing.graph
             newCycles = if erasedStrokes == Nil then s.drawing.cycles else findCycles newGraph

          in s { drawing =
              { graph: newGraph
              , cycles: newCycles
              , snapPoints: snapPoints newGraph
              }
            , undos = s.drawing : s.undos
            , redos = Nil
            }

erase s = s

updateForStroke :: State -> Stroke -> State
updateForStroke s stroke
  = s { drawing =
        { graph: newGraph
        , cycles: newCycles
        , snapPoints: snapPoints newGraph
        }
      , undos = s.drawing : s.undos
      , redos = Nil
      }
  where
    intersections = findIntersections stroke s.drawing.graph
    splitStroke = case lookup stroke intersections of
                       Just ss -> ss
                       _ -> singleton stroke
    newGraph = applyIntersections intersections s.drawing.graph
    newCycles = findCycles newGraph

module App.Events where

import Prelude
import App.Background (Background)
import App.Cycle (Cycle, findCycles)
import App.Geometry (Point, Stroke(Line, Arc), closeToPoint)
import App.Graph (applyIntersections, edges, findIntersections, removeMultiple)
import App.Snap (snapToPoint, snapPoints)
import App.State (State, Tool(..))
import CSS.Color (Color)
import Data.List (List(..), filter, singleton, (:))
import Data.Map (keys, lookup)
import Data.Map (update) as Map
import Data.Maybe (Maybe(..))
import KeyDown (KeyData)
import Mouse (MouseData(..))
import Prelude ((==))
import Pux (EffModel, noEffects)

data Event
  = Select Tool
  | SelectCycle Cycle
  | ApplyColor Cycle Color
  | WindowResize Int Int
  | ChangeBackground Background
  | Key KeyData
  | Mouse MouseData
  | NoOp

foldp :: forall fx. Event -> State -> EffModel State Event fx
foldp evt st = noEffects $ update evt st

update :: Event -> State -> State
update (Mouse (MouseDown p)) s =
  case s.tool of LineTool -> drawPoint s p
                 ArcTool -> drawPoint s p
                 EraserTool opts -> erase s {tool = EraserTool opts {down=true, pt=p}}
                 _ -> s

update (Mouse (MouseMove p)) s =
  case s.tool of LineTool -> updateSnapPoint s p
                 ArcTool -> updateSnapPoint s p
                 EraserTool opts -> erase s {tool = EraserTool opts {pt=p}}
                 _ -> s

update (Mouse (MouseUp pt)) s =
  case s.tool of EraserTool opts -> s {tool = EraserTool opts {down=false, pt=pt}}
                 _ -> s

update (Mouse (Wheel delta)) s =
  case s.tool of
    EraserTool opts -> s {
      tool = EraserTool opts {size = clamp 5.0 405.0 (opts.size + if delta < 0.0 then 10.0 else -10.0)}
    }
    _ -> s

update (Select tool) s
  = s { tool = tool
      , click = Nothing
      , hover = Nothing
      , snapPoint = Nothing
      , currentStroke = Nothing
      , selection = Nil
      }

update (ApplyColor cycle color) s =
  s { drawing { cycles = Map.update (\c -> (Just color)) cycle s.drawing.cycles }
    , undos = s.drawing : s.undos
    , redos = Nil
    }

update (WindowResize w h) s =
  s {windowWidth = w, windowHeight = h}

update (ChangeBackground b) s =
  s {background = b, snapPoint = Nothing}

update (Key k) s =
  let undoState = case s.undos of Nil -> s
                                  lastDrawing : rest -> s { drawing = lastDrawing
                                                          , undos = rest
                                                          , redos = s.drawing : s.redos
                                                          }

      redoState = case s.redos of Nil -> s
                                  nextDrawing : rest -> s { drawing = nextDrawing
                                                          , undos = s.drawing : s.undos
                                                          , redos = rest
                                                          }

   in case k of {code: "KeyZ", meta: true, shift: false} -> undoState
                {code: "KeyZ", ctrl: true, shift: false} -> undoState
                {code: "KeyZ", meta: true, shift: true} -> redoState
                {code: "KeyZ", ctrl: true, shift: true} -> redoState
                _ -> s

update (SelectCycle cycle) state = state {selection = singleton cycle}

update NoOp s = s

drawPoint :: State -> Point -> State
drawPoint s p =
  let newPt = case snapToPoint p s.background s.drawing.snapPoints of
                   Just sp -> sp
                   _ -> p
   in case s.click of
       Nothing -> s { click = Just newPt }
       Just c ->
         case newStroke s newPt of
              Nothing -> s
              Just stroke -> (updateForStroke s stroke) { click = Nothing
                                                        , currentStroke = Nothing
                                                        , hover = Nothing
                                                        , snapPoint = Nothing
                                                        }

updateSnapPoint :: State -> Point -> State
updateSnapPoint s p =
  let sp = snapToPoint p s.background s.drawing.snapPoints
      newPt = case sp of Just sp' -> sp'
                         _ -> p
   in s { hover = Just p
        , currentStroke = newStroke s newPt
        , snapPoint = sp
        }

newStroke :: State -> Point -> Maybe Stroke
newStroke s p =
  case s.click of
       Just c ->
          case s.tool of
               ArcTool -> Just $ (Arc c p p true)
               LineTool -> Just $ Line c p
               _ -> Nothing

       Nothing -> Nothing

-- erase around the given point
erase :: State -> State
erase s@{tool: EraserTool {down: true, pt, size}} =
  s { drawing =
      { graph: newGraph
      , cycles: newCycles
      , snapPoints: snapPoints newGraph
      }
    , undos = s.drawing : s.undos
    , redos = Nil
    }
  where
    erasedStrokes = filter (closeToPoint pt size) $ edges s.drawing.graph
    newGraph = if erasedStrokes == Nil then s.drawing.graph else removeMultiple erasedStrokes s.drawing.graph
    newCycles = if erasedStrokes == Nil then s.drawing.cycles else findCycles newGraph
erase s = s

updateForStroke :: State -> Stroke -> State
updateForStroke s stroke
  = s { drawing =
        { graph: newGraph
        , cycles: newCycles
        , snapPoints: snapPoints newGraph
        }
      , undos = s.drawing : s.undos
      , redos = Nil
      }
  where
    intersections = findIntersections stroke s.drawing.graph
    splitStroke = case lookup stroke intersections of
                       Just ss -> ss
                       _ -> singleton stroke
    newGraph = applyIntersections intersections s.drawing.graph
    newCycles = findCycles newGraph


Removed duplication

Removed duplication

module OIDC.Crypt
  ( Payload
  , Header
  , hashNonce
  , bindState
  , unbindState
  , verifyIdToken
  , pluckKeyId
  , pluckEmail
  , readHeader
  , readPayload
  , module OIDC.Crypt.Types
  , module J
  ) where

import Control.Applicative (when)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Now as Now
import Data.DateTime.Instant (Instant)
import Data.DateTime.Instant as Instant
import Data.Either (Either)
import Data.Int as Int
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Time.Duration (Seconds(Seconds))
import Data.Time.Duration as Duration
import OIDC.Crypt.JSONWebKey as J
import OIDC.Crypt.Types
import Prelude (bind, not, (<<<), ($), (&&), (<$>), (<=), (>), (*))

foreign import
  data RSAKey :: *

foreign import
  data Header :: *

foreign import
  data Payload :: *

type AcceptedFields
  = { alg :: Array String
    , iss :: Array Issuer
    , gracePeriod :: Seconds
    , verifyAt :: Seconds
    }

foreign import
  hashNonce
    :: UnhashedNonce
    -> HashedNonce

foreign import
  bindState
    :: StateString
    -> KeyString
    -> BoundStateJWS

foreign import
  getKey
    :: J.JSONWebKey
    -> RSAKey

foreign import
  verifyJWT
    :: forall eff
     . IdToken
    -> RSAKey
    -> AcceptedFields
    -> Eff (err :: EXCEPTION | eff) Boolean

foreign import
  readPayload
    :: forall eff
     . IdToken
    -> Eff (err :: EXCEPTION | eff) Payload

foreign import
  readHeader
    :: forall eff
     . IdToken
    -> Eff (err :: EXCEPTION | eff) Header

foreign import
  verifyNonce
    :: UnhashedNonce
    -> Payload
    -> Boolean

foreign import
  _unbindState
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> BoundStateJWS
    -> KeyString
    -> Maybe StateString

foreign import
  verifyAudience
    :: ClientID
    -> Payload
    -> Boolean

foreign import
  _pluckKeyId
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Header
    -> Maybe KeyId

foreign import
  _pluckEmail
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Payload
    -> Maybe Email

foreign import
  _pluckIAT
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Payload
    -> Maybe Int

foreign import
  _pluckExp
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Payload
    -> Maybe Int

unbindState
  :: BoundStateJWS
  -> KeyString
  -> Maybe StateString
unbindState = _unbindState Nothing Just

pluckKeyId
  :: Header
  -> Maybe KeyId
pluckKeyId = _pluckKeyId Nothing Just

pluckEmail
  :: Payload
  -> Maybe Email
pluckEmail = _pluckEmail Nothing Just

pluckIAT
  :: Payload
  -> Maybe Int
pluckIAT = _pluckIAT Nothing Just

pluckExp
  :: Payload
  -> Maybe Int
pluckExp = _pluckExp Nothing Just

verifyIAT :: Seconds -> Payload -> Boolean
verifyIAT unixTimeNow payload =
  maybe false (_ <= unixTimeNow) (Seconds <<< Int.toNumber <$> pluckIAT payload)

verifyExp :: Seconds -> Payload -> Boolean
verifyExp unixTimeNow payload =
  maybe false (_ > unixTimeNow) (Seconds <<< Int.toNumber <$> pluckExp payload)

instantToSeconds ∷ Instant -> Seconds
instantToSeconds = Duration.convertDuration <<< Instant.unInstant

verifyIdToken
  :: forall eff
   . Seconds
  -> IdToken
  -> Issuer
  -> ClientID
  -> UnhashedNonce
  -> J.JSONWebKey
  -> Eff (now :: NOW | eff) (Either Exception.Error Boolean)
verifyIdToken gracePeriod idToken issuer clientId unhashedNonce providerPublicKey =
  Exception.try do
    payload <- readPayload idToken
    unixTimeNow <- instantToSeconds <$> Now.now
    when
      (not $ verifyNonce unhashedNonce payload)
      (Exception.throw "Nonce doesn't match, possible replay attack.")
    when
      (not $ verifyAudience clientId payload)
      (Exception.throw "Audience (client id) doesn't match.")
    when
      (not $ verifyIAT unixTimeNow payload)
      (Exception.throw "Token issued in the future. Check the time on your computer.")
    when
      (not $ verifyExp unixTimeNow payload)
      (Exception.throw "Token expired.")
    verifyJWT
      idToken
      (getKey providerPublicKey)
      { alg: ["RS256"]
      , iss: [issuer]
      , gracePeriod: gracePeriod
      , verifyAt: unixTimeNow
      }

module OIDC.Crypt
  ( Payload
  , Header
  , hashNonce
  , bindState
  , unbindState
  , verifyIdToken
  , pluckKeyId
  , pluckEmail
  , readHeader
  , readPayload
  , module OIDC.Crypt.Types
  , module J
  ) where

import Control.Applicative (when)
import Control.Bind ((=<<))
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Exception as Exception
import Control.Monad.Eff.Now (NOW)
import Control.Monad.Eff.Now as Now
import Data.DateTime.Instant (Instant)
import Data.DateTime.Instant as Instant
import Data.Either (Either)
import Data.Int as Int
import Data.Maybe (Maybe(Just, Nothing), maybe)
import Data.Time.Duration (Seconds(Seconds))
import Data.Time.Duration as Duration
import OIDC.Crypt.JSONWebKey as J
import OIDC.Crypt.Types
import Prelude (bind, not, (<<<), ($), (&&), (<$>), (<=), (>), (*))

foreign import
  data RSAKey :: *

foreign import
  data Header :: *

foreign import
  data Payload :: *

type AcceptedFields
  = { alg :: Array String
    , iss :: Array Issuer
    , gracePeriod :: Seconds
    , verifyAt :: Seconds
    }

foreign import
  hashNonce
    :: UnhashedNonce
    -> HashedNonce

foreign import
  bindState
    :: StateString
    -> KeyString
    -> BoundStateJWS

foreign import
  getKey
    :: J.JSONWebKey
    -> RSAKey

foreign import
  verifyJWT
    :: forall eff
     . IdToken
    -> RSAKey
    -> AcceptedFields
    -> Eff (err :: EXCEPTION | eff) Boolean

foreign import
  readPayload
    :: forall eff
     . IdToken
    -> Eff (err :: EXCEPTION | eff) Payload

foreign import
  readHeader
    :: forall eff
     . IdToken
    -> Eff (err :: EXCEPTION | eff) Header

foreign import
  verifyNonce
    :: UnhashedNonce
    -> Payload
    -> Boolean

foreign import
  _unbindState
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> BoundStateJWS
    -> KeyString
    -> Maybe StateString

foreign import
  verifyAudience
    :: ClientID
    -> Payload
    -> Boolean

foreign import
  _pluckKeyId
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Header
    -> Maybe KeyId

foreign import
  _pluckEmail
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Payload
    -> Maybe Email

foreign import
  _pluckIAT
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Payload
    -> Maybe Int

foreign import
  _pluckExp
    :: forall a
     . Maybe a
    -> (a -> Maybe a)
    -> Payload
    -> Maybe Int

unbindState
  :: BoundStateJWS
  -> KeyString
  -> Maybe StateString
unbindState = _unbindState Nothing Just

pluckKeyId
  :: Header
  -> Maybe KeyId
pluckKeyId = _pluckKeyId Nothing Just

pluckEmail
  :: Payload
  -> Maybe Email
pluckEmail = _pluckEmail Nothing Just

pluckIAT
  :: Payload
  -> Maybe Int
pluckIAT = _pluckIAT Nothing Just

pluckExp
  :: Payload
  -> Maybe Int
pluckExp = _pluckExp Nothing Just

verifyIAT :: Seconds -> Payload -> Boolean
verifyIAT unixTimeNow payload =
  maybe false (_ <= unixTimeNow) (Seconds <<< Int.toNumber <$> pluckIAT payload)

verifyExp :: Seconds -> Payload -> Boolean
verifyExp unixTimeNow payload =
  maybe false (_ > unixTimeNow) (Seconds <<< Int.toNumber <$> pluckExp payload)

instantToSeconds ∷ Instant -> Seconds
instantToSeconds = Duration.convertDuration <<< Instant.unInstant

verifyIdToken
  :: forall eff
   . Seconds
  -> IdToken
  -> Issuer
  -> ClientID
  -> UnhashedNonce
  -> J.JSONWebKey
  -> Eff (now :: NOW | eff) (Either Exception.Error Boolean)
verifyIdToken gracePeriod idToken issuer clientId unhashedNonce providerPublicKey =
  Exception.try do
    payload <- readPayload idToken
    unixTimeNow <- instantToSeconds <$> Now.now
    when
      (not $ verifyNonce unhashedNonce payload)
      (Exception.throw "Nonce doesn't match, possible replay attack.")
    when
      (not $ verifyAudience clientId payload)
      (Exception.throw "Audience (client id) doesn't match.")
    when
      (not $ verifyAudience clientId payload)
      (Exception.throw "Audience (client id) doesn't match.")
    when
      (not $ verifyIAT unixTimeNow payload)
      (Exception.throw "Token issued in the future. Check the time on your computer.")
    when
      (not $ verifyExp unixTimeNow payload)
      (Exception.throw "Token expired.")
    verifyJWT
      idToken
      (getKey providerPublicKey)
      { alg: ["RS256"]
      , iss: [issuer]
      , gracePeriod: gracePeriod
      , verifyAt: unixTimeNow
      }


Sequence unsafe effects with magic-do (#14)

module Halogen.VDom.DOM
  ( VDomMachine
  , VDomStep
  , VDomSpec(..)
  , buildVDom
  , buildText
  , buildElem
  , buildKeyed
  , buildWidget
  ) where

import Prelude
import Control.Monad.Eff (Eff, foreachE)

import Data.Array as Array
import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Nullable (toNullable)
import Data.Tuple (Tuple(..), fst)

import DOM (DOM)
import DOM.Node.Types (Element, Node, Document, elementToNode) as DOM

import Halogen.VDom.Machine (Step(..), Machine)
import Halogen.VDom.Machine as Machine
import Halogen.VDom.Types (VDom(..), ElemSpec(..), Namespace(..), runGraft)
import Halogen.VDom.Util as Util

type VDomMachine eff a b = Machine (Eff eff) a b

type VDomStep eff a b = Eff eff (Step (Eff eff) a b)

-- | Widget machines recursively reference the configured spec to potentially
-- | enable recursive trees of Widgets.
newtype VDomSpec eff a w = VDomSpec
  { buildWidget ∷ VDomSpec eff a w → VDomMachine eff w DOM.Node
  , buildAttributes ∷ DOM.Element → VDomMachine eff a Unit
  , document ∷ DOM.Document
  }

type VDomEffects eff = (dom ∷ DOM | eff)

-- | Starts an initial `VDom` machine by providing a `VDomSpec`.
-- |
-- | ```purescript
-- | main = do
-- |   machine1 ← buildVDom spec vdomTree1
-- |   machine2 ← Machine.step machine1 vdomTree2
-- |   machine3 ← Machine.step machine2 vdomTree3
-- |   ...
-- | ````
buildVDom
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → VDomMachine (VDomEffects eff) (VDom a w) DOM.Node
buildVDom spec = render
  where
  render = case _ of
    Text s → buildText spec s
    Elem es ch → buildElem spec es ch
    Keyed es ch → buildKeyed spec es ch
    Widget w → buildWidget spec w
    Grafted g → buildVDom spec (runGraft g)

buildText
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → String
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildText (VDomSpec spec) = render
  where
  render s = do
    node ← Fn.runFn2 Util.createTextNode s spec.document
    pure (Step node (Fn.runFn2 patch node s) (done node))

  patch = Fn.mkFn2 \node s1 → case _ of
    Grafted g →
      Fn.runFn2 patch node s1 (runGraft g)
    Text s2 → do
      let res = Step node (Fn.runFn2 patch node s2) (done node)
      case s1 == s2 of
        true → pure res
        _ → do
          Fn.runFn2 Util.setTextContent s2 node
          pure res
    vdom → do
      done node
      buildVDom (VDomSpec spec) vdom

  done node = do
    parent ← pure (Util.unsafeParent node)
    Fn.runFn2 Util.removeChild node parent

buildElem
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → ElemSpec a
  → Array (VDom a w)
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildElem (VDomSpec spec) = render
  where
  render es1@(ElemSpec ns1 name1 as1) ch1 = do
    el ← Fn.runFn3 Util.createElement (toNullable ns1) name1 spec.document
    let
      node = DOM.elementToNode el
      onChild = Fn.mkFn2 \ix child → do
        res@Step n m h ← buildVDom (VDomSpec spec) child
        Fn.runFn3 Util.insertChildIx ix n node
        pure res
    steps ← Fn.runFn2 Util.forE ch1 onChild
    attrs ← spec.buildAttributes el as1
    pure
      (Step node
        (Fn.runFn4 patch node attrs es1 steps)
        (Fn.runFn3 done node attrs steps))

  patch = Fn.mkFn4 \node attrs (es1@(ElemSpec ns1 name1 as1)) ch1 → case _ of
    Grafted g →
      Fn.runFn4 patch node attrs es1 ch1 (runGraft g)
    Elem es2@(ElemSpec ns2 name2 as2) ch2 | Fn.runFn2 eqElemSpec es1 es2 → do
      case Array.length ch1, Array.length ch2 of
        0, 0 → do
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn4 patch node attrs' es2 ch1)
              (Fn.runFn3 done node attrs' ch1))
        _, _ → do
          let
            onThese = Fn.mkFn3 \ix (prev@Step n step halt) vdom → do
              res@Step n' m' h' ← step vdom
              Fn.runFn3 Util.insertChildIx ix n' node
              pure res
            onThis = Fn.mkFn2 \ix (Step n _ halt) → halt
            onThat = Fn.mkFn2 \ix vdom → do
              res@Step n m h ← buildVDom (VDomSpec spec) vdom
              Fn.runFn3 Util.insertChildIx ix n node
              pure res
          steps ← Fn.runFn5 Util.diffWithIxE ch1 ch2 onThese onThis onThat
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn4 patch node attrs' es2 steps)
              (Fn.runFn3 done node attrs' steps))
    vdom → do
      Fn.runFn3 done node attrs ch1
      buildVDom (VDomSpec spec) vdom

  done = Fn.mkFn3 \node attrs steps → do
    parent ← pure (Util.unsafeParent node)
    Fn.runFn2 Util.removeChild node parent
    foreachE steps Machine.halt
    Machine.halt attrs

buildKeyed
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → ElemSpec a
  → Array (Tuple String (VDom a w))
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildKeyed (VDomSpec spec) = render
  where
  render es1@(ElemSpec ns1 name1 as1) ch1 = do
    el ← Fn.runFn3 Util.createElement (toNullable ns1) name1 spec.document
    let
      node = DOM.elementToNode el
      onChild = Fn.mkFn3 \k ix (Tuple _ vdom) → do
        res@Step n m h ← buildVDom (VDomSpec spec) vdom
        Fn.runFn3 Util.insertChildIx ix n node
        pure res
    steps ← Fn.runFn3 Util.strMapWithIxE ch1 fst onChild
    attrs ← spec.buildAttributes el as1
    pure
      (Step node
        (Fn.runFn5 patch node attrs es1 steps (Array.length ch1))
        (Fn.runFn3 done node attrs steps))

  patch = Fn.mkFn5 \node attrs (es1@(ElemSpec ns1 name1 as1)) ch1 len1 → case _ of
    Grafted g →
      Fn.runFn5 patch node attrs es1 ch1 len1 (runGraft g)
    Keyed es2@(ElemSpec ns2 name2 as2) ch2 | Fn.runFn2 eqElemSpec es1 es2 →
      case len1, Array.length ch2 of
        0, 0 → do
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn5 patch node attrs' es2 ch1 0)
              (Fn.runFn3 done node attrs' ch1))
        _, len2 → do
          let
            onThese = Fn.mkFn4 \k ix' (Step n step _) (Tuple _ vdom) → do
              res@Step n' m' h' ← step vdom
              Fn.runFn3 Util.insertChildIx ix' n' node
              pure res
            onThis = Fn.mkFn2 \k (Step n _ halt) → halt
            onThat = Fn.mkFn3 \k ix (Tuple _ vdom) → do
              res@Step n' m' h' ← buildVDom (VDomSpec spec) vdom
              Fn.runFn3 Util.insertChildIx ix n' node
              pure res
          steps ← Fn.runFn6 Util.diffWithKeyAndIxE ch1 ch2 fst onThese onThis onThat
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn5 patch node attrs' es2 steps len2)
              (Fn.runFn3 done node attrs' steps))
    vdom → do
      Fn.runFn3 done node attrs ch1
      buildVDom (VDomSpec spec) vdom

  done = Fn.mkFn3 \node attrs steps → do
    parent ← pure (Util.unsafeParent node)
    Fn.runFn2 Util.removeChild node parent
    Fn.runFn2 Util.forInE steps (Fn.mkFn2 \_ (Step _ _ halt) → halt)
    Machine.halt attrs

buildWidget
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → w
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildWidget (VDomSpec spec) = render
  where
  render w = do
    res@Step n m h ← spec.buildWidget (VDomSpec spec) w
    pure (Step n (patch res) h)

  patch prev@(Step node step halt) = case _ of
    Grafted g →
      patch prev (runGraft g)
    Widget w → do
      res@Step n m h ← step w
      pure (Step n (patch res) h)
    vdom → do
      halt
      buildVDom (VDomSpec spec) vdom

eqElemSpec
  ∷ ∀ a
  . Fn.Fn2 (ElemSpec a) (ElemSpec a) Boolean
eqElemSpec = Fn.mkFn2 \a b →
  case a, b of
    ElemSpec ns1 name1 _, ElemSpec ns2 name2 _ | name1 == name2 →
      case ns1, ns2 of
        Just (Namespace ns1'), Just (Namespace ns2') | ns1' == ns2' → true
        Nothing, Nothing → true
        _, _ → false
    _, _ → false

module Halogen.VDom.DOM
  ( VDomMachine
  , VDomStep
  , VDomSpec(..)
  , buildVDom
  , buildText
  , buildElem
  , buildKeyed
  , buildWidget
  ) where

import Prelude
import Control.Monad.Eff (Eff, foreachE)

import Data.Array as Array
import Data.Function.Uncurried as Fn
import Data.Maybe (Maybe(..))
import Data.Nullable (toNullable)
import Data.Tuple (Tuple(..), fst)

import DOM (DOM)
import DOM.Node.Types (Element, Node, Document, elementToNode) as DOM

import Halogen.VDom.Machine (Step(..), Machine)
import Halogen.VDom.Machine as Machine
import Halogen.VDom.Types (VDom(..), ElemSpec(..), Namespace(..), runGraft)
import Halogen.VDom.Util as Util

type VDomMachine eff a b = Machine (Eff eff) a b

type VDomStep eff a b = Eff eff (Step (Eff eff) a b)

-- | Widget machines recursively reference the configured spec to potentially
-- | enable recursive trees of Widgets.
newtype VDomSpec eff a w = VDomSpec
  { buildWidget ∷ VDomSpec eff a w → VDomMachine eff w DOM.Node
  , buildAttributes ∷ DOM.Element → VDomMachine eff a Unit
  , document ∷ DOM.Document
  }

type VDomEffects eff = (dom ∷ DOM | eff)

-- | Starts an initial `VDom` machine by providing a `VDomSpec`.
-- |
-- | ```purescript
-- | main = do
-- |   machine1 ← buildVDom spec vdomTree1
-- |   machine2 ← Machine.step machine1 vdomTree2
-- |   machine3 ← Machine.step machine2 vdomTree3
-- |   ...
-- | ````
buildVDom
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → VDomMachine (VDomEffects eff) (VDom a w) DOM.Node
buildVDom spec = render
  where
  render = case _ of
    Text s → buildText spec s
    Elem es ch → buildElem spec es ch
    Keyed es ch → buildKeyed spec es ch
    Widget w → buildWidget spec w
    Grafted g → buildVDom spec (runGraft g)

buildText
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → String
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildText (VDomSpec spec) = render
  where
  render s = do
    node ← Fn.runFn2 Util.createTextNode s spec.document
    pure (Step node (Fn.runFn2 patch node s) (done node))

  patch = Fn.mkFn2 \node s1 → case _ of
    Grafted g →
      Fn.runFn2 patch node s1 (runGraft g)
    Text s2 → do
      let res = Step node (Fn.runFn2 patch node s2) (done node)
      case s1 == s2 of
        true → pure res
        _ → do
          Fn.runFn2 Util.setTextContent s2 node
          pure res
    vdom → do
      done node
      buildVDom (VDomSpec spec) vdom

  done node = do
    Fn.runFn2 Util.removeChild node (Util.unsafeParent node)

buildElem
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → ElemSpec a
  → Array (VDom a w)
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildElem (VDomSpec spec) = render
  where
  render es1@(ElemSpec ns1 name1 as1) ch1 = do
    el ← Fn.runFn3 Util.createElement (toNullable ns1) name1 spec.document
    let
      node = DOM.elementToNode el
      onChild = Fn.mkFn2 \ix child → do
        res@Step n m h ← buildVDom (VDomSpec spec) child
        Fn.runFn3 Util.insertChildIx ix n node
        pure res
    steps ← Fn.runFn2 Util.forE ch1 onChild
    attrs ← spec.buildAttributes el as1
    pure
      (Step node
        (Fn.runFn4 patch node attrs es1 steps)
        (Fn.runFn3 done node attrs steps))

  patch = Fn.mkFn4 \node attrs (es1@(ElemSpec ns1 name1 as1)) ch1 → case _ of
    Grafted g →
      Fn.runFn4 patch node attrs es1 ch1 (runGraft g)
    Elem es2@(ElemSpec ns2 name2 as2) ch2 | Fn.runFn2 eqElemSpec es1 es2 → do
      case Array.length ch1, Array.length ch2 of
        0, 0 → do
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn4 patch node attrs' es2 ch1)
              (Fn.runFn3 done node attrs' ch1))
        _, _ → do
          let
            onThese = Fn.mkFn3 \ix (prev@Step n step halt) vdom → do
              res@Step n' m' h' ← step vdom
              Fn.runFn3 Util.insertChildIx ix n' node
              pure res
            onThis = Fn.mkFn2 \ix (res@Step n _ halt) → halt
            onThat = Fn.mkFn2 \ix vdom → do
              res@Step n m h ← buildVDom (VDomSpec spec) vdom
              Fn.runFn3 Util.insertChildIx ix n node
              pure res
          steps ← Fn.runFn5 Util.diffWithIxE ch1 ch2 onThese onThis onThat
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn4 patch node attrs' es2 steps)
              (Fn.runFn3 done node attrs' steps))
    vdom → do
      Fn.runFn3 done node attrs ch1
      buildVDom (VDomSpec spec) vdom

  done = Fn.mkFn3 \node attrs steps → do
    Fn.runFn2 Util.removeChild node (Util.unsafeParent node)
    foreachE steps Machine.halt
    Machine.halt attrs

buildKeyed
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → ElemSpec a
  → Array (Tuple String (VDom a w))
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildKeyed (VDomSpec spec) = render
  where
  render es1@(ElemSpec ns1 name1 as1) ch1 = do
    el ← Fn.runFn3 Util.createElement (toNullable ns1) name1 spec.document
    let
      node = DOM.elementToNode el
      onChild = Fn.mkFn3 \k ix (Tuple _ vdom) → do
        res@Step n m h ← buildVDom (VDomSpec spec) vdom
        Fn.runFn3 Util.insertChildIx ix n node
        pure res
    steps ← Fn.runFn3 Util.strMapWithIxE ch1 fst onChild
    attrs ← spec.buildAttributes el as1
    pure
      (Step node
        (Fn.runFn5 patch node attrs es1 steps (Array.length ch1))
        (Fn.runFn3 done node attrs steps))

  patch = Fn.mkFn5 \node attrs (es1@(ElemSpec ns1 name1 as1)) ch1 len1 → case _ of
    Grafted g →
      Fn.runFn5 patch node attrs es1 ch1 len1 (runGraft g)
    Keyed es2@(ElemSpec ns2 name2 as2) ch2 | Fn.runFn2 eqElemSpec es1 es2 →
      case len1, Array.length ch2 of
        0, 0 → do
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn5 patch node attrs' es2 ch1 0)
              (Fn.runFn3 done node attrs' ch1))
        _, len2 → do
          let
            onThese = Fn.mkFn4 \k ix' (Step n step _) (Tuple _ vdom) → do
              res@Step n' m' h' ← step vdom
              Fn.runFn3 Util.insertChildIx ix' n' node
              pure res
            onThis = Fn.mkFn2 \k (Step n _ halt) → halt
            onThat = Fn.mkFn3 \k ix (Tuple _ vdom) → do
              res@Step n' m' h' ← buildVDom (VDomSpec spec) vdom
              Fn.runFn3 Util.insertChildIx ix n' node
              pure res
          steps ← Fn.runFn6 Util.diffWithKeyAndIxE ch1 ch2 fst onThese onThis onThat
          attrs' ← Machine.step attrs as2
          pure
            (Step node
              (Fn.runFn5 patch node attrs' es2 steps len2)
              (Fn.runFn3 done node attrs' steps))
    vdom → do
      Fn.runFn3 done node attrs ch1
      buildVDom (VDomSpec spec) vdom

  done = Fn.mkFn3 \node attrs steps → do
    Fn.runFn2 Util.removeChild node (Util.unsafeParent node)
    Fn.runFn2 Util.forInE steps (Fn.mkFn2 \_ (Step _ _ halt) → halt)
    Machine.halt attrs

buildWidget
  ∷ ∀ eff a w
  . VDomSpec (VDomEffects eff) a w
  → w
  → VDomStep (VDomEffects eff) (VDom a w) DOM.Node
buildWidget (VDomSpec spec) = render
  where
  render w = do
    res@Step n m h ← spec.buildWidget (VDomSpec spec) w
    pure (Step n (patch res) h)

  patch prev@(Step node step halt) = case _ of
    Grafted g →
      patch prev (runGraft g)
    Widget w → do
      res@Step n m h ← step w
      pure (Step n (patch res) h)
    vdom → do
      halt
      buildVDom (VDomSpec spec) vdom

eqElemSpec
  ∷ ∀ a
  . Fn.Fn2 (ElemSpec a) (ElemSpec a) Boolean
eqElemSpec = Fn.mkFn2 \a b →
  case a, b of
    ElemSpec ns1 name1 _, ElemSpec ns2 name2 _ | name1 == name2 →
      case ns1, ns2 of
        Just (Namespace ns1'), Just (Namespace ns2') | ns1' == ns2' → true
        Nothing, Nothing → true
        _, _ → false
    _, _ → false


Updates for 0.7

Updates for 0.7

module Console where

import Prelude

import Control.Monad.Eff

-- | The `CONSOLE` effect represents those computations which write to the console.
foreign import data CONSOLE :: !

-- | Write a message to the console.
foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

-- | Write an error to the console.
foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

-- | Write a value to the console, using its `Show` instance to produce a `String`.
print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit
print = log <<< show

module Console where

import Control.Monad.Eff

-- | The `CONSOLE` effect represents those computations which write to the console.
foreign import data CONSOLE :: !

-- | Write a message to the console.
foreign import log :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

-- | Write an error to the console.
foreign import error :: forall eff. String -> Eff (console :: CONSOLE | eff) Unit

-- | Write a value to the console, using its `Show` instance to produce a `String`.
print :: forall a eff. (Show a) => a -> Eff (console :: CONSOLE | eff) Unit
print = log <<< show


Fix behaviour of Open card (#1105)

Fix behaviour of Open card (#1105)

{-
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.MillerColumns.Component
  ( ItemSpec
  , ItemHTML
  , component
  , module SlamData.Workspace.MillerColumns.Component.Query
  , module SlamData.Workspace.MillerColumns.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Eff (Eff)

import Data.Array as A
import Data.Traversable (scanr)
import Data.List ((:))
import Data.List as L
import Data.Unfoldable (replicate)

import DOM (DOM)
import DOM.HTML.Types (HTMLElement, htmlElementToElement)
import DOM.Node.Element (scrollWidth, setScrollLeft) as DOM
import DOM.HTML.HTMLElement (offsetWidth) as DOM

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Component.Utils (raise)

import SlamData.Monad (Slam)
import SlamData.Workspace.MillerColumns.Component.Query (Query(..))
import SlamData.Workspace.MillerColumns.Component.State (State, initialState)

type ItemSpec a i m =
  { label ∷ a → String
  , render ∷ a → H.ComponentHTML (Const Void)
  , load ∷ L.List i → m (Maybe (L.List a))
  , id ∷ a → i
  }

type HTML i = H.ComponentHTML (Query i)
type DSL a i m p = H.ComponentDSL (State a i) (Query i) m p

type ItemHTML = H.ComponentHTML (Const Void)

type RenderRec i = { path ∷ L.List i, html ∷ Array (HTML i) }

component
  ∷ ∀ a i
  . Eq i
  ⇒ ItemSpec a i Slam
  → Maybe (L.List i)
  → H.Component (State a i) (Query i) Slam
component ispec initial =
  H.lifecycleComponent
    { render
    , eval
    , initializer: map (H.action ∘ Populate) initial
    , finalizer: Nothing
    }
  where

  render ∷ State a i → HTML i
  render { columns, selected } =
    let
      -- Drop the root item from `selected` (since there's no corresponding
      -- rendered item), and reverse it (foldl) to produce a list rather than a
      -- stack, so the steps can be zipped with the columns. The fold also tags
      -- the steps as `Left` or `Right`, where `Right` is the "tip", so we can
      -- add a class to the tip-selected-item as necessary.
      selectSteps = A.fromFoldable (foldl go L.Nil (fromMaybe L.Nil (L.init selected)))
      go acc a = case acc of
        L.Nil → pure (Right a)
        _ → Left a : acc
    in
      HH.div
        [ HP.class_ (HH.className "sd-miller-columns")
        , HP.ref (H.action ∘ Ref)
        ]
        $ _.html
        $ foldl goColumn
            { path: L.Nil, html: [] }
            (A.zip columns (pad selectSteps (A.length columns)))

  goColumn
    ∷ RenderRec i
    → Tuple (Tuple i (L.List a)) (Maybe (Either i i))
    → RenderRec i
  goColumn acc (Tuple (Tuple item children) sel) =
    let path = item : acc.path
    in { path, html: acc.html <> [renderColumn path children sel] }

  renderColumn ∷ L.List i → L.List a → Maybe (Either i i) → HTML i
  renderColumn colPath items selected =
    HH.ul
      [ HP.class_ (HH.className "sd-miller-column")
      , ARIA.label "Column"
      , HP.ref (\_ → H.action Extended)
      ]
      $ A.fromFoldable (renderItem colPath selected <$> items)

  renderItem ∷ L.List i → Maybe (Either i i) → a → HTML i
  renderItem colPath selected item =
    let
      label = ispec.label item
      isSelected = Just (ispec.id item) == (either id id <$> selected)
      isTip = isSelected && maybe false isRight selected
    in
      HH.li
        [ HE.onClick $ HE.input_ $ Populate (ispec.id item : colPath)
        , HP.title label
        , ARIA.label ("Select " <> label)
        , HP.classes
            $ (guard isSelected $> HH.className "selected")
            <> (guard isTip $> HH.className "tip")
        ]
        [ absurd ∘ getConst <$> ispec.render item ]

  eval ∷ Query i ~> DSL a i Slam
  eval (Ref mel next) = do
    H.modify (_ { element = mel })
    pure next
  eval (Extended next) = do
    traverse_ (H.fromEff ∘ scrollToRight) =<< H.gets _.element
    pure next
  eval (Populate path next) = do
    currentPath <- H.gets _.selected

    let
      prefix = findPathPrefix currentPath path
      remainder = L.take (L.length path - L.length prefix) path
      remPaths = scanr (:) prefix remainder

    -- Explicitly check whether anything needs loading before proceeding:
    -- incrementing `currentCycle` when there is no work to be done can
    -- break things if we're awaiting a previous load of the same path.
    when (not L.null remPaths) do

      H.modify \st → st
        { cycle = st.cycle + 1
        , columns = A.take (L.length prefix) st.columns
        , selected = L.take (L.length prefix + 1) path
        }

      currentCycle ← H.gets _.cycle

      raise $ H.action $ Loading true

      more ← H.liftH (parTraverse ispec.load remPaths)

      -- `load` is async, so in case multiple `Populate`s have been raised we need
      -- to check that we still care about the results of the load we just
      -- triggered.
      --
      -- The "cycle" counter is incremented every time a `load` is triggered, so
      -- if it differs after a `load` completes we know a competing `load` has
      -- been triggered in the mean time, and we can just abandon this result.
      --
      -- We can't just use `fork` here since we need to continue performing
      -- actions in `ComponentDSL` after the load completes, and there's no
      -- `MonadFork` instance for `ComponentDSL`.
      currentCycle' ← H.gets _.cycle
      when (currentCycle == currentCycle') do
        let
          newColumns = foldr go [] (L.zip remainder more)
          go (Tuple item colItems) cols =
            maybe cols (\items -> cols <> [Tuple item items]) colItems
        H.modify \st → st
          { columns = st.columns <> newColumns
          , selected = path
          }
        raise $ H.action $ Loading false

    pure next
  eval (Loading _ next) =
    pure next

findPathPrefix ∷ ∀ a. Eq a ⇒ L.List a → L.List a → L.List a
findPathPrefix xs ys =
  let
    lxs = L.length xs
    lys = L.length ys
    xs' = if lxs > lys then L.drop (lxs - lys) xs else xs
    ys' = if lys > lxs then L.drop (lys - lxs) ys else ys
  in
    snd $ foldr go (Tuple true L.Nil) (L.zip xs' ys')
  where
  go (Tuple x y) (Tuple matching acc)
    | matching && x == y = Tuple true (x : acc)
    | otherwise = Tuple false acc

pad ∷ ∀ a. Array a → Int → Array (Maybe a)
pad xs length = map Just xs <> replicate (length - A.length xs) Nothing

scrollToRight ∷ ∀ eff. HTMLElement → Eff (dom ∷ DOM | eff) Unit
scrollToRight hel = do
  let el = htmlElementToElement hel
  maxScroll ← (-) <$> DOM.scrollWidth el <*> DOM.offsetWidth hel
  DOM.setScrollLeft maxScroll el

{-
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.MillerColumns.Component
  ( ItemSpec
  , ItemHTML
  , component
  , module SlamData.Workspace.MillerColumns.Component.Query
  , module SlamData.Workspace.MillerColumns.Component.State
  ) where

import SlamData.Prelude

import Control.Monad.Eff (Eff)

import Data.Array as A
import Data.Traversable (scanr)
import Data.List ((:))
import Data.List as L
import Data.Unfoldable (replicate)

import DOM (DOM)
import DOM.HTML.Types (HTMLElement, htmlElementToElement)
import DOM.Node.Element (scrollWidth, setScrollLeft) as DOM
import DOM.HTML.HTMLElement (offsetWidth) as DOM

import Halogen as H
import Halogen.HTML.Events.Indexed as HE
import Halogen.HTML.Indexed as HH
import Halogen.HTML.Properties.Indexed as HP
import Halogen.HTML.Properties.Indexed.ARIA as ARIA
import Halogen.Component.Utils (raise)

import SlamData.Monad (Slam)
import SlamData.Workspace.MillerColumns.Component.Query (Query(..))
import SlamData.Workspace.MillerColumns.Component.State (State, initialState)

type ItemSpec a i m =
  { label ∷ a → String
  , render ∷ a → H.ComponentHTML (Const Void)
  , load ∷ L.List i → m (Maybe (L.List a))
  , id ∷ a → i
  }

type HTML i = H.ComponentHTML (Query i)
type DSL a i m p = H.ComponentDSL (State a i) (Query i) m p

type ItemHTML = H.ComponentHTML (Const Void)

type RenderRec i = { path ∷ L.List i, html ∷ Array (HTML i) }

component
  ∷ ∀ a i
  . Eq i
  ⇒ ItemSpec a i Slam
  → Maybe (L.List i)
  → H.Component (State a i) (Query i) Slam
component ispec initial =
  H.lifecycleComponent
    { render
    , eval
    , initializer: map (H.action ∘ Populate) initial
    , finalizer: Nothing
    }
  where

  render ∷ State a i → HTML i
  render { columns, selected } =
    let
      -- Drop the root item from `selected` (since there's no corresponding
      -- rendered item), and reverse it (foldl) to produce a list rather than a
      -- stack, so the steps can be zipped with the columns. The fold also tags
      -- the steps as `Left` or `Right`, where `Right` is the "tip", so we can
      -- add a class to the tip-selected-item as necessary.
      selectSteps = A.fromFoldable (foldl go L.Nil (fromMaybe L.Nil (L.init selected)))
      go acc a = case acc of
        L.Nil → pure (Right a)
        _ → Left a : acc
    in
      HH.div
        [ HP.class_ (HH.className "sd-miller-columns")
        , HP.ref (H.action ∘ Ref)
        ]
        $ _.html
        $ foldl goColumn
            { path: L.Nil, html: [] }
            (A.zip columns (pad selectSteps (A.length columns)))

  goColumn
    ∷ RenderRec i
    → Tuple (Tuple i (L.List a)) (Maybe (Either i i))
    → RenderRec i
  goColumn acc (Tuple (Tuple item children) sel) =
    let path = item : acc.path
    in { path, html: acc.html <> [renderColumn path children sel] }

  renderColumn ∷ L.List i → L.List a → Maybe (Either i i) → HTML i
  renderColumn colPath items selected =
    HH.ul
      [ HP.class_ (HH.className "sd-miller-column")
      , ARIA.label "Column"
      , HP.ref (\_ → H.action Extended)
      ]
      $ A.fromFoldable (renderItem colPath selected <$> items)

  renderItem ∷ L.List i → Maybe (Either i i) → a → HTML i
  renderItem colPath selected item =
    let
      label = ispec.label item
      isSelected = Just (ispec.id item) == (either id id <$> selected)
      isTip = isSelected && maybe false isRight selected
    in
      HH.li
        [ HE.onClick $ HE.input_ $ Populate (ispec.id item : colPath)
        , HP.title label
        , ARIA.label ("Select " <> label)
        , HP.classes
            $ (guard isSelected $> HH.className "selected")
            <> (guard isTip $> HH.className "tip")
        ]
        [ absurd ∘ getConst <$> ispec.render item ]

  eval ∷ Query i ~> DSL a i Slam
  eval (Ref mel next) = do
    H.modify (_ { element = mel })
    pure next
  eval (Extended next) = do
    traverse_ (H.fromEff ∘ scrollToRight) =<< H.gets _.element
    pure next
  eval (Populate path next) = do
    currentPath <- H.gets _.selected

    let
      prefix = findPathPrefix currentPath path
      remainder = L.take (L.length path - L.length prefix) path
      remPaths = scanr (:) prefix remainder

    H.modify \st → st
      { cycle = st.cycle + 1
      , columns = A.take (L.length prefix) st.columns
      , selected = L.take (L.length prefix + 1) path
      }

    currentCycle ← H.gets _.cycle

    raise $ H.action $ Loading true

    more ← H.liftH (parTraverse ispec.load remPaths)

    -- `load` is async, so in case multiple `Populate`s have been raised we need
    -- to check that we still care about the results of the load we just
    -- triggered.
    --
    -- The "cycle" counter is incremented every time a `load` is triggered, so
    -- if it differs after a `load` completes we know a competing `load` has
    -- been triggered in the mean time, and we can just abandon this result.
    --
    -- We can't just use `fork` here since we need to continue performing
    -- actions in `ComponentDSL` after the load completes, and there's no
    -- `MonadFork` instance for `ComponentDSL`.
    currentCycle' ← H.gets _.cycle
    when (currentCycle == currentCycle') do
      let
        newColumns = foldr go [] (L.zip remainder more)
        go (Tuple item colItems) cols =
          maybe cols (\items -> cols <> [Tuple item items]) colItems
      H.modify \st → st
        { columns = st.columns <> newColumns
        , selected = path
        }
      raise $ H.action $ Loading false

    pure next
  eval (Loading _ next) =
    pure next

findPathPrefix ∷ ∀ a. Eq a ⇒ L.List a → L.List a → L.List a
findPathPrefix xs ys =
  let
    lxs = L.length xs
    lys = L.length ys
    xs' = if lxs > lys then L.drop (lxs - lys) xs else xs
    ys' = if lys > lxs then L.drop (lys - lxs) ys else ys
  in
    snd $ foldr go (Tuple true L.Nil) (L.zip xs' ys')
  where
  go (Tuple x y) (Tuple matching acc)
    | matching && x == y = Tuple true (x : acc)
    | otherwise = Tuple false acc

pad ∷ ∀ a. Array a → Int → Array (Maybe a)
pad xs length = map Just xs <> replicate (length - A.length xs) Nothing

scrollToRight ∷ ∀ eff. HTMLElement → Eff (dom ∷ DOM | eff) Unit
scrollToRight hel = do
  let el = htmlElementToElement hel
  maxScroll ← (-) <$> DOM.scrollWidth el <*> DOM.offsetWidth hel
  DOM.setScrollLeft maxScroll el


[CSL-1016] Fix tx sending from new wallets

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPaperVendWalletRedeem, emptyCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet emptyCPassPhrase) $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ emptyCPassPhrase) <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ emptyCPassPhrase) <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed

redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedemtionKey :: String -> Boolean
isValidRedemtionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid paper vend key is base58 encoded 32byte data
isValidPaperVendRedemtionKey :: String -> Boolean
isValidPaperVendRedemtionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code

module Daedalus.ClientApi where

import Prelude
import Daedalus.BackendApi as B
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (newRef, REF)
import Control.Promise (Promise, fromAff)
import Daedalus.Types (getProfileLocale, mkCAddress, mkCCoin, mkCWalletMeta, mkCTxId, mkCTxMeta, mkCCurrency, mkCProfile, mkCWalletInit, mkCWalletRedeem, mkCWalletInitIgnoreChecksum, mkBackupPhrase, mkCInitialized, mkCPassPhrase, mkCPaperVendWalletRedeem, emptyCPassPhrase)
import Daedalus.WS (WSConnection(WSNotConnected), mkWSState, ErrorCb, NotifyCb, openConn)
import Data.Argonaut (Json)
import Data.Argonaut.Generic.Aeson (encodeJson)
import Data.String.Base64 as B64
import Data.Base58 as B58
import Data.Array as A
import Data.String (length, stripSuffix, Pattern (..))
import Data.Maybe (isJust, maybe)
import Data.Function.Eff (EffFn1, mkEffFn1, EffFn2, mkEffFn2, EffFn4, mkEffFn4, EffFn3, mkEffFn3, EffFn6, mkEffFn6)
import Network.HTTP.Affjax (AJAX)
import WebSocket (WEBSOCKET)
import Control.Monad.Error.Class (throwError)
import Data.Either (either)
import Daedalus.Crypto as Crypto

getLocale :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getLocale = fromAff $ map encodeJson (getProfileLocale <$> B.getProfile)

updateLocale :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
updateLocale = mkEffFn1 \locale -> fromAff <<< map encodeJson <<< B.updateProfile $ mkCProfile locale

getWallets :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
getWallets = fromAff $ map encodeJson B.getWallets

getWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
getWallet = mkEffFn1 $ fromAff <<< map encodeJson <<< B.getWallet <<< mkCAddress

getHistory :: forall eff. EffFn3 (ajax :: AJAX | eff) String Int Int (Promise Json)
getHistory = mkEffFn3 \addr skip limit -> fromAff <<< map encodeJson $
    B.getHistory
        (mkCAddress addr)
        skip
        limit

searchHistory :: forall eff. EffFn4 (ajax :: AJAX | eff) String String Int Int (Promise Json)
searchHistory = mkEffFn4 \addr search skip limit -> fromAff <<< map encodeJson $
    B.searchHistory
        (mkCAddress addr)
        search
        skip
        limit

send :: forall eff. EffFn3 (ajax :: AJAX | eff) String String String (Promise Json)
send = mkEffFn3 \addrFrom addrTo amount -> fromAff <<< map encodeJson $
    B.send
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)

sendExtended :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String String (Promise Json)
sendExtended = mkEffFn6 \addrFrom addrTo amount curr title desc -> fromAff <<< map encodeJson $
    B.sendExtended
        emptyCPassPhrase
        (mkCAddress addrFrom)
        (mkCAddress addrTo)
        (mkCCoin amount)
        (mkCCurrency curr)
        title
        desc

generateMnemonic :: forall eff. Eff (crypto :: Crypto.CRYPTO | eff) String
generateMnemonic = Crypto.generateMnemonic

-- | bip39.validateMnemonic and has at least len words
isValidMnemonic :: forall eff. EffFn2 (crypto :: Crypto.CRYPTO | eff) Int String Boolean
isValidMnemonic = mkEffFn2 \len -> pure <<< either (const false) (const true) <<< mkBackupPhrase len

newWallet :: forall eff . EffFn4 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String String
  (Promise Json)
newWallet = mkEffFn4 \wType wCurrency wName mnemonic -> fromAff <<< map encodeJson <<<
    either throwError (B.newWallet $ mkCPassPhrase "") $ mkCWalletInit wType wCurrency wName mnemonic

-- NOTE: https://issues.serokell.io/issue/DAE-33#comment=96-1798
-- Daedalus.ClientApi.newWallet(
--     'CWTPersonal'
--   , 'ADA'
--   , 'wallet name'
--   , function(mnemonics) {
--     // if this function finishes we will send request for wallet
--     // creation to the backend. That means user validated and
--     // stored mnemonics.
--     // if an exception is thrown new wallet request will be aborted
--     // and promise should return thrown error
--     if(userSavedMnemonics) {
--       // do nothing
--     } else {
--       throw new Error("Wallet canceled")
--     }
--   }
--   )()
--   .then(function(value) {
--     console.log('SUCCESS', value);
--   }, function(reason) {
--     console.log('ERROR', reason);
--   })
-- newWalletDeprecated :: forall eff . Fn4 String String String (EffFn1 (err :: EXCEPTION | eff) String Unit)
--   (Eff(ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) (Promise Json))
-- newWalletDeprecated = mkFn4 \wType wCurrency wName wConfirmMnemonic -> fromAff $ map encodeJson $ do
--
--     mnemonic <- liftEff Crypto.generateMnemonic
--     -- FIXME: @jens how did we satisfy this with notify? I am having trouble again
--     isConfirmed <- liftEff' $ unsafeInterleaveEff $ runEffFn1 wConfirmMnemonic mnemonic
--     either throwError B.newWallet $ do
--         isConfirmed
--         mkCWalletInit wType wCurrency wName mnemonic

updateWallet :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Int (Promise Json)
updateWallet = mkEffFn6 \addr wType wCurrency wName wAssurance wUnit -> fromAff <<< map encodeJson <<<
    B.updateWallet
        (mkCAddress addr)
        $ mkCWalletMeta wType wCurrency wName wAssurance wUnit

updateTransaction :: forall eff. EffFn6 (ajax :: AJAX | eff) String String String String String Number (Promise Unit)
updateTransaction = mkEffFn6 \addr ctxId ctmCurrency ctmTitle ctmDescription ctmDate -> fromAff <<<
    B.updateTransaction
        (mkCAddress addr)
        (mkCTxId ctxId)
        $ mkCTxMeta ctmCurrency ctmTitle ctmDescription ctmDate

deleteWallet :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Unit)
deleteWallet = mkEffFn1 $ fromAff <<< B.deleteWallet <<< mkCAddress

isValidAddress :: forall eff. EffFn2 (ajax :: AJAX | eff) String String (Promise Boolean)
isValidAddress = mkEffFn2 \currency -> fromAff <<< B.isValidAddress (mkCCurrency currency)

notify :: forall eff. EffFn2 (ref :: REF, ws :: WEBSOCKET, err :: EXCEPTION | eff) (NotifyCb eff) (ErrorCb eff) Unit
notify = mkEffFn2 \messageCb errorCb -> do
    -- TODO (akegalj) grab global (mutable) state of  here
    -- instead of creating newRef
    conn <- newRef WSNotConnected
    openConn $ mkWSState conn messageCb errorCb

blockchainSlotDuration :: forall eff. Eff (ajax :: AJAX | eff) (Promise Int)
blockchainSlotDuration = fromAff B.blockchainSlotDuration

restoreWallet :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWallet = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInit wType wCurrency wName

restoreWalletIgnoreChecksum :: forall eff. EffFn4 (ajax :: AJAX | eff) String String String String (Promise Json)
restoreWalletIgnoreChecksum = mkEffFn4 \wType wCurrency wName -> fromAff <<< map encodeJson <<< either throwError (B.restoreWallet $ mkCPassPhrase "") <<< mkCWalletInitIgnoreChecksum wType wCurrency wName

nextUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
nextUpdate = fromAff $ map encodeJson B.nextUpdate

applyUpdate :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
applyUpdate = fromAff B.applyUpdate

systemVersion :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
systemVersion = fromAff $ map encodeJson B.systemVersion

redeemAda :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String (Promise Json)
redeemAda = mkEffFn2 \seed -> fromAff <<< map encodeJson <<< B.redeemAda <<< mkCWalletRedeem seed

redeemAdaPaperVend :: forall eff. EffFn3 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) String String String (Promise Json)
redeemAdaPaperVend = mkEffFn3 \seed mnemonic -> fromAff <<< map encodeJson <<< either throwError B.redeemAdaPaperVend <<< mkCPaperVendWalletRedeem seed mnemonic

reportInit :: forall eff. EffFn2 (ajax :: AJAX, crypto :: Crypto.CRYPTO | eff) Int Int (Promise Unit)
reportInit = mkEffFn2 \total -> fromAff <<< B.reportInit <<< mkCInitialized total

importKey :: forall eff. EffFn1 (ajax :: AJAX | eff) String (Promise Json)
importKey = mkEffFn1 $ fromAff <<< map encodeJson <<< B.importKey

syncProgress :: forall eff. Eff (ajax :: AJAX | eff) (Promise Json)
syncProgress = fromAff $ map encodeJson B.syncProgress

testReset :: forall eff. Eff (ajax :: AJAX | eff) (Promise Unit)
testReset = fromAff B.testReset

-- Valid redeem code is base64 encoded 32byte data
-- NOTE: this method handles both base64 and base64url base on rfc4648: see more https://github.com/menelaos/purescript-b64/blob/59e2e9189358a4c8e3eef8662ca281906844e783/src/Data/String/Base64.purs#L182
isValidRedemtionKey :: String -> Boolean
isValidRedemtionKey code = either (const false) (const $ endsWithEqual && 44 == length code) $ B64.decode code
  where
    -- Because it is 32byte base64 encoded
    endsWithEqual = isJust $ stripSuffix (Pattern "=") code

-- Valid paper vend key is base58 encoded 32byte data
isValidPaperVendRedemtionKey :: String -> Boolean
isValidPaperVendRedemtionKey code = maybe false ((==) 32 <<< A.length) $ B58.decode code


indentation

indentation

{-
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.GlobalMenu.Component
  ( component
  , Query(..)
  , MenuOpen(..)
  , Message(..)
  , AuthenticateOrPresentHelp(..)
  , State
  , module SlamData.GlobalMenu.Bus
  ) where

import SlamData.Prelude

import DOM.Event.Event as DEE

import Control.UI.Browser as Browser
import Control.Monad.Aff.AVar as AVar
import Control.Monad.Aff.Bus as Bus
import Control.Monad.Eff as Eff
import Control.Monad.Eff.Ref as Ref
import Control.Monad.Eff.Exception as Exception

import Halogen as H
import Halogen.Component.Utils (busEventSource)
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Query.EventSource as ES
import Halogen.HTML.Events as HE

import OIDC.Crypt as Crypt

import Quasar.Advanced.Types (ProviderR)

import SlamData.AuthenticationMode as AuthenticationMode
import SlamData.Workspace.Eval.Card as EvalCard
import SlamData.GlobalError (GlobalError)
import SlamData.GlobalError as GlobalError
import SlamData.GlobalMenu.Bus (SignInMessage(..))
import SlamData.Monad (Slam)
import SlamData.Quasar as Api
import SlamData.Quasar.Auth as Auth
import SlamData.Quasar.Auth.Authentication (AuthenticationError, toNotificationOptions)
import SlamData.Quasar.Auth.Store as AuthStore
import SlamData.Render.Icon as I
import SlamData.Wiring as Wiring
import SlamData.Workspace.Eval.Persistence as Persistence

import Utils.DOM as DOM

data AuthenticateOrPresentHelp

data Query a
  = Authenticate (Maybe ProviderR) a
  | DismissSubmenu a
  | HandleGlobalError GlobalError a
  | Init a
  | PresentAttribution a
  | SignOut a
  | StopPropagation DOM.Event (Query a)
  | ToggleMenu MenuOpen a

data MenuOpen
 = SignInMenu
 | HelpMenu

derive instance eqMenuOpen ∷ Eq MenuOpen

type State =
  { email ∷ Maybe String
  , loggedIn ∷ Boolean
  , menuOpen ∷ Maybe MenuOpen
  , providers ∷ Maybe (Array ProviderR)
  }

data Message =
  PresentAttributionsDialog

type HTML = H.ComponentHTML Query
type DSL = H.ComponentDSL State Query Message Slam

component ∷ H.Component HH.HTML Query Unit Message Slam
component =
  H.lifecycleComponent
    { initialState: \_ →
      { email: Nothing
      , loggedIn: false
      , menuOpen: Nothing
      , providers: Nothing
      }
    , render
    , eval
    , initializer: Just (H.action Init)
    , finalizer: Nothing
    , receiver: const Nothing
    }

render ∷ State → HTML
render state =
  let
    stopProp action e =
      Just $ StopPropagation (DOM.toEvent e) $ H.action action

    container ∷ HH.ClassName
    container = HH.ClassName "menu-container"

    active ∷ HH.ClassName
    active = HH.ClassName "active"

    submenuItem =
      HP.classes $ HH.ClassName <$> [ "menu-item", "submenu-item" ]

    submenu = HH.ul [ HP.class_ $ HH.ClassName "submenu" ]

    -- wraps stiff in `li > button`
    sitem provider =
      HH.li [ submenuItem ]
        [ HH.button
            [ HP.classes $ HH.ClassName <$> [ "menu-item-button", "submenu-item-button" ]
            , HE.onClick $ stopProp $ Authenticate $ pure provider
            ]
            [ HH.text $ "Sign in with " <> provider.displayName ]
        ]

    -- wraps stuff in `li > a`
    hitem attrs children =
      HH.li [ submenuItem ]
        [ HH.a
          ([ HP.classes $ HH.ClassName <$> [ "menu-item-link", "submenu-item-link" ] ] <> attrs)
          children
        ]

    userInfo =
      flip foldMap state.email \e →
        [ HH.div [ HP.class_ $ HH.ClassName "user-info" ] [ HH.text e ] ]

    signInMenu =
      case state.providers, state.email of
        Just ps, _ →
          [ HH.div
            [ HP.classes $ [ container, HH.ClassName "sign-in-menu-container" ] ] $
            [ HH.button
                [ HP.classes $ [ HH.ClassName "sign-in-menu-button " ]
                  <> if state.menuOpen == Just SignInMenu then [ active ] else []
                , HE.onClick $ stopProp $ ToggleMenu SignInMenu
                ]
                [ I.lockSm, HH.text "Sign in" ]
            ] <>
              if state.menuOpen == Just SignInMenu then
                [ submenu $ sitem <$> ps ]
              else
                []
          ]

        _, Just _ →
          [ HH.div
              [ HP.classes [ container, HH.ClassName "sign-in-menu-container" ] ] $
              [ HH.button
                  [ HP.class_ $ HH.ClassName "sign-in-menu-button "
                  , HE.onClick $ stopProp $ SignOut -- Authenticate Nothing
                  ]
                  [ I.unlockSm, HH.text "Sign out" ]
              ]
          ]

        _, _ →
          []

    helpMenu =
      HH.div
        [ HP.classes $ [ container, HH.ClassName "help-menu-container" ] ] $
        [ HH.button
            [ HP.classes $ [ HH.ClassName "help-menu-button" ]
                <> if state.menuOpen == Just HelpMenu then [ active ] else []
            , HE.onClick $ stopProp $ ToggleMenu HelpMenu
            ]
            [ I.helpSm, HH.text "Help" ]
        ] <>
          if state.menuOpen == Just HelpMenu then
            [ submenu
              [ hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/users-guide.html" ]
                  [ HH.text "User guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/administration-guide.html" ]
                  [ HH.text "Administrator guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/developers-guide.html" ]
                  [ HH.text "Developer guide" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/helpful-tips.html" ]
                  [ HH.text "Helpful tips" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/sql-squared-reference.html" ]
                  [ HH.text "SQL² reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/slamdown-reference.html" ]
                  [ HH.text "SlamDown reference" ]
              , hitem
                  [ HP.href "http://docs.slamdata.com/en/v4.2/troubleshooting-faq.html" ]
                  [ HH.text "Troubleshooting FAQ" ]
              , HH.li [ submenuItem ]
                  [ HH.button
                      [ HP.classes $ HH.ClassName <$>
                          [ "menu-item-button", "submenu-item-button" ]
                      , HE.onClick $ stopProp $ PresentAttribution
                      ]
                      [ HH.text $ "Attribution" ]
                  ]
              ]
            ]
          else
            []

  in
    HH.div
      [ HP.classes $ [ HH.ClassName "sd-global-menu" ] ] $
      userInfo <> signInMenu <> [ helpMenu ]

eval ∷ Query ~> DSL
eval = case _ of
  Authenticate providerR next → do
    authenticate providerR
    pure next

  DismissSubmenu next → do
    H.modify _{ menuOpen = Nothing }
    pure next

  HandleGlobalError error next →
    case error of
      GlobalError.Unauthorized _ → update $> next
      _ → pure next

  Init next → do
    { bus } ← H.lift Wiring.expose
    H.subscribe $ busEventSource (flip HandleGlobalError ES.Listening) bus.globalError
    update
    pure next

  PresentAttribution next → do
    H.modify _{ menuOpen = Nothing }
    H.raise PresentAttributionsDialog
    pure next

  SignOut next → do
    H.modify _{ email = Nothing }
    eval $ Authenticate Nothing next

  StopPropagation e q → do
    H.liftEff $ DEE.stopPropagation e
    eval q

  ToggleMenu which next → do
    menuOpen ← H.gets _.menuOpen
    let
      m = case menuOpen, which of
        Just HelpMenu, HelpMenu → Nothing
        Just SignInMenu, SignInMenu → Nothing
        _, _ → Just which
    H.modify _{ menuOpen = m }
    pure next

update ∷ DSL Unit
update = do
  maybeIdToken ← H.lift Auth.getIdToken
  case maybeIdToken of
    Just idToken → do
      either
        (const retrieveProvidersAndUpdateMenu)
        putEmailToMenu
        (Eff.runPure $ Exception.try $ Crypt.readPayload idToken)
    Nothing →
      retrieveProvidersAndUpdateMenu
  where
  putEmailToMenu ∷ Crypt.Payload → DSL Unit
  putEmailToMenu payload =
    H.modify _{ loggedIn = true, email = map unwrap $ Crypt.pluckEmail payload }

  retrieveProvidersAndUpdateMenu ∷ DSL Unit
  retrieveProvidersAndUpdateMenu = void do
    eProviders ← Api.retrieveAuthProviders
    case eProviders of
      Right p → H.modify _{ providers = p }
      _ → pure unit

authenticate ∷ Maybe ProviderR → DSL Unit
authenticate = maybe logOut logIn
  where
  keySuffix ∷ String
  keySuffix =
    AuthenticationMode.toKeySuffix AuthenticationMode.ChosenProvider

  logOut ∷ DSL Unit
  logOut = do
    AuthStore.removeIdToken keySuffix
    AuthStore.removeUnhashedNonce keySuffix
    AuthStore.removeProvider keySuffix
    update

  logIn ∷ ProviderR → DSL Unit
  logIn providerR = do
    { auth } ← H.lift Wiring.expose
    idToken ← H.liftAff AVar.makeVar
    H.liftAff $ Bus.write { providerR, idToken, prompt: true, keySuffix } auth.requestToken
    either signInFailure (const $ signInSuccess) =<< (H.liftAff $ AVar.takeVar idToken)

  signInSuccess ∷ DSL Unit
  signInSuccess = do
    wiring ← Wiring.expose
    update
    traverse_ (lift ∘ Persistence.queueEvalImmediate ∘ EvalCard.toAll)
      =<< (H.liftEff $ Ref.readRef wiring.auth.retryEval)
    whenM
      (H.liftEff $ Ref.readRef wiring.auth.retrySave)
      (void $ lift $ Persistence.saveWorkspace)
    H.liftAff $ Bus.write SignInSuccess wiring.auth.signIn

  signInFailure ∷ AuthenticationError → DSL Unit
  signInFailure error = do
    { auth, bus } ← H.lift Wiring.expose
    H.liftAff do
      maybe (pure unit) (flip Bus.write bus.notify) (toNotificationOptions error)
      Bus.write SignInFailure auth.signIn

presentHelp ∷ String → DSL Unit
presentHelp = H.liftEff ∘ Browser.newTab