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

Improved API for logs (new SuccessLog & ErrorLog).

beta
Philippe Pittoli 2024-02-20 19:23:05 +01:00
parent c2e51dc964
commit 1d15a47c77
6 changed files with 128 additions and 115 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
src/App/AdministrationInterface.purs
View File

@ -172,12 +172,12 @@ handleAction = case _ of
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
old_page <- H.liftEffect $ Storage.getItem "current-ada-page" sessionstorage old_page <- H.liftEffect $ Storage.getItem "current-ada-page" sessionstorage
case old_page of case old_page of
Nothing -> H.raise $ Log $ SimpleLog "we hadn't changed page before reload apparently." Nothing -> H.raise $ Log $ ErrorLog "We hadn't changed page before reload apparently."
Just page -> case page of Just page -> case page of
"Home" -> handleAction $ Routing Home "Home" -> handleAction $ Routing Home
"Search" -> handleAction $ Routing Search "Search" -> handleAction $ Routing Search
"Add" -> handleAction $ Routing Add "Add" -> handleAction $ Routing Add
_ -> H.raise $ Log $ SimpleLog $ "reload but cannot understand old page: " <> page _ -> H.raise $ Log $ ErrorLog $ "Reload but cannot understand old page: " <> page
Finalize -> do Finalize -> do
state <- H.get state <- H.get
@ -195,10 +195,10 @@ handleAction = case _ of
PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
ShowUser uid -> do ShowUser uid -> do
H.raise $ Log $ SimpleLog $ "[😇] Trying to show a user details (uid: " <> show uid <> ")" H.raise $ Log $ SystemLog $ "Show a user details (uid: " <> show uid <> ")"
RemoveUser uid -> do RemoveUser uid -> do
H.raise $ Log $ SimpleLog $ "[😇] Trying to remove user " <> show uid H.raise $ Log $ SystemLog $ "Remove user " <> show uid
ab <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Just uid } ab <- H.liftEffect $ AuthD.serialize $ AuthD.MkDeleteUser { user: Just uid }
H.raise $ MessageToSend ab H.raise $ MessageToSend ab
@ -220,7 +220,7 @@ handleAction = case _ of
, email: Just (Email.Email email) , email: Just (Email.Email email)
, password: pass } , password: pass }
H.raise $ MessageToSend ab H.raise $ MessageToSend ab
H.raise $ Log $ SimpleLog "[😇] Trying to add a user" H.raise $ Log $ SystemLog "Add a user"
Routing page -> do Routing page -> do
-- Store the current page we are on and restore it when we reload. -- Store the current page we are on and restore it when we reload.
@ -240,7 +240,6 @@ handleAction = case _ of
AuthD.MkSearchUser { regex: not_empty_string regex, offset: Just 0 } AuthD.MkSearchUser { regex: not_empty_string regex, offset: Just 0 }
H.raise $ MessageToSend ab H.raise $ MessageToSend ab
H.modify_ _ { matching_users = [] } H.modify_ _ { matching_users = [] }
H.raise $ Log $ SimpleLog "[😇] Trying to search a user"
not_empty_string :: String -> Maybe String not_empty_string :: String -> Maybe String
not_empty_string "" = Nothing not_empty_string "" = Nothing
@ -258,23 +257,21 @@ handleQuery = case _ of
MessageReceived message a -> do MessageReceived message a -> do
case message of case message of
(AuthD.GotError errmsg) -> do
H.raise $ Log $ SimpleLog $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason
(AuthD.GotUserAdded msg) -> do (AuthD.GotUserAdded msg) -> do
H.raise $ Log $ SimpleLog $ "[🎉] Success! Server added user: " <> show msg.user H.raise $ Log $ SuccessLog $ "Added user: " <> show msg.user
(AuthD.GotMatchingUsers msg) -> do (AuthD.GotMatchingUsers msg) -> do
H.raise $ Log $ SimpleLog "[🎉] Received a list of users." H.raise $ Log $ SuccessLog "Got list of matched users."
H.modify_ _ { matching_users = msg.users } H.modify_ _ { matching_users = msg.users }
(AuthD.GotUserDeleted msg) -> do (AuthD.GotUserDeleted msg) -> do
H.raise $ Log $ SimpleLog $ "[🎉] user (uid: " <> show msg.uid <> ") got removed." H.raise $ Log $ SuccessLog $ "User (uid: " <> show msg.uid <> ") got removed."
{ matching_users } <- H.get { matching_users } <- H.get
H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users } H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users }
-- Unexpected message. -- Unexpected message.
_ -> do _ -> do
H.raise $ Log $ SimpleLog $ "[😈] Failed! Authentication server didn't send a valid message." H.raise $ Log $ ErrorLog $ "Authentication server didn't send a valid message."
pure (Just a) pure (Just a)
ConnectionIsDown a -> do ConnectionIsDown a -> do

162
src/App/Container.purs
View File

@ -302,7 +302,7 @@ handleAction = case _ of
AuthenticateToAuthd v -> case v of AuthenticateToAuthd v -> case v of
Left token -> do Left token -> do
handleAction $ Log $ SimpleLog "[🤖] authenticate to authd with a token!" handleAction $ Log $ SystemLog "Authenticate to authd with a token!"
message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token } message <- H.liftEffect $ AuthD.serialize $ AuthD.MkAuthByToken { token }
H.tell _ws_auth unit (WS.ToSend message) H.tell _ws_auth unit (WS.ToSend message)
Right (Tuple login password) -> do Right (Tuple login password) -> do
@ -319,7 +319,7 @@ handleAction = case _ of
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
case token of case token of
Nothing -> handleAction $ Log $ SimpleLog "no token!" Nothing -> handleAction $ Log $ ErrorLog "no token!"
Just t -> do Just t -> do
H.modify_ _ { token = Just t } H.modify_ _ { token = Just t }
handleAction AuthenticateToDNSManager handleAction AuthenticateToDNSManager
@ -371,9 +371,9 @@ handleAction = case _ of
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
case token of case token of
Nothing -> handleAction $ Log $ SimpleLog "no token!" Nothing -> handleAction $ Log $ ErrorLog "no token!"
Just t -> do Just t -> do
handleAction $ Log $ SimpleLog "Let's authenticate to authd" handleAction $ Log $ SystemLog "Let's authenticate to authd"
handleAction $ AuthenticateToAuthd (Left t) handleAction $ AuthenticateToAuthd (Left t)
WS.WSJustClosed -> do WS.WSJustClosed -> do
@ -387,93 +387,97 @@ handleAction = case _ of
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 $ ErrorLog $
-- "received a message that couldn't be decoded. Reason: " <> show err
case err of case err of
(AuthD.JSONERROR jerr) -> do (AuthD.JSONERROR jerr) -> do
-- print_json_string messageEvent.message -- print_json_string messageEvent.message
handleAction $ Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
(AuthD.UnknownError unerr) -> handleAction $ Log $ SimpleLog ("[🤖] Parsing error: AuthD.UnknownError" <> (show unerr)) (AuthD.UnknownError unerr) -> handleAction $ Log $ ErrorLog $
(AuthD.UnknownNumber ) -> handleAction $ Log $ SimpleLog ("[🤖] Parsing error: AuthD.UnknownNumber") "Parsing error: AuthD.UnknownError" <> (show unerr)
(AuthD.UnknownNumber ) -> handleAction $ Log $ ErrorLog
"Parsing error: AuthD.UnknownNumber"
-- Cases where we understood the message. -- Cases where we understood the message.
-- TODO: create a modal to show some of these? -- TODO: create a modal to show some of these?
Right response -> do Right response -> do
case response of case response of
(AuthD.GotUser _) -> do (AuthD.GotUser _) -> do
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUser message." handleAction $ Log $ ErrorLog "TODO: received a GotUser message."
m@(AuthD.GotUserAdded _) -> do m@(AuthD.GotUserAdded _) -> do
{ current_page } <- H.get { current_page } <- H.get
case current_page of case current_page of
Registration -> do Registration -> do
handleAction $ Log $ SimpleLog """ handleAction $ Log $ SuccessLog """
[🎉] you are now registered, copy the token we sent you by email to finish your registration. You are now registered, copy the token we sent you by email to finish your registration.
""" """
handleAction $ Routing MailValidation handleAction $ Routing MailValidation
_ -> handleAction $ DispatchAuthDaemonMessage m _ -> handleAction $ DispatchAuthDaemonMessage m
(AuthD.GotUserEdited _) -> do (AuthD.GotUserEdited _) -> do
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUserEdited message." handleAction $ Log $ ErrorLog "TODO: received a GotUserEdited message."
(AuthD.GotUserValidated _) -> do (AuthD.GotUserValidated _) -> do
handleAction $ Log $ SimpleLog "[🎉] you got validated! You can now log in!" handleAction $ Log $ SuccessLog "User got validated! You can now log in!"
handleAction $ Routing Authentication handleAction $ Routing Authentication
(AuthD.GotUsersList _) -> do (AuthD.GotUsersList _) -> do
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUsersList message." handleAction $ Log $ ErrorLog "TODO: received a GotUsersList message."
(AuthD.GotPermissionCheck _) -> do (AuthD.GotPermissionCheck _) -> do
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotPermissionCheck message." handleAction $ Log $ ErrorLog "TODO: received a GotPermissionCheck message."
(AuthD.GotPermissionSet _) -> do (AuthD.GotPermissionSet _) -> do
handleAction $ Log $ SimpleLog "[😈] Received a GotPermissionSet message." handleAction $ Log $ ErrorLog "Received a GotPermissionSet message."
(AuthD.GotPasswordRecovered _) -> do (AuthD.GotPasswordRecovered _) -> do
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotPasswordRecovered message." handleAction $ Log $ ErrorLog "TODO: received a GotPasswordRecovered message."
m@(AuthD.GotMatchingUsers _) -> do m@(AuthD.GotMatchingUsers _) -> do
{ current_page } <- H.get { current_page } <- H.get
case current_page of case current_page of
Administration -> handleAction $ DispatchAuthDaemonMessage m Administration -> handleAction $ DispatchAuthDaemonMessage m
_ -> handleAction $ Log $ SimpleLog _ -> handleAction $ Log $ ErrorLog
"[😈] received a GotMatchingUsers message while not on authd admin page." "received a GotMatchingUsers message while not on authd admin page."
m@(AuthD.GotUserDeleted _) -> do m@(AuthD.GotUserDeleted _) -> do
{ current_page } <- H.get { current_page } <- H.get
case current_page of case current_page of
Administration -> handleAction $ DispatchAuthDaemonMessage m Administration -> handleAction $ DispatchAuthDaemonMessage m
_ -> handleAction $ Log $ SimpleLog _ -> handleAction $ Log $ ErrorLog
"[😈] received a GotUserDeleted message while not on authd admin page." "received a GotUserDeleted message while not on authd admin page."
(AuthD.GotErrorMustBeAuthenticated _) -> do (AuthD.GotErrorMustBeAuthenticated _) -> do
handleAction $ Log $ SimpleLog "[😈] Fail: received a GotErrorMustBeAuthenticated message." handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
(AuthD.GotErrorAlreadyUsedLogin _) -> do (AuthD.GotErrorAlreadyUsedLogin _) -> do
handleAction $ Log $ SimpleLog "[😈] Fail: received a GotErrorAlreadyUsedLogin message." handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
(AuthD.GotErrorUserNotFound _) -> do (AuthD.GotErrorUserNotFound _) -> do
handleAction $ Log $ SimpleLog "[😈] Fail: received a GotErrorUserNotFound message." handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
-- The authentication failed. -- The authentication failed.
(AuthD.GotError errmsg) -> do (AuthD.GotError errmsg) -> do
handleAction $ Log $ SimpleLog $ "[😈] Failed: " <> maybe "server didn't tell why" (\v -> v) errmsg.reason handleAction $ Log $ ErrorLog $ " generic error message: "
<> maybe "server didn't tell why" (\v -> v) errmsg.reason
(AuthD.GotPasswordRecoverySent _) -> do (AuthD.GotPasswordRecoverySent _) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Password recovery: email sent!" handleAction $ Log $ SuccessLog $ "Password recovery: email sent!"
(AuthD.GotErrorPasswordTooShort _) -> do (AuthD.GotErrorPasswordTooShort _) -> do
handleAction $ Log $ SimpleLog "[😈] Password too short!" handleAction $ Log $ ErrorLog "Password too short!"
(AuthD.GotErrorMailRequired _) -> do (AuthD.GotErrorMailRequired _) -> do
handleAction $ Log $ SimpleLog "[😈] Email required!" handleAction $ Log $ ErrorLog "Email required!"
(AuthD.GotErrorInvalidCredentials _) -> do (AuthD.GotErrorInvalidCredentials _) -> do
handleAction $ Log $ SimpleLog "[😈] Invalid credentials!" handleAction $ Log $ ErrorLog "Invalid credentials!"
(AuthD.GotErrorRegistrationsClosed _) -> do (AuthD.GotErrorRegistrationsClosed _) -> do
handleAction $ Log $ SimpleLog "[😈] Registration closed! Try another time or contact an administrator." handleAction $ Log $ ErrorLog "Registration closed! Try another time or contact an administrator."
(AuthD.GotErrorInvalidLoginFormat _) -> do (AuthD.GotErrorInvalidLoginFormat _) -> do
handleAction $ Log $ SimpleLog "[😈] Invalid login format!" handleAction $ Log $ ErrorLog "Invalid login format!"
(AuthD.GotErrorInvalidEmailFormat _) -> do (AuthD.GotErrorInvalidEmailFormat _) -> do
handleAction $ Log $ SimpleLog "[😈] Invalid email format!" handleAction $ Log $ ErrorLog "Invalid email format!"
(AuthD.GotErrorAlreadyUsersInDB _) -> do (AuthD.GotErrorAlreadyUsersInDB _) -> do
handleAction $ Log $ SimpleLog "[😈] Login already taken!" handleAction $ Log $ ErrorLog "Login already taken!"
(AuthD.GotErrorReadOnlyProfileKeys _) -> do (AuthD.GotErrorReadOnlyProfileKeys _) -> do
handleAction $ Log $ SimpleLog "[😈] Trying to add a profile with some invalid (read-only) keys!" handleAction $ Log $ ErrorLog "Trying to add a profile with some invalid (read-only) keys!"
(AuthD.GotErrorInvalidActivationKey _) -> do (AuthD.GotErrorInvalidActivationKey _) -> do
handleAction $ Log $ SimpleLog "[😈] Invalid activation key!" handleAction $ Log $ ErrorLog "Invalid activation key!"
(AuthD.GotErrorUserAlreadyValidated _) -> do (AuthD.GotErrorUserAlreadyValidated _) -> do
handleAction $ Log $ SimpleLog "[😈] User already validated!" handleAction $ Log $ ErrorLog "User already validated!"
(AuthD.GotErrorCannotContactUser _) -> do (AuthD.GotErrorCannotContactUser _) -> do
handleAction $ Log $ SimpleLog "[😈] User cannot be contacted. Are you sure about your email address?" handleAction $ Log $ ErrorLog "User cannot be contacted. Email address may be invalid."
(AuthD.GotErrorInvalidRenewKey _) -> do (AuthD.GotErrorInvalidRenewKey _) -> do
handleAction $ Log $ SimpleLog "[😈] Invalid renew key!" handleAction $ Log $ ErrorLog "Invalid renew key!"
-- The authentication was a success! -- The authentication was a success!
(AuthD.GotToken msg) -> do (AuthD.GotToken msg) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Authenticated to authd!" handleAction $ Log $ SuccessLog $ "Authenticated to authd!"
H.modify_ _ { token = Just msg.token } H.modify_ _ { token = Just msg.token }
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
@ -481,7 +485,8 @@ handleAction = case _ of
handleAction AuthenticateToDNSManager handleAction AuthenticateToDNSManager
(AuthD.GotKeepAlive _) -> do (AuthD.GotKeepAlive _) -> do
handleAction $ Log $ SimpleLog $ "[🤖] KeepAlive!🤖🤖🤖" -- handleAction $ Log $ SystemLog $ "KeepAlive!"
pure unit
pure unit pure unit
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component. -- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
@ -504,7 +509,7 @@ handleAction = case _ of
WS.MessageReceived (Tuple _ message) -> do WS.MessageReceived (Tuple _ message) -> do
handleAction $ DecodeDNSMessage message handleAction $ DecodeDNSMessage message
WS.WSJustConnected -> do WS.WSJustConnected -> do
handleAction $ Log $ SimpleLog "[🤖] connection with dnsmanagerd was closed, let's re-authenticate" handleAction $ Log $ SystemLog "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
@ -517,85 +522,87 @@ handleAction = case _ of
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 $ ErrorLog $
-- "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 $ ErrorLog $ "JSON parsing error: " <> jerr
(DNSManager.UnknownError unerr) -> (DNSManager.UnknownError unerr) ->
handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownError" <> (show unerr) handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownError" <> (show unerr)
(DNSManager.UnknownNumber ) -> (DNSManager.UnknownNumber ) ->
handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownNumber" handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownNumber"
-- 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 (DNSManager.MkDomainNotFound _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: DomainNotFound" handleAction $ Log $ ErrorLog $ "DomainNotFound"
(DNSManager.MkRRNotFound _) -> do (DNSManager.MkRRNotFound _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: RRNotFound" handleAction $ Log $ ErrorLog $ "RRNotFound"
(DNSManager.MkInvalidZone _) -> do (DNSManager.MkInvalidZone _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: InvalidZone" handleAction $ Log $ ErrorLog $ "InvalidZone"
(DNSManager.MkDomainChanged _) -> do (DNSManager.MkDomainChanged _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: DomainChanged" handleAction $ Log $ ErrorLog $ "DomainChanged"
(DNSManager.MkUnknownZone _) -> do (DNSManager.MkUnknownZone _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: UnknownZone" handleAction $ Log $ ErrorLog $ "UnknownZone"
(DNSManager.MkDomainList _) -> do (DNSManager.MkDomainList _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkDomainList" handleAction $ Log $ ErrorLog $ "MkDomainList"
(DNSManager.MkUnknownUser _) -> do (DNSManager.MkUnknownUser _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkUnknownUser" handleAction $ Log $ ErrorLog $ "MkUnknownUser"
(DNSManager.MkNoOwnership _) -> do (DNSManager.MkNoOwnership _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkNoOwnership" handleAction $ Log $ ErrorLog $ "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 $ ErrorLog $ "reason is: " <> errmsg.reason
(DNSManager.MkErrorUserNotLogged _) -> do (DNSManager.MkErrorUserNotLogged _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Failed! The user isn't connected!" handleAction $ Log $ ErrorLog $ "The user isn't connected!"
handleAction $ Log $ SimpleLog $ "[🤖] Trying to authenticate to fix the problem..." handleAction $ Log $ SystemLog $ "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 $ ErrorLog $ "Invalid token! Try re-authenticate."
(DNSManager.MkDomainAlreadyExists _) -> do (DNSManager.MkDomainAlreadyExists _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Failed! The domain already exists." handleAction $ Log $ ErrorLog $ "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 $ ErrorLog $ "Domain not acceptable (see accepted domain list)."
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 $ SuccessLog $ "Received the list of accepted domains!"
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
m@(DNSManager.MkLogged _) -> do m@(DNSManager.MkLogged _) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Authenticated to dnsmanagerd!" handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd!"
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
m@(DNSManager.MkDomainAdded response) -> do m@(DNSManager.MkDomainAdded response) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Domain added: " <> response.domain handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
(DNSManager.MkRRReadOnly response) -> do (DNSManager.MkRRReadOnly response) -> do
handleAction $ Log $ SimpleLog $ "[😈] Trying to modify a read-only resource! " handleAction $ Log $ ErrorLog $ "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
m@(DNSManager.MkRRUpdated _) -> do m@(DNSManager.MkRRUpdated _) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Resource updated!" handleAction $ Log $ SuccessLog $ "Resource updated!"
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
m@(DNSManager.MkRRAdded response) -> do m@(DNSManager.MkRRAdded response) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Resource Record added: " <> response.rr.rrtype handleAction $ Log $ SuccessLog $ "Resource Record added: " <> response.rr.rrtype
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
(DNSManager.MkInvalidDomainName _) -> do (DNSManager.MkInvalidDomainName _) -> do
handleAction $ Log $ SimpleLog $ "[😈] Failed! The domain is not valid!" handleAction $ Log $ ErrorLog $ "The domain is not valid!"
m@(DNSManager.MkDomainDeleted response) -> do m@(DNSManager.MkDomainDeleted response) -> do
handleAction $ Log $ SimpleLog $ "[🎉] The domain '" <> response.domain <> "' has been deleted!" handleAction $ Log $ SuccessLog $ "The domain '" <> response.domain <> "' has been deleted!"
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
m@(DNSManager.MkRRDeleted response) -> do m@(DNSManager.MkRRDeleted response) -> do
handleAction $ Log $ SimpleLog $ "[🎉] RR (rrid: '" <> show response.rrid <> "') has been deleted!" handleAction $ Log $ SuccessLog $ "RR (rrid: '" <> show response.rrid <> "') has been deleted!"
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
m@(DNSManager.MkZone _) -> do m@(DNSManager.MkZone _) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Zone received!" handleAction $ Log $ SuccessLog $ "Zone received!"
handleAction $ DispatchDNSMessage m handleAction $ DispatchDNSMessage m
(DNSManager.MkInvalidRR response) -> do (DNSManager.MkInvalidRR response) -> do
handleAction $ Log $ SimpleLog $ "[😈] Invalid resource record: " <> A.intercalate ", " response.errors handleAction $ Log $ ErrorLog $ "Invalid resource record: " <> A.intercalate ", " response.errors
(DNSManager.MkSuccess _) -> do (DNSManager.MkSuccess _) -> do
handleAction $ Log $ SimpleLog $ "[🎉] Success!" handleAction $ Log $ SuccessLog $ "(generic) Success!"
(DNSManager.GotKeepAlive _) -> do (DNSManager.GotKeepAlive _) -> do
handleAction $ Log $ SimpleLog $ "[🤖] KeepAlive!🤖🤖🤖" -- handleAction $ Log $ SystemLog $ "KeepAlive!"
pure unit
pure unit pure unit
-- | Send a received DNS manager message to a component. -- | Send a received DNS manager message to a component.
@ -611,12 +618,17 @@ handleAction = case _ of
-- For `Zone`, send a request to `dnsmanagerd` for the zone content. -- For `Zone`, send a request to `dnsmanagerd` for the zone content.
state <- H.get state <- H.get
case state.current_page, message of case state.current_page, message of
-- Home + Logged = page just reloaded.
Home, m@(DNSManager.MkLogged _) -> do Home, m@(DNSManager.MkLogged _) -> do
update_domain_list state m update_domain_list state m
revert_old_page revert_old_page
-- Logged = page just reloaded, but page already changed, no need to do that again.
_, m@(DNSManager.MkLogged _) -> do
-- handleAction $ Log $ SystemLog "logged to dnsmanagerd, do not change page"
update_domain_list state m
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)
_, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd" _, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
pure unit pure unit
where where
update_domain_list state m = do update_domain_list state m = do
@ -624,7 +636,7 @@ handleAction = case _ of
Nothing -> do Nothing -> do
let new_value = DomainListInterface.page_reload (DomainListInterface.initialState unit) m let new_value = DomainListInterface.page_reload (DomainListInterface.initialState unit) m
H.modify_ _ { store_DomainListInterface_state = Just new_value } H.modify_ _ { store_DomainListInterface_state = Just new_value }
Just _ -> handleAction $ Log $ SystemLog "we already have a state? WTH?!" Just _ -> pure unit
revert_old_page = do revert_old_page = do
-- Get back to the previous page. -- Get back to the previous page.
@ -651,6 +663,6 @@ handleAction = case _ of
--print_json_string arraybuffer = do --print_json_string arraybuffer = do
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String)) -- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
-- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer -- value <- H.liftEffect $ IPC.fromTypedIPC arraybuffer
-- H.raise $ Log $ SimpleLog $ case (value) of -- H.raise $ Log $ ErrorLog $ case (value) of
-- Left _ -> "Cannot even fromTypedIPC the message." -- Left _ -> "Cannot even fromTypedIPC the message."
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string -- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string

16
src/App/Log.purs
View File

@ -52,9 +52,11 @@ handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () O
handleQuery = case _ of handleQuery = case _ of
Log message a -> do Log message a -> do
case message of case message of
SimpleLog str -> appendMessage str SimpleLog str -> appendMessage str
SystemLog str -> systemMessage str SystemLog str -> systemMessage str
UnableToSend str -> unableToSend str UnableToSend str -> unableToSend str
ErrorLog str -> errorMessage str
SuccessLog str -> successMessage str
pure (Just a) pure (Just a)
@ -81,6 +83,14 @@ appendMessage msg = do
systemMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit systemMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
systemMessage msg = appendMessage ("[🤖] System: " <> msg) systemMessage msg = appendMessage ("[🤖] System: " <> msg)
-- Append an error message to the chat log.
errorMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
errorMessage msg = appendMessage ("[🛑] Error: " <> msg)
-- Append a success message to the chat log.
successMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
successMessage msg = appendMessage ("[🎉] " <> msg)
-- A system message to use when a message cannot be sent. -- A system message to use when a message cannot be sent.
unableToSend :: forall r m. MonadState (IncompleteState r) m => String -> m Unit unableToSend :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
unableToSend reason = systemMessage ("Unable to send. " <> reason) unableToSend reason = appendMessage ("[🛑] Unable to send. " <> reason)

2
src/App/LogMessage.purs
View File

@ -4,3 +4,5 @@ data LogMessage
= SimpleLog String = SimpleLog String
| SystemLog String | SystemLog String
| UnableToSend String | UnableToSend String
| ErrorLog String
| SuccessLog String

22
src/App/WS.purs
View File

@ -3,7 +3,7 @@
module App.WS where module App.WS where
import Prelude (Unit, bind, discard, pure, show, void, when import Prelude (Unit, bind, discard, pure, show, void, when
, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<), (+)) , ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<))
import Control.Monad.Rec.Class (forever) import Control.Monad.Rec.Class (forever)
import Control.Monad.Except (runExcept) import Control.Monad.Except (runExcept)
@ -54,7 +54,7 @@ data Query a = ToSend ArrayBuffer a
type Slot = H.Slot Query Output type Slot = H.Slot Query Output
-- | `timer` triggers a `Tick` action every `keepalive` seconds. -- | `timer` triggers a `Tick` action every `keepalive` ms.
timer :: forall m a. MonadAff m => a -> m (HS.Emitter a) timer :: forall m a. MonadAff m => a -> m (HS.Emitter a)
timer val = do timer val = do
{ emitter, listener } <- H.liftEffect HS.create { emitter, listener } <- H.liftEffect HS.create
@ -96,7 +96,7 @@ type WSInfo
} }
-- | The state of this component only is composed of the websocket. -- | The state of this component only is composed of the websocket.
type State = { wsInfo :: WSInfo, seconds :: Number } type State = { wsInfo :: WSInfo }
component :: forall m. MonadAff m => H.Component Query Input Output m component :: forall m. MonadAff m => H.Component Query Input Output m
component = component =
@ -117,18 +117,13 @@ initialState url =
, connection: Nothing , connection: Nothing
, reconnect: false , reconnect: false
} }
, seconds: 0.0
} }
-- | The component shows a string when the connection is established, or a button when the connection has closed. -- | The component shows a string when the connection is established, or a button when the connection has closed.
render :: forall m. State -> H.ComponentHTML Action () m render :: forall m. State -> H.ComponentHTML Action () m
render { wsInfo, seconds } render { wsInfo }
= HH.div_ = HH.div_ [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ]
[ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
, HH.text ("You have been here for " <> show seconds <> " seconds")
]
where where
renderFootnote :: String -> H.ComponentHTML Action () m renderFootnote :: String -> H.ComponentHTML Action () m
renderFootnote txt = renderFootnote txt =
HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ] HH.div [ HP.style "margin-bottom: 0.125rem; color: grey;" ] [ HH.small_ [ HH.text txt ] ]
@ -162,10 +157,7 @@ handleAction action = do
_ <- H.subscribe =<< timer Tick _ <- H.subscribe =<< timer Tick
handleAction ConnectWebSocket handleAction ConnectWebSocket
Tick -> do Tick -> H.raise KeepAlive
H.modify_ \state -> state { seconds = state.seconds + keepalive }
-- Applicative KeepAlive. The same message type works for both `authd` and `dnsmanagerd`.
H.raise KeepAlive
Finalize -> do Finalize -> do
-- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'" -- H.raise $ Log $ SystemLog $ "Closing websocket for '" <> wsInfo.url <> "'"
@ -229,7 +221,7 @@ handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () O
handleQuery = case _ of handleQuery = case _ of
ToSend message a -> do ToSend message a -> do
send_message message send_message message
pure Nothing pure (Just a)
send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit
send_message message = do send_message message = do

20
src/App/ZoneInterface.purs
View File

@ -394,7 +394,7 @@ handleAction = case _ of
CreateUpdateRRModal rr_id -> do CreateUpdateRRModal rr_id -> do
state <- H.get state <- H.get
case first (\rr -> rr.rrid == rr_id) state._resources of case first (\rr -> rr.rrid == rr_id) state._resources of
Nothing -> H.raise $ Log $ SimpleLog $ "RR not found (RR " <> show rr_id <> ")" Nothing -> H.raise $ Log $ ErrorLog $ "RR not found (RR " <> show rr_id <> ")"
Just rr -> do Just rr -> do
H.modify_ _ { _currentRR = rr } H.modify_ _ { _currentRR = rr }
H.modify_ _ { rr_modal = UpdateRRModal } H.modify_ _ { rr_modal = UpdateRRModal }
@ -541,7 +541,7 @@ handleAction = case _ of
-- | Initialize the ZoneInterface component: ask for the domain zone to `dnsmanagerd`. -- | Initialize the ZoneInterface component: ask for the domain zone to `dnsmanagerd`.
Initialize -> do Initialize -> do
{ _domain } <- H.get { _domain } <- H.get
H.raise $ Log $ SimpleLog $ "Asking the server for the zone" <> _domain H.raise $ Log $ SystemLog $ "Asking the server for the zone" <> _domain
message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _domain } message <- H.liftEffect $ DNSManager.serialize $ DNSManager.MkGetZone { domain: _domain }
H.raise $ MessageToSend message H.raise $ MessageToSend message
@ -551,8 +551,8 @@ handleAction = case _ of
state <- H.get state <- H.get
case Validation.validation state._currentRR of case Validation.validation state._currentRR of
Left actual_errors -> do Left actual_errors -> do
-- H.raise $ Log $ SimpleLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:" -- H.raise $ Log $ ErrorLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
-- loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> show_error v) actual_errors -- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors
H.modify_ _ { _currentRR_errors = actual_errors } H.modify_ _ { _currentRR_errors = actual_errors }
Right newrr -> do Right newrr -> do
H.modify_ _ { _currentRR_errors = [] } H.modify_ _ { _currentRR_errors = [] }
@ -563,7 +563,7 @@ handleAction = case _ of
-- | Can fail if the content of the form isn't valid. -- | Can fail if the content of the form isn't valid.
AddRR t newrr -> do AddRR t newrr -> do
state <- H.get state <- H.get
H.raise $ Log $ SimpleLog $ "Add new " <> show t H.raise $ Log $ SystemLog $ "Add new " <> show t
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkAddRR { domain: state._domain, rr: newrr } $ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
@ -587,7 +587,7 @@ handleAction = case _ of
SaveRR rr -> do SaveRR rr -> do
state <- H.get state <- H.get
H.raise $ Log $ SimpleLog $ "Updating RR " <> show rr.rrid H.raise $ Log $ SystemLog $ "Updating RR " <> show rr.rrid
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
$ DNSManager.MkUpdateRR { domain: state._domain, rr: rr } $ DNSManager.MkUpdateRR { domain: state._domain, rr: rr }
@ -595,7 +595,7 @@ handleAction = case _ of
RemoveRR rr_id -> do RemoveRR rr_id -> do
{ _domain } <- H.get { _domain } <- H.get
H.raise $ Log $ SimpleLog $ "Ask to remove rr (rrid: " <> show rr_id <> ")" H.raise $ Log $ SystemLog $ "Ask to remove rr (rrid: " <> show rr_id <> ")"
-- Send a removal message. -- Send a removal message.
message <- H.liftEffect message <- H.liftEffect
$ DNSManager.serialize $ DNSManager.serialize
@ -624,7 +624,7 @@ handleQuery = case _ of
(DNSManager.MkZone response) -> do (DNSManager.MkZone response) -> do
add_entries response.zone.resources add_entries response.zone.resources
_ -> H.raise $ Log $ SimpleLog $ "[😈] Message not handled in ZoneInterface." _ -> H.raise $ Log $ ErrorLog $ "Message not handled in ZoneInterface."
pure (Just a) pure (Just a)
ConnectionIsDown a -> do ConnectionIsDown a -> do
@ -644,10 +644,10 @@ handleQuery = case _ of
new_state <- H.get new_state <- H.get
H.put $ add_RR new_state new_rr H.put $ add_RR new_state new_rr
add_entries [] = H.raise $ Log $ SimpleLog "[🎉] Zone fully loaded!" add_entries [] = pure unit
add_entries arr = do add_entries arr = do
case A.head arr, A.tail arr of case A.head arr, A.tail arr of
Nothing, _ -> H.raise $ Log $ SimpleLog "Done adding entries (but why this didn't performed pattern matching??)" Nothing, _ -> pure unit
Just new_rr, tail -> do Just new_rr, tail -> do
state <- H.get state <- H.get
H.put $ add_RR state new_rr H.put $ add_RR state new_rr