Improved API for logs (new SuccessLog & ErrorLog).
This commit is contained in:
parent
c2e51dc964
commit
1d15a47c77
@ -172,12 +172,12 @@ handleAction = case _ of
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
old_page <- H.liftEffect $ Storage.getItem "current-ada-page" sessionstorage
|
||||
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
|
||||
"Home" -> handleAction $ Routing Home
|
||||
"Search" -> handleAction $ Routing Search
|
||||
"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
|
||||
state <- H.get
|
||||
@ -195,10 +195,10 @@ handleAction = case _ of
|
||||
PreventSubmit ev -> H.liftEffect $ Event.preventDefault ev
|
||||
|
||||
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
|
||||
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 }
|
||||
H.raise $ MessageToSend ab
|
||||
|
||||
@ -220,7 +220,7 @@ handleAction = case _ of
|
||||
, email: Just (Email.Email email)
|
||||
, password: pass }
|
||||
H.raise $ MessageToSend ab
|
||||
H.raise $ Log $ SimpleLog "[😇] Trying to add a user"
|
||||
H.raise $ Log $ SystemLog "Add a user"
|
||||
|
||||
Routing page -> do
|
||||
-- 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 }
|
||||
H.raise $ MessageToSend ab
|
||||
H.modify_ _ { matching_users = [] }
|
||||
H.raise $ Log $ SimpleLog "[😇] Trying to search a user"
|
||||
|
||||
not_empty_string :: String -> Maybe String
|
||||
not_empty_string "" = Nothing
|
||||
@ -258,23 +257,21 @@ handleQuery = case _ of
|
||||
|
||||
MessageReceived message a -> do
|
||||
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
|
||||
H.raise $ Log $ SimpleLog $ "[🎉] Success! Server added user: " <> show msg.user
|
||||
H.raise $ Log $ SuccessLog $ "Added user: " <> show msg.user
|
||||
|
||||
(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 }
|
||||
|
||||
(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
|
||||
H.modify_ _ { matching_users = A.filter (\x -> x.uid /= msg.uid) matching_users }
|
||||
|
||||
-- Unexpected message.
|
||||
_ -> 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)
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
|
||||
@ -302,7 +302,7 @@ handleAction = case _ of
|
||||
|
||||
AuthenticateToAuthd v -> case v of
|
||||
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 }
|
||||
H.tell _ws_auth unit (WS.ToSend message)
|
||||
Right (Tuple login password) -> do
|
||||
@ -319,7 +319,7 @@ handleAction = case _ of
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> handleAction $ Log $ SimpleLog "no token!"
|
||||
Nothing -> handleAction $ Log $ ErrorLog "no token!"
|
||||
Just t -> do
|
||||
H.modify_ _ { token = Just t }
|
||||
handleAction AuthenticateToDNSManager
|
||||
@ -371,9 +371,9 @@ handleAction = case _ of
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
token <- H.liftEffect $ Storage.getItem "user-authd-token" sessionstorage
|
||||
case token of
|
||||
Nothing -> handleAction $ Log $ SimpleLog "no token!"
|
||||
Nothing -> handleAction $ Log $ ErrorLog "no token!"
|
||||
Just t -> do
|
||||
handleAction $ Log $ SimpleLog "Let's authenticate to authd"
|
||||
handleAction $ Log $ SystemLog "Let's authenticate to authd"
|
||||
handleAction $ AuthenticateToAuthd (Left t)
|
||||
|
||||
WS.WSJustClosed -> do
|
||||
@ -387,93 +387,97 @@ handleAction = case _ of
|
||||
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 $ ErrorLog $
|
||||
-- "received a message that couldn't be decoded. Reason: " <> show err
|
||||
case err of
|
||||
(AuthD.JSONERROR jerr) -> do
|
||||
-- print_json_string messageEvent.message
|
||||
handleAction $ Log $ SimpleLog $ "[🤖] JSON parsing error: " <> jerr
|
||||
(AuthD.UnknownError unerr) -> handleAction $ Log $ SimpleLog ("[🤖] Parsing error: AuthD.UnknownError" <> (show unerr))
|
||||
(AuthD.UnknownNumber ) -> handleAction $ Log $ SimpleLog ("[🤖] Parsing error: AuthD.UnknownNumber")
|
||||
handleAction $ Log $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(AuthD.UnknownError unerr) -> handleAction $ Log $ ErrorLog $
|
||||
"Parsing error: AuthD.UnknownError" <> (show unerr)
|
||||
(AuthD.UnknownNumber ) -> handleAction $ Log $ ErrorLog
|
||||
"Parsing error: AuthD.UnknownNumber"
|
||||
|
||||
-- Cases where we understood the message.
|
||||
-- TODO: create a modal to show some of these?
|
||||
Right response -> do
|
||||
case response of
|
||||
(AuthD.GotUser _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUser message."
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUser message."
|
||||
m@(AuthD.GotUserAdded _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Registration -> do
|
||||
handleAction $ Log $ SimpleLog """
|
||||
[🎉] you are now registered, copy the token we sent you by email to finish your registration.
|
||||
handleAction $ Log $ SuccessLog """
|
||||
You are now registered, copy the token we sent you by email to finish your registration.
|
||||
"""
|
||||
handleAction $ Routing MailValidation
|
||||
_ -> handleAction $ DispatchAuthDaemonMessage m
|
||||
(AuthD.GotUserEdited _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUserEdited message."
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUserEdited message."
|
||||
(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
|
||||
(AuthD.GotUsersList _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotUsersList message."
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotUsersList message."
|
||||
(AuthD.GotPermissionCheck _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotPermissionCheck message."
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotPermissionCheck message."
|
||||
(AuthD.GotPermissionSet _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Received a GotPermissionSet message."
|
||||
handleAction $ Log $ ErrorLog "Received a GotPermissionSet message."
|
||||
(AuthD.GotPasswordRecovered _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] TODO: received a GotPasswordRecovered message."
|
||||
handleAction $ Log $ ErrorLog "TODO: received a GotPasswordRecovered message."
|
||||
m@(AuthD.GotMatchingUsers _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> handleAction $ Log $ SimpleLog
|
||||
"[😈] received a GotMatchingUsers message while not on authd admin page."
|
||||
_ -> handleAction $ Log $ ErrorLog
|
||||
"received a GotMatchingUsers message while not on authd admin page."
|
||||
m@(AuthD.GotUserDeleted _) -> do
|
||||
{ current_page } <- H.get
|
||||
case current_page of
|
||||
Administration -> handleAction $ DispatchAuthDaemonMessage m
|
||||
_ -> handleAction $ Log $ SimpleLog
|
||||
"[😈] received a GotUserDeleted message while not on authd admin page."
|
||||
_ -> handleAction $ Log $ ErrorLog
|
||||
"received a GotUserDeleted message while not on authd admin page."
|
||||
(AuthD.GotErrorMustBeAuthenticated _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Fail: received a GotErrorMustBeAuthenticated message."
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorMustBeAuthenticated message."
|
||||
(AuthD.GotErrorAlreadyUsedLogin _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Fail: received a GotErrorAlreadyUsedLogin message."
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorAlreadyUsedLogin message."
|
||||
(AuthD.GotErrorUserNotFound _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Fail: received a GotErrorUserNotFound message."
|
||||
handleAction $ Log $ ErrorLog "received a GotErrorUserNotFound message."
|
||||
|
||||
-- The authentication failed.
|
||||
(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
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] Password recovery: email sent!"
|
||||
handleAction $ Log $ SuccessLog $ "Password recovery: email sent!"
|
||||
(AuthD.GotErrorPasswordTooShort _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Password too short!"
|
||||
handleAction $ Log $ ErrorLog "Password too short!"
|
||||
(AuthD.GotErrorMailRequired _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Email required!"
|
||||
handleAction $ Log $ ErrorLog "Email required!"
|
||||
(AuthD.GotErrorInvalidCredentials _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Invalid credentials!"
|
||||
handleAction $ Log $ ErrorLog "Invalid credentials!"
|
||||
(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
|
||||
handleAction $ Log $ SimpleLog "[😈] Invalid login format!"
|
||||
handleAction $ Log $ ErrorLog "Invalid login format!"
|
||||
(AuthD.GotErrorInvalidEmailFormat _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Invalid email format!"
|
||||
handleAction $ Log $ ErrorLog "Invalid email format!"
|
||||
(AuthD.GotErrorAlreadyUsersInDB _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] Login already taken!"
|
||||
handleAction $ Log $ ErrorLog "Login already taken!"
|
||||
(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
|
||||
handleAction $ Log $ SimpleLog "[😈] Invalid activation key!"
|
||||
handleAction $ Log $ ErrorLog "Invalid activation key!"
|
||||
(AuthD.GotErrorUserAlreadyValidated _) -> do
|
||||
handleAction $ Log $ SimpleLog "[😈] User already validated!"
|
||||
handleAction $ Log $ ErrorLog "User already validated!"
|
||||
(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
|
||||
handleAction $ Log $ SimpleLog "[😈] Invalid renew key!"
|
||||
handleAction $ Log $ ErrorLog "Invalid renew key!"
|
||||
-- The authentication was a success!
|
||||
(AuthD.GotToken msg) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] Authenticated to authd!"
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to authd!"
|
||||
H.modify_ _ { token = Just msg.token }
|
||||
|
||||
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
|
||||
@ -481,7 +485,8 @@ handleAction = case _ of
|
||||
|
||||
handleAction AuthenticateToDNSManager
|
||||
(AuthD.GotKeepAlive _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[🤖] KeepAlive!🤖🤖🤖"
|
||||
-- handleAction $ Log $ SystemLog $ "KeepAlive!"
|
||||
pure unit
|
||||
pure unit
|
||||
|
||||
-- | Send a received authentication daemon message `AuthD.AnswerMessage` to a component.
|
||||
@ -504,7 +509,7 @@ handleAction = case _ of
|
||||
WS.MessageReceived (Tuple _ message) -> do
|
||||
handleAction $ DecodeDNSMessage message
|
||||
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
|
||||
H.tell _dli unit DomainListInterface.ConnectionIsUp
|
||||
WS.WSJustClosed -> H.tell _dli unit DomainListInterface.ConnectionIsDown
|
||||
@ -517,85 +522,87 @@ handleAction = case _ of
|
||||
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 $ ErrorLog $
|
||||
-- "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 $ ErrorLog $ "JSON parsing error: " <> jerr
|
||||
(DNSManager.UnknownError unerr) ->
|
||||
handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownError" <> (show unerr)
|
||||
handleAction $ Log $ ErrorLog $ "Parsing error: DNSManager.UnknownError" <> (show unerr)
|
||||
(DNSManager.UnknownNumber ) ->
|
||||
handleAction $ Log $ SimpleLog $ "[🤖] Parsing error: DNSManager.UnknownNumber"
|
||||
handleAction $ Log $ ErrorLog $ "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"
|
||||
handleAction $ Log $ ErrorLog $ "DomainNotFound"
|
||||
(DNSManager.MkRRNotFound _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Fail: RRNotFound"
|
||||
handleAction $ Log $ ErrorLog $ "RRNotFound"
|
||||
(DNSManager.MkInvalidZone _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Fail: InvalidZone"
|
||||
handleAction $ Log $ ErrorLog $ "InvalidZone"
|
||||
(DNSManager.MkDomainChanged _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Fail: DomainChanged"
|
||||
handleAction $ Log $ ErrorLog $ "DomainChanged"
|
||||
(DNSManager.MkUnknownZone _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Fail: UnknownZone"
|
||||
handleAction $ Log $ ErrorLog $ "UnknownZone"
|
||||
(DNSManager.MkDomainList _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkDomainList"
|
||||
handleAction $ Log $ ErrorLog $ "MkDomainList"
|
||||
(DNSManager.MkUnknownUser _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkUnknownUser"
|
||||
handleAction $ Log $ ErrorLog $ "MkUnknownUser"
|
||||
(DNSManager.MkNoOwnership _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Fail: MkNoOwnership"
|
||||
handleAction $ Log $ ErrorLog $ "MkNoOwnership"
|
||||
-- The authentication failed.
|
||||
(DNSManager.MkError errmsg) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Failed, reason is: " <> errmsg.reason
|
||||
handleAction $ Log $ ErrorLog $ "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 $ ErrorLog $ "The user isn't connected!"
|
||||
handleAction $ Log $ SystemLog $ "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 $ ErrorLog $ "Invalid token! Try re-authenticate."
|
||||
(DNSManager.MkDomainAlreadyExists _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[😈] Failed! The domain already exists."
|
||||
handleAction $ Log $ ErrorLog $ "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 $ ErrorLog $ "Domain not acceptable (see accepted domain list)."
|
||||
handleAction $ DispatchDNSMessage m
|
||||
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
|
||||
m@(DNSManager.MkLogged _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] Authenticated to dnsmanagerd!"
|
||||
handleAction $ Log $ SuccessLog $ "Authenticated to dnsmanagerd!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
m@(DNSManager.MkDomainAdded response) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] Domain added: " <> response.domain
|
||||
handleAction $ Log $ SuccessLog $ "Domain added: " <> response.domain
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(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
|
||||
<> "resource rrid: " <> show response.rr.rrid
|
||||
m@(DNSManager.MkRRUpdated _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] Resource updated!"
|
||||
handleAction $ Log $ SuccessLog $ "Resource updated!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
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
|
||||
(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
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] The domain '" <> response.domain <> "' has been deleted!"
|
||||
handleAction $ Log $ SuccessLog $ "The domain '" <> response.domain <> "' has been deleted!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
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
|
||||
m@(DNSManager.MkZone _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] Zone received!"
|
||||
handleAction $ Log $ SuccessLog $ "Zone received!"
|
||||
handleAction $ DispatchDNSMessage m
|
||||
(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
|
||||
handleAction $ Log $ SimpleLog $ "[🎉] Success!"
|
||||
handleAction $ Log $ SuccessLog $ "(generic) Success!"
|
||||
(DNSManager.GotKeepAlive _) -> do
|
||||
handleAction $ Log $ SimpleLog $ "[🤖] KeepAlive!🤖🤖🤖"
|
||||
-- handleAction $ Log $ SystemLog $ "KeepAlive!"
|
||||
pure unit
|
||||
pure unit
|
||||
|
||||
-- | 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.
|
||||
state <- H.get
|
||||
case state.current_page, message of
|
||||
-- Home + Logged = page just reloaded.
|
||||
Home, m@(DNSManager.MkLogged _) -> do
|
||||
update_domain_list state m
|
||||
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)
|
||||
Zone _ , _ -> H.tell _zi unit (ZoneInterface.MessageReceived message)
|
||||
_, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
|
||||
_, _ -> handleAction $ Log $ SystemLog "unexpected message from dnsmanagerd"
|
||||
pure unit
|
||||
where
|
||||
update_domain_list state m = do
|
||||
@ -624,7 +636,7 @@ handleAction = case _ of
|
||||
Nothing -> do
|
||||
let new_value = DomainListInterface.page_reload (DomainListInterface.initialState unit) m
|
||||
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
|
||||
-- Get back to the previous page.
|
||||
@ -651,6 +663,6 @@ handleAction = case _ of
|
||||
--print_json_string arraybuffer = do
|
||||
-- -- fromTypedIPC :: ArrayBuffer -> Effect (Either ParseError (Tuple UInt String))
|
||||
-- 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."
|
||||
-- Right (Tuple messageTypeNumber string) -> "Number is: " <> show messageTypeNumber <> ", received string: " <> string
|
||||
|
||||
@ -52,9 +52,11 @@ handleQuery :: forall a m. MonadAff m => Query a -> H.HalogenM State Action () O
|
||||
handleQuery = case _ of
|
||||
Log message a -> do
|
||||
case message of
|
||||
SimpleLog str -> appendMessage str
|
||||
SystemLog str -> systemMessage str
|
||||
SimpleLog str -> appendMessage str
|
||||
SystemLog str -> systemMessage str
|
||||
UnableToSend str -> unableToSend str
|
||||
ErrorLog str -> errorMessage str
|
||||
SuccessLog str -> successMessage str
|
||||
pure (Just a)
|
||||
|
||||
|
||||
@ -81,6 +83,14 @@ appendMessage msg = do
|
||||
systemMessage :: forall r m. MonadState (IncompleteState r) m => String -> m Unit
|
||||
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.
|
||||
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)
|
||||
|
||||
@ -4,3 +4,5 @@ data LogMessage
|
||||
= SimpleLog String
|
||||
| SystemLog String
|
||||
| UnableToSend String
|
||||
| ErrorLog String
|
||||
| SuccessLog String
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
module App.WS where
|
||||
|
||||
import Prelude (Unit, bind, discard, pure, show, void, when
|
||||
, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<), (+))
|
||||
, ($), (&&), (<$>), (<>), (>>=), (>=>), (<<<), map, (=<<))
|
||||
|
||||
import Control.Monad.Rec.Class (forever)
|
||||
import Control.Monad.Except (runExcept)
|
||||
@ -54,7 +54,7 @@ data Query a = ToSend ArrayBuffer a
|
||||
|
||||
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 val = do
|
||||
{ emitter, listener } <- H.liftEffect HS.create
|
||||
@ -96,7 +96,7 @@ type WSInfo
|
||||
}
|
||||
|
||||
-- | 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 =
|
||||
@ -117,18 +117,13 @@ initialState url =
|
||||
, connection: Nothing
|
||||
, reconnect: false
|
||||
}
|
||||
, seconds: 0.0
|
||||
}
|
||||
|
||||
-- | 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 { wsInfo, seconds }
|
||||
= HH.div_
|
||||
[ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect)
|
||||
, HH.text ("You have been here for " <> show seconds <> " seconds")
|
||||
]
|
||||
render { wsInfo }
|
||||
= HH.div_ [ renderReconnectButton (isNothing wsInfo.connection && wsInfo.reconnect) ]
|
||||
where
|
||||
|
||||
renderFootnote :: String -> H.ComponentHTML Action () m
|
||||
renderFootnote 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
|
||||
handleAction ConnectWebSocket
|
||||
|
||||
Tick -> do
|
||||
H.modify_ \state -> state { seconds = state.seconds + keepalive }
|
||||
-- Applicative KeepAlive. The same message type works for both `authd` and `dnsmanagerd`.
|
||||
H.raise KeepAlive
|
||||
Tick -> H.raise KeepAlive
|
||||
|
||||
Finalize -> do
|
||||
-- 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
|
||||
ToSend message a -> do
|
||||
send_message message
|
||||
pure Nothing
|
||||
pure (Just a)
|
||||
|
||||
send_message :: forall m. MonadAff m => ArrayBuffer -> H.HalogenM State Action () Output m Unit
|
||||
send_message message = do
|
||||
|
||||
@ -394,7 +394,7 @@ handleAction = case _ of
|
||||
CreateUpdateRRModal rr_id -> do
|
||||
state <- H.get
|
||||
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
|
||||
H.modify_ _ { _currentRR = rr }
|
||||
H.modify_ _ { rr_modal = UpdateRRModal }
|
||||
@ -541,7 +541,7 @@ handleAction = case _ of
|
||||
-- | Initialize the ZoneInterface component: ask for the domain zone to `dnsmanagerd`.
|
||||
Initialize -> do
|
||||
{ _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 }
|
||||
H.raise $ MessageToSend message
|
||||
|
||||
@ -551,8 +551,8 @@ handleAction = case _ of
|
||||
state <- H.get
|
||||
case Validation.validation state._currentRR of
|
||||
Left actual_errors -> do
|
||||
-- H.raise $ Log $ SimpleLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
|
||||
-- loopE (\v -> H.raise $ Log $ SimpleLog $ "==> " <> show_error v) actual_errors
|
||||
-- H.raise $ Log $ ErrorLog $ "Cannot add this " <> show t <> " RR, some errors occured in the record:"
|
||||
-- loopE (\v -> H.raise $ Log $ ErrorLog $ "==> " <> show_error v) actual_errors
|
||||
H.modify_ _ { _currentRR_errors = actual_errors }
|
||||
Right newrr -> do
|
||||
H.modify_ _ { _currentRR_errors = [] }
|
||||
@ -563,7 +563,7 @@ handleAction = case _ of
|
||||
-- | Can fail if the content of the form isn't valid.
|
||||
AddRR t newrr -> do
|
||||
state <- H.get
|
||||
H.raise $ Log $ SimpleLog $ "Add new " <> show t
|
||||
H.raise $ Log $ SystemLog $ "Add new " <> show t
|
||||
message <- H.liftEffect
|
||||
$ DNSManager.serialize
|
||||
$ DNSManager.MkAddRR { domain: state._domain, rr: newrr }
|
||||
@ -587,7 +587,7 @@ handleAction = case _ of
|
||||
|
||||
SaveRR rr -> do
|
||||
state <- H.get
|
||||
H.raise $ Log $ SimpleLog $ "Updating RR " <> show rr.rrid
|
||||
H.raise $ Log $ SystemLog $ "Updating RR " <> show rr.rrid
|
||||
message <- H.liftEffect
|
||||
$ DNSManager.serialize
|
||||
$ DNSManager.MkUpdateRR { domain: state._domain, rr: rr }
|
||||
@ -595,7 +595,7 @@ handleAction = case _ of
|
||||
|
||||
RemoveRR rr_id -> do
|
||||
{ _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.
|
||||
message <- H.liftEffect
|
||||
$ DNSManager.serialize
|
||||
@ -624,7 +624,7 @@ handleQuery = case _ of
|
||||
(DNSManager.MkZone response) -> do
|
||||
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)
|
||||
|
||||
ConnectionIsDown a -> do
|
||||
@ -644,10 +644,10 @@ handleQuery = case _ of
|
||||
new_state <- H.get
|
||||
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
|
||||
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
|
||||
state <- H.get
|
||||
H.put $ add_RR state new_rr
|
||||
|
||||
Loading…
Reference in New Issue
Block a user