From 22f78dc47597207322f65d8700ca6aa3b5a5f217 Mon Sep 17 00:00:00 2001
From: Philippe PITTOLI <karchnu@karchnu.fr>
Date: Fri, 5 Apr 2024 18:23:01 +0200
Subject: [PATCH] Broader use of the Generic class.
---
src/App/Container.purs | 31 ++++++++++++-----------
src/App/Page/Navigation.purs | 16 ++++++++----
src/App/Page/Zone.purs | 30 +++++++----------------
src/App/Type/AcceptedRRTypes.purs | 4 +--
src/App/Type/DKIM.purs | 34 +++++++++++++-------------
src/App/Type/GenericSerialization.purs | 6 +++++
src/App/Type/Pages.purs | 9 +++++++
7 files changed, 71 insertions(+), 59 deletions(-)
create mode 100644 src/App/Type/GenericSerialization.purs
diff --git a/src/App/Container.purs b/src/App/Container.purs
index d0856d9..a16ce24 100644
--- a/src/App/Container.purs
+++ b/src/App/Container.purs
@@ -241,8 +241,7 @@ render state
= HH.div_ $
[ render_header
, render_nav
- , Bulma.columns_ [ Bulma.column_ [ render_login ]
- , Bulma.column_ [ render_notifications ] ]
+ , render_notifications
, case state.current_page of
Home -> render_home
Authentication -> render_auth_form
@@ -264,8 +263,6 @@ render state
GoodNotification v -> Bulma.box [Bulma.notification_success v CloseNotif]
BadNotification v -> Bulma.box [Bulma.notification_danger v CloseNotif]
- render_login = maybe (Bulma.p "") (\l -> Bulma.box [ Bulma.p $ "You are connected as: " <> l]) state.login
-
render_home :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
render_home = HH.slot_ _ho unit HomeInterface.component unit
render_domainlist_interface :: forall monad. MonadAff monad => H.ComponentHTML Action ChildSlots monad
@@ -320,19 +317,21 @@ handleAction = case _ of
Nothing -> revert_old_page
Just _ -> pure unit -- Authentication will happen when web sockets are up!
+ login_name <- H.liftEffect $ Storage.getItem "user-login" sessionstorage
+ case login_name of
+ Nothing -> pure unit
+ Just name -> do H.modify_ _ { login = Just name }
+ H.tell _nav unit $ NavigationInterface.TellLogin (Just name)
+
Routing page -> do
-- Store the current page we are on and restore it when we reload.
sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+ H.liftEffect $ Storage.setItem "current-page" (show page) sessionstorage
+
_ <- case page of
- Home -> H.liftEffect $ Storage.setItem "current-page" "Home" sessionstorage
- Authentication -> H.liftEffect $ Storage.setItem "current-page" "Authentication" sessionstorage
- Registration -> H.liftEffect $ Storage.setItem "current-page" "Registration" sessionstorage
- MailValidation -> H.liftEffect $ Storage.setItem "current-page" "MailValidation" sessionstorage
- DomainList -> H.liftEffect $ Storage.setItem "current-page" "DomainList" sessionstorage
- Zone zone -> do _ <- H.liftEffect $ Storage.setItem "current-page" "Zone" sessionstorage
- H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
- Setup -> H.liftEffect $ Storage.setItem "current-page" "Setup" sessionstorage
- Administration -> H.liftEffect $ Storage.setItem "current-page" "Administration" sessionstorage
+ Zone zone -> H.liftEffect $ Storage.setItem "current-zone" zone sessionstorage
+ _ -> pure unit
+
H.modify_ _ { current_page = page }
Log message -> do
@@ -403,7 +402,11 @@ handleAction = case _ of
AI.AuthenticateToAuthd v -> handleAction $ AuthenticateToAuthd (Right v)
AI.Log message -> handleAction $ Log message
- AI.UserLogin login -> H.modify_ _ { login = Just login }
+ AI.UserLogin login -> do
+ sessionstorage <- H.liftEffect $ Window.sessionStorage =<< HTML.window
+ _ <- H.liftEffect $ Storage.setItem "user-login" login sessionstorage
+ H.modify_ _ { login = Just login }
+ H.tell _nav unit $ NavigationInterface.TellLogin (Just login)
RegistrationInterfaceEvent ev -> case ev of
RI.MessageToSend message -> H.tell _ws_auth unit (WS.ToSend message)
diff --git a/src/App/Page/Navigation.purs b/src/App/Page/Navigation.purs
index 5d750ae..9fec7d3 100644
--- a/src/App/Page/Navigation.purs
+++ b/src/App/Page/Navigation.purs
@@ -34,6 +34,7 @@ data Output
data Query a
= ToggleLogged Boolean a
| ToggleAdmin Boolean a
+ | TellLogin (Maybe String) a
type Slot = H.Slot Query Output
@@ -55,7 +56,7 @@ data Action
-- | - `logged`, a boolean to toggle the display of some parts of the menu.
-- | - `active`, a boolean to toggle the display of the menu.
-- | - `admin`, a boolean to toggle the display of administration page link.
-type State = { logged :: Boolean, active :: Boolean, admin :: Boolean }
+type State = { logged :: Boolean, login :: Maybe String, active :: Boolean, admin :: Boolean }
component :: forall m. MonadAff m => H.Component Query Input Output m
component =
@@ -68,7 +69,7 @@ component =
}
initialState :: Input -> State
-initialState _ = { logged: false, active: false, admin: false }
+initialState _ = { logged: false, login: Nothing, active: false, admin: false }
handleAction :: forall m. MonadAff m => Action -> H.HalogenM State Action () Output m Unit
handleAction = case _ of
@@ -87,6 +88,9 @@ handleQuery = case _ of
ToggleAdmin isadmin a -> do
H.modify_ _ { admin = isadmin }
pure (Just a)
+ TellLogin login a -> do
+ H.modify_ _ { login = login }
+ pure (Just a)
-- | The navigation bar is a complex component to render.
@@ -98,7 +102,7 @@ handleQuery = case _ of
-- | Also, when clicked again, the list disappears.
render :: forall m. State -> H.ComponentHTML Action () m
-render { logged, active, admin } =
+render { logged, active, admin, login } =
main_nav
[ nav_brand [ logo, burger_menu ]
, nav_menu
@@ -117,7 +121,7 @@ render { logged, active, admin } =
right_bar_div =
case logged of
false -> [ link_auth, link_register, link_mail_validation ]
- _ -> [ link_setup, link_disconnection ]
+ _ -> render_login login <> [ link_setup, link_disconnection ]
navbar_color = C.is_success
@@ -127,7 +131,7 @@ render { logged, active, admin } =
, ARIA.role "navigation"
]
- logo = HH.strong [HP.classes $ C.navbar_item <> (C.is_size 4)] [HH.text "🔻🍉"]
+ logo = HH.strong [HP.classes $ C.navbar_item <> (C.is_size 4)] [HH.text "🍉"]
-- HH.a [HP.classes C.navbar_item, HP.href "/"]
-- [HH.img [HP.src "/logo.jpeg", HP.width 112, HP.height 28]]
@@ -158,6 +162,8 @@ render { logged, active, admin } =
link_register = nav_link_strong "Register" (Navigate Registration)
link_mail_validation = nav_link "Mail verification" (Navigate MailValidation)
link_setup = nav_link_warn "⚒ Setup" (Navigate Setup)
+ render_login Nothing = []
+ render_login (Just l)= [nav_link ("logged as " <> l) (Navigate Setup)]
link_disconnection =
nav_link_ (C.has_text_light <> C.has_background_danger) "Disconnection" UnLog
diff --git a/src/App/Page/Zone.purs b/src/App/Page/Zone.purs
index 1ef95b9..433f7ab 100644
--- a/src/App/Page/Zone.purs
+++ b/src/App/Page/Zone.purs
@@ -189,18 +189,6 @@ data RRModal
| UpdateRRModal
| RemoveRRModal RRId
-show_accepted_type :: AcceptedRRTypes -> String
-show_accepted_type = case _ of
- A -> "A"
- AAAA -> "AAAA"
- TXT -> "TXT"
- CNAME -> "CNAME"
- NS -> "NS"
- MX -> "MX"
- SRV -> "SRV"
- SPF -> "SPF"
- DKIM -> "DKIM"
-
string_to_acceptedtype :: String -> Maybe AcceptedRRTypes
string_to_acceptedtype str = case str of
"A" -> Just A
@@ -506,12 +494,12 @@ render state
, Bulma.div_content [Bulma.explanation Explanations.dkim_default_algorithms]
, Bulma.selection_field "idDKIMSignature" "Signature algo"
DKIM_sign_algo
- (map DKIM.show_signature_algorithm DKIM.sign_algos)
- (DKIM.show_signature_algorithm $ fromMaybe DKIM.RSA state.dkim.k)
+ (map show DKIM.sign_algos)
+ (show $ fromMaybe DKIM.RSA state.dkim.k)
, Bulma.selection_field "idDKIMHash" "Hash algo"
DKIM_hash_algo
- (map DKIM.show_hashing_algorithm DKIM.hash_algos)
- (DKIM.show_hashing_algorithm $ fromMaybe DKIM.SHA256 state.dkim.h)
+ (map show DKIM.hash_algos)
+ (show $ fromMaybe DKIM.SHA256 state.dkim.h)
, Bulma.box_input "pkDKIM" "Public Key" "Your public key, such as 'MIIBIjANBgqh...'"
DKIM_pubkey state.dkim.p should_be_disabled
, Bulma.box_input "noteDKIM" "Note" "Note for fellow administrators."
@@ -535,7 +523,7 @@ render state
where
title = case state.rr_modal of
NoModal -> "Error: no modal should be displayed"
- NewRRModal t_ -> "New " <> show_accepted_type t_ <> " resource record"
+ NewRRModal t_ -> "New " <> show t_ <> " resource record"
UpdateRRModal -> "Update RR " <> show state._currentRR.rrid
RemoveRRModal rr_id -> "Error: should display removal modal instead (for RR " <> show rr_id <> ")"
foot = foot_ <> [Bulma.cancel_button CancelModal]
@@ -922,10 +910,10 @@ render_resources records
Just dkim ->
[
-- , HH.td_ [ Bulma.p $ maybe "(default)" id rr.v ] -- For now, version isn't displayed. Assume DKIM1.
- HH.td_ [ Bulma.p $ maybe "" DKIM.show_hashing_algorithm dkim.h ]
- , HH.td_ [ Bulma.p $ maybe "" DKIM.show_signature_algorithm dkim.k ]
- , HH.td_ [ Bulma.p $ CP.take 5 dkim.p ]
- , HH.td_ [ Bulma.p $ fromMaybe "" dkim.n ]
+ HH.td_ [ Bulma.p $ maybe "" show dkim.h ]
+ , HH.td_ [ Bulma.p $ maybe "" show dkim.k ]
+ , HH.td_ [ Bulma.p $ CP.take 5 dkim.p ]
+ , HH.td_ [ Bulma.p $ fromMaybe "" dkim.n ]
, if rr.readonly
then HH.td_ [ Bulma.btn_readonly ]
else HH.td_ [ Bulma.btn_modify (CreateUpdateRRModal rr.rrid), Bulma.btn_delete (DeleteRRModal rr.rrid) ]
diff --git a/src/App/Type/AcceptedRRTypes.purs b/src/App/Type/AcceptedRRTypes.purs
index afcddc6..c524702 100644
--- a/src/App/Type/AcceptedRRTypes.purs
+++ b/src/App/Type/AcceptedRRTypes.purs
@@ -18,7 +18,7 @@ data AcceptedRRTypes
| SPF
| DKIM
-derive instance genericMyADT :: Generic AcceptedRRTypes _
+derive instance genericAcceptedRRTypes :: Generic AcceptedRRTypes _
-instance showMyADT :: Show AcceptedRRTypes where
+instance showAcceptedRRTypes :: Show AcceptedRRTypes where
show = genericShow
diff --git a/src/App/Type/DKIM.purs b/src/App/Type/DKIM.purs
index 82d9fe9..6937674 100644
--- a/src/App/Type/DKIM.purs
+++ b/src/App/Type/DKIM.purs
@@ -1,5 +1,10 @@
module App.Type.DKIM where
+import Prelude
+import Data.Generic.Rep (class Generic)
+import Data.Show.Generic (genericShow)
+
+import App.Type.GenericSerialization (generic_serialization)
import Data.Maybe (Maybe(..))
import Data.Codec.Argonaut (JsonCodec)
@@ -39,10 +44,13 @@ emptyDKIMRR = { v: Nothing, k: Just RSA, h: Just SHA256, p: "", n: Nothing }
data HashingAlgorithm = {- SHA1 | -} SHA256
hash_algos = [ {- "sha1", -} SHA256] :: Array HashingAlgorithm
+derive instance genericHashingAlgorithm :: Generic HashingAlgorithm _
+instance showHashingAlgorithm :: Show HashingAlgorithm where
+ show = genericShow
-- | Codec for just encoding a single value of type `HashingAlgorithm`.
codecHashingAlgorithm :: CA.JsonCodec HashingAlgorithm
-codecHashingAlgorithm = CA.prismaticCodec "HashingAlgorithm" str_to_hashing_algorithm show_hashing_algorithm CA.string
+codecHashingAlgorithm = CA.prismaticCodec "HashingAlgorithm" str_to_hashing_algorithm generic_serialization CA.string
str_to_hashing_algorithm :: String -> Maybe HashingAlgorithm
str_to_hashing_algorithm = case _ of
@@ -50,17 +58,15 @@ str_to_hashing_algorithm = case _ of
"sha256" -> Just SHA256
_ -> Nothing
-show_hashing_algorithm :: HashingAlgorithm -> String
-show_hashing_algorithm = case _ of
- -- SHA1 -> "sha1"
- SHA256 -> "sha256"
-
data SignatureAlgorithm = RSA | ED25519
sign_algos = [RSA, ED25519] :: Array SignatureAlgorithm
+derive instance genericSignatureAlgorithm :: Generic SignatureAlgorithm _
+instance showSignatureAlgorithm :: Show SignatureAlgorithm where
+ show = genericShow
-- | Codec for just encoding a single value of type `SignatureAlgorithm`.
codecSignatureAlgorithm :: CA.JsonCodec SignatureAlgorithm
-codecSignatureAlgorithm = CA.prismaticCodec "SignatureAlgorithm" str_to_signature_algorithm show_signature_algorithm CA.string
+codecSignatureAlgorithm = CA.prismaticCodec "SignatureAlgorithm" str_to_signature_algorithm generic_serialization CA.string
str_to_signature_algorithm :: String -> Maybe SignatureAlgorithm
str_to_signature_algorithm = case _ of
@@ -68,22 +74,16 @@ str_to_signature_algorithm = case _ of
"ed25519" -> Just ED25519
_ -> Nothing
-show_signature_algorithm :: SignatureAlgorithm -> String
-show_signature_algorithm = case _ of
- RSA -> "rsa"
- ED25519 -> "ed25519"
-
data Version = DKIM1
+derive instance genericVersion :: Generic Version _
+instance showVersion :: Show Version where
+ show = genericShow
-- | Codec for just encoding a single value of type `Version`.
codecVersion :: CA.JsonCodec Version
-codecVersion = CA.prismaticCodec "Version" str_to_version show_version CA.string
+codecVersion = CA.prismaticCodec "Version" str_to_version generic_serialization CA.string
str_to_version :: String -> Maybe Version
str_to_version = case _ of
"dkim1" -> Just DKIM1
_ -> Nothing
-
-show_version :: Version -> String
-show_version = case _ of
- DKIM1 -> "dkim1"
diff --git a/src/App/Type/GenericSerialization.purs b/src/App/Type/GenericSerialization.purs
new file mode 100644
index 0000000..7ede036
--- /dev/null
+++ b/src/App/Type/GenericSerialization.purs
@@ -0,0 +1,6 @@
+module App.Type.GenericSerialization where
+import Prelude (show, class Show, (<<<))
+import Data.String (toLower)
+
+generic_serialization :: forall a. Show a => a -> String
+generic_serialization = toLower <<< show
diff --git a/src/App/Type/Pages.purs b/src/App/Type/Pages.purs
index 7d85a29..d79fbaf 100644
--- a/src/App/Type/Pages.purs
+++ b/src/App/Type/Pages.purs
@@ -1,4 +1,8 @@
module App.Type.Pages where
+
+import Prelude
+import Data.Generic.Rep (class Generic)
+import Data.Show.Generic (genericShow)
-- | This list will grow in a near future.
-- |
-- | TODO:
@@ -11,3 +15,8 @@ data Page
| Zone String -- | `Zone`: to manage a zone.
| Setup -- | `Setup`: user account administration page
| Administration -- | `Administration`: administration page (for both `authd` and `dnsmanagerd`).
+
+derive instance genericPage :: Generic Page _
+
+instance showPage :: Show Page where
+ show = genericShow