karchnu
/
halogen-websocket-ipc-playzone
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Can build again

beta
Philippe Pittoli 2023-09-30 14:52:48 +02:00
parent ab654ddbe7
commit 5ac94bf0fe
1 changed files with 64 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

105
src/App/Container.purs
View File

@ -1,15 +1,17 @@
module App.Container where module App.Container where
import Prelude (Unit, bind, discard, unit, ($)) import Prelude (Unit, bind, discard, unit, ($), (<>), show, pure)
import Bulma as Bulma import Bulma as Bulma
import App.Nav as Nav import App.Nav as Nav
import Data.Array as A
import Data.Maybe (Maybe(..)) import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Tuple (Tuple(..)) import Data.Tuple (Tuple(..))
import App.AuthenticationForm as AF import App.AuthenticationForm as AF
import App.Log as Log import App.Log as AppLog
import App.WS as WS import App.WS as WS
import App.AuthenticationDaemonAdminInterface as AAI import App.AuthenticationDaemonAdminInterface as AAI
import App.DomainListInterface as DomainListInterface import App.DomainListInterface as DomainListInterface
@ -20,6 +22,7 @@ import Halogen as H
import Halogen.HTML as HH import Halogen.HTML as HH
import Type.Proxy (Proxy(..)) import Type.Proxy (Proxy(..))
import Effect.Aff.Class (class MonadAff) import Effect.Aff.Class (class MonadAff)
import Data.ArrayBuffer.Types (ArrayBuffer)
import App.LogMessage (LogMessage(..)) import App.LogMessage (LogMessage(..))
@ -51,6 +54,9 @@ data Action
-- | Then, the message will be provided to the `DispatchDNSMessage` action. -- | Then, the message will be provided to the `DispatchDNSMessage` action.
| DNSRawMessageReceived ArrayBuffer | DNSRawMessageReceived ArrayBuffer
-- | Log message (through the Log component).
| Log LogMessage
type State = { token :: Maybe String type State = { token :: Maybe String
, uid :: Maybe Int , uid :: Maybe Int
, current_page :: Page , current_page :: Page
@ -59,7 +65,7 @@ type State = { token :: Maybe String
} }
type ChildSlots = type ChildSlots =
( log :: Log.Slot Unit ( log :: AppLog.Slot Unit
, ho :: HomeInterface.Slot Unit , ho :: HomeInterface.Slot Unit
, ws_auth :: WS.Slot Unit , ws_auth :: WS.Slot Unit
, ws_dns :: WS.Slot Unit , ws_dns :: WS.Slot Unit
@ -129,7 +135,7 @@ render state
Just _ -> Bulma.hero "net libre" "free domains" Just _ -> Bulma.hero "net libre" "free domains"
render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_logs :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_logs = Bulma.container [ HH.slot_ _log unit Log.component unit ] render_logs = Bulma.container [ HH.slot_ _log unit AppLog.component unit ]
render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad render_auth_WS :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_auth_WS = HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthenticationDaemonEvent render_auth_WS = HH.slot _ws_auth unit WS.component "ws://127.0.0.1:8080" AuthenticationDaemonEvent
@ -165,7 +171,7 @@ handleAction :: forall o monad. MonadAff monad => Action -> H.HalogenM State Act
handleAction = case _ of handleAction = case _ of
Routing page -> H.modify_ _ { current_page = page } Routing page -> H.modify_ _ { current_page = page }
Log message -> H.tell _log unit $ Log.Log message Log message -> H.tell _log unit $ AppLog.Log message
AuthenticateToDNSManager -> do AuthenticateToDNSManager -> do
state <- H.get state <- H.get
@ -174,18 +180,18 @@ handleAction = case _ of
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token } message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
H.tell _ws_dns unit (WS.ToSend message) H.tell _ws_dns unit (WS.ToSend message)
Nothing -> do Nothing -> do
H.tell _log unit (Log.Log $ SimpleLog "Trying to authenticate to dnsmanager without a token") H.tell _log unit (AppLog.Log $ SimpleLog "Trying to authenticate to dnsmanager without a token")
AuthenticationComponentEvent ev -> case ev of AuthenticationComponentEvent ev -> case ev of
AF.AuthToken (Tuple uid token) -> do AF.AuthToken (Tuple uid token) -> do
H.modify_ _ { uid = Just uid, token = Just token, current_page = DomainList } H.modify_ _ { uid = Just uid, token = Just token, current_page = DomainList }
handleAction AuthenticateToDNSManager handleAction AuthenticateToDNSManager
AF.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AF.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
AF.Log message -> H.tell _log unit (Log.Log message) AF.Log message -> H.tell _log unit (AppLog.Log message)
AuthenticationDaemonAdminComponentEvent ev -> case ev of AuthenticationDaemonAdminComponentEvent ev -> case ev of
AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message) AAI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
AAI.Log message -> H.tell _log unit (Log.Log message) AAI.Log message -> H.tell _log unit (AppLog.Log message)
AAI.StoreState s -> H.modify_ _ { store_AuthenticationDaemonAdmin_state = Just s } AAI.StoreState s -> H.modify_ _ { store_AuthenticationDaemonAdmin_state = Just s }
AAI.AskState -> do AAI.AskState -> do
state <- H.get state <- H.get
@ -193,12 +199,12 @@ handleAction = case _ of
ZoneInterfaceEvent ev -> case ev of ZoneInterfaceEvent ev -> case ev of
ZoneInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message) ZoneInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
ZoneInterface.Log message -> H.tell _log unit (Log.Log message) ZoneInterface.Log message -> H.tell _log unit (AppLog.Log message)
ZoneInterface.DNSManagerReconnect -> handleAction AuthenticateToDNSManager ZoneInterface.DNSManagerReconnect -> handleAction AuthenticateToDNSManager
DomainListComponentEvent ev -> case ev of DomainListComponentEvent ev -> case ev of
DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message) DomainListInterface.MessageToSend message -> H.tell _ws_dns unit (WS.ToSend message)
DomainListInterface.Log message -> H.tell _log unit (Log.Log message) DomainListInterface.Log message -> H.tell _log unit (AppLog.Log message)
DomainListInterface.DNSManagerReconnect -> handleAction AuthenticateToDNSManager DomainListInterface.DNSManagerReconnect -> handleAction AuthenticateToDNSManager
DomainListInterface.StoreState s -> H.modify_ _ { store_DomainListInterface_state = Just s } DomainListInterface.StoreState s -> H.modify_ _ { store_DomainListInterface_state = Just s }
DomainListInterface.ChangePageZoneInterface domain -> do DomainListInterface.ChangePageZoneInterface domain -> do
@ -221,7 +227,7 @@ handleAction = case _ of
WS.WSJustClosed -> do WS.WSJustClosed -> do
H.tell _af unit AF.ConnectionIsDown H.tell _af unit AF.ConnectionIsDown
H.tell _aai unit AAI.ConnectionIsDown H.tell _aai unit AAI.ConnectionIsDown
WS.Log message -> H.tell _log unit (Log.Log message) WS.Log message -> H.tell _log unit (AppLog.Log message)
Disconnection -> do Disconnection -> do
H.put $ initialState unit H.put $ initialState unit
@ -232,78 +238,95 @@ handleAction = case _ of
WS.MessageReceived (Tuple _ message) -> do WS.MessageReceived (Tuple _ message) -> do
handleAction $ DNSRawMessageReceived message handleAction $ DNSRawMessageReceived message
WS.WSJustConnected -> do WS.WSJustConnected -> do
handleAction Log $ SimpleLog "Connection with dnsmanagerd was closed, let's re-authenticate" handleAction $ Log $ SimpleLog "Connection with dnsmanagerd was closed, let's re-authenticate"
handleAction AuthenticateToDNSManager handleAction AuthenticateToDNSManager
H.tell _dli unit DomainListInterface.ConnectionIsUp H.tell _dli unit DomainListInterface.ConnectionIsUp
WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown
WS.Log message -> H.tell _log unit (Log.Log message) WS.Log message -> H.tell _log unit (AppLog.Log message)
DNSRawMessageReceived message -> do DNSRawMessageReceived message -> do
receivedMessage <- H.liftEffect $ DNSManager.deserialize message receivedMessage <- H.liftEffect $ DNSManager.deserialize message
case receivedMessage of case receivedMessage of
-- Cases where we didn't understand the message. -- Cases where we didn't understand the message.
Left err -> do Left err -> do
-- handleAction Log $ SimpleLog $ "[🤖] received a message that couldn't be decoded..., reason: " <> show err -- handleAction $ Log $ SimpleLog $ "[🤖] received a message that couldn't be decoded..., reason: " <> show err
case err of case err of
(DNSManager.JSONERROR jerr) -> do (DNSManager.JSONERROR jerr) -> do
handleAction Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr handleAction $ Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr
(DNSManager.UnknownError unerr) -> (DNSManager.UnknownError unerr) ->
handleAction Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownError" <> (show unerr) handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownError" <> (show unerr)
(DNSManager.UnknownNumber ) -> (DNSManager.UnknownNumber ) ->
handleAction Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownNumber" handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownNumber"
pure Nothing
-- Cases where we understood the message. -- Cases where we understood the message.
Right received_msg -> do Right received_msg -> do
case received_msg of case received_msg of
(DNSManager.MkDomainNotFound _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: DomainNotFound"
(DNSManager.MkRRNotFound _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: RRNotFound"
(DNSManager.MkInvalidZone _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: InvalidZone"
(DNSManager.MkDomainChanged _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: DomainChanged"
(DNSManager.MkUnknownZone _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: UnknownZone"
(DNSManager.MkDomainList _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkDomainList"
(DNSManager.MkUnknownUser _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkUnknownUser"
(DNSManager.MkNoOwnership _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkNoOwnership"
-- The authentication failed. -- The authentication failed.
(DNSManager.MkError errmsg) -> do (DNSManager.MkError errmsg) -> do
handleAction Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason handleAction $ Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason
(DNSManager.MkErrorUserNotLogged _) -> do (DNSManager.MkErrorUserNotLogged _) -> do
handleAction Log $ SimpleLog $ "[😈] Failed! The user isn't connected!" handleAction $ Log $ SimpleLog $ "[😈] Failed! The user isn't connected!"
handleAction Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..." handleAction $ Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..."
handleAction AuthenticateToDNSManager handleAction AuthenticateToDNSManager
(DNSManager.MkErrorInvalidToken _) -> do (DNSManager.MkErrorInvalidToken _) -> do
H.modify_ _ { token = Nothing, current_page = Home } H.modify_ _ { token = Nothing, current_page = Home }
handleAction Log $ SimpleLog $ "Failed connection! Invalid token! Try re-authenticate." handleAction $ Log $ SimpleLog $ "Failed connection! Invalid token! Try re-authenticate."
(DNSManager.MkDomainAlreadyExists _) -> do (DNSManager.MkDomainAlreadyExists _) -> do
handleAction Log $ SimpleLog $ "Failed! The domain already exists." handleAction $ Log $ SimpleLog $ "Failed! The domain already exists."
m@(DNSManager.MkUnacceptableDomain _) -> do m@(DNSManager.MkUnacceptableDomain _) -> do
handleAction Log $ SimpleLog $ "Failed! The domain is not acceptable (not in the list of accepted domains)." handleAction $ Log $ SimpleLog $ "Failed! The domain is not acceptable (not in the list of accepted domains)."
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
m@(DNSManager.MkAcceptedDomains _) -> do m@(DNSManager.MkAcceptedDomains _) -> do
handleAction Log $ SimpleLog $ "Received the list of accepted domains!" handleAction $ Log $ SimpleLog $ "Received the list of accepted domains!"
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
(DNSManager.MkLogged _) -> do (DNSManager.MkLogged _) -> do
handleAction Log $ SimpleLog $ "[TODO] Authenticated to dnsmanagerd!" handleAction $ Log $ SimpleLog $ "[TODO] Authenticated to dnsmanagerd!"
(DNSManager.MkDomainAdded response) -> do (DNSManager.MkDomainAdded response) -> do
handleAction Log $ SimpleLog $ "[TODO] Domain added: " <> response.domain handleAction $ Log $ SimpleLog $ "[TODO] Domain added: " <> response.domain
(DNSManager.MkRRReadOnly response) -> do (DNSManager.MkRRReadOnly response) -> do
handleAction Log $ SimpleLog $ "[😈] Trying to modify a read-only resource! " handleAction $ Log $ SimpleLog $ "[😈] Trying to modify a read-only resource! "
<> "domain: " <> response.domain <> "domain: " <> response.domain
<> "resource rrid: " <> show response.rr.rrid <> "resource rrid: " <> show response.rr.rrid
(DNSManager.MkRRUpdated response) -> do (DNSManager.MkRRUpdated _) -> do
handleAction Log $ SimpleLog $ "[🎉] Resource updated!" handleAction $ Log $ SimpleLog $ "[🎉] Resource updated!"
(DNSManager.MkRRAdded response) -> do (DNSManager.MkRRAdded response) -> do
handleAction Log $ SimpleLog $ "[🎉] Resource Record added: " <> response.rr.rrtype handleAction $ Log $ SimpleLog $ "[🎉] Resource Record added: " <> response.rr.rrtype
(DNSManager.MkInvalidDomainName _) -> do (DNSManager.MkInvalidDomainName _) -> do
handleAction Log $ SimpleLog $ "[😈] Failed! The domain is not valid!" handleAction $ Log $ SimpleLog $ "[😈] Failed! The domain is not valid!"
(DNSManager.MkDomainDeleted response) -> do (DNSManager.MkDomainDeleted response) -> do
handleAction Log $ SimpleLog $ "[TODO] The domain '" <> response.domain <> "' has been deleted!" handleAction $ Log $ SimpleLog $ "[TODO] The domain '" <> response.domain <> "' has been deleted!"
(DNSManager.MkRRDeleted response) -> do (DNSManager.MkRRDeleted response) -> do
handleAction Log $ SimpleLog $ "[🎉] RR (rrid: '" <> show response.rrid <> "') has been deleted!" handleAction $ Log $ SimpleLog $ "[🎉] RR (rrid: '" <> show response.rrid <> "') has been deleted!"
(DNSManager.MkZone response) -> do (DNSManager.MkZone _) -> do
handleAction Log $ SimpleLog $ "[🎉] Zone received!" handleAction $ Log $ SimpleLog $ "[🎉] Zone received!"
(DNSManager.MkInvalidRR response) -> do (DNSManager.MkInvalidRR response) -> do
handleAction Log $ SimpleLog $ "[😈] Invalid resource record: " <> A.intercalate ", " response.errors handleAction $ Log $ SimpleLog $ "[😈] Invalid resource record: " <> A.intercalate ", " response.errors
(DNSManager.MkSuccess _) -> do (DNSManager.MkSuccess _) -> do
handleAction Log $ SimpleLog $ "[🎉] Success!" handleAction $ Log $ SimpleLog $ "[🎉] Success!"
pure unit
-- Send a received DNS manager message to a component. -- Send a received DNS manager message to a component.
DispatchDNSMessage message -> do DispatchDNSMessage _ -> do
handleAction Log $ SimpleLog "should send a DNS message to a component" handleAction $ Log $ SimpleLog "should send a DNS message to a component"
--{ current_page } <- H.get --{ current_page } <- H.get
--case current_page of --case current_page of
-- DomainList -> H.tell _dli unit (DomainListInterface.MessageReceived message) -- DomainList -> H.tell _dli unit (DomainListInterface.MessageReceived message)
-- Zone _ -> H.tell _zi unit (ZoneInterface.MessageReceived message) -- Zone _ -> H.tell _zi unit (ZoneInterface.MessageReceived message)
-- _ -> H.tell _log unit (Log.Log $ SystemLog "unexpected message from dnsmanagerd") -- _ -> H.tell _log unit (AppLog.Log $ SystemLog "unexpected message from dnsmanagerd")
pure unit