Use completion code from atom plugin

Use completion code from atom plugin

module IdePurescript.Completion where

import Prelude
import Control.Monad.Aff (Aff)
import Data.Array (filter)
import Data.Either (Either)
import Data.Maybe (Maybe(..), fromMaybe)
import Data.String (Pattern(..), contains, indexOf)
import Data.String.Regex (Regex, regex)
import Data.String.Regex.Flags (noFlags)
import IdePurescript.PscIde (eitherToErr, getCompletion)
import IdePurescript.Regex (match', test')
import PscIde (NET, listAvailableModules)
import PscIde.Command (ModuleList(..), TypeInfo(..))

type ModuleInfo =
  { modules :: Array String
  , getQualifiedModule :: String -> Array String
  , mainModule :: Maybe String
  }

data SuggestionType = Module | Type | Function | Value

modulePart :: String
modulePart = """((?:[A-Z][A-Za-z0-9]*\.)*(?:[A-Z][A-Za-z0-9]*))"""

identPart :: String
identPart = "([a-zA-Z_][a-zA-Z0-9_']*)"

moduleRegex :: Either String Regex
moduleRegex = regex ("(?:^|[^A-Za-z_.])(?:" <> modulePart <> """\.)?""" <> identPart <> "?$") noFlags

explicitImportRegex :: Either String Regex
explicitImportRegex = regex ("""^import\s+""" <> modulePart <> """\s+\([^)]*?""" <> identPart <> "$") noFlags

getModuleSuggestions :: forall eff. Int -> String -> Aff (net :: NET | eff) (Array String)
getModuleSuggestions port prefix = do
  list <- eitherToErr $ listAvailableModules port
  pure $ case list of
    (ModuleList lst) -> filter (\m -> indexOf (Pattern prefix) m == Just 0) lst

data SuggestionResult =
  ModuleSuggestion { text :: String, suggestType :: SuggestionType, prefix :: String }
  | IdentSuggestion { mod :: String, identifier :: String, qualifier :: Maybe String, valueType :: String, suggestType :: SuggestionType, prefix :: String }

getSuggestions :: forall eff. Int -> {
    line :: String,
    moduleInfo :: ModuleInfo
  } -> Aff (net :: NET | eff) (Array SuggestionResult)
getSuggestions port { line, moduleInfo: { modules, getQualifiedModule, mainModule } } =
  if moduleExplicit then
    case match' explicitImportRegex line of
      Just [ Just _, Just mod, Just token ] -> do
        completions <- getCompletion port token mainModule Nothing [ mod ] getQualifiedModule
        pure $ map (result (Just mod) token) completions
      _ -> pure []
  else
    case parsed of
      Just { mod, token } ->
        if moduleCompletion then do
          let prefix = getModuleName (fromMaybe "" mod) token
          completions <- getModuleSuggestions port prefix
          pure $ map (modResult prefix) completions
        else do
          completions <- getCompletion port token mainModule mod modules getQualifiedModule
          pure $ map (result mod token) completions
      Nothing -> pure []
    where
    getModuleName "" token  = token
    getModuleName mod token = mod <> "." <> token

    isImport = indexOf (Pattern "import") line == Just 0
    hasBracket = indexOf (Pattern "(") line /= Nothing
    moduleCompletion = isImport && not hasBracket
    moduleExplicit = isImport && hasBracket

    parsed = case match' moduleRegex line of
        Just [ Just _, mod, tok ] | mod /= Nothing || tok /= Nothing ->
          Just { mod, token: fromMaybe "" tok}
        _ -> Nothing

    modResult prefix moduleName = ModuleSuggestion { text: moduleName, suggestType: Module, prefix }
    result qualifier prefix (TypeInfo {type', identifier, module': mod}) =
      IdentSuggestion { mod, identifier, qualifier, suggestType, prefix, valueType: type' }
      where
        suggestType =
          if contains (Pattern "->") type' then Function
          else if test' (regex "^[A-Z]" noFlags) identifier then Type
          else Value

error: pathspec 'src/IdePurescript/Completion.purs' did not match any file(s) known to git


Enable preview by default - it keeps the screen/camera alive.

Better for the demo!

module Gonimo.UI.Socket.Internal where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError, catchError)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isNothing, isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (GonimoError(RegisterSessionFailed, AjaxError), toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.State.Types (SessionId(SessionId))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (sessionId, streamURL, isAvailable, mediaStream, babyName, currentFamily, localStream, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (toDeviceType, makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI (postSocketByFamilyIdByToDevice, deleteSessionByFamilyIdByDeviceIdBySessionId)
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Subscriber (postSessionByFamilyIdByDeviceId, receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.PureScript.Affjax (ErrorDescription(ConnectionError))
import Servant.Subscriber (Subscriptions)
import Servant.Subscriber.Connection (Notification(WebSocketClosed))
import WebRTC.MediaStream (mediaStreamToBlob, createObjectURL, stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

init :: AuthData-> State
init authData' = { authData : authData' -- FIXME: Does this really have to be here? And if so shouldn't we move other stuff from loaded here too? Like subscriptions? Family member list?
                 , sessionId : Nothing
                 , currentFamily : Nothing
                 , channels : Map.empty
                 , isAvailable : false
                 , localStream : Nothing
                 , streamURL : Nothing
                 , babyName : "baby"
                 , newBabyName : "baby"
                 , constraints : MediaStreamConstraints { audio : true, video : true }
                 , previewEnabled : true
                 }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  AcceptConnection channelId'                    -> handleAcceptConnection channelId'
  GetUserMedia                                   -> handleGetUserMedia
  StopUserMedia                                  -> handleStopUserMedia
  EnablePreview onoff                            -> onlyModify $ _ { previewEnabled = onoff }
  AddChannel channelId' cState                   -> do channel channelId' .= Just cState
                                                       updateChannel channelId' ChannelC.InitConnection
  ChannelA channelId' (ChannelC.ReportError err) -> pure [pure $ ReportError err]
  ChannelA channelId' action'                    -> updateChannel channelId' action'
  CloseChannel channelId'                        -> pure [ pure $ ChannelA channelId' ChannelC.CloseConnection
                                                         , pure $ RemoveChannel channelId'
                                                         ]
  CloseBabyChannel channelId'                    -> do
    isBabyStation' <- gets (_^?channel channelId' <<< _Just <<< to _.isBabyStation)
    case isBabyStation' of
         Just true                               -> pure $ wrapAction (CloseChannel channelId')
         _                                       -> pure []
  RemoveChannel channelId'                       -> channel channelId' .= Nothing
                                                    *> pure []
  SwitchFamily familyId'                       -> handleFamilySwitch familyId'
  ServerFamilyGoOffline familyId sessionId     -> handleServerFamilyGoOffline familyId sessionId
  SetAuthData auth                             -> handleSetAuthData auth
  SetSessionId sessionId'                      -> sessionId .= sessionId' *> pure []
  StartBabyStation                             -> handleStartBabyStation
  InitBabyStation stream                       -> handleInitBabyStation stream
  SetStreamURL url                             -> streamURL .= url -- TODO: On Nothing we should free the url.
                                                  *> pure []

  HandleSubscriber msg                         -> pure []
  SetBabyName name                             -> babyName .= name *> pure []
  SetNewBabyName name                          -> do
    newBabyName .= name
    babyName .= name
    pure []
  ConnectToBaby babyId                         -> handleConnectToBaby babyId
  StopBabyStation                              -> handleStopBabyStation
  ReportError err                              -> noEffects
  Nop                                          -> noEffects

toChannel :: forall ps. ChannelId -> ToChild (Props ps) State (ChannelC.Props {}) ChannelC.State
toChannel channelId' = do
  state <- get
  pProps <- ask
  let
    props :: ChannelC.Props {}
    props = mkChannelProps pProps state channelId'
  pure $ makeChildData (channel channelId' <<< _Just) props

handleGetUserMedia :: forall ps. ComponentType (Props ps) State Action
handleGetUserMedia = do
  state <- get :: Component (Props ps) State State
  case state.localStream of
    Nothing -> runGonimo $
        InitBabyStation <$> liftAff (getUserMedia state.constraints)
    Just _ -> pure []

handleStopUserMedia :: forall ps. ComponentType (Props ps) State Action
handleStopUserMedia = do
  state <- get :: Component (Props ps) State State
  let mStream = if state.isAvailable
                then Nothing
                else state.localStream
  case mStream of
    Nothing -> pure []
    Just stream -> do
      localStream .= Nothing :: (Maybe MediaStream)
      pure [ do
                liftEff $ stopStream stream
                pure Nop
           ]

handleStartBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStartBabyStation = do
  state <- get :: Component (Props ps) State State
  if isJust state.localStream
    then isAvailable .= true
    else isAvailable .= false
  noEffects

handleInitBabyStation :: forall ps.
                          MediaStream
                       -> ComponentType (Props ps) State Action
handleInitBabyStation stream = do
  localStream .= Just stream
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ stream
            pure $ SetStreamURL (Just url)
       ]

handleAcceptConnection :: forall ps. ChannelId -> ComponentType (Props ps) State  Action
handleAcceptConnection channelId' = do
  state <- get
  if state.isAvailable
    then pure [ AddChannel channelId' <$> ChannelC.init state.localStream ]
    else pure []

handleFamilySwitch :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleFamilySwitch familyId' = do
    state <- get :: Component (Props ps) State State
    let oldFamily = state.currentFamily
    modify $ _ { currentFamily = Just familyId' }
    let action = fromFoldable
                 $ ServerFamilyGoOffline
                 <$> oldFamily <*> state.sessionId
    pure $ doCleanup state CloseChannel (pure <$> action)

handleSetAuthData :: forall ps. AuthData -> ComponentType (Props ps) State Action
handleSetAuthData auth = do
  state <- get
  authData .= auth
  pure $ doCleanup state CloseChannel []

handleStopBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStopBabyStation = do
  state <- get :: Component (Props ps) State State
  props <- ask :: Component (Props ps) State (Props ps)
  isAvailable .= false
  pure $ doCleanup state CloseBabyChannel []

handleServerFamilyGoOffline :: forall ps. Key Family -> SessionId -> ComponentType (Props ps) State Action
handleServerFamilyGoOffline familyId sessionId = do
    state <- get :: Component (Props ps) State State
    let deviceId = (runAuthData state.authData).deviceId
    runGonimo $ do
      deleteSessionByFamilyIdByDeviceIdBySessionId familyId deviceId sessionId
      pure Nop

handleConnectToBaby :: forall ps. Key Device -> ComponentType (Props ps) State Action
handleConnectToBaby babyId = do
  state <- get
  props <- ask
  let ourId = state ^. authData <<< to runAuthData <<< deviceId
  let actions = fromMaybe [] $ do
        familyId <- state.currentFamily
        pure [ toIO props.settings $ do
                  secret <- postSocketByFamilyIdByToDevice ourId familyId babyId
                  let channelId' = makeChannelId babyId secret
                  AddChannel channelId' <$> liftIO (ChannelC.init Nothing)
             ]
  pure actions

updateChannel :: forall ps. ChannelId -> ChannelC.Action -> ComponentType (Props ps) State Action
updateChannel channelId' = toParent [] (ChannelA channelId')
                           <<< liftChild (toChannel channelId')
                           <<< ChannelC.update

doCleanup :: State -> (ChannelId -> Action) -> Array (IO Action) -> Array (IO Action)
doCleanup state cleanup action =
    if Map.isEmpty state.channels
    then action
    else Arr.fromFoldable (pure <<< cleanup <$> Map.keys state.channels)
         <> action

getParentChannels :: State -> Array (Tuple ChannelId ChannelC.State)
getParentChannels =  Arr.filter (not _.isBabyStation <<< snd ) <<< Arr.fromFoldable
                     <<< Map.toList <<< _.channels

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ) <<< join)
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> ( if state.isAvailable
                     then fromFoldable $ do
                               familyId'' <- familyId'
                               pure $ receiveAChannel authData'.deviceId familyId''
                     else []
                   )
                <> (fromFoldable
                    $ postSessionByFamilyIdByDeviceId (maybe Nop (SetSessionId <<< Just))
                    <$> pure (toDeviceType state) <*> familyId' <*> pure authData'.deviceId
                   )
  in
      foldl append mempty subArray

mkChannelProps :: forall ps. Props ps -> State -> ChannelId -> ChannelC.Props {}
mkChannelProps props state channelId = { ourId : state ^. authData <<< to runAuthData <<< deviceId
                                       , theirId : toTheirId channelId
                                       , cSecret : toCSecret channelId
                                       , familyId : ChannelC.unsafeMakeFamilyId state.currentFamily
                                       , settings : props.settings
                                       , sendAction : lmap (ChannelA channelId) props.sendActionSocket
                                       , onlineDevices : props.onlineDevices
                                       }

module Gonimo.UI.Socket.Internal where

import Prelude
import Data.Array as Arr
import Data.Map as Map
import Gonimo.Client.Effects as Console
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Channel.Types as ChannelC
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import WebRTC.MediaStream.Track as Track
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError, catchError)
import Control.Monad.IO (IO)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Reader (ask, runReader)
import Control.Monad.Reader.Class (class MonadReader, ask)
import Control.Monad.State.Class (gets, modify, put, get, class MonadState)
import Data.Array (concat, fromFoldable)
import Data.Foldable (foldl)
import Data.Lens (use, to, (^?), (^.), _Just, (.=))
import Data.Map (Map)
import Data.Maybe (isNothing, isJust, maybe, fromMaybe, Maybe(Nothing, Just))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Traversable (traverse, traverse_)
import Data.Tuple (uncurry, snd, Tuple(Tuple))
import Gonimo.Client.Types (GonimoError(RegisterSessionFailed, AjaxError), toIO, Settings)
import Gonimo.Pux (wrapAction, noEffects, runGonimo, Component, liftChild, toParent, ComponentType, makeChildData, ToChild, onlyModify, Update, class MonadComponent)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.State.Types (SessionId(SessionId))
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Lenses (sessionId, streamURL, isAvailable, mediaStream, babyName, currentFamily, localStream, authData, newBabyName)
import Gonimo.UI.Socket.Message (decodeFromString)
import Gonimo.UI.Socket.Types (toDeviceType, makeChannelId, toCSecret, toTheirId, ChannelId(ChannelId), channel, Props, State, Action(..))
import Gonimo.WebAPI (postSocketByFamilyIdByToDevice, deleteSessionByFamilyIdByDeviceIdBySessionId)
import Gonimo.WebAPI.Lenses (deviceId, _AuthData)
import Gonimo.WebAPI.Subscriber (postSessionByFamilyIdByDeviceId, receiveSocketByFamilyIdByToDevice, receiveSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Pux.Html (Html)
import Servant.PureScript.Affjax (ErrorDescription(ConnectionError))
import Servant.Subscriber (Subscriptions)
import Servant.Subscriber.Connection (Notification(WebSocketClosed))
import WebRTC.MediaStream (mediaStreamToBlob, createObjectURL, stopStream, MediaStreamConstraints(MediaStreamConstraints), getUserMedia, MediaStream, getTracks)
import WebRTC.RTC (RTCPeerConnection)

init :: AuthData-> State
init authData' = { authData : authData' -- FIXME: Does this really have to be here? And if so shouldn't we move other stuff from loaded here too? Like subscriptions? Family member list?
                 , sessionId : Nothing
                 , currentFamily : Nothing
                 , channels : Map.empty
                 , isAvailable : false
                 , localStream : Nothing
                 , streamURL : Nothing
                 , babyName : "baby"
                 , newBabyName : "baby"
                 , constraints : MediaStreamConstraints { audio : true, video : true }
                 , previewEnabled : false
                 }

update :: forall ps. Update (Props ps) State Action
update action = case action of
  AcceptConnection channelId'                    -> handleAcceptConnection channelId'
  GetUserMedia                                   -> handleGetUserMedia
  StopUserMedia                                  -> handleStopUserMedia
  EnablePreview onoff                            -> onlyModify $ _ { previewEnabled = onoff }
  AddChannel channelId' cState                   -> do channel channelId' .= Just cState
                                                       updateChannel channelId' ChannelC.InitConnection
  ChannelA channelId' (ChannelC.ReportError err) -> pure [pure $ ReportError err]
  ChannelA channelId' action'                    -> updateChannel channelId' action'
  CloseChannel channelId'                        -> pure [ pure $ ChannelA channelId' ChannelC.CloseConnection
                                                         , pure $ RemoveChannel channelId'
                                                         ]
  CloseBabyChannel channelId'                    -> do
    isBabyStation' <- gets (_^?channel channelId' <<< _Just <<< to _.isBabyStation)
    case isBabyStation' of
         Just true                               -> pure $ wrapAction (CloseChannel channelId')
         _                                       -> pure []
  RemoveChannel channelId'                       -> channel channelId' .= Nothing
                                                    *> pure []
  SwitchFamily familyId'                       -> handleFamilySwitch familyId'
  ServerFamilyGoOffline familyId sessionId     -> handleServerFamilyGoOffline familyId sessionId
  SetAuthData auth                             -> handleSetAuthData auth
  SetSessionId sessionId'                      -> sessionId .= sessionId' *> pure []
  StartBabyStation                             -> handleStartBabyStation
  InitBabyStation stream                       -> handleInitBabyStation stream
  SetStreamURL url                             -> streamURL .= url -- TODO: On Nothing we should free the url.
                                                  *> pure []

  HandleSubscriber msg                         -> pure []
  SetBabyName name                             -> babyName .= name *> pure []
  SetNewBabyName name                          -> do
    newBabyName .= name
    babyName .= name
    pure []
  ConnectToBaby babyId                         -> handleConnectToBaby babyId
  StopBabyStation                              -> handleStopBabyStation
  ReportError err                              -> noEffects
  Nop                                          -> noEffects

toChannel :: forall ps. ChannelId -> ToChild (Props ps) State (ChannelC.Props {}) ChannelC.State
toChannel channelId' = do
  state <- get
  pProps <- ask
  let
    props :: ChannelC.Props {}
    props = mkChannelProps pProps state channelId'
  pure $ makeChildData (channel channelId' <<< _Just) props

handleGetUserMedia :: forall ps. ComponentType (Props ps) State Action
handleGetUserMedia = do
  state <- get :: Component (Props ps) State State
  case state.localStream of
    Nothing -> runGonimo $
        InitBabyStation <$> liftAff (getUserMedia state.constraints)
    Just _ -> pure []

handleStopUserMedia :: forall ps. ComponentType (Props ps) State Action
handleStopUserMedia = do
  state <- get :: Component (Props ps) State State
  let mStream = if state.isAvailable
                then Nothing
                else state.localStream
  case mStream of
    Nothing -> pure []
    Just stream -> do
      localStream .= Nothing :: (Maybe MediaStream)
      pure [ do
                liftEff $ stopStream stream
                pure Nop
           ]

handleStartBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStartBabyStation = do
  state <- get :: Component (Props ps) State State
  if isJust state.localStream
    then isAvailable .= true
    else isAvailable .= false
  noEffects

handleInitBabyStation :: forall ps.
                          MediaStream
                       -> ComponentType (Props ps) State Action
handleInitBabyStation stream = do
  localStream .= Just stream
  pure [ do
            url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ stream
            pure $ SetStreamURL (Just url)
       ]

handleAcceptConnection :: forall ps. ChannelId -> ComponentType (Props ps) State  Action
handleAcceptConnection channelId' = do
  state <- get
  if state.isAvailable
    then pure [ AddChannel channelId' <$> ChannelC.init state.localStream ]
    else pure []

handleFamilySwitch :: forall ps. Key Family -> ComponentType (Props ps) State Action
handleFamilySwitch familyId' = do
    state <- get :: Component (Props ps) State State
    let oldFamily = state.currentFamily
    modify $ _ { currentFamily = Just familyId' }
    let action = fromFoldable
                 $ ServerFamilyGoOffline
                 <$> oldFamily <*> state.sessionId
    pure $ doCleanup state CloseChannel (pure <$> action)

handleSetAuthData :: forall ps. AuthData -> ComponentType (Props ps) State Action
handleSetAuthData auth = do
  state <- get
  authData .= auth
  pure $ doCleanup state CloseChannel []

handleStopBabyStation :: forall ps. ComponentType (Props ps) State Action
handleStopBabyStation = do
  state <- get :: Component (Props ps) State State
  props <- ask :: Component (Props ps) State (Props ps)
  isAvailable .= false
  pure $ doCleanup state CloseBabyChannel []

handleServerFamilyGoOffline :: forall ps. Key Family -> SessionId -> ComponentType (Props ps) State Action
handleServerFamilyGoOffline familyId sessionId = do
    state <- get :: Component (Props ps) State State
    let deviceId = (runAuthData state.authData).deviceId
    runGonimo $ do
      deleteSessionByFamilyIdByDeviceIdBySessionId familyId deviceId sessionId
      pure Nop

handleConnectToBaby :: forall ps. Key Device -> ComponentType (Props ps) State Action
handleConnectToBaby babyId = do
  state <- get
  props <- ask
  let ourId = state ^. authData <<< to runAuthData <<< deviceId
  let actions = fromMaybe [] $ do
        familyId <- state.currentFamily
        pure [ toIO props.settings $ do
                  secret <- postSocketByFamilyIdByToDevice ourId familyId babyId
                  let channelId' = makeChannelId babyId secret
                  AddChannel channelId' <$> liftIO (ChannelC.init Nothing)
             ]
  pure actions

updateChannel :: forall ps. ChannelId -> ChannelC.Action -> ComponentType (Props ps) State Action
updateChannel channelId' = toParent [] (ChannelA channelId')
                           <<< liftChild (toChannel channelId')
                           <<< ChannelC.update

doCleanup :: State -> (ChannelId -> Action) -> Array (IO Action) -> Array (IO Action)
doCleanup state cleanup action =
    if Map.isEmpty state.channels
    then action
    else Arr.fromFoldable (pure <<< cleanup <$> Map.keys state.channels)
         <> action

getParentChannels :: State -> Array (Tuple ChannelId ChannelC.State)
getParentChannels =  Arr.filter (not _.isBabyStation <<< snd ) <<< Arr.fromFoldable
                     <<< Map.toList <<< _.channels

getSubscriptions :: forall ps. Props ps -> State -> Subscriptions Action
getSubscriptions props state =
  let
    authData' = state ^. authData <<< to runAuthData
    familyId' = state ^. currentFamily
    receiveAChannel deviceId' familyId'' =
      receiveSocketByFamilyIdByToDevice
        (maybe Nop (AcceptConnection <<< uncurry makeChannelId ) <<< join)
        familyId''
        deviceId'

    getChannelSubscriptions :: forall m. (MonadReader Settings m)
                                  => ChannelId -> m (Subscriptions Action)
    getChannelSubscriptions channelId' =
      let
        cProps = mkChannelProps props state channelId'
      in
      map (ChannelA channelId') <$> ChannelC.getSubscriptions cProps

    getChannelsSubscriptions :: forall m. (MonadReader Settings m)
                                => Map ChannelId ChannelC.State
                                -> Array (m (Subscriptions Action))
    getChannelsSubscriptions = Arr.fromFoldable <<< map getChannelSubscriptions <<< Map.keys

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader props.settings)
                $ getChannelsSubscriptions state.channels
                <> ( if state.isAvailable
                     then fromFoldable $ do
                               familyId'' <- familyId'
                               pure $ receiveAChannel authData'.deviceId familyId''
                     else []
                   )
                <> (fromFoldable
                    $ postSessionByFamilyIdByDeviceId (maybe Nop (SetSessionId <<< Just))
                    <$> pure (toDeviceType state) <*> familyId' <*> pure authData'.deviceId
                   )
  in
      foldl append mempty subArray

mkChannelProps :: forall ps. Props ps -> State -> ChannelId -> ChannelC.Props {}
mkChannelProps props state channelId = { ourId : state ^. authData <<< to runAuthData <<< deviceId
                                       , theirId : toTheirId channelId
                                       , cSecret : toCSecret channelId
                                       , familyId : ChannelC.unsafeMakeFamilyId state.currentFamily
                                       , settings : props.settings
                                       , sendAction : lmap (ChannelA channelId) props.sendActionSocket
                                       , onlineDevices : props.onlineDevices
                                       }


4.15.4

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/mikemcgowan/purescript-book.git/'


Introduce `OptionAlias` type

Introduce `OptionAlias` type

module Language.Docopt.OptionAlias (
    OptionAlias (..)
  , Aliases ()
  ) where

import Prelude
import Data.List (List(), (:))
import Data.Function (on)
import Data.Generic (class Generic, gEq, gShow)
import Data.String (singleton) as String
import Data.NonEmpty (NonEmpty(..), fromNonEmpty)
import Data.NonEmpty as NonEmpty

type Aliases = NonEmpty List OptionAlias
data OptionAlias = Short Char | Long String

instance showAlias :: Show OptionAlias where
  show (Short c) = "Short " <> show c
  show (Long  s) = "Long "  <> show s

instance eqAlias :: Eq OptionAlias where
  eq (Short c) (Short c') = c == c'
  eq (Long  s) (Long  s') = s == s'
  eq _         _          = false

instance ordAlias :: Ord OptionAlias where
  compare (Short c) (Short c') = c `compare` c'
  compare (Long  s) (Long  s') = s `compare` s'
  compare (Long  _) _          = GT -- move long names to the back
  compare (Short _) _          = LT -- move short names to the front

derive instance genericOptionAlias :: Generic OptionAlias

prettyPrintOptionAlias :: OptionAlias -> String
prettyPrintOptionAlias (Short c) = "-"  <> (String.singleton c)
prettyPrintOptionAlias (Long  n) = "--" <> n

isLong :: OptionAlias -> Boolean
isLong (Long _) = true
isLong _        = false

isShort :: OptionAlias -> Boolean
isShort (Short _) = true
isShort _         = false

toAliasList :: NonEmpty List OptionAlias -> List OptionAlias
toAliasList = fromNonEmpty (:)

error: pathspec 'src/Language/Docopt/OptionAlias.purs' did not match any file(s) known to git


Added event listener for "inactive"

Added event listener for "inactive"

Maybe this helps?!

module Gonimo.UI.Socket.Channel where

import Prelude
import Control.Monad.Eff.Console as Console
import Data.Array as Arr
import Data.CatQueue as Q
import Data.List as List
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.MediaStream.Track as Track
import WebRTC.RTC as RTC
import WebRTC.RTCRtpSender as Sender
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (catchException)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (modify, get)
import Data.Array (zip)
import Data.Foldable (traverse_)
import Data.Identity (runIdentity)
import Data.Lens ((+=), (-=), (^?), _Just, lens, Lens, (.=), use, (%=), to, LensP)
import Data.List (List(Cons, Nil))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Traversable (traverse)
import Data.Tuple (snd, fst, uncurry, curry, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Client.Vibrations (stopVibration, startVibration, Vibrator)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (audioStats, maxMessagesInFlight, messagesInFlight, messageQueue, Action(EnqueueMessage), Action(..), State, Props, StreamConnectionState(..), StreamConnectionStats, videoStats, connectionState, packetsReceived, TrackKind(..), vibrator)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (stopSound, playSound, loadSound, boostVolumeMediaStream, coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (unsafeToString)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.MediaStream.Track (addEventListener, MediaStreamTrack)
import WebRTC.RTC (closeRTCPeerConnection, RTCPeerConnection, iceConnectionState, oniceconnectionstatechange, onconnectionstatechange, onnegotiationneeded, MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, Ice, newRTCPeerConnection)
import WebRTC.Util (onConnectionDrop)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ { urls : [ "turn:gonimo.com:3478" ]
                                                                  , username : "gonimo"
                                                                  , credential : "Aeloh5chai2eil1" -- FIXME: For production this obviously should not be hardcoded.
                                                                  , credentialType : "password"
                                                                  }
                                                                ]
                                                 }
                           )
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    -- Close rtc connection once a track ends - so parent will notice local problems:
    tracks <- liftEff $ MediaStream.getTracks origStream
    let addListener event = liftEff <<< addEventListener event (const (closeRTCPeerConnection rtcConnection))
    traverse_ (addListener "ended") tracks
    traverse_ (addListener "mute") tracks
    traverse_ (addListener "inactive") tracks -- Let's see if this helps
    liftEff $ boostVolumeMediaStream origStream

  connState <- liftEff $ iceConnectionState rtcConnection
  let isBabyStation = isJust stream
  alarm' <- if isBabyStation -- We only need alarm at the parent side
            then pure Nothing
            else map Just <<< liftAff $ loadSound "/sounds/pup_alert.mp3"
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isBabyStation
          , messageQueue  : Nil
          , messagesInFlight : 0
          , audioStats : initStreamConnectionStats
          , videoStats : initStreamConnectionStats
          , vibrator   : Nothing
          , alarm : alarm'
          , alarmIsOn : false
          }

initStreamConnectionStats :: StreamConnectionStats
initStreamConnectionStats = { packetsReceived : 0
                            , connectionState : ConnectionNotAvailable
                            }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  StartNegotiation                   -> handleStartNegotiation
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeConnection
  CloseConnection                    -> handleCloseConnection
  AcceptMessages num messages        -> handleAcceptMessages num messages
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  OnAudioConnectionDrop mPackets     -> handleOnConnectionDrop audioStats mPackets
  OnVideoConnectionDrop mPackets     -> handleOnConnectionDrop videoStats mPackets
  RegisterMediaTracks tracks         -> traverse_ handleRegisterMediaTrack tracks *> pure []
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  EnqueueMessage message             -> handleEnqueueMessage message
  MessageSent nAction                -> handleMessageSent nAction
  SetVibrator mVibrator              -> handleSetVibrator mVibrator
  TurnOnAlarm onOff                  -> handleTurnOnAlarm onOff
  ConnectionClosed                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         liftEff $ onnegotiationneeded (coerceEffects <<< props.sendAction $ StartNegotiation) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else pure $ EnqueueMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            pure Nop
       ]

handleStartNegotiation :: forall ps. ComponentType (Props ps) State Action
handleStartNegotiation = do
  state <- get
  pure [ do
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            pure <<< EnqueueMessage $ Message.SessionDescriptionOffer offer
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  pure [ pure <<< EnqueueMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
    state <- get
    props <- ask
    let registerConnDrop = if state.isBabyStation
                           then []
                           else [ registerOnConnectionDrop props state ]
    pure $ registerConnDrop
         <> [ do
              url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
              pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
            ]
  where
    registerOnConnectionDrop :: Props ps -> State -> IO Action
    registerOnConnectionDrop props state = do
      mVideoTrack <- map Arr.head <<< liftEff $ MediaStream.getVideoTracks event.stream
      mAudioTrack <- map Arr.head <<< liftEff $ MediaStream.getAudioTracks event.stream
      let kindArray kind = Arr.fromFoldable <<< map (const kind)
      maybeRegister props OnAudioConnectionDrop mAudioTrack state.rtcConnection
      maybeRegister props OnVideoConnectionDrop mVideoTrack state.rtcConnection
      -- pure $ RegisterMediaTracks (kindArray audioStats mAudioTrack <> kindArray videoStats mVideoTrack)
      pure $ RegisterMediaTracks (kindArray AudioTrack mAudioTrack <> kindArray VideoTrack mVideoTrack)

    maybeRegister :: Props ps -> (Maybe Int -> Action) -> Maybe MediaStreamTrack -> RTCPeerConnection -> IO Unit
    maybeRegister _ _ Nothing _ = pure unit
    maybeRegister props mkAction mTrack@(Just track) pc = do
      let eventHandler = coerceEffects <<< props.sendAction <<< mkAction
      liftEff $ onConnectionDrop eventHandler mTrack pc
      liftEff $ addEventListener "ended" (const (eventHandler Nothing)) track
      liftEff $ addEventListener "ended" (const (Console.log "Track ended")) track

handleOnConnectionDrop :: forall ps. LensP State StreamConnectionStats
                          -> Maybe Int -> ComponentType (Props ps) State Action
handleOnConnectionDrop stats mPackets= do
    case mPackets of
      Nothing -> do
        stats <<< connectionState %= updateState ConnectionDied
        status <- use (stats <<< connectionState)
        case status of
          ConnectionDied -> do
            let vibratorActions = [ do
                                       vibrator' <- liftEff $ startVibration [200, 100, 250, 100, 300]
                                       pure $ (SetVibrator <<< Just) vibrator'
                                  ]
            alarmActions <- handleTurnOnAlarm true
            pure $ alarmActions <> vibratorActions
          _ -> pure []
      Just packets -> do
        stats <<< packetsReceived .= packets
        stats <<< connectionState %= updateState ConnectionReliable
        pure []
  where
    -- updateState new old
    updateState :: StreamConnectionState -> StreamConnectionState -> StreamConnectionState
    updateState ConnectionNotAvailable ConnectionDied = ConnectionNotAvailable -- User can stop a dead connection.
    updateState _ ConnectionDied = ConnectionDied -- In all other cases it remains dead.
    updateState ConnectionUnknown ConnectionNotAvailable = ConnectionUnknown
    updateState _ ConnectionNotAvailable = ConnectionNotAvailable
    updateState new _ = new

handleSetVibrator :: forall ps. Maybe Vibrator -> ComponentType (Props ps) State Action
handleSetVibrator mVibrator = do
  state <- get :: Component (Props ps) State State
  let oldVibrator = state.vibrator
  vibrator .= mVibrator
  pure [ liftEff $ do
            traverse_ stopVibration oldVibrator
            pure Nop
       ]

handleTurnOnAlarm :: forall ps. Boolean -> ComponentType (Props ps) State Action
handleTurnOnAlarm onOff = do
  state <- get :: Component (Props ps) State State
  let old = state.alarmIsOn
  modify $ _ { alarmIsOn = onOff }
  let actions =
        if onOff
        then [ do
                  liftEff $ traverse_ playSound state.alarm
                  pure Nop
            ]
        else [ do
                  liftEff $ traverse_ stopSound state.alarm
                  pure Nop
            ]
  if old /= onOff
    then pure actions
    else pure []

handleRegisterMediaTrack :: forall ps. TrackKind -> Component (Props ps) State Unit
handleRegisterMediaTrack AudioTrack = audioStats <<< connectionState .= ConnectionUnknown
handleRegisterMediaTrack VideoTrack = videoStats <<< connectionState .= ConnectionUnknown

getSendMessages :: forall ps. Component (Props ps) State (Array String -> IO Action)
getSendMessages = do
  let sendMessages = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  let sendMessage = map MessageSent
                    <<< toIO props.settings
                    <<< ( \msgs ->  do
                             sendMessages msgs familyId' fromDevice' toDevice' channelId'
                             pure Nop
                        )
  pure sendMessage

handleAcceptMessages :: forall ps. MessageNumber -> Array String -> ComponentType (Props ps) State Action
handleAcceptMessages msgNumber msgs = do
  let decoded = Arr.mapMaybe decodeFromString msgs
  props <- ask
  let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
  deleteActions <- runGonimo $ do
    deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
    pure Nop
  messageActions <- Arr.concat <$> traverse handleMessage decoded
  pure $ deleteActions <> messageActions

handleMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleMessage msg = do
  state <- get
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              pure <<< EnqueueMessage $ Message.SessionDescriptionAnswer answer
          ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
          ]
    Message.IceCandidate candidate ->
      pure [ do
              let test = runMaybeIceCandidate candidate
              case test of
                Nothing -> pure unit -- let's see whether this helps
                Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
              pure Nop
          ]
    Message.CloseConnection -> closeConnection

closeConnection :: forall ps. ComponentType (Props ps) State Action
closeConnection = do
  state <- get :: Component (Props ps) State State
  let conn = state.rtcConnection
  audioStats <<< connectionState .= ConnectionNotAvailable
  videoStats <<< connectionState .= ConnectionNotAvailable
  alarmA <- handleTurnOnAlarm false
  pure $ [ liftEff $ do
            catchException (\_ -> Console.log "Stopping vibrations failed!")
              $ traverse_ stopVibration state.vibrator
            pure $ SetVibrator Nothing
        , liftEff $ do
            catchException (\_ -> Console.log "Closing RTC connection failed!")
              $ closeRTCPeerConnection conn
            pure ConnectionClosed
        ]
    <> alarmA

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  state <- get :: Component (Props ps) State State
  closeActions <- closeConnection
  pure $ [ pure $ EnqueueMessage Message.CloseConnection ] <> closeActions

handleEnqueueMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleEnqueueMessage message = do
  let strMsg = encodeToString message
  allClear <- use $ messagesInFlight <<< to (_ < maxMessagesInFlight)
  sendMessages <- getSendMessages
  if allClear
    then do
      messagesInFlight += 1
      pure [ sendMessages $ Arr.singleton strMsg ] -- Ready to take off!
    else do
      messageQueue %= Cons strMsg
      pure []

handleMessageSent :: forall ps. Action -> ComponentType (Props ps) State Action
handleMessageSent nAction = do
  messagesInFlight -= 1
  newActions <- update nAction
  queue :: List String <- use messageQueue
  sendMessages <- getSendMessages
  let messages = Arr.fromFoldable $ List.reverse queue
  ourActions <-
        if Arr.null messages
        then pure []
        else do
          messageQueue .= Nil :: (List String)
          messagesInFlight += 1
          pure [ sendMessages messages ]
  pure $ newActions <> ourActions

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , H.div [ A.style [Tuple "position" "relative"]] -- Needed so absolute positioning of error works.
              [ viewVideo state
              , viewError state
              ]
            , viewStreamStatus state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

viewError :: State -> Html Action
viewError state =
  let
    isBroken connState = case connState of
      ConnectionDied -> true
      _              -> false
    audioBroken = isBroken state.audioStats.connectionState
    videoBroken = isBroken state.videoStats.connectionState
    brokenText = if audioBroken && not videoBroken
                 then "Audio connection broken!"
                 else if not audioBroken && videoBroken
                      then "Video connection broken!"
                      else "Connection broken!"

    errorView = H.div [ A.className "brokenConnectionOverlay" ]
                [ H.h2 [] [ H.text brokenText ]
                , H.p []
                  [
                    H.text "Please reconnect or check on your baby!"
                  ]
                ]
  in
   if audioBroken || videoBroken
   then errorView
   else H.div [] []

viewStreamStatus :: State -> Html Action
viewStreamStatus state =
  let
     getStatus connState = case connState of
       ConnectionNotAvailable -> H.text "x"
       ConnectionUnknown  -> H.text "Might break unnoticed"
       ConnectionReliable -> H.text "Reliable"
       ConnectionDied     -> H.text "Dead"
     videoStatus = getStatus state.videoStats.connectionState
     audioStatus = getStatus state.audioStats.connectionState
  in
   H.div []
   [ H.text "Audio: " , audioStatus
   , H.text ", "
   , H.text "Video: ", videoStatus
   ]

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId toAction
    toAction :: Maybe (Maybe (Tuple MessageNumber (Array String))) -> Action
    toAction (Just (Just (Tuple num messages))) = AcceptMessages num messages
    toAction (Just Nothing) = Nop
    toAction Nothing = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret

module Gonimo.UI.Socket.Channel where

import Prelude
import Control.Monad.Eff.Console as Console
import Data.Array as Arr
import Data.CatQueue as Q
import Data.List as List
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.UI.Socket.Message as Message
import Pux.Html.Attributes as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import WebRTC.MediaStream as MediaStream
import WebRTC.MediaStream.Track as Track
import WebRTC.RTC as RTC
import WebRTC.RTCRtpSender as Sender
import Control.Monad.Aff (Aff)
import Control.Monad.Aff.Class (liftAff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Eff.Exception (catchException)
import Control.Monad.IO (IO)
import Control.Monad.Maybe.Trans (MaybeT(MaybeT), runMaybeT)
import Control.Monad.Reader (runReaderT)
import Control.Monad.Reader.Class (ask, class MonadReader)
import Control.Monad.State.Class (modify, get)
import Data.Array (zip)
import Data.Foldable (traverse_)
import Data.Identity (runIdentity)
import Data.Lens ((+=), (-=), (^?), _Just, lens, Lens, (.=), use, (%=), to, LensP)
import Data.List (List(Cons, Nil))
import Data.Maybe (fromMaybe, isJust, maybe, Maybe(Nothing, Just))
import Data.Traversable (traverse)
import Data.Tuple (snd, fst, uncurry, curry, Tuple(Tuple))
import Gonimo.Client.Types (toIO, Settings)
import Gonimo.Client.Vibrations (stopVibration, startVibration, Vibrator)
import Gonimo.Pux (noEffects, runGonimo, Component, Update, onlyModify, ComponentType)
import Gonimo.Server.Db.Entities (Family(Family), Device(Device))
import Gonimo.Server.State.Types (MessageNumber(MessageNumber))
import Gonimo.Server.Types.Lenses (_Baby)
import Gonimo.Types (Secret(Secret), Key(Key))
import Gonimo.UI.Socket.Channel.Types (audioStats, maxMessagesInFlight, messagesInFlight, messageQueue, Action(EnqueueMessage), Action(..), State, Props, StreamConnectionState(..), StreamConnectionStats, videoStats, connectionState, packetsReceived, TrackKind(..), vibrator)
import Gonimo.UI.Socket.Lenses (mediaStream)
import Gonimo.UI.Socket.Message (runMaybeIceCandidate, MaybeIceCandidate(JustIceCandidate, NoIceCandidate), encodeToString, decodeFromString, Message)
import Gonimo.Util (stopSound, playSound, loadSound, boostVolumeMediaStream, coerceEffects)
import Gonimo.WebAPI (deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber, putSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Gonimo.WebAPI.Subscriber (getSocketByFamilyIdByFromDeviceByToDeviceByChannelId)
import Pux.Html (text, Html)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (unsafeToString)
import Servant.Subscriber (Subscriptions)
import Unsafe.Coerce (unsafeCoerce)
import WebRTC.MediaStream (createObjectURL, mediaStreamToBlob, stopStream, getUserMedia, MediaStreamConstraints(MediaStreamConstraints), MediaStream)
import WebRTC.MediaStream.Track (addEventListener, MediaStreamTrack)
import WebRTC.RTC (closeRTCPeerConnection, RTCPeerConnection, iceConnectionState, oniceconnectionstatechange, onconnectionstatechange, onnegotiationneeded, MediaStreamEvent, setLocalDescription, createAnswer, iceEventCandidate, IceEvent, onicecandidate, onaddstream, addIceCandidate, setRemoteDescription, fromRTCSessionDescription, createOffer, addStream, RTCIceCandidateInit, Ice, newRTCPeerConnection)
import WebRTC.Util (onConnectionDrop)

init :: Maybe MediaStream -> IO State
init stream = do
  rtcConnection <- liftEff (newRTCPeerConnection { iceServers : [ { urls : [ "turn:gonimo.com:3478" ]
                                                                  , username : "gonimo"
                                                                  , credential : "Aeloh5chai2eil1" -- FIXME: For production this obviously should not be hardcoded.
                                                                  , credentialType : "password"
                                                                  }
                                                                ]
                                                 }
                           )
  ourStream <- runMaybeT $ do
    origStream <- MaybeT <<< pure $ stream
    -- Close rtc connection once a track ends - so parent will notice local problems:
    tracks <- liftEff $ MediaStream.getTracks origStream
    let addListener event = liftEff <<< addEventListener event (const (closeRTCPeerConnection rtcConnection))
    traverse_ (addListener "ended") tracks
    traverse_ (addListener "mute") tracks
    liftEff $ boostVolumeMediaStream origStream

  connState <- liftEff $ iceConnectionState rtcConnection
  let isBabyStation = isJust stream
  alarm' <- if isBabyStation -- We only need alarm at the parent side
            then pure Nothing
            else map Just <<< liftAff $ loadSound "/sounds/pup_alert.mp3"
  pure $  { mediaStream : ourStream
          , remoteStream : Nothing
          , rtcConnection : rtcConnection
          , isBabyStation : isBabyStation
          , messageQueue  : Nil
          , messagesInFlight : 0
          , audioStats : initStreamConnectionStats
          , videoStats : initStreamConnectionStats
          , vibrator   : Nothing
          , alarm : alarm'
          , alarmIsOn : false
          }

initStreamConnectionStats :: StreamConnectionStats
initStreamConnectionStats = { packetsReceived : 0
                            , connectionState : ConnectionNotAvailable
                            }

remoteStream :: forall a b r. Lens { "remoteStream" :: a | r } { "remoteStream" :: b | r } a b
remoteStream = lens _."remoteStream" (_ { "remoteStream" = _ })

update :: forall ps. Update (Props ps) State Action
update action = case action of
  InitConnection                     -> handleInit -- Things we can't do in init already.
  StartStreaming constraints         -> handleStartStreaming constraints
  StartNegotiation                   -> handleStartNegotiation
  SetMediaStream stream              -> handleSetMediaStream stream
  StopStreaming                      -> closeConnection
  CloseConnection                    -> handleCloseConnection
  AcceptMessages num messages        -> handleAcceptMessages num messages
  OnIceCandidate iceEvent            -> handleOnIceCandidate iceEvent
  OnAddStream streamEvent            -> handleOnAddStream streamEvent
  OnAudioConnectionDrop mPackets     -> handleOnConnectionDrop audioStats mPackets
  OnVideoConnectionDrop mPackets     -> handleOnConnectionDrop videoStats mPackets
  RegisterMediaTracks tracks         -> traverse_ handleRegisterMediaTrack tracks *> pure []
  SetRemoteStream stream             -> remoteStream .= Just stream *> pure []
  ReportError _                      -> noEffects
  EnqueueMessage message             -> handleEnqueueMessage message
  MessageSent nAction                -> handleMessageSent nAction
  SetVibrator mVibrator              -> handleSetVibrator mVibrator
  TurnOnAlarm onOff                  -> handleTurnOnAlarm onOff
  ConnectionClosed                      -> noEffects
  Nop                                -> noEffects

handleInit :: forall ps. ComponentType (Props ps) State Action
handleInit = do
  props <- ask :: Component (Props ps) State (Props ps)
  state <- get :: Component (Props ps) State State
  pure
    [ do
         liftEff $ onaddstream (coerceEffects <<< props.sendAction <<< OnAddStream ) state.rtcConnection
         liftEff $ onicecandidate (coerceEffects <<< props.sendAction <<< OnIceCandidate ) state.rtcConnection
         liftEff $ onnegotiationneeded (coerceEffects <<< props.sendAction $ StartNegotiation) state.rtcConnection
         if state.isBabyStation
           then pure Nop
           else pure $ EnqueueMessage Message.StartStreaming
    ]

handleStartStreaming :: forall ps.
                        MediaStreamConstraints
                        -> ComponentType (Props ps) State Action
handleStartStreaming constraints =
  pure [ liftAff $ SetMediaStream <$> coerceEffects (getUserMedia constraints) ]

handleSetMediaStream :: forall ps. MediaStream -> ComponentType (Props ps) State Action
handleSetMediaStream stream = do
  mediaStream .= Just stream
  startStreaming stream

startStreaming :: forall ps. MediaStream -> ComponentType (Props ps) State Action
startStreaming stream = do
  state <- get
  pure [ do
            liftEff $ addStream stream state.rtcConnection
            pure Nop
       ]

handleStartNegotiation :: forall ps. ComponentType (Props ps) State Action
handleStartNegotiation = do
  state <- get
  pure [ do
            offer <- liftAff $ createOffer state.rtcConnection
            liftAff $ setLocalDescription offer state.rtcConnection
            pure <<< EnqueueMessage $ Message.SessionDescriptionOffer offer
       ]

handleOnIceCandidate :: forall ps. IceEvent -> ComponentType (Props ps) State Action
handleOnIceCandidate event = do
  let candidate = iceEventCandidate event
  let mCandidate = maybe NoIceCandidate JustIceCandidate candidate
  pure [ pure <<< EnqueueMessage $ Message.IceCandidate mCandidate ]

handleOnAddStream :: forall ps. MediaStreamEvent  -> ComponentType (Props ps) State Action
handleOnAddStream event = do
    state <- get
    props <- ask
    let registerConnDrop = if state.isBabyStation
                           then []
                           else [ registerOnConnectionDrop props state ]
    pure $ registerConnDrop
         <> [ do
              url <- liftEff <<< createObjectURL <<< mediaStreamToBlob $ event.stream
              pure $ SetRemoteStream $ { stream : event.stream, objectURL : url }
            ]
  where
    registerOnConnectionDrop :: Props ps -> State -> IO Action
    registerOnConnectionDrop props state = do
      mVideoTrack <- map Arr.head <<< liftEff $ MediaStream.getVideoTracks event.stream
      mAudioTrack <- map Arr.head <<< liftEff $ MediaStream.getAudioTracks event.stream
      let kindArray kind = Arr.fromFoldable <<< map (const kind)
      maybeRegister props OnAudioConnectionDrop mAudioTrack state.rtcConnection
      maybeRegister props OnVideoConnectionDrop mVideoTrack state.rtcConnection
      -- pure $ RegisterMediaTracks (kindArray audioStats mAudioTrack <> kindArray videoStats mVideoTrack)
      pure $ RegisterMediaTracks (kindArray AudioTrack mAudioTrack <> kindArray VideoTrack mVideoTrack)

    maybeRegister :: Props ps -> (Maybe Int -> Action) -> Maybe MediaStreamTrack -> RTCPeerConnection -> IO Unit
    maybeRegister _ _ Nothing _ = pure unit
    maybeRegister props mkAction mTrack@(Just track) pc = do
      let eventHandler = coerceEffects <<< props.sendAction <<< mkAction
      liftEff $ onConnectionDrop eventHandler mTrack pc
      liftEff $ addEventListener "ended" (const (eventHandler Nothing)) track
      liftEff $ addEventListener "ended" (const (Console.log "Track ended")) track

handleOnConnectionDrop :: forall ps. LensP State StreamConnectionStats
                          -> Maybe Int -> ComponentType (Props ps) State Action
handleOnConnectionDrop stats mPackets= do
    case mPackets of
      Nothing -> do
        stats <<< connectionState %= updateState ConnectionDied
        status <- use (stats <<< connectionState)
        case status of
          ConnectionDied -> do
            let vibratorActions = [ do
                                       vibrator' <- liftEff $ startVibration [200, 100, 250, 100, 300]
                                       pure $ (SetVibrator <<< Just) vibrator'
                                  ]
            alarmActions <- handleTurnOnAlarm true
            pure $ alarmActions <> vibratorActions
          _ -> pure []
      Just packets -> do
        stats <<< packetsReceived .= packets
        stats <<< connectionState %= updateState ConnectionReliable
        pure []
  where
    -- updateState new old
    updateState :: StreamConnectionState -> StreamConnectionState -> StreamConnectionState
    updateState ConnectionNotAvailable ConnectionDied = ConnectionNotAvailable -- User can stop a dead connection.
    updateState _ ConnectionDied = ConnectionDied -- In all other cases it remains dead.
    updateState ConnectionUnknown ConnectionNotAvailable = ConnectionUnknown
    updateState _ ConnectionNotAvailable = ConnectionNotAvailable
    updateState new _ = new

handleSetVibrator :: forall ps. Maybe Vibrator -> ComponentType (Props ps) State Action
handleSetVibrator mVibrator = do
  state <- get :: Component (Props ps) State State
  let oldVibrator = state.vibrator
  vibrator .= mVibrator
  pure [ liftEff $ do
            traverse_ stopVibration oldVibrator
            pure Nop
       ]

handleTurnOnAlarm :: forall ps. Boolean -> ComponentType (Props ps) State Action
handleTurnOnAlarm onOff = do
  state <- get :: Component (Props ps) State State
  let old = state.alarmIsOn
  modify $ _ { alarmIsOn = onOff }
  let actions =
        if onOff
        then [ do
                  liftEff $ traverse_ playSound state.alarm
                  pure Nop
            ]
        else [ do
                  liftEff $ traverse_ stopSound state.alarm
                  pure Nop
            ]
  if old /= onOff
    then pure actions
    else pure []

handleRegisterMediaTrack :: forall ps. TrackKind -> Component (Props ps) State Unit
handleRegisterMediaTrack AudioTrack = audioStats <<< connectionState .= ConnectionUnknown
handleRegisterMediaTrack VideoTrack = videoStats <<< connectionState .= ConnectionUnknown

getSendMessages :: forall ps. Component (Props ps) State (Array String -> IO Action)
getSendMessages = do
  let sendMessages = putSocketByFamilyIdByFromDeviceByToDeviceByChannelId
  props <- ask
  let familyId' = props.familyId
  let fromDevice' = props.ourId
  let toDevice' = props.theirId
  let channelId' = props.cSecret
  let sendMessage = map MessageSent
                    <<< toIO props.settings
                    <<< ( \msgs ->  do
                             sendMessages msgs familyId' fromDevice' toDevice' channelId'
                             pure Nop
                        )
  pure sendMessage

handleAcceptMessages :: forall ps. MessageNumber -> Array String -> ComponentType (Props ps) State Action
handleAcceptMessages msgNumber msgs = do
  let decoded = Arr.mapMaybe decodeFromString msgs
  props <- ask
  let deleteMessage = deleteSocketByFamilyIdByFromDeviceByToDeviceByChannelIdMessagesByMessageNumber
  deleteActions <- runGonimo $ do
    deleteMessage props.familyId props.theirId props.ourId props.cSecret msgNumber
    pure Nop
  messageActions <- Arr.concat <$> traverse handleMessage decoded
  pure $ deleteActions <> messageActions

handleMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleMessage msg = do
  state <- get
  case msg of
    Message.StartStreaming -> fromMaybe (pure []) $ startStreaming <$> state.mediaStream
    Message.SessionDescriptionOffer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              answer <- liftAff $ createAnswer state.rtcConnection
              liftAff $ setLocalDescription answer state.rtcConnection
              pure <<< EnqueueMessage $ Message.SessionDescriptionAnswer answer
          ]
    Message.SessionDescriptionAnswer description ->
      pure [ do
              liftAff $ setRemoteDescription description state.rtcConnection
              pure Nop
          ]
    Message.IceCandidate candidate ->
      pure [ do
              let test = runMaybeIceCandidate candidate
              case test of
                Nothing -> pure unit -- let's see whether this helps
                Just c -> liftAff $ addIceCandidate (runMaybeIceCandidate candidate) state.rtcConnection
              pure Nop
          ]
    Message.CloseConnection -> closeConnection

closeConnection :: forall ps. ComponentType (Props ps) State Action
closeConnection = do
  state <- get :: Component (Props ps) State State
  let conn = state.rtcConnection
  audioStats <<< connectionState .= ConnectionNotAvailable
  videoStats <<< connectionState .= ConnectionNotAvailable
  alarmA <- handleTurnOnAlarm false
  pure $ [ liftEff $ do
            catchException (\_ -> Console.log "Stopping vibrations failed!")
              $ traverse_ stopVibration state.vibrator
            pure $ SetVibrator Nothing
        , liftEff $ do
            catchException (\_ -> Console.log "Closing RTC connection failed!")
              $ closeRTCPeerConnection conn
            pure ConnectionClosed
        ]
    <> alarmA

handleCloseConnection :: forall ps. ComponentType (Props ps) State Action
handleCloseConnection = do
  state <- get :: Component (Props ps) State State
  closeActions <- closeConnection
  pure $ [ pure $ EnqueueMessage Message.CloseConnection ] <> closeActions

handleEnqueueMessage :: forall ps. Message -> ComponentType (Props ps) State Action
handleEnqueueMessage message = do
  let strMsg = encodeToString message
  allClear <- use $ messagesInFlight <<< to (_ < maxMessagesInFlight)
  sendMessages <- getSendMessages
  if allClear
    then do
      messagesInFlight += 1
      pure [ sendMessages $ Arr.singleton strMsg ] -- Ready to take off!
    else do
      messageQueue %= Cons strMsg
      pure []

handleMessageSent :: forall ps. Action -> ComponentType (Props ps) State Action
handleMessageSent nAction = do
  messagesInFlight -= 1
  newActions <- update nAction
  queue :: List String <- use messageQueue
  sendMessages <- getSendMessages
  let messages = Arr.fromFoldable $ List.reverse queue
  ourActions <-
        if Arr.null messages
        then pure []
        else do
          messageQueue .= Nil :: (List String)
          messagesInFlight += 1
          pure [ sendMessages messages ]
  pure $ newActions <> ourActions

view :: forall ps. Props ps -> State -> Html Action
view props state =
  let
    mBabyDevice = Tuple.lookup props.theirId props.onlineDevices
    babyName = fromMaybe "unknown baby" $ mBabyDevice ^? _Just <<< _Baby
  in
    H.div [ A.className "panel panel-default" ]
            [ H.div [ A.className "panel-heading" ]
              [
                H.text babyName
              ]
            , H.div [ A.style [Tuple "position" "relative"]] -- Needed so absolute positioning of error works.
              [ viewVideo state
              , viewError state
              ]
            , viewStreamStatus state
            ]

viewVideo :: State -> Html Action
viewVideo state =
   case state.remoteStream of
       Nothing -> H.text $ "Sorry - no video there yet, please check that your camera/microphone "
                  <> "are enabled on the baby station and your browser allows us to access it."
       Just stream ->
         H.video [ A.src stream.objectURL
                 , A.autoPlay "true"
                 , A.controls true
                 , A.width "100%"
                 ] []

viewError :: State -> Html Action
viewError state =
  let
    isBroken connState = case connState of
      ConnectionDied -> true
      _              -> false
    audioBroken = isBroken state.audioStats.connectionState
    videoBroken = isBroken state.videoStats.connectionState
    brokenText = if audioBroken && not videoBroken
                 then "Audio connection broken!"
                 else if not audioBroken && videoBroken
                      then "Video connection broken!"
                      else "Connection broken!"

    errorView = H.div [ A.className "brokenConnectionOverlay" ]
                [ H.h2 [] [ H.text brokenText ]
                , H.p []
                  [
                    H.text "Please reconnect or check on your baby!"
                  ]
                ]
  in
   if audioBroken || videoBroken
   then errorView
   else H.div [] []

viewStreamStatus :: State -> Html Action
viewStreamStatus state =
  let
     getStatus connState = case connState of
       ConnectionNotAvailable -> H.text "x"
       ConnectionUnknown  -> H.text "Might break unnoticed"
       ConnectionReliable -> H.text "Reliable"
       ConnectionDied     -> H.text "Dead"
     videoStatus = getStatus state.videoStats.connectionState
     audioStatus = getStatus state.audioStats.connectionState
  in
   H.div []
   [ H.text "Audio: " , audioStatus
   , H.text ", "
   , H.text "Video: ", videoStatus
   ]

getSubscriptions :: forall m ps. (MonadReader Settings m) => Props ps -> m (Subscriptions Action)
getSubscriptions props =
  let
    receiveMessage = getSocketByFamilyIdByFromDeviceByToDeviceByChannelId toAction
    toAction :: Maybe (Maybe (Tuple MessageNumber (Array String))) -> Action
    toAction (Just (Just (Tuple num messages))) = AcceptMessages num messages
    toAction (Just Nothing) = Nop
    toAction Nothing = Nop
  in
    receiveMessage props.familyId props.theirId props.ourId props.cSecret


Add PureScript implementation

Add PureScript implementation

bkkCrypt :: String -> String
bkkCrypt = id

error: pathspec 'PureScript/BKKCrypt.purs' did not match any file(s) known to git


define straightforward main function as poc

module Main where

import Prelude
import Data.Either(Either)
import Control.Monad.Eff(Eff)
import Control.Monad.Eff.Console(CONSOLE, logShow)
import Data.Argonaut.Parser(jsonParser)
import Data.Argonaut.Decode(decodeJson)
import Ifrit.Core(Stage)
import Ifrit.Drivers.MongoDB(ingest)

input :: Either String Stage
input =
  jsonParser
  "{\"@\":\"map\",\"=\":{\"amount\":{\"@\":\"inject\",\"[]\":{\"@\":\"field\",\"=\":\"authorizations\"},\"=\":{\"@\":\"avg\",\"=\":{\"@\":\"field\",\"=\":\"amount\"}}}}}"
  --"{\"@\":\"map\",\"=\":{\"amount\":{\"@\":\"field\",\"=\":\"authorizations\"}}}"
  >>= decodeJson

main :: Eff (console :: CONSOLE) Unit
main =
  do logShow $ input
     logShow $ ingest <$> input

error: pathspec 'src/Main.purs' did not match any file(s) known to git


use pattern matching

use pattern matching

remote: Support for password authentication was removed on August 13, 2021.
remote: Please see https://docs.github.com/en/get-started/getting-started-with-git/about-remote-repositories#cloning-with-https-urls for information on currently recommended modes of authentication.
fatal: Authentication failed for 'https://github.com/michaelsbradleyjr/advent-of-code.git/'


Hopefully fixed telegram link for real now,

module Gonimo.UI.Invite where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.Html as Html
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Apply ((*>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (uncurry, Tuple(Tuple))
import Global (encodeURIComponent, encodeURI)
import Gonimo.Client.Types (Settings, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Pux (noEffects, onlyModify, Update, runGonimo, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings  :: Settings
                , rFamilyId :: Key Family
                , rFamily   :: Family
                , baseURL :: String
                | ps
                }

type State =
  { email          :: String
  , invitationSent :: Boolean
  , invitationId   :: Key Invitation
  , invitation   :: Invitation
  }

-- | We take our props in init to ensure the caller takes care of providing proper props.
--   Ensuring this on the first call to update is a tad to late.
init :: forall ps. Tuple (Key Invitation) Invitation -> Props ps -> State
init (Tuple invKey inv) _ = { email : ""
                            , invitationSent : false
                            , invitationId : invKey
                            , invitation : inv
                            }

data Action = SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError GonimoError
            | MakeNewInvitation
            | SetInvitationData (Key Invitation) Invitation
            | GoToOverview
            | GoToBabyStation
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps. Update (Props ps) State Action
update action = case action of
  (SetEmail email )         -> onlyModify $ _ { email = email, invitationSent = false }
  InvitationSent            -> handleInvitationSent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  ReportError err           -> noEffects
  Nop                       -> noEffects

makeInviteLink :: String -> Invitation -> String
makeInviteLink baseURL (Invitation inv) = baseURL <> "?" <> "acceptInvitation="
                                          <> gDefaultEncodeURLPiece inv.invitationSecret

handleInvitationSent :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleInvitationSent = do
  modify $ _ { invitationSent = true }
  pure [ pure MakeNewInvitation ] -- Prevent user from re-using the already sent invitation

handleMakeNewInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleMakeNewInvitation = do
  props <- ask
  runGonimo $ uncurry SetInvitationData <$> postInvitationsByFamilyId props.rFamilyId

handleSendInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleSendInvitation = do
  state <- get
  runGonimo $ do
    postInvitationsOutbox $ WebAPI.SendInvitation state.invitationId (EmailInvitation state.email)
    pure InvitationSent

--------------------------------------------------------------------------------

view :: forall ps. Props ps -> State -> Html Action
view props state =
    let invitationLink = makeInviteLink (props.baseURL) state.invitation
        escapedLink = encodeURIComponent invitationLink
     in div []
                   [ div [A.className "page-header"]
                     [ div [ A.className "container"
                           , A.style [Tuple "width" "100%"]]
                       [ h3 [] [ text "Device Management"
                               , br [] []
                               , small []
                                 [ text $ "Here you can add new devices to your"
                                       <> " families, you only have to visit the"
                                       <> " following one-time link on another device." ]
                               ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "copy & paste"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "You can either copy & paste it in to your"
                                    <> " favourite messenger (e.g. WhatsApp) to"
                                    <> " send it."
                              ]
                       , div [ A.className "input-group" ]
                           [ span [ A.className "input-group-addon glyphicon glyphicon-copy", A.id_ "sdflkjsll291" ]
                             []
                           , input [ A.type_ "text", A.className "form-control", A.readOnly true
                                   , A.value invitationLink
                                   ] []
                           ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "Share it"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "Or you can share it directly with WhatsApp, Telegram .."
                              ]
                       , p []
                         [
                           H.a [ A.href $ "whatsapp://send?text=" <> escapedLink
                               ] [ H.text "Whatsapp" ]
                         , H.text " "
                         , H.a [ A.href $ "https://telegram.me/share/url?url=" <> escapedLink
                               ] [ H.text "Telegram" ]
                         ]
                       ]
                     ]
                   , div [A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "email"]
                     , div [A.className "jumbotron"]
                       [ p []  [ text "Or you can let us do the work send it via email …"
                               ]
                       , div [ E.onKeyUp handleEnter ]
                         [ div [A.className "input-group"]
                           [ span [A.className "input-group-addon glyphicon glyphicon-envelope"] []
                           , input [ A.type_ "text"
                                   , A.className "form-control"
                                   , A.placeholder "mail@example.com"
                                   , E.onInput $ \ev -> SetEmail ev.target.value
                                   , A.value state.email
                                   ] []
                           ]
                         ]
                       , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ SendInvitation
                                 ]
                         [ text " Send Invitation! "
                         , span [A.className "glyphicon glyphicon-send"] []
                         ]
                       , if state.invitationSent
                         then div [ A.className "alert alert-success"]
                              [ h3 [] [text $ "Invitation sent successfully to '"
                                           <> state.email <> "'!"
                                      , br [] []
                                      , small [] [text $ "But don't forget to add"
                                            <> " 'noreply@gonimo.com' to your address book,"
                                            <> " otherwise this invitation might end up in"
                                            <> " your spam-folder!"]
                                      ]
                              , button [ A.className "btn btn-block btn-default"
                                       , A.style [Tuple "margin-left" "0px"] ]
                                [ text $ "Oops - Did you send the invitation to the wrong recipient?"
                                , br [] []
                                , text "No problem just click me and then and then 'decline' to invalidate the link."
                                , br [] []
                                , br [] []
                                , text "TODO: how to preserve the previous one time link?"
                                ]
                              ]
                         else span [] []
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                       [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
                   , nav []
                     [ ul [ A.className "pager" ]
                       [ li [ A.className "previous"
                            , E.onClick $ const $ GoToOverview
                            ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                                    , text "Back to Overview"
                                    ]
                              ]
                       , li [ A.className "next"
                            , E.onClick $ const $ GoToBabyStation
                            ] [ a [] [ text "Make this device a baby station"
                                     , span [A.ariaHidden "true"] [text " →"]
                                     ]
                              ]
                       ]

                     ]
                   , div [A.className "jumbotron"]
                      [ div [A.className "container"]
                        [ p [] [ text "Want to add another device?" ]
                        , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ MakeNewInvitation
                                 ]
                          [ span [ A.className "glyphicon glyphicon-repeat"] []
                          , text " Generate new one-time link "
                          ]
                        ]
                      ]
                    ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: State -> Html Action
viewSent state = viewLogo $ text "Invitation sucessfully sent!"

module Gonimo.UI.Invite where

import Gonimo.UI.Html
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.Html as Html
import Gonimo.WebAPI.Types as WebAPI
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Elements as H
import Pux.Html.Events as E
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Apply ((*>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.IO (IO)
import Control.Monad.Reader.Class (ask)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (get, modify)
import Data.Either (Either(Right, Left))
import Data.Generic (gShow)
import Data.Maybe (isJust, isNothing, Maybe(..))
import Data.Tuple (uncurry, Tuple(Tuple))
import Global (encodeURIComponent, encodeURI)
import Gonimo.Client.Types (Settings, GonimoError, Gonimo, class ReportErrorAction)
import Gonimo.Pux (noEffects, onlyModify, Update, runGonimo, class MonadComponent)
import Gonimo.Server.DbEntities (Invitation(Invitation), Family(Family))
import Gonimo.Server.Types (InvitationDelivery(EmailInvitation), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (Key(Key), Secret(Secret))
import Gonimo.WebAPI (postInvitationsOutbox, postInvitationsByFamilyId, postFamilies, SPParams_(SPParams_), postAccounts, postFunnyName)
import Gonimo.WebAPI.Types (AuthData(AuthData))
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (a, button, br, i, input, p, h1, h2, h3, text, span, Html, img, div, small, li, ul, nav)
import Pux.Html.Attributes (offset)
import Servant.PureScript.Affjax (AjaxError)
import Servant.PureScript.Settings (gDefaultEncodeURLPiece, defaultSettings, SPSettings_(SPSettings_))
import Signal (constant, Signal)
import Prelude hiding (div)

type Props ps = { settings  :: Settings
                , rFamilyId :: Key Family
                , rFamily   :: Family
                , baseURL :: String
                | ps
                }

type State =
  { email          :: String
  , invitationSent :: Boolean
  , invitationId   :: Key Invitation
  , invitation   :: Invitation
  }

-- | We take our props in init to ensure the caller takes care of providing proper props.
--   Ensuring this on the first call to update is a tad to late.
init :: forall ps. Tuple (Key Invitation) Invitation -> Props ps -> State
init (Tuple invKey inv) _ = { email : ""
                            , invitationSent : false
                            , invitationId : invKey
                            , invitation : inv
                            }

data Action = SetEmail String
            | SendInvitation
            | InvitationSent
            | ReportError GonimoError
            | MakeNewInvitation
            | SetInvitationData (Key Invitation) Invitation
            | GoToOverview
            | GoToBabyStation
            | Nop

instance reportErrorActionAction :: ReportErrorAction Action where
  reportError = ReportError

update :: forall ps. Update (Props ps) State Action
update action = case action of
  (SetEmail email )         -> onlyModify $ _ { email = email, invitationSent = false }
  InvitationSent            -> handleInvitationSent
  SendInvitation            -> handleSendInvitation
  MakeNewInvitation         -> handleMakeNewInvitation
  SetInvitationData id' inv -> onlyModify $ \state -> state { invitationId = id', invitation = inv }
  GoToOverview              -> noEffects
  GoToBabyStation           -> noEffects
  ReportError err           -> noEffects
  Nop                       -> noEffects

makeInviteLink :: String -> Invitation -> String
makeInviteLink baseURL (Invitation inv) = baseURL <> "?" <> "acceptInvitation="
                                          <> gDefaultEncodeURLPiece inv.invitationSecret

handleInvitationSent :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleInvitationSent = do
  modify $ _ { invitationSent = true }
  pure [ pure MakeNewInvitation ] -- Prevent user from re-using the already sent invitation

handleMakeNewInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleMakeNewInvitation = do
  props <- ask
  runGonimo $ uncurry SetInvitationData <$> postInvitationsByFamilyId props.rFamilyId

handleSendInvitation :: forall m ps. (MonadComponent (Props ps) State m) => m (Array (IO Action))
handleSendInvitation = do
  state <- get
  runGonimo $ do
    postInvitationsOutbox $ WebAPI.SendInvitation state.invitationId (EmailInvitation state.email)
    pure InvitationSent

--------------------------------------------------------------------------------

view :: forall ps. Props ps -> State -> Html Action
view props state =
    let invitationLink = makeInviteLink (props.baseURL) state.invitation
        escapedLink = encodeURIComponent invitationLink
     in div []
                   [ div [A.className "page-header"]
                     [ div [ A.className "container"
                           , A.style [Tuple "width" "100%"]]
                       [ h3 [] [ text "Device Management"
                               , br [] []
                               , small []
                                 [ text $ "Here you can add new devices to your"
                                       <> " families, you only have to visit the"
                                       <> " following one-time link on another device." ]
                               ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "copy & paste"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "You can either copy & paste it in to your"
                                    <> " favourite messenger (e.g. WhatsApp) to"
                                    <> " send it."
                              ]
                       , div [ A.className "input-group" ]
                           [ span [ A.className "input-group-addon glyphicon glyphicon-copy", A.id_ "sdflkjsll291" ]
                             []
                           , input [ A.type_ "text", A.className "form-control", A.readOnly true
                                   , A.value invitationLink
                                   ] []
                           ]
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "Share it"]
                     , div [A.className "jumbotron"]
                       [ p [] [ text $ "Or you can share it directly with WhatsApp, Telegram .."
                              ]
                       , p []
                         [
                           H.a [ A.href $ "whatsapp://send?text=" <> escapedLink
                               ] [ H.text "Whatsapp" ]
                         , H.text " "
                         , H.a [ A.href $ "tg://msg?text=" <> escapedLink
                               ] [ H.text "Telegram" ]
                         ]
                       ]
                     ]
                   , div [A.className "container"
                         , A.style [Tuple "width" "100%"]]
                     [ h3 [] [text "email"]
                     , div [A.className "jumbotron"]
                       [ p []  [ text "Or you can let us do the work send it via email …"
                               ]
                       , div [ E.onKeyUp handleEnter ]
                         [ div [A.className "input-group"]
                           [ span [A.className "input-group-addon glyphicon glyphicon-envelope"] []
                           , input [ A.type_ "text"
                                   , A.className "form-control"
                                   , A.placeholder "mail@example.com"
                                   , E.onInput $ \ev -> SetEmail ev.target.value
                                   , A.value state.email
                                   ] []
                           ]
                         ]
                       , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ SendInvitation
                                 ]
                         [ text " Send Invitation! "
                         , span [A.className "glyphicon glyphicon-send"] []
                         ]
                       , if state.invitationSent
                         then div [ A.className "alert alert-success"]
                              [ h3 [] [text $ "Invitation sent successfully to '"
                                           <> state.email <> "'!"
                                      , br [] []
                                      , small [] [text $ "But don't forget to add"
                                            <> " 'noreply@gonimo.com' to your address book,"
                                            <> " otherwise this invitation might end up in"
                                            <> " your spam-folder!"]
                                      ]
                              , button [ A.className "btn btn-block btn-default"
                                       , A.style [Tuple "margin-left" "0px"] ]
                                [ text $ "Oops - Did you send the invitation to the wrong recipient?"
                                , br [] []
                                , text "No problem just click me and then and then 'decline' to invalidate the link."
                                , br [] []
                                , br [] []
                                , text "TODO: how to preserve the previous one time link?"
                                ]
                              ]
                         else span [] []
                       ]
                     ]
                   , div [ A.className "container"
                         , A.style [Tuple "width" "100%"]]
                       [ text "Invitation successfully transmitted? Then go back to overview or make this device a baby station right away .... " ]
                   , nav []
                     [ ul [ A.className "pager" ]
                       [ li [ A.className "previous"
                            , E.onClick $ const $ GoToOverview
                            ] [a [] [ span [A.ariaHidden "true"] [text "← "]
                                    , text "Back to Overview"
                                    ]
                              ]
                       , li [ A.className "next"
                            , E.onClick $ const $ GoToBabyStation
                            ] [ a [] [ text "Make this device a baby station"
                                     , span [A.ariaHidden "true"] [text " →"]
                                     ]
                              ]
                       ]

                     ]
                   , div [A.className "jumbotron"]
                      [ div [A.className "container"]
                        [ p [] [ text "Want to add another device?" ]
                        , button [ A.className "btn btn-block btn-info"
                                 , A.style [Tuple "margin-left" "0px"]
                                 , A.type_ "button"
                                 , E.onClick $ const $ MakeNewInvitation
                                 ]
                          [ span [ A.className "glyphicon glyphicon-repeat"] []
                          , text " Generate new one-time link "
                          ]
                        ]
                      ]
                    ]
  where
    handleEnter :: E.KeyboardEvent -> Action
    handleEnter ev = if ev.keyCode == 13 then SendInvitation else Nop

viewSent :: State -> Html Action
viewSent state = viewLogo $ text "Invitation sucessfully sent!"


Add (empty) test file

Add (empty) test file

module Test.Main where

import Control.Monad.Eff.Console

main = do
  log "You should add some tests."

error: pathspec 'test/Main.purs' did not match any file(s) known to git