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

Can build again

Browse Source
This commit is contained in:
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
import Prelude (Unit, bind, discard, unit, ($))
import Prelude (Unit, bind, discard, unit, ($), (<>), show, pure)
import Bulma as Bulma
import App.Nav as Nav
import Data.Array as A
import Data.Maybe (Maybe(..))
import Data.Either (Either(..))
import Data.Tuple (Tuple(..))
import App.AuthenticationForm as AF
import App.Log as Log
import App.Log as AppLog
import App.WS as WS
import App.AuthenticationDaemonAdminInterface as AAI
import App.DomainListInterface as DomainListInterface
@ -20,6 +22,7 @@ import Halogen as H
import Halogen.HTML as HH
import Type.Proxy (Proxy(..))
import Effect.Aff.Class (class MonadAff)
import Data.ArrayBuffer.Types (ArrayBuffer)
import App.LogMessage (LogMessage(..))
@ -51,6 +54,9 @@ data Action
-- | Then, the message will be provided to the `DispatchDNSMessage` action.
| DNSRawMessageReceived ArrayBuffer
-- | Log message (through the Log component).
| Log LogMessage
type State = { token :: Maybe String
, uid :: Maybe Int
, current_page :: Page
@ -59,7 +65,7 @@ type State = { token :: Maybe String
}
type ChildSlots =
( log :: Log.Slot Unit
( log :: AppLog.Slot Unit
, ho :: HomeInterface.Slot Unit
, ws_auth :: WS.Slot Unit
, ws_dns :: WS.Slot Unit
@ -129,7 +135,7 @@ render state
Just _ -> Bulma.hero "net libre" "free domains"
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 = 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
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
state <- H.get
@ -174,18 +180,18 @@ handleAction = case _ of
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkLogin { token: token }
H.tell _ws_dns unit (WS.ToSend message)
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
AF.AuthToken (Tuple uid token) -> do
H.modify_ _ { uid = Just uid, token = Just token, current_page = DomainList }
handleAction AuthenticateToDNSManager
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
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.AskState -> do
state <- H.get
@ -193,12 +199,12 @@ handleAction = case _ of
ZoneInterfaceEvent ev -> case ev of
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
DomainListComponentEvent ev -> case ev of
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.StoreState s -> H.modify_ _ { store_DomainListInterface_state = Just s }
DomainListInterface.ChangePageZoneInterface domain -> do
@ -221,7 +227,7 @@ handleAction = case _ of
WS.WSJustClosed -> do
H.tell _af unit AF.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
H.put $ initialState unit
@ -232,78 +238,95 @@ handleAction = case _ of
WS.MessageReceived (Tuple _ message) -> do
handleAction $ DNSRawMessageReceived message
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
H.tell _dli unit DomainListInterface.ConnectionIsUp
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
receivedMessage <- H.liftEffect $ DNSManager.deserialize message
case receivedMessage of
-- Cases where we didn't understand the message.
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
(DNSManager.JSONERROR jerr) -> do
handleAction Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr
handleAction $ Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr
(DNSManager.UnknownError unerr) ->
handleAction Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownError" <> (show unerr)
handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownError" <> (show unerr)
(DNSManager.UnknownNumber ) ->
handleAction Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownNumber"
pure Nothing
handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownNumber"
-- Cases where we understood the message.
Right received_msg -> do
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.
(DNSManager.MkError errmsg) -> do
handleAction Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason
handleAction $ Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason
(DNSManager.MkErrorUserNotLogged _) -> do
handleAction Log $ SimpleLog $ "[😈] Failed! The user isn't connected!"
handleAction Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..."
handleAction $ Log $ SimpleLog $ "[😈] Failed! The user isn't connected!"
handleAction $ Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..."
handleAction AuthenticateToDNSManager
(DNSManager.MkErrorInvalidToken _) -> do
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
handleAction Log $ SimpleLog $ "Failed! The domain already exists."
handleAction $ Log $ SimpleLog $ "Failed! The domain already exists."
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
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
(DNSManager.MkLogged _) -> do
handleAction Log $ SimpleLog $ "[TODO] Authenticated to dnsmanagerd!"
handleAction $ Log $ SimpleLog $ "[TODO] Authenticated to dnsmanagerd!"
(DNSManager.MkDomainAdded response) -> do
handleAction Log $ SimpleLog $ "[TODO] Domain added: " <> response.domain
handleAction $ Log $ SimpleLog $ "[TODO] Domain added: " <> response.domain
(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
<> "resource rrid: " <> show response.rr.rrid
(DNSManager.MkRRUpdated response) -> do
handleAction Log $ SimpleLog $ "[🎉] Resource updated!"
(DNSManager.MkRRUpdated _) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Resource updated!"
(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
handleAction Log $ SimpleLog $ "[😈] Failed! The domain is not valid!"
handleAction $ Log $ SimpleLog $ "[😈] Failed! The domain is not valid!"
(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
handleAction Log $ SimpleLog $ "[🎉] RR (rrid: '" <> show response.rrid <> "') has been deleted!"
(DNSManager.MkZone response) -> do
handleAction Log $ SimpleLog $ "[🎉] Zone received!"
handleAction $ Log $ SimpleLog $ "[🎉] RR (rrid: '" <> show response.rrid <> "') has been deleted!"
(DNSManager.MkZone _) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Zone received!"
(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
handleAction Log $ SimpleLog $ "[🎉] Success!"
handleAction $ Log $ SimpleLog $ "[🎉] Success!"
pure unit
-- Send a received DNS manager message to a component.
DispatchDNSMessage message -> do
handleAction Log $ SimpleLog "should send a DNS message to a component"
DispatchDNSMessage _ -> do
handleAction $ Log $ SimpleLog "should send a DNS message to a component"
--{ current_page } <- H.get
--case current_page of
-- DomainList -> H.tell _dli unit (DomainListInterface.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