Switch family on invitation accept

Switch family on invitation accept

-- TODO: Encapsulation between Loaded and Socket is very very weak! Some parts are here, some parts are there- this should be fixed!
-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError, catchError)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (gets, get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens (_Just, (.=), to, (^.), (^?), use)
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (snd, uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError(AjaxError, RegisterSessionFailed), class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.Db.Entities (Device(Device), Family(Family))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.AcceptInvitation (isAccepted)
import Gonimo.UI.Error (handleError, viewError, class ErrorAction, UserError(NoError, DeviceInvalid))
import Gonimo.UI.Loaded.Central (CentralItem, getCentrals)
import Gonimo.UI.Loaded.Types (babiesOnlineCount, mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket.Lenses (sessionId)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postSessionByFamilyIdByDeviceId, postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, i, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (offset, letterSpacing)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (ErrorDescription(ConnectionError), errorToString, AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(WebSocketOpened, HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update Init                                    = handleInit
update (SetState state)                        = put state *> pure []
update (ReportError err)                       = handleError err
update (InviteA _ InviteC.GoToOverview)        = handleRequestCentral ReqCentralOverview
update (InviteA _ InviteC.GoToBabyStation)     = handleRequestCentral ReqCentralBaby
update (InviteA _ (InviteC.ReportError err))   = handleError err
update (InviteA mProps action)                 = updateInvite mProps action
update (AcceptA AcceptC.GoToBabyStation)       = handleRequestCentral ReqCentralBaby
update (AcceptA (AcceptC.ReportError err))     = handleError err
update (AcceptA action)                        = updateAccept action
update (SocketA a@(SocketC.ReportError err))   = append <$> handleError err <*> updateSocket a
update (SocketA action)                        = updateSocket action
update (OverviewA (OverviewC.SocketA socketA)) = updateSocket socketA
update (OverviewA OverviewC.GoToInviteView)    = handleRequestCentral ReqCentralInvite
update (OverviewA action)                      = updateOverview action
update (SetFamilyIds ids)                      = handleSetFamilyIds ids
update (UpdateFamily familyId' family')        = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (RequestCentral c)                      = handleRequestCentral c
update (SetCentral c)                          = handleSetCentral c
update (SetOnlineDevices devices)              = handleSetOnlineDevices devices
update (SetDeviceInfos devices)                = handleSetDeviceInfos devices
update (SetURL url)                            = handleSetURL url
update (HandleSubscriber msg)                  = handleSubscriber msg
update ResetDevice                             = handleResetDevice
update ClearError                              = handleClearError
update Nop                                     = noEffects

toInvite :: InviteProps -> ToChild Unit State InviteProps InviteC.State
toInvite props = pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toOverview :: ToChild Unit State Props OverviewC.State
toOverview = do
  props <- mkProps <$> get
  pure $ makeChildData overviewS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: Maybe InviteProps -> InviteC.Action -> ComponentType Unit State Action
updateInvite mProps iAction = do
  state <- get :: Component Unit State State
  let props = mkInviteProps state <|> mProps -- State props have higher priority!
  case props of
    Nothing -> pure $
              [ toIO (mkSettings $ state^.authData) $ do
                    name <- postFunnyName
                    fid' <- postFamilies name
                    family' <- getFamiliesByFamilyId fid'
                    let newProps = mkInviteProps' fid' family' state
                    pure $ InviteA (Just newProps) iAction
              ]
    Just rProps ->
      toParent [] (InviteA Nothing) <<< liftChild (toInvite rProps) <<< InviteC.update $ iAction

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept action = do
  case action of
    AcceptC.EnteredFamily familyId' -> currentFamily .= familyId'
    _                               -> pure unit
  toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update $ action

updateOverview :: OverviewC.Action -> ComponentType Unit State Action
updateOverview = toParent [] OverviewA <<< liftChild toOverview <<< OverviewC.update

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleInit :: ComponentType Unit State Action
handleInit = pure []

handleSubscriber :: Notification -> ComponentType Unit State Action
handleSubscriber notification = do
  append <$> Error.handleSubscriber notification
         <*> updateSocket (SocketC.HandleSubscriber notification)

handleSetDeviceInfos :: Array (Tuple (Key Device) DeviceInfo) -> ComponentType Unit State Action
handleSetDeviceInfos devices = do
  modify $ _ { deviceInfos = devices }
  if Arr.length devices <=1
    then doAutoSwitchCentral ReqCentralInvite
    else pure []

handleSetOnlineDevices :: Array (Tuple (Key Device) DeviceType) -> ComponentType Unit State Action
handleSetOnlineDevices devices = do
  modify $ _ { onlineDevices = devices }
  let isBaby dev = case dev of
        Baby _ -> true
        _    -> false
  let babies = Arr.filter (isBaby <<< snd) devices
  let babyCount = Arr.length babies
  prevBabyCount <- use babiesOnlineCount
  weAreBaby <- use (socketS<<<to SocketC.toDeviceType <<< to isBaby)
  babiesOnlineCount .= babyCount
  if babyCount > prevBabyCount && not weAreBaby
    then doAutoSwitchCentral ReqCentralOverview
    else pure []

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleRequestCentral :: CentralReq -> ComponentType Unit State Action
handleRequestCentral c = do
  state <- get
  r <- case c of
    ReqCentralInvite   -> do
      let invProps = mkInviteProps state
      case invProps of
        Nothing    -> pure
                   [ toIO (mkSettings $ state^.authData) $ do
                        name <- postFunnyName
                        fid' <- postFamilies name
                        family' <- getFamiliesByFamilyId fid'
                        let newProps = mkInviteProps' fid' family' state
                        invData <- postInvitationsByFamilyId fid'
                        pure <<< SetCentral <<< CentralInvite $ (InviteC.init invData newProps)
                   ]
        Just props -> pure
                      [ toIO (mkSettings $ state^.authData) $ do
                           invData <- postInvitationsByFamilyId props.rFamilyId
                           pure <<< SetCentral $ CentralInvite (InviteC.init invData props)
                      ]
    ReqCentralOverview -> handleSetCentral CentralOverview
    ReqCentralBaby     -> do
                          handleSetCentral CentralBaby
                          pure [ pure $ SocketA SocketC.GetUserMedia ]
  case Tuple state.central c of
    Tuple CentralBaby ReqCentralBaby -> pure r
    Tuple CentralBaby _              -> pure $ [ pure $ SocketA SocketC.StopUserMedia ] <> r
    Tuple _ _                        -> pure r

handleSetCentral :: Central -> ComponentType Unit State Action
handleSetCentral central' = central .= central' *> noEffects

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  let switchFamily
        = if isNothing state.socketS.currentFamily
          then fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
          else []
  if Arr.null ids
    then doAutoSwitchCentral ReqCentralInvite
    else pure switchFamily

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 }
      actions <- handleSetCentral $ CentralAccept (AcceptC.init)
      pure $ [ do
               liftEff $ navigateTo withoutQuery
               inviteEffect s
             ] <> actions

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept (Just _) -> state.central
      _                     -> CentralOverview

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

-- Switch central if it is safe to do so. Use this function if you want to switch the central
-- automatically - not by user request.
doAutoSwitchCentral :: CentralReq -> ComponentType Unit State Action
doAutoSwitchCentral req = do
  mycentral <- use central
  case mycentral of
    CentralAccept acceptS' -> if isAccepted acceptS'
                              then handleRequestCentral req
                              else pure []
    _               -> handleRequestCentral req
--------------------------------------------------------------------------------

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewCentral state
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
    -- Brand and toggle get grouped for better mobile display --
          [ div [ A.className "navbar-header"]
            [ burgerButton
            , a [ A.className "navbar-brand"]
              [ img [ A.alt "gonimo"
                    , A.src "./pix/gonimo-brand-01.svg"
                    , A.width "45px"
                    , A.height "45px"
                    , A.style [Tuple "padding" "5px 7.5px 0px 7.5px"]
                    ] []
              ]
            ]

    -- Collect the nav links, forms, and other content for toggling --
          , div [ A.className "collapse navbar-collapse"
                , A.id_ "navbarmenu"
                , A.style [Tuple "width" "100%"]
                , A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"
                ]
            [ ul [ A.className "nav navbar-nav"] $ (viewCentralItem <$> getCentrals state) <>
              [ viewFamilyChooser state
        --      , viewUserSettings
              ]
            ]
          ]
        ]

  where
    burgerButton :: Html Action
    burgerButton = button [ A.type_ "button"
                          , A.className "navbar-toggle collapsed"
                          , A.dataToggle "collapse"
                          , A.dataTarget "#navbarmenu"
                          , A.ariaExpanded "false"
                          ]
                   [ span [A.className "sr-only"] [text "Toggle navigation"]
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   ]
    viewCentralItem :: CentralItem -> Html Action
    viewCentralItem item =
      if item.enabled
      then
        li (if item.selected then [ A.className "active" ] else []
            <>    [ A.dataToggle "collapse"
                  , A.dataTarget ".navbar-collapse.in"
                  ]
          )
          [ a [ E.onClick <<< const $ RequestCentral item.req
              , A.type_ "button", A.role "button"
              ]
            [ text $ userShow item.req ]
          ]
      else span [] []

viewUserSettings :: Html Action
viewUserSettings =
  li [A.className "dropdown navbar-right"]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-user"] []
    , text " "
    , text "Max Mustermann"
    , text " "
    , span [A.className "caret"] []
    ]
  , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
    [ li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change user settings (WIP)"]]
    , li [A.className "disabled"] [a [] [text " User settings "
                  ,i [A.className "fa fa-fw fa-cog pull-right"] []]]
    , li [A.className "disabled"] [ a [] [ text "Change password "
                   , i [A.className "fa fa-fw fa-lock pull-right" ][]
                   ]]
    , li [A.className "divider", A.role "separator"] []
    , li [A.className "disabled"] [a [] [ text "Log-Out "
                  , i [A.className "fa fa-fw fa-sign-out pull-right"] []
                  ]]
    ]
  ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
    invProps = mkInviteProps state
  in
   case state.central of
    CentralInvite s -> case invProps of
      Nothing -> viewLoading "Loading, please wait ..."
      Just invProps' -> map (InviteA Nothing) $ InviteC.view invProps' s
    CentralAccept s -> map AcceptA $ AcceptC.view props s
    CentralOverview     -> map OverviewA   $ OverviewC.view props state.overviewS
    CentralBaby     -> map SocketA   $ SocketC.view props state.socketS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-striped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [
               -- th [ A.className "centered"] [ text "Online" ]
             -- , th [ A.className "centered"] [ text "Type" ]
               th [] [ text "Name" ]
             , th [] [ text "Last Seen"]
             -- , th [] []
             -- , th [] []
             -- , th [] []
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [
                 -- td [A.className "centered"] [ i [ A.className ("fa fa-" <> "circle-o") -- "check-circle"
                 --       , A.dataToggle "tooltip"
                 --       , A.dataPlacement "right"
                 --       , A.title "offline" ] []]
                 --       --, A.title "online" ] []]
               -- , td [A.className "centered"]
               --     [ i [ A.className ("fa fa-fw fa-" <> "mobile")
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
                 td [] [ text name ]
               , td [] [ text lastAccessed ]
               -- , td [] [ i [ A.className "fa fa-fw fa-pencil"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
               -- , td [] [ i [ A.className "fa fa-fw fa-trash"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "delete device from family" ] []]
               --
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state =
  li [ A.className "dropdown"
     , A.dataToggle "collapse"
     ]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-users"] []
    , text " "
    , text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)
    {--, span [] [text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)]--}
    , text " "
    , span [A.className "caret"] [] ]
    , H.ul [A.className "dropdown-menu"] $
        [li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change family to"]]]
        <> (fromFoldable <<< map (uncurry (viewFamily state.socketS.currentFamily))
                         <<< Map.toList $ state.families)
  ]
  where
    doSwitchFamily :: Key Family -> Action
    doSwitchFamily = SocketA <<< SocketC.SwitchFamily

    viewFamily :: Maybe (Key Family) -> Key Family -> Family -> Html Action
    viewFamily currentFamilyId familyId (Family family) =
        li [] [a [E.onClick $ const $ doSwitchFamily familyId ] $
                 [text family.familyName] <> if Just familyId == currentFamilyId
                                                then [text " ✔"]
                                                else []
              ]

--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily
    sessionId' = state^.socketS<<<sessionId
    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $ do
           _ <- sessionId' -- Avoid error message `FamilyNotOnline` when not yet ready.
           Sub.getSessionByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< to SocketC.toDeviceType
    sessionId'    = state ^. socketS <<< to _.sessionId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.putSessionByFamilyIdByDeviceIdBySessionId onlineStatus'
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _       -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
    sessionId' = state ^. socketS <<< to _.sessionId
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.deleteSessionByFamilyIdByDeviceIdBySessionId
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d

-- TODO: Encapsulation between Loaded and Socket is very very weak! Some parts are here, some parts are there- this should be fixed!
-- | Loaded application ui logic
module Gonimo.UI.Loaded where

import Gonimo.UI.Html
import Data.Array as Arr
import Data.List as List
import Data.Map as Map
import Data.Tuple as Tuple
import Gonimo.Client.Effects as Gonimo
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.LocalStorage as Key
import Gonimo.Client.Router as Router
import Gonimo.Client.Types as Gonimo
import Gonimo.UI.AcceptInvitation as AcceptC
import Gonimo.UI.Error as Error
import Gonimo.UI.Invite as InviteC
import Gonimo.UI.Overview as OverviewC
import Gonimo.UI.Socket as SocketC
import Gonimo.UI.Socket.Channel as ChannelC
import Gonimo.UI.Socket.Lenses as SocketC
import Gonimo.UI.Socket.Types as SocketC
import Gonimo.WebAPI.MakeRequests as Reqs
import Gonimo.WebAPI.Subscriber as Sub
import Pux.Html as H
import Pux.Html.Attributes as A
import Pux.Html.Attributes.Aria as A
import Pux.Html.Attributes.Bootstrap as A
import Pux.Html.Events as E
import Servant.PureScript.Affjax as Affjax
import Servant.Subscriber as Sub
import Servant.Subscriber.Connection as Sub
import Browser.LocalStorage (STORAGE, localStorage)
import Control.Alt ((<|>))
import Control.Monad.Aff (Aff)
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Class (liftEff)
import Control.Monad.Error.Class (throwError, catchError)
import Control.Monad.Except.Trans (runExceptT)
import Control.Monad.Reader (runReader)
import Control.Monad.Reader.Class (class MonadReader)
import Control.Monad.Reader.Trans (runReaderT)
import Control.Monad.State.Class (gets, get, modify, put)
import Data.Argonaut.Generic.Aeson (decodeJson)
import Data.Array (fromFoldable, concat, catMaybes, head)
import Data.Bifunctor (bimap)
import Data.Either (either, Either(Right, Left))
import Data.Foldable (foldl)
import Data.Generic (class Generic)
import Data.Generic (gShow)
import Data.Lens (_Just, (.=), to, (^.), (^?), use)
import Data.Map (Map)
import Data.Maybe (fromMaybe, isNothing, maybe, Maybe(..))
import Data.Monoid (mempty)
import Data.Profunctor (lmap)
import Data.Semigroup (append)
import Data.String (takeWhile)
import Data.Traversable (traverse)
import Data.Tuple (snd, uncurry, fst, Tuple(Tuple))
import Debug.Trace (trace)
import Gonimo.Client.Types (toIO, Settings, GonimoError(AjaxError, RegisterSessionFailed), class ReportErrorAction, Gonimo)
import Gonimo.Pux (noEffects, Component, toParent, runGonimo, liftChild, ComponentType, makeChildData, ToChild, onlyModify, Update, wrapAction)
import Gonimo.Server.Db.Entities (Device(Device), Family(Family))
import Gonimo.Server.Db.Entities.Helpers (runFamily)
import Gonimo.Server.Error (ServerError(InvalidAuthToken))
import Gonimo.Server.Types (DeviceType(Baby, NoBaby), AuthToken, AuthToken(GonimoSecret))
import Gonimo.Types (dateToString, Key(Key), Secret(Secret))
import Gonimo.UI.AcceptInvitation (isAccepted)
import Gonimo.UI.Error (handleError, viewError, class ErrorAction, UserError(NoError, DeviceInvalid))
import Gonimo.UI.Loaded.Central (CentralItem, getCentrals)
import Gonimo.UI.Loaded.Types (babiesOnlineCount, mkInviteProps', CentralReq(..), mkInviteProps, mkSettings, mkProps, central, familyIds, authData, currentFamily, socketS, overviewS, Props, acceptS, inviteS, State, Action(..), Central(..), InviteProps)
import Gonimo.UI.Socket.Lenses (sessionId)
import Gonimo.Util (userShow, toString, fromString)
import Gonimo.WebAPI (postSessionByFamilyIdByDeviceId, postInvitationsByFamilyId, postFamilies, getFamiliesByFamilyId, postFunnyName, SPParams_(SPParams_), postAccounts)
import Gonimo.WebAPI.Types (DeviceInfo(DeviceInfo), AuthData(AuthData))
import Gonimo.WebAPI.Types.Helpers (runAuthData)
import Partial.Unsafe (unsafeCrashWith)
import Pux (renderToDOM, fromSimple, start)
import Pux.Html (text, small, script, li, i, a, nav, h3, h2, td, tbody, th, tr, thead, table, ul, p, button, input, h1, span, Html, img, div)
import Pux.Html.Attributes (offset, letterSpacing)
import Pux.Html.Events (FormEvent, FocusEvent)
import Pux.Router (navigateTo)
import Servant.PureScript.Affjax (ErrorDescription(ConnectionError), errorToString, AjaxError)
import Servant.PureScript.Settings (defaultSettings, SPSettings_(SPSettings_))
import Servant.Subscriber (Subscriber)
import Servant.Subscriber.Connection (Notification(WebSocketOpened, HttpRequestFailed, ParseError, WebSocketClosed, WebSocketError))
import Servant.Subscriber.Internal (doDecode, coerceEffects)
import Servant.Subscriber.Request (HttpRequest(HttpRequest))
import Servant.Subscriber.Response (HttpResponse(HttpResponse))
import Servant.Subscriber.Subscriptions (Subscriptions)
import Servant.Subscriber.Util (toUserType)
import Signal (constant, Signal)
import Prelude hiding (div)

update :: Update Unit State Action
update Init                                    = handleInit
update (SetState state)                        = put state *> pure []
update (ReportError err)                       = handleError err
update (InviteA _ InviteC.GoToOverview)        = handleRequestCentral ReqCentralOverview
update (InviteA _ InviteC.GoToBabyStation)     = handleRequestCentral ReqCentralBaby
update (InviteA _ (InviteC.ReportError err))   = handleError err
update (InviteA mProps action)                 = updateInvite mProps action
update (AcceptA AcceptC.GoToBabyStation)       = handleRequestCentral ReqCentralBaby
update (AcceptA (AcceptC.ReportError err))     = handleError err
update (AcceptA action)                        = updateAccept action
update (SocketA a@(SocketC.ReportError err))   = append <$> handleError err <*> updateSocket a
update (SocketA action)                        = updateSocket action
update (OverviewA (OverviewC.SocketA socketA)) = updateSocket socketA
update (OverviewA OverviewC.GoToInviteView)    = handleRequestCentral ReqCentralInvite
update (OverviewA action)                      = updateOverview action
update (SetFamilyIds ids)                      = handleSetFamilyIds ids
update (UpdateFamily familyId' family')        = onlyModify $ \state ->  state { families = Map.insert familyId' family' state.families }
update (RequestCentral c)                      = handleRequestCentral c
update (SetCentral c)                          = handleSetCentral c
update (SetOnlineDevices devices)              = handleSetOnlineDevices devices
update (SetDeviceInfos devices)                = handleSetDeviceInfos devices
update (SetURL url)                            = handleSetURL url
update (HandleSubscriber msg)                  = handleSubscriber msg
update ResetDevice                             = handleResetDevice
update ClearError                              = handleClearError
update Nop                                     = noEffects

toInvite :: InviteProps -> ToChild Unit State InviteProps InviteC.State
toInvite props = pure $ makeChildData inviteS props

toAccept :: ToChild Unit State Props AcceptC.State
toAccept = do
  props <- mkProps <$> get
  pure $ makeChildData acceptS props

toOverview :: ToChild Unit State Props OverviewC.State
toOverview = do
  props <- mkProps <$> get
  pure $ makeChildData overviewS props

toSocket :: ToChild Unit State Props SocketC.State
toSocket = do
  props <- mkProps <$> get
  pure $ makeChildData socketS props

updateInvite :: Maybe InviteProps -> InviteC.Action -> ComponentType Unit State Action
updateInvite mProps iAction = do
  state <- get :: Component Unit State State
  let props = mkInviteProps state <|> mProps -- State props have higher priority!
  case props of
    Nothing -> pure $
              [ toIO (mkSettings $ state^.authData) $ do
                    name <- postFunnyName
                    fid' <- postFamilies name
                    family' <- getFamiliesByFamilyId fid'
                    let newProps = mkInviteProps' fid' family' state
                    pure $ InviteA (Just newProps) iAction
              ]
    Just rProps ->
      toParent [] (InviteA Nothing) <<< liftChild (toInvite rProps) <<< InviteC.update $ iAction

updateAccept :: AcceptC.Action -> ComponentType Unit State Action
updateAccept = toParent [] AcceptA <<< liftChild toAccept <<< AcceptC.update

updateOverview :: OverviewC.Action -> ComponentType Unit State Action
updateOverview = toParent [] OverviewA <<< liftChild toOverview <<< OverviewC.update

updateSocket :: SocketC.Action -> ComponentType Unit State Action
updateSocket action = do
  case action of
    SocketC.SetAuthData _ -> handleSetAuthData
    _ -> pure unit
  toParent [] SocketA <<< liftChild toSocket $ SocketC.update action

inviteEffect :: forall m. Monad m => Secret -> m Action
inviteEffect = pure <<< AcceptA <<< AcceptC.LoadInvitation

handleInit :: ComponentType Unit State Action
handleInit = pure []

handleSubscriber :: Notification -> ComponentType Unit State Action
handleSubscriber notification = do
  append <$> Error.handleSubscriber notification
         <*> updateSocket (SocketC.HandleSubscriber notification)

handleSetDeviceInfos :: Array (Tuple (Key Device) DeviceInfo) -> ComponentType Unit State Action
handleSetDeviceInfos devices = do
  modify $ _ { deviceInfos = devices }
  if Arr.length devices <=1
    then doAutoSwitchCentral ReqCentralInvite
    else pure []

handleSetOnlineDevices :: Array (Tuple (Key Device) DeviceType) -> ComponentType Unit State Action
handleSetOnlineDevices devices = do
  modify $ _ { onlineDevices = devices }
  let isBaby dev = case dev of
        Baby _ -> true
        _    -> false
  let babies = Arr.filter (isBaby <<< snd) devices
  let babyCount = Arr.length babies
  prevBabyCount <- use babiesOnlineCount
  weAreBaby <- use (socketS<<<to SocketC.toDeviceType <<< to isBaby)
  babiesOnlineCount .= babyCount
  if babyCount > prevBabyCount && not weAreBaby
    then doAutoSwitchCentral ReqCentralOverview
    else pure []

handleResetDevice :: ComponentType Unit State Action
handleResetDevice = do
  props <- mkProps <$> get :: Component Unit State State
  pure $ [ toIO props.settings $ do
              liftEff $ localStorage.removeItem Key.authData
              SocketA <<< SocketC.SetAuthData <$> getAuthData
         ]

handleRequestCentral :: CentralReq -> ComponentType Unit State Action
handleRequestCentral c = do
  state <- get
  r <- case c of
    ReqCentralInvite   -> do
      let invProps = mkInviteProps state
      case invProps of
        Nothing    -> pure
                   [ toIO (mkSettings $ state^.authData) $ do
                        name <- postFunnyName
                        fid' <- postFamilies name
                        family' <- getFamiliesByFamilyId fid'
                        let newProps = mkInviteProps' fid' family' state
                        invData <- postInvitationsByFamilyId fid'
                        pure <<< SetCentral <<< CentralInvite $ (InviteC.init invData newProps)
                   ]
        Just props -> pure
                      [ toIO (mkSettings $ state^.authData) $ do
                           invData <- postInvitationsByFamilyId props.rFamilyId
                           pure <<< SetCentral $ CentralInvite (InviteC.init invData props)
                      ]
    ReqCentralOverview -> handleSetCentral CentralOverview
    ReqCentralBaby     -> do
                          handleSetCentral CentralBaby
                          pure [ pure $ SocketA SocketC.GetUserMedia ]
  case Tuple state.central c of
    Tuple CentralBaby ReqCentralBaby -> pure r
    Tuple CentralBaby _              -> pure $ [ pure $ SocketA SocketC.StopUserMedia ] <> r
    Tuple _ _                        -> pure r

handleSetCentral :: Central -> ComponentType Unit State Action
handleSetCentral central' = central .= central' *> noEffects

handleSetAuthData :: Component Unit State Unit
handleSetAuthData = modify $ \state -> state
                                  {
                                   userError = case state.userError of
                                      DeviceInvalid -> NoError
                                      _ -> state.userError
                                  }
handleSetFamilyIds :: Array (Key Family) -> ComponentType Unit State Action
handleSetFamilyIds ids = do
  familyIds .= ids
  state <- get :: Component Unit State State
  let switchFamily
        = if isNothing state.socketS.currentFamily
          then fromFoldable $ pure <<< SocketA <<< SocketC.SwitchFamily <$> Arr.head ids
          else []
  if Arr.null ids
    then doAutoSwitchCentral ReqCentralInvite
    else pure switchFamily

handleSetURL :: String -> ComponentType Unit State Action
handleSetURL url = do
  let
    route = Router.match url
    withoutQuery = takeWhile (_ /= '?') url
  case route of
    Router.Home -> onlyModify $ _ { url = url }
    Router.AcceptInvitation s -> do
      modify $ _ { url = withoutQuery
                 }
      actions <- handleSetCentral $ CentralAccept (AcceptC.init)
      pure $ [ do
               liftEff $ navigateTo withoutQuery
               inviteEffect s
             ] <> actions

handleClearError :: ComponentType Unit State Action
handleClearError = do
  state <- (get :: Component Unit State State)
  let
    newCentral = case state.central of
      CentralAccept (Just _) -> state.central
      _                     -> CentralOverview

  onlyModify $ _ { userError = NoError
                 , central = newCentral
                 }

-- Switch central if it is safe to do so. Use this function if you want to switch the central
-- automatically - not by user request.
doAutoSwitchCentral :: CentralReq -> ComponentType Unit State Action
doAutoSwitchCentral req = do
  mycentral <- use central
  case mycentral of
    CentralAccept acceptS' -> if isAccepted acceptS'
                              then handleRequestCentral req
                              else pure []
    _               -> handleRequestCentral req
--------------------------------------------------------------------------------

view :: State -> Html Action
view state =
  let
    numDevices = Arr.length state.onlineDevices
  in
    case state.userError of
      NoError ->
        div []
        [ viewHeader state
        , viewCentral state
        , div []
          [ h3 [] [ text $ show numDevices <> " Device(s) currently online:" ]
          , div [] [ viewOnlineDevices state ]
          ]
        ]
      err -> viewError state

viewHeader :: State -> Html Action
viewHeader state =
      nav [ A.className "navbar navbar-default" ]
      [ div [ A.className "container"]
    -- Brand and toggle get grouped for better mobile display --
          [ div [ A.className "navbar-header"]
            [ burgerButton
            , a [ A.className "navbar-brand"]
              [ img [ A.alt "gonimo"
                    , A.src "./pix/gonimo-brand-01.svg"
                    , A.width "45px"
                    , A.height "45px"
                    , A.style [Tuple "padding" "5px 7.5px 0px 7.5px"]
                    ] []
              ]
            ]

    -- Collect the nav links, forms, and other content for toggling --
          , div [ A.className "collapse navbar-collapse"
                , A.id_ "navbarmenu"
                , A.style [Tuple "width" "100%"]
                , A.dataToggle "collapse"
                , A.dataTarget ".navbar-collapse.in"
                ]
            [ ul [ A.className "nav navbar-nav"] $ (viewCentralItem <$> getCentrals state) <>
              [ viewFamilyChooser state
        --      , viewUserSettings
              ]
            ]
          ]
        ]

  where
    burgerButton :: Html Action
    burgerButton = button [ A.type_ "button"
                          , A.className "navbar-toggle collapsed"
                          , A.dataToggle "collapse"
                          , A.dataTarget "#navbarmenu"
                          , A.ariaExpanded "false"
                          ]
                   [ span [A.className "sr-only"] [text "Toggle navigation"]
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   , span [A.className "icon-bar"] []
                   ]
    viewCentralItem :: CentralItem -> Html Action
    viewCentralItem item =
      if item.enabled
      then
        li (if item.selected then [ A.className "active" ] else []
            <>    [ A.dataToggle "collapse"
                  , A.dataTarget ".navbar-collapse.in"
                  ]
          )
          [ a [ E.onClick <<< const $ RequestCentral item.req
              , A.type_ "button", A.role "button"
              ]
            [ text $ userShow item.req ]
          ]
      else span [] []

viewUserSettings :: Html Action
viewUserSettings =
  li [A.className "dropdown navbar-right"]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-user"] []
    , text " "
    , text "Max Mustermann"
    , text " "
    , span [A.className "caret"] []
    ]
  , ul [A.className "dropdown-menu", A.style [Tuple "minWidth" "180px"]]
    [ li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change user settings (WIP)"]]
    , li [A.className "disabled"] [a [] [text " User settings "
                  ,i [A.className "fa fa-fw fa-cog pull-right"] []]]
    , li [A.className "disabled"] [ a [] [ text "Change password "
                   , i [A.className "fa fa-fw fa-lock pull-right" ][]
                   ]]
    , li [A.className "divider", A.role "separator"] []
    , li [A.className "disabled"] [a [] [ text "Log-Out "
                  , i [A.className "fa fa-fw fa-sign-out pull-right"] []
                  ]]
    ]
  ]

viewCentral :: State -> Html Action
viewCentral state =
  let
    props = mkProps state
    invProps = mkInviteProps state
  in
   case state.central of
    CentralInvite s -> case invProps of
      Nothing -> viewLoading "Loading, please wait ..."
      Just invProps' -> map (InviteA Nothing) $ InviteC.view invProps' s
    CentralAccept s -> map AcceptA $ AcceptC.view props s
    CentralOverview     -> map OverviewA   $ OverviewC.view props state.overviewS
    CentralBaby     -> map SocketA   $ SocketC.view props state.socketS

viewOnlineDevices :: State -> Html Action
viewOnlineDevices state = table [ A.className "table table-striped"]
                          [ head
                          , body
                          ]
  where
    head = thead []
           [ tr []
             [
               -- th [ A.className "centered"] [ text "Online" ]
             -- , th [ A.className "centered"] [ text "Type" ]
               th [] [ text "Name" ]
             , th [] [ text "Last Seen"]
             -- , th [] []
             -- , th [] []
             -- , th [] []
             ]
           ]
    body = tbody []
           <<< Arr.mapMaybe viewOnlineDevice
           $ map fst state.onlineDevices
    viewOnlineDevice deviceId = do
        (DeviceInfo info) <- Tuple.lookup deviceId state.deviceInfos
        let name = info.deviceInfoName
        let lastAccessed = dateToString info.deviceInfoLastAccessed
        pure $ tr []
               [
                 -- td [A.className "centered"] [ i [ A.className ("fa fa-" <> "circle-o") -- "check-circle"
                 --       , A.dataToggle "tooltip"
                 --       , A.dataPlacement "right"
                 --       , A.title "offline" ] []]
                 --       --, A.title "online" ] []]
               -- , td [A.className "centered"]
               --     [ i [ A.className ("fa fa-fw fa-" <> "mobile")
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
                 td [] [ text name ]
               , td [] [ text lastAccessed ]
               -- , td [] [ i [ A.className "fa fa-fw fa-pencil"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "edit device name" ] []
               --         ]
               -- , td [] [ i [ A.className "fa fa-fw fa-trash"
               --         , A.dataToggle "tooltip"
               --         , A.dataPlacement "right"
               --         , A.title "delete device from family" ] []]
               --
               ]

viewFamilyChooser :: State -> Html Action
viewFamilyChooser state =
  li [ A.className "dropdown"
     , A.dataToggle "collapse"
     ]
  [ a [ A.className "dropdown-toggle"
      , A.href "#"
      , A.role "button"
      , A.dataToggle "dropdown"
      , A.type_ "button"
      ]
    [ i [A.className "fa fa-fw fa-users"] []
    , text " "
    , text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)
    {--, span [] [text $ fromMaybe "" $ _.familyName <<< runFamily <$> (state.socketS.currentFamily >>= flip Map.lookup state.families)]--}
    , text " "
    , span [A.className "caret"] [] ]
    , H.ul [A.className "dropdown-menu"] $
        [li [A.dataToggle "collapse"] [div [A.className "dropdown-header"] [text "Change family to"]]]
        <> (fromFoldable <<< map (uncurry (viewFamily state.socketS.currentFamily))
                         <<< Map.toList $ state.families)
  ]
  where
    doSwitchFamily :: Key Family -> Action
    doSwitchFamily = SocketA <<< SocketC.SwitchFamily

    viewFamily :: Maybe (Key Family) -> Key Family -> Family -> Html Action
    viewFamily currentFamilyId familyId (Family family) =
        li [] [a [E.onClick $ const $ doSwitchFamily familyId ] $
                 [text family.familyName] <> if Just familyId == currentFamilyId
                                                then [text " ✔"]
                                                else []
              ]

--------------------------------------------------------------------------------
getSubscriptions :: State -> Subscriptions Action
getSubscriptions state =
  let
    familyId = state^?currentFamily
    sessionId' = state^.socketS<<<sessionId
    --subscribeGetFamily :: forall m. MonadReader Settings m => Key Family -> m (Subscriptions Action)
    subscribeGetFamily familyId' =
      Sub.getFamiliesByFamilyId (maybe Nop (UpdateFamily familyId')) familyId'

    subArray :: Array (Subscriptions Action)
    subArray = map (flip runReader (mkSettings $ state^.authData)) <<< concat $
      [ [ Sub.getAccountsByAccountIdFamilies (maybe Nop SetFamilyIds)
                                          (runAuthData $ state^.authData).accountId
        ]
      , fromFoldable $ do
           _ <- sessionId' -- Avoid error message `FamilyNotOnline` when not yet ready.
           Sub.getSessionByFamilyId (maybe Nop SetOnlineDevices) <$> familyId
      , fromFoldable $
        Sub.getFamiliesByFamilyIdDeviceInfos (maybe Nop SetDeviceInfos) <$> familyId
      , map subscribeGetFamily state.familyIds
      ]
  in
   case state.userError of
     NoError -> foldl append mempty subArray <> map SocketA (SocketC.getSubscriptions (mkProps state) state.socketS)
     _       -> mempty

getPongRequest :: State -> Maybe HttpRequest
getPongRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    onlineStatus' = state ^. socketS <<< to SocketC.toDeviceType
    sessionId'    = state ^. socketS <<< to _.sessionId
    familyId = state^?currentFamily
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.putSessionByFamilyIdByDeviceIdBySessionId onlineStatus'
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _       -> Nothing

getCloseRequest :: State -> Maybe HttpRequest
getCloseRequest state =
  let
    deviceId = (runAuthData $ state^.authData).deviceId
    familyId = state^?currentFamily
    sessionId' = state ^. socketS <<< to _.sessionId
  in
   case state.userError of
     NoError -> flip runReader (mkSettings $ state^.authData) <$>
                ( Reqs.deleteSessionByFamilyIdByDeviceIdBySessionId
                  <$> familyId
                  <*> pure deviceId
                  <*> sessionId'
                )
     _ -> Nothing

-- | Retrieve AuthData from local storage or if not present get new one from server
getAuthData :: Gonimo AuthData
getAuthData = do
  md <- liftEff $ localStorage.getItem Key.authData
  Gonimo.log $ "Got authdata from local storage: " <> gShow md
  case md of
    Nothing -> do
      auth <- postAccounts
      Gonimo.log $ "Got Nothing - called postAccounts and got: " <> gShow auth
      Gonimo.log $ "Calling setItem with : " <> gShow Key.authData
      liftEff $ localStorage.setItem Key.authData auth
      pure auth
    Just d  -> pure d


Job is now type instead of newtype.

Job is now type instead of newtype.

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/0dB/cats-utils.git/'


Name generation

Name generation

module Data.DOM.Name
  ( Element()
  , Attribute()
  , Name()
  , Content()
  , AttributeKey()
  , IsValue

  , a
  , div
  , p
  , img

  , href
  , href'
  , _class
  , src
  , width
  , height
  , name

  , (:=)
  , text
  , elem
  , newName

  , runName

  , render
  ) where

import Data.Maybe
import Data.Tuple (snd)
import Data.Array (map)
import Data.String (joinWith)
import Data.Foldable (for_)

import Control.Monad.Free
import Control.Monad.RWS
import Control.Monad.RWS.Class

newtype Element = Element
  { name         :: String
  , attribs      :: [Attribute]
  , content      :: Maybe (Content Unit)
  }

newtype Name = Name String

runName :: Name -> String
runName (Name n) = n

data ContentF a
  = TextContent String a
  | ElementContent Element a
  | NewName (Name -> a)

instance functorContentF :: Functor ContentF where
  (<$>) f (TextContent s a) = TextContent s (f a)
  (<$>) f (ElementContent e a) = ElementContent e (f a)
  (<$>) f (NewName k) = NewName (f <<< k)

newtype Content a = Content (Free ContentF a)

runContent :: forall a. Content a -> Free ContentF a
runContent (Content x) = x

instance functorContent :: Functor Content where
  (<$>) f (Content x) = Content (f <$> x)

instance applyContent :: Apply Content where
  (<*>) (Content f) (Content x) = Content (f <*> x)

instance applicativeContent :: Applicative Content where
  pure = Content <<< pure

instance bindContent :: Bind Content where
  (>>=) (Content x) f = Content (x >>= (runContent <<< f))

instance monadContent :: Monad Content

newtype Attribute = Attribute
  { key          :: String
  , value        :: String
  }

newtype AttributeKey a = AttributeKey String

element :: String -> [Attribute] -> Maybe (Content Unit) -> Element
element name attribs content = Element
  { name:      name
  , attribs:   attribs
  , content:   content
  }

text :: String -> Content Unit
text s = Content $ liftF $ TextContent s unit

elem :: Element -> Content Unit
elem e = Content $ liftF $ ElementContent e unit

newName :: Content Name
newName = Content $ liftF $ NewName id

class IsValue a where
  toValue :: a -> String

instance stringIsValue :: IsValue String where
  toValue = id

instance numberIsValue :: IsValue Number where
  toValue = show

instance nameIsValue :: IsValue Name where
  toValue (Name n) = "#" ++ n

(:=) :: forall a. (IsValue a) => AttributeKey a -> a -> Attribute
(:=) (AttributeKey key) value = Attribute
  { key: key
  , value: toValue value
  }

a :: [Attribute] -> Content Unit -> Element
a attribs content = element "a" attribs (Just content)

div :: [Attribute] -> Content Unit -> Element
div attribs content = element "div" attribs (Just content)

p :: [Attribute] -> Content Unit -> Element
p attribs content = element "p" attribs (Just content)

img :: [Attribute] -> Element
img attribs = element "img" attribs Nothing

href :: AttributeKey String
href = AttributeKey "href"

href' :: AttributeKey Name
href' = AttributeKey "href"

name :: AttributeKey String
name = AttributeKey "name"

_class :: AttributeKey String
_class = AttributeKey "class"

src :: AttributeKey String
src = AttributeKey "src"

width :: AttributeKey Number
width = AttributeKey "width"

height :: AttributeKey Number
height = AttributeKey "height"

type Interp = RWS Unit String Number

render :: Element -> String
render e = snd $ evalRWS (renderElement e) unit 0
  where
  renderElement :: Element -> Interp Unit
  renderElement (Element e) = do
    tell "<"
    tell e.name
    for_ e.attribs $ \a -> do
      tell " "
      renderAttribute a
    renderContent e.content

    where
    renderAttribute :: Attribute -> Interp Unit
    renderAttribute (Attribute a) = do
      tell a.key
      tell "=\""
      tell a.value
      tell "\""

    renderContent :: Maybe (Content Unit) -> Interp Unit
    renderContent Nothing = tell " />"
    renderContent (Just (Content content)) = do
      tell ">"
      iterM renderContentItem content
      tell "</"
      tell e.name
      tell ">"

    renderContentItem :: forall a. ContentF (Interp a) -> Interp a
    renderContentItem (TextContent s rest) = do
      tell s
      rest
    renderContentItem (ElementContent e rest) = do
      renderElement e
      rest
    renderContentItem (NewName k) = do
      n <- get
      let name = Name $ "name" ++ show n
      put $ n + 1
      k name

error: pathspec 'chapter14/src/Data/DOM/Name.purs' did not match any file(s) known to git


Added Main module with requestAnimationFrame demo

module Main where

import Prelude
import Control.Monad.Eff (Eff)
import Control.Monad.Eff.Console (CONSOLE, log)
import DOM (DOM)
import DOM.HTML (window)
import DOM.HTML.Window (RequestAnimationFrameId, requestAnimationFrame)

main :: forall e. Eff (dom :: DOM, console :: CONSOLE | e) RequestAnimationFrameId
main = do
	window <- window
	requestAnimationFrame (log "Hello world!") window

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


Add test for retry combinator

Add test for retry combinator

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/aspidites/purescript-affjax.git/'


Add Solver monad

Add Solver monad

Implemented as `ExceptT e (State s) a`

module Neodoc.Solve.Type where

import Prelude

import Data.List (List(..), (:))
import Data.Either (Either(..))
import Control.Monad.Except.Trans
import Control.Monad.State (State, evalState)

import Neodoc.Data.Description
import Neodoc.Solve.Error

type SolveState = {
  descriptions :: List Description
}

type Solver a = ExceptT SolveError (State SolveState) a

type Solver a = EitherT SolveState (Either SolveError) a

runSolver
  :: ∀ a
   . List Description
  -> Solver a
  -> Either SolveError a
runSolver descriptions = flip evalStateT { descriptions }

fail :: ∀ a. String -> Solver a
fail = throwError <<< SolveError

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