secure?

secure?

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Chat.ServerTypes
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function (const, (<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup ((<>))
import Data.String (take)
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, liftH, modify, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events.Indexed (input_, onClick, onInput, onKeyPress, onSubmit)
import Halogen.HTML.Indexed (button, input, textarea)
import Halogen.Query (get, set)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)
import DOM(DOM)
import DOM.HTML
import DOM.HTML.Window
import DOM.HTML.Location

type State = {cur :: String , text :: Array ChatMessage, sub :: Boolean}

initial :: State
initial = {cur: "", text: [], sub: false}

data Query a = Connect a | Disconnect a | UpdateText (Array ChatMessage) a | SendMessage a | UpdateCurrent String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

onlyForKey :: forall props g ev.
  (Functor g) => Number
                   -> ({ "keyCode" :: Number
                       | props
                       }
                       -> g (Maybe ev)
                      )
                      -> { "keyCode" :: Number
                         | props
                         }
                         -> g (Maybe ev)
onlyForKey i input  = (\ (a@{keyCode}) -> (if keyCode == 13.0 then id else const Nothing) <$> input a)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadAff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur, sub} = H.div_ $
                    append (if not sub
                        then []
                        else [ H.input [ P.value cur
                                       , E.onValueInput (E.input UpdateCurrent)
                                       , E.onKeyPress  (onlyForKey 13.0 (E.input_ SendMessage))
                                       ]
                            , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]])
                        $ (\(ChatMessage t) -> H.div_ [H.text (t.userName <> ": " <> t.messageBody)]) <$> text

              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                sub <- liftH $ liftEff initSubscriber
                subscribe (chatMessages sub.messages)
                modify (\s -> s {sub = true})
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= t})
                pure a
              eval (SendMessage a) = do
                st <- get
                merr <- liftH <<< liftAff $ sendMessage st.cur
                case merr of
                    Just err -> do modify (\s ->  s {text= append [systemMessage err] s.text})
                                   pure a
                    Nothing -> do modify (\s -> s {cur = ""})
                                  pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a

data Action = Update (Array ChatMessage)
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}
websocketUrl :: forall eff. Eff (dom :: DOM | eff) String
websocketUrl = do
  l <- location =<< window
  h <- host l
  prot <- protocol l
  let p = case prot of
            "http:" -> "ws:"
            "https:" -> "wss:"
            _ -> "wss:"
  pure $ p <> "//"<> h

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL, dom ::DOM  | eff) (SubscriberData (channel :: CHANNEL, dom ::DOM | eff))
initSubscriber = do
  ch <- channel Nop
  url <- websocketUrl
  let
    c :: Config (channel :: CHANNEL, dom ::DOM | eff) Action
    c = {
        url : url <> "/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  Signal Action ->
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       )
       Unit
callback sig eff = do
    runSignal (eff <$> sig)

systemMessage :: String -> ChatMessage
systemMessage s = ChatMessage {userName: "System", messageBody: s}

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => Signal Action ->  EventSource Query g
chatMessages sig = eventSource (callback sig) (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText [systemMessage "No op"]
            ReportError -> f $ UpdateText [systemMessage "Error"]
            SubscriberLog s -> f $ UpdateText [systemMessage s]
        )
        where
            f x = pure $ action x

sendMessage :: forall eff. String -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s = do
    ebs <- runExceptT $ runReaderT (postGame s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing

module Component.Chat where

import Prelude
import WebAPI.Settings
import WebAPI
import Chat.ServerTypes
import Halogen.HTML.Events.Indexed as E
import Halogen.HTML.Indexed as H
import Halogen.HTML.Properties.Indexed as P
import Servant.Subscriber as Subscribe
import Signal.Channel as Chan
import WebAPI.Subscriber as Sub
import Control.Category ((<<<))
import Control.Monad (class Monad, pure, bind)
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (class MonadAff, liftAff)
import Control.Monad.Aff.Console (error)
import Control.Monad.Aff.Free (class Affable)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (class MonadEff, liftEff)
import Control.Monad.Eff.Exception (EXCEPTION)
import Control.Monad.Eff.Ref (REF)
import Control.Monad.Except (runExceptT)
import Control.Monad.Reader (runReaderT)
import Data.Either (Either(..))
import Data.Function (const, (<<<))
import Data.Generic (gCompare, gShow)
import Data.Maybe (Maybe(..), maybe, maybe')
import Data.Monoid (append)
import Data.NaturalTransformation (type (~>))
import Data.Semigroup ((<>))
import Data.String (take)
import Halogen (Component, ComponentDSL, ComponentHTML, EventSource, HalogenEffects, action, eventSource, liftH, modify, subscribe)
import Halogen.Component (lifecycleComponent)
import Halogen.HTML.Events (onChange)
import Halogen.HTML.Events.Indexed (input_, onClick, onInput, onKeyPress, onSubmit)
import Halogen.HTML.Indexed (button, input, textarea)
import Halogen.Query (get, set)
import Network.HTTP.Affjax (AJAX)
import Servant.PureScript.Affjax (errorToString)
import Servant.Subscriber (Subscriber, SubscriberEff, makeSubscriber)
import Servant.Subscriber.Connection (Config)
import Servant.Subscriber.Internal (doCallback)
import Signal (Signal, runSignal)
import Signal.Channel (Channel, send, channel, CHANNEL)
import WebAPI.Subscriber (getGame)
import WebSocket (WEBSOCKET)
import DOM(DOM)
import DOM.HTML
import DOM.HTML.Window
import DOM.HTML.Location

type State = {cur :: String , text :: Array ChatMessage, sub :: Boolean}

initial :: State
initial = {cur: "", text: [], sub: false}

data Query a = Connect a | Disconnect a | UpdateText (Array ChatMessage) a | SendMessage a | UpdateCurrent String a

type Effects  eff = (ajax :: AJAX, channel :: CHANNEL, ref :: REF, ws :: WEBSOCKET | eff)

onlyForKey :: forall props g ev.
  (Functor g) => Number
                   -> ({ "keyCode" :: Number
                       | props
                       }
                       -> g (Maybe ev)
                      )
                      -> { "keyCode" :: Number
                         | props
                         }
                         -> g (Maybe ev)
onlyForKey i input  = (\ (a@{keyCode}) -> (if keyCode == 13.0 then id else const Nothing) <$> input a)

chat :: forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g, MonadAff (HalogenEffects(Effects eff)) g) => Component State Query g
chat = lifecycleComponent {render, eval, initializer: Just (action Connect), finalizer: Just (action Disconnect)}
        where
              render :: State -> ComponentHTML Query
              render {text, cur, sub} = H.div_ $
                    append (if not sub
                        then []
                        else [ H.input [ P.value cur
                                       , E.onValueInput (E.input UpdateCurrent)
                                       , E.onKeyPress  (onlyForKey 13.0 (E.input_ SendMessage))
                                       ]
                            , H.button [E.onClick (E.input_ SendMessage)] [H.text "Send"]])
                        $ (\(ChatMessage t) -> H.div_ [H.text (t.userName <> ": " <> t.messageBody)]) <$> text

              eval :: Query ~> (ComponentDSL State Query g)
              eval (Connect a) = do
                sub <- liftH $ liftEff initSubscriber
                subscribe (chatMessages sub.messages)
                modify (\s -> s {sub = true})
                pure a
              eval (Disconnect a) = pure a
              eval (UpdateText t a) = do
                modify (\s ->  s {text= t})
                pure a
              eval (SendMessage a) = do
                st <- get
                merr <- liftH <<< liftAff $ sendMessage st.cur
                case merr of
                    Just err -> do modify (\s ->  s {text= append [systemMessage err] s.text})
                                   pure a
                    Nothing -> do modify (\s -> s {cur = ""})
                                  pure a
              eval (UpdateCurrent s a) = do
                modify (\st -> st {cur = s})
                pure a

data Action = Update (Array ChatMessage)
            | ReportError
            | SubscriberLog String
            | Nop

type SubscriberData eff = {
  subscriber :: Subscriber eff Action
, messages :: Signal Action
}

initSubscriber :: forall eff. SubscriberEff (channel :: CHANNEL, dom ::DOM  | eff) (SubscriberData (channel :: CHANNEL, dom ::DOM | eff))
initSubscriber = do
  ch <- channel Nop
  url <- host =<< location =<< window
  let
    c :: Config (channel :: CHANNEL, dom ::DOM | eff) Action
    c = {
        url : "ws://"<> url <> "/subscriber"
      , notify : send ch <<< SubscriberLog <<< gShow
      , callback : send ch
      }
  sub <- makeSubscriber c
  let sig = Chan.subscribe ch
  --pongReq <- flip runReaderT settings $ MakeReq.putCounter (CounterAdd 1) -- | Let's play a bit! :-)
  -- closeReq <- flip runReaderT settings $ MakeReq.putCounter (CounterSet 100)
  subs <- flip runReaderT settings $ Sub.getGame (maybe (ReportError) Update)
  let conn = Subscribe.getConnection sub
 -- C.setPongRequest pongReq conn -- |< Hihi :-)
 -- C.setCloseRequest closeReq conn
  Subscribe.deploy subs sub
  pure $ { subscriber : sub, messages : sig }

callback :: forall eff.
  Signal Action ->
  (Action -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       ) Unit  )
  -> Eff
       ( "ref" :: REF
       , "ws" :: WEBSOCKET
       , "err" :: EXCEPTION
       , "channel" :: CHANNEL
       , dom ::DOM
       | eff
       )
       Unit
callback sig eff = do
    runSignal (eff <$> sig)

systemMessage :: String -> ChatMessage
systemMessage s = ChatMessage {userName: "System", messageBody: s}

chatMessages ::  forall g eff. (Monad g, Affable (HalogenEffects(Effects eff)) g) => Signal Action ->  EventSource Query g
chatMessages sig = eventSource (callback sig) (\a -> case a of
            Update s -> f $ UpdateText s
            Nop -> f $ UpdateText [systemMessage "No op"]
            ReportError -> f $ UpdateText [systemMessage "Error"]
            SubscriberLog s -> f $ UpdateText [systemMessage s]
        )
        where
            f x = pure $ action x

sendMessage :: forall eff. String -> Aff (ajax :: AJAX | eff) (Maybe String)
sendMessage s = do
    ebs <- runExceptT $ runReaderT (postGame s) settings
    pure $ case ebs of
        Left err -> Just $ errorToString err
        _ -> Nothing


Remove Tuple import

Remove Tuple import

-- | This module defines the reader monad transformer, `ReaderT`.

module Control.Monad.Reader.Trans
  ( ReaderT(..), runReaderT, withReaderT, mapReaderT
  , module Control.Monad.Trans
  , module Control.Monad.Reader.Class
  ) where

import Prelude

import Data.Distributive (Distributive, distribute, collect)

import Control.Alt
import Control.Alternative
import Control.Monad.Eff.Class
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.Rec.Class
import Control.Monad.State.Class
import Control.Monad.Writer.Class
import Control.Monad.Trans
import Control.MonadPlus
import Control.Plus

import Data.Either

-- | The reader monad transformer.
-- |
-- | This monad transformer extends the base monad transformer with a _global context_ of
-- | type `r`.
-- |
-- | The `MonadReader` type class describes the operations supported by this monad.
newtype ReaderT r m a = ReaderT (r -> m a)

-- | Run a computation in the `ReaderT` monad.
runReaderT :: forall r m a. ReaderT r m a -> (r -> m a)
runReaderT (ReaderT x) = x

-- | Change the type of the result in a `ReaderT` monad action.
mapReaderT :: forall r m1 m2 a b. (m1 a -> m2 b) -> ReaderT r m1 a -> ReaderT r m2 b
mapReaderT f m = ReaderT $ f <<< runReaderT m

-- | Change the type of the context in a `ReaderT` monad action.
withReaderT :: forall r1 r2 m a b. (r2 -> r1) -> ReaderT r1 m a -> ReaderT r2 m a
withReaderT f m = ReaderT $ runReaderT m <<< f

instance functorReaderT :: (Functor m) => Functor (ReaderT r m) where
  map f = mapReaderT $ (<$>) f

instance applyReaderT :: (Applicative m) => Apply (ReaderT r m) where
  apply f v = ReaderT \r -> runReaderT f r <*> runReaderT v r

instance applicativeReaderT :: (Applicative m) => Applicative (ReaderT r m) where
  pure = ReaderT <<< const <<< pure

instance altReaderT :: (Alt m) => Alt (ReaderT r m) where
  alt m n = ReaderT \r -> runReaderT m r <|> runReaderT n r

instance plusReaderT :: (Plus m) => Plus (ReaderT r m) where
  empty = ReaderT (const empty)

instance alternativeReaderT :: (Alternative m) => Alternative (ReaderT r m)

instance bindReaderT :: (Monad m) => Bind (ReaderT r m) where
  bind m k = ReaderT \r -> do
    a <- runReaderT m r
    runReaderT (k a) r

instance monadReaderT :: (Monad m) => Monad (ReaderT r m)

instance monadPlusReaderT :: (MonadPlus m) => MonadPlus (ReaderT r m)

instance monadTransReaderT :: MonadTrans (ReaderT r) where
  lift = ReaderT <<< const

instance monadEffReader :: (MonadEff eff m) => MonadEff eff (ReaderT r m) where
  liftEff = lift <<< liftEff

instance monadContReaderT :: (MonadCont m) => MonadCont (ReaderT r m) where
  callCC f = ReaderT $ \r -> callCC $ \c -> runReaderT (f (\a -> ReaderT $ const $ c a)) r

instance monadErrorReaderT :: (MonadError e m) => MonadError e (ReaderT r m) where
  throwError e = lift (throwError e)
  catchError m h = ReaderT $ \r -> catchError (runReaderT m r) (\e -> runReaderT (h e) r)

instance monadReaderReaderT :: (Monad m) => MonadReader r (ReaderT r m) where
  ask = ReaderT return
  local = withReaderT

instance monadStateReaderT :: (MonadState s m) => MonadState s (ReaderT r m) where
  state f = lift (state f)

instance monadWriterReaderT :: (Monad m, MonadWriter w m) => MonadWriter w (ReaderT r m) where
  writer wd = lift (writer wd)
  listen = mapReaderT listen
  pass = mapReaderT pass

instance distributiveReaderT :: (Distributive g) => Distributive (ReaderT e g) where
  distribute a = ReaderT \e -> collect (flip runReaderT e) a
  collect f = distribute <<< map f

instance monadRecReaderT :: (MonadRec m) => MonadRec (ReaderT r m) where
  tailRecM k a = ReaderT \r -> tailRecM (k' r) a
    where
    k' r a = do
      result <- runReaderT (k a) r
      return $ either Left Right result

-- | This module defines the reader monad transformer, `ReaderT`.

module Control.Monad.Reader.Trans
  ( ReaderT(..), runReaderT, withReaderT, mapReaderT
  , module Control.Monad.Trans
  , module Control.Monad.Reader.Class
  ) where

import Prelude

import Data.Distributive (Distributive, distribute, collect)

import Control.Alt
import Control.Alternative
import Control.Monad.Eff.Class
import Control.Monad.Cont.Class
import Control.Monad.Error.Class
import Control.Monad.Reader.Class
import Control.Monad.Rec.Class
import Control.Monad.State.Class
import Control.Monad.Writer.Class
import Control.Monad.Trans
import Control.MonadPlus
import Control.Plus

import Data.Either
import Data.Tuple

-- | The reader monad transformer.
-- |
-- | This monad transformer extends the base monad transformer with a _global context_ of
-- | type `r`.
-- |
-- | The `MonadReader` type class describes the operations supported by this monad.
newtype ReaderT r m a = ReaderT (r -> m a)

-- | Run a computation in the `ReaderT` monad.
runReaderT :: forall r m a. ReaderT r m a -> (r -> m a)
runReaderT (ReaderT x) = x

-- | Change the type of the result in a `ReaderT` monad action.
mapReaderT :: forall r m1 m2 a b. (m1 a -> m2 b) -> ReaderT r m1 a -> ReaderT r m2 b
mapReaderT f m = ReaderT $ f <<< runReaderT m

-- | Change the type of the context in a `ReaderT` monad action.
withReaderT :: forall r1 r2 m a b. (r2 -> r1) -> ReaderT r1 m a -> ReaderT r2 m a
withReaderT f m = ReaderT $ runReaderT m <<< f

instance functorReaderT :: (Functor m) => Functor (ReaderT r m) where
  map f = mapReaderT $ (<$>) f

instance applyReaderT :: (Applicative m) => Apply (ReaderT r m) where
  apply f v = ReaderT \r -> runReaderT f r <*> runReaderT v r

instance applicativeReaderT :: (Applicative m) => Applicative (ReaderT r m) where
  pure = ReaderT <<< const <<< pure

instance altReaderT :: (Alt m) => Alt (ReaderT r m) where
  alt m n = ReaderT \r -> runReaderT m r <|> runReaderT n r

instance plusReaderT :: (Plus m) => Plus (ReaderT r m) where
  empty = ReaderT (const empty)

instance alternativeReaderT :: (Alternative m) => Alternative (ReaderT r m)

instance bindReaderT :: (Monad m) => Bind (ReaderT r m) where
  bind m k = ReaderT \r -> do
    a <- runReaderT m r
    runReaderT (k a) r

instance monadReaderT :: (Monad m) => Monad (ReaderT r m)

instance monadPlusReaderT :: (MonadPlus m) => MonadPlus (ReaderT r m)

instance monadTransReaderT :: MonadTrans (ReaderT r) where
  lift = ReaderT <<< const

instance monadEffReader :: (MonadEff eff m) => MonadEff eff (ReaderT r m) where
  liftEff = lift <<< liftEff

instance monadContReaderT :: (MonadCont m) => MonadCont (ReaderT r m) where
  callCC f = ReaderT $ \r -> callCC $ \c -> runReaderT (f (\a -> ReaderT $ const $ c a)) r

instance monadErrorReaderT :: (MonadError e m) => MonadError e (ReaderT r m) where
  throwError e = lift (throwError e)
  catchError m h = ReaderT $ \r -> catchError (runReaderT m r) (\e -> runReaderT (h e) r)

instance monadReaderReaderT :: (Monad m) => MonadReader r (ReaderT r m) where
  ask = ReaderT return
  local = withReaderT

instance monadStateReaderT :: (MonadState s m) => MonadState s (ReaderT r m) where
  state f = lift (state f)

instance monadWriterReaderT :: (Monad m, MonadWriter w m) => MonadWriter w (ReaderT r m) where
  writer wd = lift (writer wd)
  listen = mapReaderT listen
  pass = mapReaderT pass

instance distributiveReaderT :: (Distributive g) => Distributive (ReaderT e g) where
  distribute a = ReaderT \e -> collect (flip runReaderT e) a
  collect f = distribute <<< map f

instance monadRecReaderT :: (MonadRec m) => MonadRec (ReaderT r m) where
  tailRecM k a = ReaderT \r -> tailRecM (k' r) a
    where
    k' r a = do
      result <- runReaderT (k a) r
      return $ either Left Right result


Align types

Align types

Original commit da530db91b560bee69b151f03d3338e4291e77b3

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximum, maximumBy)
import Data.Function (on)
import Data.List (fromFoldable)
import Data.List as L
import Data.Map (keys)
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just), fromMaybe, maybe)
import Data.Set (Set)
import Data.Set as S
import Data.String (Pattern(..), contains, length)
import Data.String as Str
import Data.String.Util as Str
import Data.Tuple (Tuple(..), fst)
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "other_" <> s
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

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

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

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

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderType x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<string, " <> rendered <> ">"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = Str.camelCase >>> Str.capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify s
    | Str.contains (Str.Pattern " ") s = "\"" <> s <> "\""
    | otherwise = s

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     let result: """ <> top <> """ = JSON.parse(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames propertyNamify ("other " <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "interface " <> className <> " {"
    indent do
        let props = M.toUnfoldable properties :: Array _
        let resolved = props <#> \(Tuple a b) -> Tuple (lookupName a propertyNames) b
        let maxWidth = props <#> fst <#> Str.length # maximum
        for_ props \(Tuple pname ptype) -> do
            let indent = maybe 1 (\w -> w - Str.length pname + 1) maxWidth
            rendered <- renderType ptype
            line $ pname <> ":" <> Str.times " " indent <> rendered <> ";"
    line "}"

module TypeScript
    ( renderer
    ) where

import Doc
import IRGraph
import Prelude

import Data.Char.Unicode (GeneralCategory(..), generalCategory, isLetter)
import Data.Foldable (for_, intercalate, maximumBy)
import Data.Function (on)
import Data.List (fromFoldable)
import Data.List as L
import Data.Map (keys)
import Data.Map as M
import Data.Maybe (Maybe(Nothing, Just))
import Data.Set (Set)
import Data.Set as S

import Data.String as Str
import Data.String.Util as Str

import Data.String.Util (camelCase, capitalize, decapitalize)
import Data.Tuple (Tuple(..))
import Utils (mapM)

renderer :: Renderer
renderer =
    { name: "TypeScript"
    , aceMode: "typescript"
    , extension: "ts"
    , doc: typeScriptDoc
    , transforms:
        { nameForClass
        , unionName: Nothing
        , unionPredicate: Just unionPredicate
        , nextName: \s -> "other_" <> s
        , forbiddenNames: []
        , topLevelNameFromGiven: id
        , forbiddenFromTopLevelNameGiven: const []
        }
    }

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

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

isValueType :: IRType -> Boolean
isValueType IRInteger = true
isValueType IRDouble = true
isValueType IRBool = true
isValueType _ = false

isLetterCharacter :: Char -> Boolean
isLetterCharacter c =
    isLetter c || (generalCategory c == Just LetterNumber)

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

isPartCharacter :: Char -> Boolean
isPartCharacter c =
    case generalCategory c of
    Nothing -> false
    Just DecimalNumber -> true
    Just ConnectorPunctuation -> true
    Just NonSpacingMark -> true
    Just SpacingCombiningMark -> true
    Just Format -> true
    _ -> isLetterCharacter c

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

renderUnion :: Set IRType -> Doc String
renderUnion s =
    case nullableFromSet s of
    Just x -> do
        rendered <- renderType x
        pure if isValueType x then rendered <> "?" else rendered
    Nothing -> do
        types <- mapM renderType $ L.fromFoldable s
        pure $ intercalate " | " types

renderType :: IRType -> Doc String
renderType = case _ of
    IRNothing -> pure "object" -- we can have arrays of nothing
    IRNull -> pure "object"
    IRInteger -> pure "long"
    IRDouble -> pure "double"
    IRBool -> pure "bool"
    IRString -> pure "string"
    IRArray a -> do
        rendered <- renderType a
        pure $ rendered <> "[]"
    IRClass i -> lookupClassName i
    IRMap t -> do
        rendered <- renderType t
        pure $ "Map<string, " <> rendered <> ">"
    IRUnion types -> renderUnion $ unionToSet types

interfaceNamify :: String -> String
interfaceNamify = camelCase >>> capitalize >>> legalizeIdentifier

propertyNamify :: String -> String
propertyNamify = camelCase >>> decapitalize >>> legalizeIdentifier

typeScriptDoc :: Doc Unit
typeScriptDoc = do
    top <- getTopLevel >>= renderType
    line $ """// To parse this JSON data:
//
//     let result: """ <> top <> """ = JSON.parse(json);
//
"""
    classes <- getClasses
    for_ classes \(Tuple i cd) -> do
        interface <- lookupClassName i
        renderInterface cd interface
        blank

renderInterface :: IRClassData -> String -> Doc Unit
renderInterface (IRClassData { names, properties }) className = do
    let propertyNames = transformNames propertyNamify ("other " <> _) (S.singleton className) $ map (\n -> Tuple n n) $ M.keys properties
    line $ "interface " <> className <> " {"
    indent do
        let maxWidth = properties # M.keys # maximumBy (compare `on` Str.length)
        for_ (M.toUnfoldable properties :: Array _) \(Tuple pname ptype) -> do
            rendered <- renderType ptype
            let csPropName = lookupName pname propertyNames
            line $ csPropName <> ": " <> rendered <> ";"
    line "}"


1591: Doesn't dismiss errors in Share dialog

Also disables the form in the case of a missing Advanced edition, since in that
case there's no way to actually share the deck

{-
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.Share.Component where

import SlamData.Prelude

import Control.UI.Browser (select)

import Data.Array as Arr
import Data.Foreign (toForeign)
import Data.String as Str
import Data.Path.Pathy (rootDir, (</>), file)
import Data.Path.Pathy as Pt

import DOM.HTML.Types (readHTMLElement)
import DOM.Classy.Element (toElement)

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import Quasar.Advanced.Types as QT

import SlamData.Quasar.Security as Q
import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Deck.Dialog.Share.Model (ShareResume(..), sharingActions, SharingInput)

import Utils.DOM as DOM
import Utils.Path (rootFile, FilePath)

import Clipboard as C

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

data SubjectType
  = User
  | Group
  | Token

derive instance subjectTypeEq ∷ Eq SubjectType

data ErrorType
  = Connection
  | Validation
  | GroupList

derive instance errorTypeEq ∷ Eq ErrorType

-- This is utility function that should be used only in
-- select/option stuff
readSubjectType ∷ String → SubjectType
readSubjectType = case _ of
  "user" → User
  "group" → Group
  "token" → Token
  _ → User

-- Same with `readSubjectType`
readShareResume ∷ String → ShareResume
readShareResume = case _ of
  "edit" → Edit
  _ → View

printShareResume ∷ ShareResume → String
printShareResume = case _ of
  Edit → "Edit"
  View → "View"

-- It would be better if all this Boolean stuff was replaced with
-- some kind of ADT abstracting automata.
type State =
  { subjectType ∷ SubjectType
  , error ∷ Maybe ErrorType
  , email ∷ String
    -- Actually should be Group from purescript-quasar
  , groups ∷ Array FilePath
  , groupSelected ∷ Maybe FilePath
  , tokenName ∷ String
  , loading ∷ Boolean
  , showError ∷ Boolean
  , submitting ∷ Boolean
  , shareResume ∷ ShareResume
  , tokenSecret ∷ Maybe String
  , sharingInput ∷ SharingInput
  }

initialState ∷ SharingInput → State
initialState sharingInput =
  { subjectType: User
  , error: Nothing
  , email: ""
  , groups: [ ]
  , groupSelected: Nothing
  , tokenName: ""
  , loading: true
  , showError: false
  , submitting: false
  , shareResume: View
  , tokenSecret: Nothing
  , sharingInput
  }

data Query a
  = Init a
  | Share a
  | ChangeGroup String a
  | ChangeEmail String a
  | ChangeShareResume ShareResume a
  | ChangeSubjectType SubjectType a
  | ChangeTokenName String a
  | DismissError a
  | SelectElement DOM.Event a
  | PreventDefault DOM.Event a
  | Cancel a

data Message = Dismiss

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

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

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    ( renderTitle
    ⊕ renderBody
    ⊕ renderFooter
    )

  where
  renderTitle ∷ Array HTML
  renderTitle = case state.tokenSecret of
    Nothing → [ HH.h4_ [ HH.text "Share deck" ] ]
    Just _ →
      [ HH.h4_
          [ HH.text
              if state.tokenName ≡ ""
                then "Untitled token"
                else state.tokenName ⊕ " token"
          ]
      , HH.h5_
          [ HH.text $ printShareResume state.shareResume ]
      ]

  renderBody ∷ Array HTML
  renderBody =
    [ HH.div
       [ HP.classes [ HH.ClassName "deck-dialog-body" ] ]
       ( renderLoading
       ⊕ foldMap renderTokenSecret state.tokenSecret
       ⊕ renderFieldsetWrapper renderSubjectForm
       )
    ]

  renderLoading ∷ Array HTML
  renderLoading =
    [ HH.div
        [ HP.classes $
            [ B.alert
            , B.alertInfo
            , HH.ClassName "share-loading"
            ]
            ⊕ (guard (not state.loading) $> B.hidden)
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    ]

  renderTokenSecret ∷ String → Array HTML
  renderTokenSecret token =
    [ HH.form
        [ HE.onSubmit (HE.input PreventDefault)
        , HP.classes $ guard state.loading $> B.hidden
        ]
        [ HH.div
            [ HP.classes [ B.inputGroup ]
            , HE.onClick (HE.input SelectElement ∘ DOM.toEvent)
            ]
            [ HH.input
                [ HP.classes [ B.formControl ]
                , HP.value token
                , HP.readOnly true
                , HP.title "Token secret"
                ]
            , HH.span
                [ HP.classes [ B.inputGroupBtn ] ]
                [ HH.button
                    [ HP.classes [ B.btn, B.btnDefault ]
                    , HP.ref copyButtonRef
                    ]
                    [ glyph B.glyphiconCopy ]
                ]
            ]
        ]
    ]

  renderFieldsetWrapper :: Array HTML -> Array HTML
  renderFieldsetWrapper c =
    let
      isFatalError = case _ of
        Just Connection -> true
        Just GroupList -> true
        _ -> false
    in
      [ HH.fieldset [ HP.disabled (isFatalError state.error) ] c ]

  renderSubjectForm ∷ Array HTML
  renderSubjectForm =
    [ HH.form
        [ HE.onSubmit (HE.input PreventDefault)
        , HP.classes $ guard (isJust state.tokenSecret ∨ state.loading) $> B.hidden
        ]
        [ HH.label_
            [ HH.text "Subject type"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange (HE.input (ChangeSubjectType ∘ readSubjectType))
                , HP.disabled state.submitting
                ]
                $ [ HH.option
                      [ HP.value "user" ]
                      [ HH.text "User" ]
                  ]
                ⊕ (guard (not $ Arr.null state.groups) $>
                    HH.option
                      [ HP.value "group" ]
                      [ HH.text "Group" ]
                  )
                ⊕ [ HH.option
                      [ HP.value "token" ]
                      [ HH.text "Token" ]
                  ]
            ]
        , HH.label
            [ HP.classes
                $ (guard (state.subjectType ≠ User) $> B.hidden)
                ⊕ (guard (state.error ≡ Just Validation) $> B.hasError)
            ]
            [ HH.text "User email"
            , HH.input
                [ HP.classes [ B.formControl ]
                , HP.value state.email
                , HE.onValueInput $ HE.input ChangeEmail
                , HP.placeholder "User email"
                , HP.type_ HP.InputText
                , HP.disabled state.submitting
                ]
            ]
        , HH.label
            [ HP.classes $ guard (state.subjectType ≠ Group) $> B.hidden ]
            [ HH.text "Group path"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange $ HE.input ChangeGroup
                , HP.disabled $ Arr.null state.groups ∨ state.submitting
                ]
                -- I find using such things in where a bit complicated
                -- because it's break context. OTOH, lambdas are not
                -- so fancy as named func. cryogenian.
                let
                  renderOption ∷ FilePath → HTML
                  renderOption group =
                    HH.option
                      [ HP.value $ Pt.printPath  group ]
                      [ HH.text $ Pt.printPath  group ]
                in
                  map renderOption state.groups
            ]
        , HH.label
            [ HP.classes $ guard (state.subjectType ≠ Token) $> B.hidden
            ]
            [ HH.text "Token name"
            , HH.input
                [ HP.classes [ B.formControl ]
                , HP.type_ HP.InputText
                , HP.placeholder "Token name"
                , HP.value state.tokenName
                , HE.onValueInput (HE.input ChangeTokenName)
                , HP.disabled state.submitting
                ]
            ]
        , HH.label_
            [ HH.text "Permission"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange (HE.input (ChangeShareResume ∘ readShareResume))
                , HP.disabled state.submitting
                ]
                [ HH.option
                    [ HP.value "view" ]
                    [ HH.text "View" ]
                , HH.option
                    [ HP.value "edit" ]
                    [ HH.text "Edit" ]
                ]
            ]
        , HH.div
            [ HP.classes
                $ [ B.alert, B.alertDanger ]
                ⊕ (if state.showError
                      ∧ (state.error ≡ Just Connection ∨ state.error ≡ Just GroupList)
                      then [ ]
                      else [ B.hidden ])
            ]
            [ HH.text
                if state.error ≡ Just Connection
                then
                  "This action couldn't be performed. "
                  ⊕ "Please check your network connection and try again"
                else
                  "Groups are unavailable. To share this deck with a group "
                  ⊕ "please check your network connection and try again."
            ]
        , HH.div
            [ HP.classes
                $ [ B.alert, B.alertInfo ]
                ⊕ (if state.showError ∧ state.error ≡ Just Validation then [ ] else [ B.hidden ])
            ]
            [ HH.text "Please check if user email is correct" ]
        ]
    ]

  renderFooter ∷ Array HTML
  renderFooter =
    [ HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        $ [ HH.button
              [ HP.classes
                  $ [ B.btn, B.btnDefault ]
                  ⊕ (guard state.loading $> B.hidden)
              , HP.type_ HP.ButtonButton
              , HE.onClick $ HE.input_ Cancel
              , HP.disabled state.submitting
              ]
              [ HH.text "Dismiss" ]
          ]
        ⊕ (guard (isNothing state.tokenSecret) *> renderShare)
    ]

  renderShare ∷ Array HTML
  renderShare =
    [ HH.button
        [ HP.classes
            $ [ B.btn, B.btnPrimary ]
            ⊕ (guard state.loading $> B.hidden)
            ⊕ (guard (isJust state.error && state.showError) $> B.hasError)
        , HP.type_ HP.ButtonButton
        , HE.onClick (HE.input_ Share)
        , HP.disabled $
            state.submitting
            ∨ ((state.email ≡ "" ∨ state.error ≡ Just Validation)
               ∧ state.subjectType ≡ User)
        ]
        [ HH.text
            if state.submitting
              then "Sharing..."
              else "Share"
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    Q.groupInfo (rootDir </> file "") >>= case _ of
      Left _ →
        H.modify _
          { error = Just GroupList
          , showError = true
          , loading = false
          }
      Right grInfo → do
        let groups = [ rootFile ] ⊕ grInfo.subGroups
        H.modify _
          { groups = groups
          , loading = false
          }
    pure next
  Share next → do
    H.modify _
      { error = Nothing
      , showError = false
      , submitting = true
      }
    state ← H.get
    if state.subjectType ≡ Token
      then shareToken state
      else sharePermission state
    pure next
  DismissError next →
    H.modify _ { showError = false } $> next
  ChangeSubjectType st next → do
    if st ≡ User
      then H.modify _
        { subjectType = st
        , error = Nothing
        , showError = false
        }
      else H.modify _ { subjectType = st }
    pure next
  ChangeEmail str next → do
    mbError ← H.gets _.error
    unless (mbError ≡ Just Connection) $
      if emailIsIncorrect str
        then H.modify _
          { error = Just Validation
          , showError = true
          , email = str
          }
        else H.modify _
          { error = Nothing
          , showError = false
          , email = str
          }
    pure next
  ChangeGroup grpString next → do
    groups ← H.gets _.groups
    let group = Arr.find (eq grpString ∘ Pt.printPath) groups
    H.modify _ { groupSelected = group }
    pure next
  ChangeTokenName str next →
    H.modify _ { tokenName = str } $> next
  ChangeShareResume sr next →
    H.modify _ { shareResume = sr } $> next
  SelectElement ev next → do
    H.liftEff $ DOM.currentTarget ev
      # readHTMLElement ∘ toForeign
      # runExcept
      # traverse_ select
    pure next
  PreventDefault ev next →
    H.liftEff (DOM.preventDefault ev) $> next
  Cancel next →
    H.raise Dismiss $> next

emailIsIncorrect ∷ String → Boolean
emailIsIncorrect = not ∘ Str.contains (Str.Pattern "@")

initClipboard ∷ String → DSL Unit
initClipboard token =
  H.getHTMLElementRef copyButtonRef >>= traverse_ \htmlEl →
    H.liftEff $ C.fromElement (toElement htmlEl) (pure token)

shareToken ∷ State → DSL Unit
shareToken state = do
  res ←
    Q.createToken
      (if state.tokenName ≡ "" then Nothing else Just $ QT.TokenName state.tokenName)
      (sharingActions state.sharingInput state.shareResume)
  case res of
    Left _ → showConnectionError
    Right token → do
      let tokenSecret = QT.runTokenHash token.secret
      H.modify _
        { tokenSecret = Just tokenSecret
        , submitting = false
        }
      initClipboard tokenSecret

sharePermission ∷ State → DSL Unit
sharePermission state = do
  let
    users = if state.subjectType ≡ User then [ QT.UserId state.email ] else [ ]
    groups = if state.subjectType ≡ Group then foldMap (pure ∘ Right) state.groupSelected else [ ]
    actions = sharingActions state.sharingInput state.shareResume
  Q.sharePermission { users, groups, actions } >>= case _ of
    Left _   → showConnectionError
    Right [] → showConnectionError
    Right _  → H.raise Dismiss

showConnectionError ∷ DSL Unit
showConnectionError =
  H.modify _
    { error = Just Connection
    , showError = true
    , submitting = false
    }

{-
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.Share.Component where

import SlamData.Prelude

import Control.UI.Browser (select)

import Data.Array as Arr
import Data.Foreign (toForeign)
import Data.String as Str
import Data.Path.Pathy (rootDir, (</>), file)
import Data.Path.Pathy as Pt

import DOM.HTML.Types (readHTMLElement)
import DOM.Classy.Element (toElement)

import Halogen as H
import Halogen.HTML.Events as HE
import Halogen.HTML as HH
import Halogen.HTML.Properties as HP
import Halogen.Themes.Bootstrap3 as B

import Quasar.Advanced.Types as QT

import SlamData.Quasar.Security as Q
import SlamData.Monad (Slam)
import SlamData.Render.Common (glyph)
import SlamData.Workspace.Deck.Dialog.Share.Model (ShareResume(..), sharingActions, SharingInput)

import Utils.DOM as DOM
import Utils.Path (rootFile, FilePath)

import Clipboard as C

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

data SubjectType
  = User
  | Group
  | Token

derive instance subjectTypeEq ∷ Eq SubjectType

data ErrorType
  = Connection
  | Validation
  | GroupList

derive instance errorTypeEq ∷ Eq ErrorType

-- This is utility function that should be used only in
-- select/option stuff
readSubjectType ∷ String → SubjectType
readSubjectType = case _ of
  "user" → User
  "group" → Group
  "token" → Token
  _ → User

-- Same with `readSubjectType`
readShareResume ∷ String → ShareResume
readShareResume = case _ of
  "edit" → Edit
  _ → View

printShareResume ∷ ShareResume → String
printShareResume = case _ of
  Edit → "Edit"
  View → "View"

-- It would be better if all this Boolean stuff was replaced with
-- some kind of ADT abstracting automata.
type State =
  { subjectType ∷ SubjectType
  , error ∷ Maybe ErrorType
  , email ∷ String
    -- Actually should be Group from purescript-quasar
  , groups ∷ Array FilePath
  , groupSelected ∷ Maybe FilePath
  , tokenName ∷ String
  , loading ∷ Boolean
  , showError ∷ Boolean
  , submitting ∷ Boolean
  , shareResume ∷ ShareResume
  , tokenSecret ∷ Maybe String
  , sharingInput ∷ SharingInput
  }

initialState ∷ SharingInput → State
initialState sharingInput =
  { subjectType: User
  , error: Nothing
  , email: ""
  , groups: [ ]
  , groupSelected: Nothing
  , tokenName: ""
  , loading: true
  , showError: false
  , submitting: false
  , shareResume: View
  , tokenSecret: Nothing
  , sharingInput
  }

data Query a
  = Init a
  | Share a
  | ChangeGroup String a
  | ChangeEmail String a
  | ChangeShareResume ShareResume a
  | ChangeSubjectType SubjectType a
  | ChangeTokenName String a
  | DismissError a
  | SelectElement DOM.Event a
  | PreventDefault DOM.Event a
  | Cancel a

data Message = Dismiss

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

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

render ∷ State → HTML
render state =
  HH.div
    [ HP.classes [ HH.ClassName "deck-dialog-share" ] ]
    ( renderTitle
    ⊕ renderBody
    ⊕ renderFooter
    )

  where
  renderTitle ∷ Array HTML
  renderTitle = case state.tokenSecret of
    Nothing → [ HH.h4_ [ HH.text "Share deck" ] ]
    Just _ →
      [ HH.h4_
          [ HH.text
              if state.tokenName ≡ ""
                then "Untitled token"
                else state.tokenName ⊕ " token"
          ]
      , HH.h5_
          [ HH.text $ printShareResume state.shareResume ]
      ]

  renderBody ∷ Array HTML
  renderBody =
    [ HH.div
       [ HP.classes [ HH.ClassName "deck-dialog-body" ]
       , HE.onClick ( HE.input_ DismissError )
       ]
       ( renderLoading
       ⊕ foldMap renderTokenSecret state.tokenSecret
       ⊕ renderSubjectForm
       )
    ]

  renderLoading ∷ Array HTML
  renderLoading =
    [ HH.div
        [ HP.classes $
            [ B.alert
            , B.alertInfo
            , HH.ClassName "share-loading"
            ]
            ⊕ (guard (not state.loading) $> B.hidden)
        ]
        [ HH.img [ HP.src "img/blue-spin.svg" ]
        , HH.text "Loading"
        ]
    ]

  renderTokenSecret ∷ String → Array HTML
  renderTokenSecret token =
    [ HH.form
        [ HE.onSubmit (HE.input PreventDefault)
        , HP.classes $ guard state.loading $> B.hidden
        ]
        [ HH.div
            [ HP.classes [ B.inputGroup ]
            , HE.onClick (HE.input SelectElement ∘ DOM.toEvent)
            ]
            [ HH.input
                [ HP.classes [ B.formControl ]
                , HP.value token
                , HP.readOnly true
                , HP.title "Token secret"
                ]
            , HH.span
                [ HP.classes [ B.inputGroupBtn ] ]
                [ HH.button
                    [ HP.classes [ B.btn, B.btnDefault ]
                    , HP.ref copyButtonRef
                    ]
                    [ glyph B.glyphiconCopy ]
                ]
            ]
        ]
    ]

  renderSubjectForm ∷ Array HTML
  renderSubjectForm =
    [ HH.form
        [ HE.onSubmit (HE.input PreventDefault)
        , HP.classes $ guard (isJust state.tokenSecret ∨ state.loading) $> B.hidden
        ]
        [ HH.label_
            [ HH.text "Subject type"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange (HE.input (ChangeSubjectType ∘ readSubjectType))
                , HP.disabled state.submitting
                ]
                $ [ HH.option
                      [ HP.value "user" ]
                      [ HH.text "User" ]
                  ]
                ⊕ (guard (not $ Arr.null state.groups) $>
                    HH.option
                      [ HP.value "group" ]
                      [ HH.text "Group" ]
                  )
                ⊕ [ HH.option
                      [ HP.value "token" ]
                      [ HH.text "Token" ]
                  ]
            ]
        , HH.label
            [ HP.classes
                $ (guard (state.subjectType ≠ User) $> B.hidden)
                ⊕ (guard (state.error ≡ Just Validation) $> B.hasError)
            ]
            [ HH.text "User email"
            , HH.input
                [ HP.classes [ B.formControl ]
                , HP.value state.email
                , HE.onValueInput $ HE.input ChangeEmail
                , HP.placeholder "User email"
                , HP.type_ HP.InputText
                , HP.disabled state.submitting
                ]
            ]
        , HH.label
            [ HP.classes $ guard (state.subjectType ≠ Group) $> B.hidden ]
            [ HH.text "Group path"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange $ HE.input ChangeGroup
                , HP.disabled $ Arr.null state.groups ∨ state.submitting
                ]
                -- I find using such things in where a bit complicated
                -- because it's break context. OTOH, lambdas are not
                -- so fancy as named func. cryogenian.
                let
                  renderOption ∷ FilePath → HTML
                  renderOption group =
                    HH.option
                      [ HP.value $ Pt.printPath  group ]
                      [ HH.text $ Pt.printPath  group ]
                in
                  map renderOption state.groups
            ]
        , HH.label
            [ HP.classes $ guard (state.subjectType ≠ Token) $> B.hidden
            ]
            [ HH.text "Token name"
            , HH.input
                [ HP.classes [ B.formControl ]
                , HP.type_ HP.InputText
                , HP.placeholder "Token name"
                , HP.value state.tokenName
                , HE.onValueInput (HE.input ChangeTokenName)
                , HP.disabled state.submitting
                ]
            ]
        , HH.label_
            [ HH.text "Permission"
            , HH.select
                [ HP.classes [ B.formControl ]
                , HE.onValueChange (HE.input (ChangeShareResume ∘ readShareResume))
                , HP.disabled state.submitting
                ]
                [ HH.option
                    [ HP.value "view" ]
                    [ HH.text "View" ]
                , HH.option
                    [ HP.value "edit" ]
                    [ HH.text "Edit" ]
                ]
            ]
        , HH.div
            [ HP.classes
                $ [ B.alert, B.alertDanger ]
                ⊕ (if state.showError
                      ∧ (state.error ≡ Just Connection ∨ state.error ≡ Just GroupList)
                      then [ ]
                      else [ B.hidden ])
            , HE.onClick (HE.input_ DismissError)
            ]
            [ HH.text
                if state.error ≡ Just Connection
                then
                  "This action couldn't be performed. "
                  ⊕ "Please check your network connection and try again"
                else
                  "Groups are unavailable. To share this deck with a group "
                  ⊕ "please check your network connection and try again."
            ]
        , HH.div
            [ HP.classes
                $ [ B.alert, B.alertInfo ]
                ⊕ (if state.showError ∧ state.error ≡ Just Validation then [ ] else [ B.hidden ])
            ]
            [ HH.text "Please check if user email is correct" ]
        ]
    ]

  renderFooter ∷ Array HTML
  renderFooter =
    [ HH.div
        [ HP.classes [ HH.ClassName "deck-dialog-footer" ] ]
        $ [ HH.button
              [ HP.classes
                  $ [ B.btn, B.btnDefault ]
                  ⊕ (guard state.loading $> B.hidden)
              , HP.type_ HP.ButtonButton
              , HE.onClick $ HE.input_ Cancel
              , HP.disabled state.submitting
              ]
              [ HH.text "Dismiss" ]
          ]
        ⊕ (guard (isNothing state.tokenSecret) *> renderShare)
    ]

  renderShare ∷ Array HTML
  renderShare =
    [ HH.button
        [ HP.classes
            $ [ B.btn, B.btnPrimary ]
            ⊕ (guard state.loading $> B.hidden)
            ⊕ (guard (isJust state.error && state.showError) $> B.hasError)
        , HP.type_ HP.ButtonButton
        , HE.onClick (HE.input_ Share)
        , HP.disabled $
            state.submitting
            ∨ ((state.email ≡ "" ∨ state.error ≡ Just Validation)
               ∧ state.subjectType ≡ User)
        ]
        [ HH.text
            if state.submitting
              then "Sharing..."
              else "Share"
        ]
    ]

eval ∷ Query ~> DSL
eval = case _ of
  Init next → do
    Q.groupInfo (rootDir </> file "") >>= case _ of
      Left _ →
        H.modify _
          { error = Just GroupList
          , showError = true
          , loading = false
          }
      Right grInfo → do
        let groups = [ rootFile ] ⊕ grInfo.subGroups
        H.modify _
          { groups = groups
          , loading = false
          }
    pure next
  Share next → do
    H.modify _
      { error = Nothing
      , showError = false
      , submitting = true
      }
    state ← H.get
    if state.subjectType ≡ Token
      then shareToken state
      else sharePermission state
    pure next
  DismissError next →
    H.modify _ { showError = false } $> next
  ChangeSubjectType st next → do
    if st ≡ User
      then H.modify _
        { subjectType = st
        , error = Nothing
        , showError = false
        }
      else H.modify _ { subjectType = st }
    pure next
  ChangeEmail str next → do
    mbError ← H.gets _.error
    unless (mbError ≡ Just Connection) $
      if emailIsIncorrect str
        then H.modify _
          { error = Just Validation
          , showError = true
          , email = str
          }
        else H.modify _
          { error = Nothing
          , showError = false
          , email = str
          }
    pure next
  ChangeGroup grpString next → do
    groups ← H.gets _.groups
    let group = Arr.find (eq grpString ∘ Pt.printPath) groups
    H.modify _ { groupSelected = group }
    pure next
  ChangeTokenName str next →
    H.modify _ { tokenName = str } $> next
  ChangeShareResume sr next →
    H.modify _ { shareResume = sr } $> next
  SelectElement ev next → do
    H.liftEff $ DOM.currentTarget ev
      # readHTMLElement ∘ toForeign
      # runExcept
      # traverse_ select
    pure next
  PreventDefault ev next →
    H.liftEff (DOM.preventDefault ev) $> next
  Cancel next →
    H.raise Dismiss $> next

emailIsIncorrect ∷ String → Boolean
emailIsIncorrect = not ∘ Str.contains (Str.Pattern "@")

initClipboard ∷ String → DSL Unit
initClipboard token =
  H.getHTMLElementRef copyButtonRef >>= traverse_ \htmlEl →
    H.liftEff $ C.fromElement (toElement htmlEl) (pure token)

shareToken ∷ State → DSL Unit
shareToken state = do
  res ←
    Q.createToken
      (if state.tokenName ≡ "" then Nothing else Just $ QT.TokenName state.tokenName)
      (sharingActions state.sharingInput state.shareResume)
  case res of
    Left _ → showConnectionError
    Right token → do
      let tokenSecret = QT.runTokenHash token.secret
      H.modify _
        { tokenSecret = Just tokenSecret
        , submitting = false
        }
      initClipboard tokenSecret

sharePermission ∷ State → DSL Unit
sharePermission state = do
  let
    users = if state.subjectType ≡ User then [ QT.UserId state.email ] else [ ]
    groups = if state.subjectType ≡ Group then foldMap (pure ∘ Right) state.groupSelected else [ ]
    actions = sharingActions state.sharingInput state.shareResume
  Q.sharePermission { users, groups, actions } >>= case _ of
    Left _   → showConnectionError
    Right [] → showConnectionError
    Right _  → H.raise Dismiss

showConnectionError ∷ DSL Unit
showConnectionError =
  H.modify _
    { error = Just Connection
    , showError = true
    , submitting = false
    }


Disable dragover when the files are dropped

module Halogen.FileDrop
  ( ui
  , initialState
  , defaultOptions
  , Query()
  , setDragOver
  , setFiles
  , openFilePicker
  , State()
  , Options()
  ) where

import Prelude

import Control.Apply
import Control.Monad.Aff (Aff(), runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Unsafe (logAny)
import Control.Monad.Eff.Exception (throwException, EXCEPTION)
import Data.Functor
import Data.Maybe
import Data.Foldable

import Halogen
import Halogen.Util (appendToBody, onLoad)
import Halogen.HTML.Core (prop, propName, attrName)
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed.Extra as E
import Halogen.HTML.Events.Handler (preventDefault, stopPropagation, EventHandler) as E
import Halogen.HTML.Properties.Indexed.Extra as P
import Halogen.HTML.CSS.Indexed (style) as P
import Halogen.HTML.Events.Forms.Extra (onFilesChange, onFilesDrop) as E

import DOM (DOM)
import DOM.HTML.Types (htmlElementToEventTarget)
import DOM.Event.EventTarget (dispatchEvent)
import DOM.Event.Types (EventType, MouseEvent, mouseEventToEvent)
import DOM.Event.EventTypes (click) as EventTypes
import DOM.HTML.Types (HTMLElement)
import DOM.File.Types (FileList())

import CSS as CSS

import Unsafe.Coerce (unsafeCoerce)

foreign import newMouseEvent :: EventType -> MouseEvent

data Query a
  = OpenFilePicker a
  | SetFiles FileList a
  | SetUploadElement HTMLElement a
  | SetDragOver Boolean a

setDragOver :: ∀ a. Boolean -> a -> Query a
setDragOver = SetDragOver

setFiles :: ∀ a. FileList -> a -> Query a
setFiles = SetFiles

openFilePicker :: ∀ a. a -> Query a
openFilePicker = OpenFilePicker

type State =
  { uploadElement :: Maybe HTMLElement
  , dragover :: Boolean
  , options :: Options
  }

initialState :: Options -> State
initialState options =
  { uploadElement: Nothing
  , dragover: false
  , options
  }

type Options
  = { view :: { dragover :: Boolean, multiple :: Boolean } -> ComponentHTML Query
    , multiple :: Boolean
    }

defaultOptions :: Options
defaultOptions
  = { view: defaultView
    , multiple: true
    }

defaultView
  :: { dragover :: Boolean, multiple :: Boolean }
  -> ComponentHTML Query
defaultView { multiple, dragover } =
  H.div_
    [ H.button
      [ E.onClick (E.input_ openFilePicker) ]
      [ H.text if multiple
               then "Select a file"
               else "Select some files"
      ]
    , H.div
        dropHandlers
        [ H.text if dragover
                 then "DROP IT!"
                 else "Or just drop it here"
        ]
    ]

dropHandlers :: ∀ r. Array (P.IProp r (Query Unit))
dropHandlers =
  [ E.onDragEnter
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragOver
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragExit
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver false)
  , E.onFilesDrop
      \files -> E.preventDefault
             *> E.stopPropagation
             $> action (setFiles files)
  ]

ui :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
   => Component State Query m
ui = component render eval

render :: ∀ m. State -> ComponentHTML Query
render state =
  H.div_
    [ H.input
      [ P.inputType P.InputFile
      , P.multiple state.options.multiple
      , E.onFilesChange (E.input setFiles)
      , P.initializer (action <<< SetUploadElement)
      , P.style do
          CSS.display CSS.displayNone
      ]
    , state.options.view
        { dragover: state.dragover
        , multiple: state.options.multiple
        }
    ]

eval :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
     => Natural Query (ComponentDSL State Query m)
eval (OpenFilePicker next) = next <$ do
  gets _.uploadElement
    >>= traverse_
          (htmlElementToEventTarget
             >>> dispatchEvent
                  (mouseEventToEvent (newMouseEvent EventTypes.click))
             >>> liftEff')

eval (SetUploadElement element next) = next <$ do
  modify (_ { uploadElement = Just element })

eval (SetFiles files next) = next <$ do
  modify (_ { dragover = false })
  liftEff' $ logAny files

eval (SetDragOver dragover next) = next <$ do
  modify (_ { dragover = dragover })

module Halogen.FileDrop
  ( ui
  , initialState
  , defaultOptions
  , Query()
  , setDragOver
  , setFiles
  , openFilePicker
  , State()
  , Options()
  ) where

import Prelude

import Control.Apply
import Control.Monad.Aff (Aff(), runAff)
import Control.Monad.Eff (Eff())
import Control.Monad.Eff.Class (class MonadEff)
import Control.Monad.Eff.Console (CONSOLE)
import Control.Monad.Eff.Console.Unsafe (logAny)
import Control.Monad.Eff.Exception (throwException, EXCEPTION)
import Data.Functor
import Data.Maybe
import Data.Foldable

import Halogen
import Halogen.Util (appendToBody, onLoad)
import Halogen.HTML.Core (prop, propName, attrName)
import Halogen.HTML.Indexed as H
import Halogen.HTML.Events.Indexed.Extra as E
import Halogen.HTML.Events.Handler (preventDefault, stopPropagation, EventHandler) as E
import Halogen.HTML.Properties.Indexed.Extra as P
import Halogen.HTML.CSS.Indexed (style) as P
import Halogen.HTML.Events.Forms.Extra (onFilesChange, onFilesDrop) as E

import DOM (DOM)
import DOM.HTML.Types (htmlElementToEventTarget)
import DOM.Event.EventTarget (dispatchEvent)
import DOM.Event.Types (EventType, MouseEvent, mouseEventToEvent)
import DOM.Event.EventTypes (click) as EventTypes
import DOM.HTML.Types (HTMLElement)
import DOM.File.Types (FileList())

import CSS as CSS

import Unsafe.Coerce (unsafeCoerce)

foreign import newMouseEvent :: EventType -> MouseEvent

data Query a
  = OpenFilePicker a
  | SetFiles FileList a
  | SetUploadElement HTMLElement a
  | SetDragOver Boolean a

setDragOver :: ∀ a. Boolean -> a -> Query a
setDragOver = SetDragOver

setFiles :: ∀ a. FileList -> a -> Query a
setFiles = SetFiles

openFilePicker :: ∀ a. a -> Query a
openFilePicker = OpenFilePicker

type State =
  { uploadElement :: Maybe HTMLElement
  , dragover :: Boolean
  , options :: Options
  }

initialState :: Options -> State
initialState options =
  { uploadElement: Nothing
  , dragover: false
  , options
  }

type Options
  = { view :: { dragover :: Boolean, multiple :: Boolean } -> ComponentHTML Query
    , multiple :: Boolean
    }

defaultOptions :: Options
defaultOptions
  = { view: defaultView
    , multiple: true
    }

defaultView
  :: { dragover :: Boolean, multiple :: Boolean }
  -> ComponentHTML Query
defaultView { multiple, dragover } =
  H.div_
    [ H.button
      [ E.onClick (E.input_ openFilePicker) ]
      [ H.text if multiple
               then "Select a file"
               else "Select some files"
      ]
    , H.div
        dropHandlers
        [ H.text if dragover
                 then "DROP IT!"
                 else "Or just drop it here"
        ]
    ]

dropHandlers :: ∀ r. Array (P.IProp r (Query Unit))
dropHandlers =
  [ E.onDragEnter
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragOver
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver true)
  , E.onDragExit
      \_ -> E.preventDefault
         *> E.stopPropagation
         $> action (setDragOver false)
  , E.onFilesDrop
      \files -> E.preventDefault
             *> E.stopPropagation
             $> action (setFiles files)
  ]

ui :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
   => Component State Query m
ui = component render eval

render :: ∀ m. State -> ComponentHTML Query
render state =
  H.div_
    [ H.input
      [ P.inputType P.InputFile
      , P.multiple state.options.multiple
      , E.onFilesChange (E.input setFiles)
      , P.initializer (action <<< SetUploadElement)
      , P.style do
          CSS.display CSS.displayNone
      ]
    , state.options.view
        { dragover: state.dragover
        , multiple: state.options.multiple
        }
    ]

eval :: ∀ m eff. (MonadEff (dom :: DOM, err :: EXCEPTION, console :: CONSOLE | eff) m)
     => Natural Query (ComponentDSL State Query m)
eval (OpenFilePicker next) = next <$ do
  gets _.uploadElement
    >>= traverse_
          (htmlElementToEventTarget
             >>> dispatchEvent
                  (mouseEventToEvent (newMouseEvent EventTypes.click))
             >>> liftEff')

eval (SetUploadElement element next) = next <$ do
  modify (_ { uploadElement = Just element })

eval (SetFiles files next) = next <$ do
  liftEff' $ logAny files

eval (SetDragOver dragover next) = next <$ do
  modify (_ { dragover = dragover })