Refactored to use fold style and renamed errored to reflect the specific error

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

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

data PresentAs = IFrame | URI

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

type State =
  { presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  , sharingInput ∷ SharingInput
  , permToken ∷ Maybe QTA.TokenR
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLoggedIn ∷ Boolean
  , copyVal ∷ String
  , noNetworkAccessToAdvancedError ∷ Boolean
  , presentStyleUriInput :: Boolean
  , styleUri :: Maybe AbsoluteURI
  , submitting ∷ Boolean
  , loading ∷ Boolean
  , clipboard ∷ Maybe C.Clipboard
  }

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

toggleStyleUriInput :: State -> State
toggleStyleUriInput state =
   state {presentStyleUriInput = not state.presentStyleUriInput}

updateStyleUri :: String -> State -> State
updateStyleUri styleUri state =
  case hush $ URI.runParseAbsoluteURI styleUri of
    Just validAbsoluteUri →
      if isJust $ styleURIPath validAbsoluteUri
        then state { styleUri = Just validAbsoluteUri }
        else state { styleUri = Nothing }
    Nothing →
      state { styleUri = Nothing }
  where
  styleURIPath ∷ AbsoluteURI → Maybe (Path Abs File Sandboxed)
  styleURIPath =
    hush
      <=< HierarchicalPart.uriPathAbs
      <<< AbsoluteURI.hierarchicalPart

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

data Query a
  = SelectElement DOM.Event a
  | Init a
  | Revoke a
  | ToggleShouldGenerateToken a
  | ToggleStyleUriInput a
  | UpdateStyleUri String a
  | PreventDefault DOM.Event a
  | HandleCancel a

data Message = Dismiss

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

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

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishURI state
  | otherwise = renderPublishIFrame state

renderPublishURI ∷ State → H.ComponentHTML Query
renderPublishURI state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    $ fold
        [ pure $ HH.h4_ [ HH.text "Publish deck" ]
        , guard state.loading $> HH.div
            [ HP.classes [ B.alert, B.alertInfo, HH.ClassName "share-loading" ] ]
            [ HH.img [ HP.src "img/blue-spin.svg" ]
            , HH.text "Loading"
            ]
        , guard (not state.loading) $> HH.div
            [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
            [ HH.p_ message
            , HH.form
                [ HE.onSubmit (HE.input PreventDefault) ]
                $ fold
                    [ pure $ HH.div
                        [ HP.classes [ B.inputGroup ] ]
                        [ HH.input
                            [ HP.classes [ B.formControl ]
                            , HP.value state.copyVal
                            , HP.readOnly true
                            , HP.disabled state.submitting
                            , HP.title "Published deck Uri"
                            , ARIA.label "Published deck Uri"
                            , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                            ]
                        , HH.span
                            [ HP.classes [ B.inputGroupBtn ] ]
                            [ HH.button
                                [ HP.classes [ B.btn, B.btnDefault ]
                                , HE.onClick (HE.input_ HandleCancel)
                                , HP.ref copyButtonRef
                                , HP.id_ "copy-button"
                                , HP.type_ HP.ButtonButton
                                , HP.disabled state.submitting
                                ]
                                [ glyph B.glyphiconCopy ]
                            ]
                        ]
                    , pure $ HH.div_
                        [ HH.a
                            [ HE.onClick (HE.input_ ToggleStyleUriInput) ]
                            [ HH.text "Add a stylesheet Uri to customize look/feel."]
                        ]
                    , guard state.presentStyleUriInput $> HH.div_
                        [ HH.input
                            [ HP.classes [ B.formControl ]
                            , HE.onValueInput (HE.input UpdateStyleUri)
                            ]
                        ]
                    ]
            ]
        , pure $ HH.div
            [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
            $ fold
                [ guard state.noNetworkAccessToAdvancedError $> HH.div
                    [ HP.classes [ B.alert, B.alertDanger ] ]
                    [ HH.text
                        $ "Couldn't share/unshare deck. "
                        ⊕ "Please check you network connection and try again"
                    ]
                , pure $ HH.button
                    [ HP.classes [ B.btn, B.btnDefault ]
                    , HE.onClick (HE.input_ HandleCancel)
                    , HP.type_ HP.ButtonButton
                    ]
                    [ HH.text "Cancel" ]
                , guard state.isLoggedIn $> HH.button
                    [ HP.classes [ B.btn, B.btnInfo ]
                    , HE.onClick (HE.input_ Revoke)
                    , ARIA.label "Revoke access to this deck"
                    , HP.title "Revoke access to this deck"
                    , HP.type_ HP.ButtonButton
                    , HP.enabled $ state.canRevoke ∧ not state.submitting
                    ]
                    [ HH.text "Revoke" ]
                , pure $ HH.a
                    (fold
                       [ pure $ HP.classes $ fold
                           [ pure B.btn
                           , pure B.btnPrimary
                           , guard state.submitting $> B.disabled
                           ]
                       , pure $ HP.target "_blank"
                       , guard state.submitting $> HP.href state.copyVal
                       ]
                    )
                    [ HH.text "Preview" ]
                ]
        ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
          $ "Anyone has access to the following link "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this link may be able to view this deck. "
            ⊕ "They may also be able to modify the link to view or edit any deck "
            ⊕ "in this workspace. Please see "
        , HH.a
            [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
            , HP.target  "_blank"
            ]
            [ HH.text "Securing SlamData Community Edition" ]
            , HH.text " for more information."
            ]

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

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

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

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

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

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

eval (ToggleStyleUriInput next) =
  H.modify toggleStyleUriInput $> next

eval (UpdateStyleUri styleUri next) =
  H.modify (updateStyleUri styleUri) *> updateCopyVal $> next

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

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

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

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

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

renderUri ∷ String → State → Either String URI.URI
renderUri locationString state@{sharingInput, permToken, isLoggedIn, styleUri} =
  case location of
    Nothing →
      Left "Bad SlamData config: workspacePath was not a valid absolute URI."
    Just loc →
      Right $ URI.URI
        (AbsoluteURI.uriScheme loc)
        (URI.HierarchicalPart
          (HierarchicalPart.authority $ AbsoluteURI.hierarchicalPart loc)
          (Right <$> path))
        (Just $ URI.Query query)
        (Just fragment)
  where
  location ∷ Maybe AbsoluteURI
  location =
    hush $ URI.runParseAbsoluteURI locationString

  path ∷ Maybe (Path Abs File Sandboxed)
  path =
    UP.sandbox =<< Pathy.parseAbsFile ("/" ⊕ Config.workspaceUrl)

  fragment ∷ String
  fragment =
    Str.drop 1
      $ mkWorkspaceHash
          (deckPath' sharingInput.workspacePath sharingInput.deckId)
          (WA.Load AT.ReadOnly)
          SM.empty

  query ∷ List (Tuple String (Maybe String))
  query =
    (guard (isJust styleUri) $> (Tuple "stylesheets" $ URI.printAbsoluteURI <$> styleUri))
      ⊕ (guard isLoggedIn $> (Tuple "permissionToken" token))

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

{-
Copyright 2016 SlamData, Inc.

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

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

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

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

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

data PresentAs = IFrame | URI

newtype ExportWarning = ExportWarning String

newtype ExportError = ExportError String

derive newtype instance eqExportWarning ∷ Eq ExportWarning
derive newtype instance ordExportWarning ∷ Ord ExportWarning

derive newtype instance eqExportError ∷ Eq ExportError
derive newtype instance ordExportError ∷ Ord ExportError

derive instance eqPresentAs ∷ Eq PresentAs

type DSL = H.ComponentDSL State Query Message Slam

type State =
  { presentingAs ∷ PresentAs
  , varMaps ∷ Map.Map CID.CardId Port.VarMap
  , sharingInput ∷ SharingInput
  , permToken ∷ Maybe QTA.TokenR
  , canRevoke ∷ Boolean
  , shouldGenerateToken ∷ Boolean
  , hovered ∷ Boolean
  , isLoggedIn ∷ Boolean
  , copyVal ∷ String
  , errored ∷ Boolean
  , warningsAndErrors ∷ Set (Either ExportWarning ExportError)
  , presentStyleUriInput :: Boolean
  , styleUri :: Maybe AbsoluteURI
  , submitting ∷ Boolean
  , loading ∷ Boolean
  , clipboard ∷ Maybe C.Clipboard
  }

initialState ∷ Input → State
initialState input =
  { presentingAs: input.presentingAs
  , varMaps: input.varMaps
  , sharingInput: input.sharingInput
  , permToken: Nothing
  , canRevoke: false
  , shouldGenerateToken: false
  , hovered: false
  , isLoggedIn: false
  , copyVal: ""
  , errored: false
  , warningsAndErrors: mempty
  , presentStyleUriInput: false
  , styleUri: Nothing
  , submitting: false
  , loading: true
  , clipboard: Nothing
  }

toggleStyleUriInput :: State -> State
toggleStyleUriInput state =
   state {presentStyleUriInput = not state.presentStyleUriInput}

updateStyleUri :: String -> State -> State
updateStyleUri styleUri state =
  case hush $ URI.runParseAbsoluteURI styleUri of
    Just validAbsoluteUri →
      if isJust $ styleURIPath validAbsoluteUri
        then state { styleUri = Just validAbsoluteUri }
        else state { styleUri = Nothing }
    Nothing →
      state { styleUri = Nothing }
  where
  styleURIPath ∷ AbsoluteURI → Maybe (Path Abs File Sandboxed)
  styleURIPath =
    hush
      <=< HierarchicalPart.uriPathAbs
      <<< AbsoluteURI.hierarchicalPart

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

data Query a
  = SelectElement DOM.Event a
  | Init a
  | Revoke a
  | ToggleShouldGenerateToken a
  | ToggleStyleUriInput a
  | UpdateStyleUri String a
  | PreventDefault DOM.Event a
  | HandleCancel a

data Message = Dismiss

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

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

render ∷ State → H.ComponentHTML Query
render state
  | state.presentingAs ≡ URI = renderPublishURI state
  | otherwise = renderPublishIFrame state

renderPublishURI ∷ State → H.ComponentHTML Query
renderPublishURI state =
  HH.div [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    [ HH.h4_ [ HH.text "Publish deck" ]
    , HH.div
        [ HP.classes
            $ [ B.alert, B.alertInfo, HH.ClassName "share-loading" ]
            ⊕ if state.loading then [ ] else [ B.hidden ]
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-body" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        [ HH.p_ message
        , HH.form
            [ HE.onSubmit (HE.input PreventDefault) ]
            $ fold
                [ pure $ HH.div
                    [ HP.classes [ B.inputGroup ] ]
                    $ [ HH.input
                        [ HP.classes [ B.formControl ]
                        , HP.value state.copyVal
                        , HP.readOnly true
                        , HP.disabled state.submitting
                        , HP.title "Published deck Uri"
                        , ARIA.label "Published deck Uri"
                        , HE.onClick (HE.input (SelectElement ∘ DOM.toEvent))
                        ]
                      , HH.span
                          [ HP.classes [ B.inputGroupBtn ] ]
                          [ HH.button
                            [ HP.classes [ B.btn, B.btnDefault ]
                            , HE.onClick (HE.input_ HandleCancel)
                            , HP.ref copyButtonRef
                            , HP.id_ "copy-button"
                            , HP.type_ HP.ButtonButton
                            , HP.disabled state.submitting
                            ]
                            [ glyph B.glyphiconCopy ]
                          ]
                      ]
                  , pure $ HH.div_
                      [ HH.a
                        [ HE.onClick (HE.input_ ToggleStyleUriInput) ]
                        [ HH.text "Add a stylesheet Uri to customize look/feel."]
                        ]
                  , guard state.presentStyleUriInput
                      $> HH.div_
                          [ HH.input
                                [ HP.classes [ B.formControl ]
                                , HE.onValueInput (HE.input UpdateStyleUri)
                                ]
                          ]
                ]
        ]
    , HH.div
        [ HP.classes
            $ [ HH.ClassName "deck-dialog-footer" ]
            ⊕ if state.loading then [ B.hidden ] else [ ]
        ]
        $ [ HH.div
              [ HP.classes
                  $ [ B.alert, B.alertDanger ]
                  ⊕ (if state.errored then [ ] else [ B.hidden ])
              ]
              [ HH.text
                  $ "Couldn't share/unshare deck. "
                  ⊕ "Please check you network connection and try again"
              ]
          , HH.button
              [ HP.classes [ B.btn, B.btnDefault ]
              , HE.onClick (HE.input_ HandleCancel)
              , HP.type_ HP.ButtonButton
              ]
              [ HH.text "Cancel" ]
          ]
        ⊕ ((guard state.isLoggedIn)
           $>  HH.button
                 [ HP.classes [ B.btn, B.btnInfo ]
                 , HE.onClick (HE.input_ Revoke)
                 , ARIA.label "Revoke access to this deck"
                 , HP.title "Revoke access to this deck"
                 , HP.type_ HP.ButtonButton
                 , HP.enabled $ state.canRevoke ∧ not state.submitting
                 ]
                 [ HH.text "Revoke" ])
        ⊕ [ HH.a
              ( [ HP.classes
                    $ [ B.btn, B.btnPrimary ]
                    ⊕ if state.submitting then [ B.disabled ] else [ ]
                , HP.target "_blank"
                ]
                ⊕ if state.submitting then [ ] else [ HP.href state.copyVal ]
              )
              [ HH.text "Preview" ]
          ]
      ]
  where
  message
    | state.isLoggedIn =
        [ HH.text
          $ "Anyone has access to the following link "
          ⊕ "will be able to view the deck. You may undo this by revoking access."
        ]
    | otherwise =
        [ HH.text
            $ "Anyone with access to this link may be able to view this deck. "
            ⊕ "They may also be able to modify the link to view or edit any deck "
            ⊕ "in this workspace. Please see "
        , HH.a [ HP.href "http://docs.slamdata.com/en/latest/securing-slamdata.html"
               , HP.target  "_blank"
               ]
            [ HH.text "Securing SlamData Community Edition" ]
        , HH.text " for more information."
        ]

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

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

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

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

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

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

eval (ToggleStyleUriInput next) =
  H.modify toggleStyleUriInput $> next

eval (UpdateStyleUri styleUri next) =
  H.modify (updateStyleUri styleUri) *> updateCopyVal $> next

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

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

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

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

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

renderUri ∷ String → State → Either String URI.URI
renderUri locationString state@{sharingInput, permToken, isLoggedIn, styleUri} =
  case location of
    Nothing →
      Left "Bad SlamData config: workspacePath was not a valid absolute URI."
    Just loc →
      Right $ URI.URI
        (AbsoluteURI.uriScheme loc)
        (URI.HierarchicalPart
          (HierarchicalPart.authority $ AbsoluteURI.hierarchicalPart loc)
          (Right <$> path))
        (Just $ URI.Query query)
        (Just fragment)
  where
  location ∷ Maybe AbsoluteURI
  location =
    hush $ URI.runParseAbsoluteURI locationString

  path ∷ Maybe (Path Abs File Sandboxed)
  path =
    UP.sandbox =<< Pathy.parseAbsFile ("/" ⊕ Config.workspaceUrl)

  fragment ∷ String
  fragment =
    Str.drop 1
      $ mkWorkspaceHash
          (deckPath' sharingInput.workspacePath sharingInput.deckId)
          (WA.Load AT.ReadOnly)
          SM.empty

  query ∷ List (Tuple String (Maybe String))
  query =
    (guard (isJust styleUri) $> (Tuple "stylesheets" $ URI.printAbsoluteURI <$> styleUri))
      ⊕ (guard isLoggedIn $> (Tuple "permissionToken" token))

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


Add comment to auth example

Add comment to auth example

module Main where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Maybe (Maybe(Just, Nothing))
import Data.MediaType.Common (textHTML)
import Data.Tuple (Tuple(Tuple))
import Hyper.Authentication (authenticated, withAuthentication)
import Hyper.Core (writeStatus, closeHeaders, statusOK, Port(Port))
import Hyper.HTML.DSL (p, text, html)
import Hyper.Node.BasicAuth (BasicAuth(BasicAuth))
import Hyper.Node.Server (runServer, defaultOptions)
import Hyper.Response (contentType)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)

data User = User String

-- This could be a function checking the username/password in a database.
userFromBasicAuth :: forall e. Tuple String String -> Aff e (Maybe User)
userFromBasicAuth =
  case _ of
    Tuple "admin" "admin" -> pure (Just (User "Administrator"))
    _ -> pure Nothing

main :: forall e. Eff (console :: CONSOLE, http ∷ HTTP, buffer :: BUFFER | e) Unit
main =
  let
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

    myProfilePage conn@{ components: { authentication: User name } } =
      writeStatus statusOK conn
      >>= contentType textHTML
      >>= closeHeaders
      >>= html (p [] (text ("You are authenticated as " <> name <> ".")))

    app = withAuthentication >=> (authenticated myProfilePage)
    components =
      { authentication: unit
      , authenticator: BasicAuth userFromBasicAuth
      }
  in runServer defaultOptions onListening onRequestError components app

module Main where

import Prelude
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (log, CONSOLE)
import Data.Maybe (Maybe(Just, Nothing))
import Data.MediaType.Common (textHTML)
import Data.Tuple (Tuple(Tuple))
import Hyper.Authentication (authenticated, withAuthentication)
import Hyper.Core (writeStatus, closeHeaders, statusOK, Port(Port))
import Hyper.HTML.DSL (p, text, html)
import Hyper.Node.BasicAuth (BasicAuth(BasicAuth))
import Hyper.Node.Server (runServer, defaultOptions)
import Hyper.Response (contentType)
import Node.Buffer (BUFFER)
import Node.HTTP (HTTP)

data User = User String

userFromBasicAuth :: forall e. Tuple String String -> Aff e (Maybe User)
userFromBasicAuth =
  case _ of
    Tuple "admin" "admin" -> pure (Just (User "Administrator"))
    _ -> pure Nothing

main :: forall e. Eff (console :: CONSOLE, http ∷ HTTP, buffer :: BUFFER | e) Unit
main =
  let
    onListening (Port port) = log ("Listening on http://localhost:" <> show port)
    onRequestError err = log ("Request failed: " <> show err)

    myProfilePage conn@{ components: { authentication: User name } } =
      writeStatus statusOK conn
      >>= contentType textHTML
      >>= closeHeaders
      >>= html (p [] (text ("You are authenticated as " <> name <> ".")))

    app = withAuthentication >=> (authenticated myProfilePage)
    components =
      { authentication: unit
      , authenticator: BasicAuth userFromBasicAuth
      }
  in runServer defaultOptions onListening onRequestError components app


Move helper encoders to the bottom in Elm

Original commit 7e59c32d1c3b7142e7e3b64accb39dfed5060cd9

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (forEnumerated_, removeElement, sortByKey, sortByKeyM)

forbiddenWords :: Array String
forbiddenWords =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "root", "encodeRoot"
    , "jenc", "jdec", "jpipe"
    , "always", "identity"
    , "array", "dict", "maybe"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenWords

forbiddenNames :: Array String
forbiddenNames = A.insert "Root" $ map capitalize forbiddenWords

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

legalizeIdentifier :: Boolean -> String -> String
legalizeIdentifier upper str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier upper ((if upper then "F_" else "f_") <> str)

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    line """module QuickType exposing (Root, root, encodeRoot)

import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array
import Dict
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias Root = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line "root : Jdec.Decoder Root"
    line $ "root = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line "encodeRoot : Root -> String"
    line $ "encodeRoot r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        blank
        renderTypeDefinition i cls
    unions <- getUnions
    for_ unions \types -> do
        blank
        renderUnionDefinition types
    blank
    line """array__enc : (a -> Jenc.Value) -> Array.Array a -> Jenc.Value
array__enc f arr =
    Jenc.array (Array.map f arr)

dict__enc : (a -> Jenc.Value) -> Dict.Dict String a -> Jenc.Value
dict__enc f dict =
    Jenc.object (Dict.toList (Dict.map (\k -> f) dict))

nullable__enc : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
nullable__enc f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null"""

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array.Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict.Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName s

lookupClassDecoderName :: Int -> Doc String
lookupClassDecoderName i = decapitalize <$> lookupClassName i

lookupUnionDecoderName :: Set IRType -> Doc String
lookupUnionDecoderName s = decapitalize <$> lookupUnionName s

encoderNameFromDecoderName :: String -> String
encoderNameFromDecoderName decoderName = "enc__" <> decoderName

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< lookupClassDecoderName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< lookupUnionDecoderName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "array__enc" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromDecoderName <$> lookupClassDecoderName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "dict__enc" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "nullable__enc" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromDecoderName <$> lookupUnionDecoderName s

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> IRClassData -> Doc Unit
renderTypeDefinition classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames lowerNameStyle (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"
    blank
    decoderName <- lookupClassDecoderName classIndex
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromDecoderName decoderName
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
        when (propsList == L.Nil) do
            line "["
        line "]"

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    name <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> name
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)
    blank
    decoderName <- lookupUnionDecoderName allTypes
    line $ decoderName <> " : Jdec.Decoder " <> name
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromDecoderName decoderName
    line $ encoderName <> " : " <> name <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"

module Elm
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Array as A
import Data.Char.Unicode (isLetter)
import Data.Foldable (for_, intercalate)
import Data.List (List, (:))
import Data.List as L
import Data.Map as Map
import Data.Maybe (Maybe(..), maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String as Str
import Data.String.Util (capitalize, decapitalize, camelCase, stringEscape)
import Data.Tuple (Tuple(..), fst)
import Utils (forEnumerated_, removeElement, sortByKey, sortByKeyM)

forbiddenWords :: Array String
forbiddenWords =
    [ "if", "then", "else"
    , "case", "of"
    , "let", "in"
    , "type"
    , "module", "where"
    , "import", "exposing"
    , "as"
    , "port"
    , "int", "float", "bool", "string"
    , "root", "encodeRoot"
    , "jenc", "jdec", "jpipe"
    , "always", "identity"
    , "array", "dict", "maybe"
    ]

forbiddenPropertyNames :: Set String
forbiddenPropertyNames = S.fromFoldable forbiddenWords

forbiddenNames :: Array String
forbiddenNames = A.insert "Root" $ map capitalize forbiddenWords

renderer :: Renderer
renderer =
    { name: "Elm"
    , aceMode: "elm"
    , extension: "elm"
    , doc: elmDoc
    , transforms:
        { nameForClass
        , unionName: Just unionName
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "Other" <> s
        , forbiddenNames: forbiddenNames
        }
    }

nameForClass :: IRClassData -> String
nameForClass (IRClassData { names }) = upperNameStyle $ combineNames names

unionName :: L.List String -> String
unionName s =
    L.sort s
    <#> upperNameStyle
    # intercalate "Or"

unionPredicate :: IRType -> Maybe (Set IRType)
unionPredicate = case _ of
    IRUnion ur ->
        let s = unionToSet ur
        in case nullableFromSet s of
            Nothing -> Just s
            _ -> Nothing
    _ -> Nothing

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || c == '_'

legalizeIdentifier :: Boolean -> String -> String
legalizeIdentifier upper str =
    case Str.charAt 0 str of
    Nothing -> "Empty"
    Just s ->
        if isLetter s then
            Str.fromCharArray $ map (\c -> if isLetterCharacter c then c else '_') $ Str.toCharArray str
        else
            legalizeIdentifier upper ((if upper then "F_" else "f_") <> str)

lowerNameStyle :: String -> String
lowerNameStyle = camelCase >>> decapitalize >>> (legalizeIdentifier false)

upperNameStyle :: String -> String
upperNameStyle = camelCase >>> capitalize >>> (legalizeIdentifier true)

renderComment :: Maybe String -> String
renderComment (Just s) = " -- " <> s
renderComment Nothing = ""

elmDoc :: Doc Unit
elmDoc = do
    line """module QuickType exposing (Root, root, encodeRoot)

import Json.Decode as Jdec
import Json.Decode.Pipeline as Jpipe
import Json.Encode as Jenc
import Array
import Dict

array__enc : (a -> Jenc.Value) -> Array.Array a -> Jenc.Value
array__enc f arr =
    Jenc.array (Array.map f arr)

dict__enc : (a -> Jenc.Value) -> Dict.Dict String a -> Jenc.Value
dict__enc f dict =
    Jenc.object (Dict.toList (Dict.map (\k -> f) dict))

nullable__enc : (a -> Jenc.Value) -> Maybe a -> Jenc.Value
nullable__enc f m =
    case m of
    Just x -> f x
    Nothing -> Jenc.null
"""
    topLevel <- getTopLevel
    { rendered: topLevelRendered } <- typeStringForType topLevel
    line $ "type alias Root = " <> topLevelRendered
    blank
    { rendered: rootDecoder } <- decoderNameForType topLevel
    line "root : Jdec.Decoder Root"
    line $ "root = " <> rootDecoder
    blank
    { rendered: rootEncoder } <- encoderNameForType topLevel
    line "encodeRoot : Root -> String"
    line $ "encodeRoot r = Jenc.encode 0 (" <> rootEncoder <> " r)"
    classes <- getClasses
    for_ classes \(Tuple i cls) -> do
        blank
        renderTypeDefinition i cls
    unions <- getUnions
    for_ unions \types -> do
        blank
        renderUnionDefinition types

singleWord :: String -> Doc { rendered :: String, multiWord :: Boolean }
singleWord w = pure { rendered: w, multiWord: false }

multiWord :: String -> String -> Doc { rendered :: String, multiWord :: Boolean }
multiWord s1 s2 = pure { rendered: s1 <> " " <> s2, multiWord: true }

parenIfNeeded :: { rendered :: String, multiWord :: Boolean } -> String
parenIfNeeded { rendered, multiWord: false } = rendered
parenIfNeeded { rendered, multiWord: true } = "(" <> rendered <> ")"

typeStringForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
typeStringForType = case _ of
    IRNothing -> singleWord "Jdec.Value"
    IRNull -> singleWord "()"
    IRInteger -> singleWord "Int"
    IRDouble -> singleWord "Float"
    IRBool -> singleWord "Bool"
    IRString -> singleWord "String"
    IRArray a -> do
        ts <- typeStringForType a
        multiWord "Array.Array" $ parenIfNeeded ts
    IRClass i -> singleWord =<< lookupClassName i
    IRMap t -> do
        ts <- typeStringForType t
        multiWord "Dict.Dict String" $ parenIfNeeded ts
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just x -> do
            ts <- typeStringForType x
            multiWord "Maybe" $ parenIfNeeded ts
        Nothing -> do
            singleWord =<< lookupUnionName s

lookupClassDecoderName :: Int -> Doc String
lookupClassDecoderName i = decapitalize <$> lookupClassName i

lookupUnionDecoderName :: Set IRType -> Doc String
lookupUnionDecoderName s = decapitalize <$> lookupUnionName s

encoderNameFromDecoderName :: String -> String
encoderNameFromDecoderName decoderName = "enc__" <> decoderName

unionConstructorName :: Set IRType -> IRType -> Doc String
unionConstructorName s t = do
    typeName <- upperNameStyle <$> getTypeNameForUnion t
    unionName <- lookupUnionName s
    pure $ typeName <> "In" <> unionName

decoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
decoderNameForType = case _ of
    IRNothing -> singleWord "Jdec.value"
    IRNull -> multiWord "Jdec.null" "()"
    IRInteger -> singleWord "Jdec.int"
    IRDouble -> singleWord "Jdec.float"
    IRBool -> singleWord "Jdec.bool"
    IRString -> singleWord "Jdec.string"
    IRArray a -> do
        dn <- decoderNameForType a
        multiWord "Jdec.array" $ parenIfNeeded dn
    IRClass i -> singleWord =<< lookupClassDecoderName i
    IRMap t -> do
        dn <- decoderNameForType t
        multiWord "Jdec.dict" $ parenIfNeeded dn
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            dn <- decoderNameForType t
            multiWord "Jdec.nullable" $ parenIfNeeded dn
        Nothing -> do
            singleWord =<< lookupUnionDecoderName s

encoderNameForType :: IRType -> Doc { rendered :: String, multiWord :: Boolean }
encoderNameForType = case _ of
    IRNothing -> singleWord "identity"
    IRNull -> multiWord "always" "Jenc.null"
    IRInteger -> singleWord "Jenc.int"
    IRDouble -> singleWord "Jenc.float"
    IRBool -> singleWord "Jenc.bool"
    IRString -> singleWord "Jenc.string"
    IRArray a -> do
        rendered <- encoderNameForType a
        multiWord "array__enc" $ parenIfNeeded rendered
    IRClass i -> singleWord =<< encoderNameFromDecoderName <$> lookupClassDecoderName i
    IRMap t -> do
        rendered <- encoderNameForType t
        multiWord "dict__enc" $ parenIfNeeded rendered
    IRUnion u ->
        let s = unionToSet u
        in case nullableFromSet s of
        Just t -> do
            rendered <- encoderNameForType t
            multiWord "nullable__enc" $ parenIfNeeded rendered
        Nothing ->
            singleWord =<< encoderNameFromDecoderName <$> lookupUnionDecoderName s

forWithPrefix_ :: forall a b p m. Applicative m => List a -> p -> p -> (p -> a -> m b) -> m Unit
forWithPrefix_ l firstPrefix restPrefix f =
    forEnumerated_ l (\i -> f $ if i == 0 then firstPrefix else restPrefix)

isOptional :: IRType -> Boolean
isOptional = case _ of
    IRUnion u ->
        case nullableFromSet $ unionToSet u of
        Just t -> true
        Nothing -> false
    -- IRNull -> true
    -- IRUnion u -> S.member IRNull $ unionToSet u
    _ -> false

renderTypeDefinition :: Int -> IRClassData -> Doc Unit
renderTypeDefinition classIndex (IRClassData { names, properties }) = do
    className <- lookupClassName classIndex
    let propertyNames = transformNames lowerNameStyle (\n -> "other" <> capitalize n) forbiddenPropertyNames $ map (\n -> Tuple n n) $ Map.keys properties
    let propsList = Map.toUnfoldable properties # sortByKey (\t -> lookupName (fst t) propertyNames)
    line $ "type alias " <> className <> " ="
    indent do
        forWithPrefix_ propsList "{ " ", " \braceOrComma (Tuple pname ptype) -> do
            let propName = lookupName pname propertyNames
            { rendered } <- typeStringForType ptype
            line $ braceOrComma <> propName <> " : " <> rendered
        when (propsList == L.Nil) do
            line "{"
        line "}"
    blank
    decoderName <- lookupClassDecoderName classIndex
    line $ decoderName <> " : Jdec.Decoder " <> className
    line $ decoderName <> " ="
    indent do
        line $ "Jpipe.decode " <> className
        for_ propsList \(Tuple pname ptype) -> do
            indent do
                propDecoder <- decoderNameForType ptype
                let { reqOrOpt, fallback } = if isOptional ptype then { reqOrOpt: "Jpipe.optional", fallback: " Nothing" } else { reqOrOpt: "Jpipe.required", fallback: "" }
                line $ "|> " <> reqOrOpt <> " \"" <> stringEscape pname <> "\" " <> (parenIfNeeded propDecoder) <> fallback
    blank
    let encoderName = encoderNameFromDecoderName decoderName
    line $ encoderName <> " : " <> className <> " -> Jenc.Value"
    line $ encoderName <> " x ="
    indent do
        line "Jenc.object"
        indent do
            forWithPrefix_ propsList "[ " ", " \bracketOrComma (Tuple pname ptype) -> do
                let propName = lookupName pname propertyNames
                { rendered: propEncoder } <- encoderNameForType ptype
                line $ bracketOrComma <> "(\"" <> stringEscape pname <> "\", " <> propEncoder <> " x." <> propName <> ")"
        when (propsList == L.Nil) do
            line "["
        line "]"

renderUnionDefinition :: Set IRType -> Doc Unit
renderUnionDefinition allTypes = do
    name <- lookupUnionName allTypes
    fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
    line $ "type " <> name
    forWithPrefix_ fields "=" "|" \equalsOrPipe t -> do
        indent do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ equalsOrPipe <> " " <> constructor
            unless (t == IRNull) do
                ts <- typeStringForType t
                line $ equalsOrPipe <> " " <> constructor <> " " <> (parenIfNeeded ts)
    blank
    decoderName <- lookupUnionDecoderName allTypes
    line $ decoderName <> " : Jdec.Decoder " <> name
    line $ decoderName <> " ="
    indent do
        let { element: maybeArray, rest: nonArrayFields } = removeElement isArray allTypes
        nonArrayDecFields <- L.fromFoldable nonArrayFields # sortByKeyM (unionConstructorName allTypes)
        let decFields = maybe nonArrayDecFields (\f -> f : nonArrayDecFields) maybeArray
        line "Jdec.oneOf"
        indent do
            forWithPrefix_ decFields "[" "," \bracketOrComma t -> do
                constructor <- unionConstructorName allTypes t
                when (t == IRNull) do
                    line $ bracketOrComma <> " Jdec.null " <> constructor
                unless (t == IRNull) do
                    decoder <- decoderNameForType t
                    line $ bracketOrComma <> " Jdec.map " <> constructor <> " " <> parenIfNeeded decoder
            line "]"
    blank
    let encoderName = encoderNameFromDecoderName decoderName
    line $ encoderName <> " : " <> name <> " -> Jenc.Value"
    line $ encoderName <> " x = case x of"
    indent do
        fields <- L.fromFoldable allTypes # sortByKeyM (unionConstructorName allTypes)
        for_ fields \t -> do
            constructor <- unionConstructorName allTypes t
            when (t == IRNull) do
                line $ constructor <> " -> Jenc.null"
            unless (t == IRNull) do
                { rendered: encoder } <- encoderNameForType t
                line $ constructor <> " y -> " <> encoder <> " y"