2023-06-16 18:54:07 +02:00
|
|
|
module App.Messages.DNSManagerDaemon where
|
|
|
|
|
|
|
|
import Prelude (bind, pure, show, ($))
|
|
|
|
|
|
|
|
import Effect (Effect)
|
|
|
|
|
|
|
|
import Data.Argonaut.Core as J
|
|
|
|
import Data.Codec.Argonaut as CA
|
|
|
|
import Data.Maybe (Maybe)
|
|
|
|
import Data.Either (Either(..))
|
|
|
|
import Data.Codec.Argonaut.Record as CAR
|
|
|
|
import Data.UInt (fromInt, toInt, UInt)
|
|
|
|
|
|
|
|
import Data.Tuple (Tuple(..))
|
|
|
|
import Data.ArrayBuffer.Types (ArrayBuffer)
|
|
|
|
|
|
|
|
-- import App.PermissionLevel as PermissionLevel
|
2023-06-17 18:07:24 +02:00
|
|
|
import App.MaintenanceSubject as MaintenanceSubject
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
import Effect.Class (liftEffect)
|
|
|
|
import Data.Argonaut.Parser as JSONParser
|
|
|
|
import Data.Bifunctor (lmap)
|
|
|
|
|
|
|
|
import App.IPC as IPC
|
2023-06-17 18:07:24 +02:00
|
|
|
import App.DNSZone as DNSZone
|
|
|
|
import App.ResourceRecord as ResourceRecord
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
{- UserID should be in a separate module with a dedicated codec. -}
|
|
|
|
type UserID = Int -- UserID is either a login or an uid number
|
|
|
|
|
|
|
|
|
|
|
|
{- 0 -}
|
|
|
|
type Login = { token :: String }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecLogin ∷ CA.JsonCodec Login
|
2023-06-16 18:54:07 +02:00
|
|
|
codecLogin = CA.object "Login" (CAR.record { token: CA.string })
|
|
|
|
|
2023-06-17 18:08:09 +02:00
|
|
|
{- 7 -}
|
|
|
|
type Maintenance = { subject :: MaintenanceSubject.MaintenanceSubject, value :: Maybe Int }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecMaintenance ∷ CA.JsonCodec Maintenance
|
2023-06-17 18:08:09 +02:00
|
|
|
codecMaintenance = CA.object "Maintenance" (CAR.record { subject: MaintenanceSubject.codec, value: CAR.optional CA.int })
|
|
|
|
|
2023-06-17 18:07:24 +02:00
|
|
|
{- 9 -}
|
|
|
|
type NewDomain = { domain :: String }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecNewDomain ∷ CA.JsonCodec NewDomain
|
2023-06-17 18:07:24 +02:00
|
|
|
codecNewDomain = CA.object "NewDomain" (CAR.record { domain: CA.string })
|
|
|
|
|
2023-06-16 18:54:07 +02:00
|
|
|
{- 10 -}
|
2023-06-17 18:07:24 +02:00
|
|
|
type AddOrUpdateZone = { zone :: DNSZone.DNSZone }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecAddOrUpdateZone ∷ CA.JsonCodec AddOrUpdateZone
|
2023-06-17 18:07:24 +02:00
|
|
|
codecAddOrUpdateZone = CA.object "AddOrUpdateZone" (CAR.record { zone: DNSZone.codec })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
{- 11 -}
|
|
|
|
type DeleteZone = { domain :: String }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecDeleteZone ∷ CA.JsonCodec DeleteZone
|
2023-06-16 18:54:07 +02:00
|
|
|
codecDeleteZone = CA.object "DeleteZone" (CAR.record { domain: CA.string })
|
|
|
|
|
|
|
|
{- 12 -}
|
|
|
|
type GetZone = { domain :: String }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecGetZone ∷ CA.JsonCodec GetZone
|
2023-06-16 18:54:07 +02:00
|
|
|
codecGetZone = CA.object "GetZone" (CAR.record { domain: CA.string })
|
|
|
|
|
|
|
|
{- 13 -}
|
|
|
|
type UserDomains = {}
|
2023-06-17 18:16:52 +02:00
|
|
|
codecUserDomains ∷ CA.JsonCodec UserDomains
|
2023-06-16 18:54:07 +02:00
|
|
|
codecUserDomains = CA.object "UserDomains" (CAR.record {})
|
|
|
|
|
|
|
|
{- 14 -}
|
2023-06-17 18:07:24 +02:00
|
|
|
type AddRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecAddRR ∷ CA.JsonCodec AddRR
|
2023-06-17 18:07:24 +02:00
|
|
|
codecAddRR = CA.object "AddRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
{- 15 -}
|
2023-06-17 18:07:24 +02:00
|
|
|
type UpdateRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecUpdateRR ∷ CA.JsonCodec UpdateRR
|
2023-06-17 18:07:24 +02:00
|
|
|
codecUpdateRR = CA.object "UpdateRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
{- 16 -}
|
|
|
|
type DeleteRR = { domain :: String, rrid :: Int }
|
2023-06-17 18:16:52 +02:00
|
|
|
codecDeleteRR ∷ CA.JsonCodec DeleteRR
|
2023-06-16 18:54:07 +02:00
|
|
|
codecDeleteRR = CA.object "DeleteRR" (CAR.record { domain: CA.string, rrid: CA.int })
|
|
|
|
|
|
|
|
{-
|
|
|
|
RESPONSES
|
|
|
|
-}
|
|
|
|
|
|
|
|
{- 0 -}
|
2023-06-17 16:04:26 +02:00
|
|
|
-- type Error = { reason :: String | Array(String) }
|
|
|
|
type Error = { reason :: String }
|
2023-06-17 18:07:24 +02:00
|
|
|
codecError ∷ CA.JsonCodec Error
|
|
|
|
codecError = CA.object "Error" (CAR.record { reason: CA.string })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
{- 1 -}
|
2023-06-17 16:04:26 +02:00
|
|
|
type Success = { }
|
|
|
|
codecSuccess ∷ CA.JsonCodec Success
|
|
|
|
codecSuccess = CA.object "Success" (CAR.record { })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
{- 2 -}
|
2023-06-17 16:04:26 +02:00
|
|
|
type ErrorInvalidToken = { }
|
|
|
|
codecErrorInvalidToken ∷ CA.JsonCodec ErrorInvalidToken
|
|
|
|
codecErrorInvalidToken = CA.object "ErrorInvalidToken" (CAR.record { })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
{- 3 -}
|
2023-06-17 16:04:26 +02:00
|
|
|
type DomainAlreadyExists = { }
|
|
|
|
codecDomainAlreadyExists ∷ CA.JsonCodec DomainAlreadyExists
|
|
|
|
codecDomainAlreadyExists = CA.object "DomainAlreadyExists" (CAR.record { })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
2023-06-18 02:11:16 +02:00
|
|
|
{- 4 -}
|
|
|
|
type ErrorUserNotLogged = { }
|
|
|
|
codecErrorUserNotLogged ∷ CA.JsonCodec ErrorUserNotLogged
|
|
|
|
codecErrorUserNotLogged = CA.object "ErrorUserNotLogged" (CAR.record { })
|
|
|
|
|
2023-06-17 16:04:26 +02:00
|
|
|
{- 10 -}
|
|
|
|
-- For now, Error is just an alias on String.
|
|
|
|
-- type InvalidZone = { errors : Array(Storage::Zone::Error) }
|
|
|
|
type InvalidZone = { errors :: Array String }
|
|
|
|
codecInvalidZone ∷ CA.JsonCodec InvalidZone
|
|
|
|
codecInvalidZone = CA.object "InvalidZone" (CAR.record { errors: CA.array CA.string })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
2023-06-17 16:04:26 +02:00
|
|
|
{- 11 -}
|
|
|
|
type DomainChanged = { }
|
|
|
|
codecDomainChanged ∷ CA.JsonCodec DomainChanged
|
|
|
|
codecDomainChanged = CA.object "DomainChanged" (CAR.record { })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
2023-06-17 16:04:26 +02:00
|
|
|
{- 12 -}
|
|
|
|
-- TODO
|
2023-06-17 18:07:24 +02:00
|
|
|
type Zone = { zone :: DNSZone.DNSZone }
|
2023-06-17 16:04:26 +02:00
|
|
|
codecZone ∷ CA.JsonCodec Zone
|
2023-06-17 18:07:24 +02:00
|
|
|
codecZone = CA.object "Zone" (CAR.record { zone: DNSZone.codec })
|
2023-06-17 16:04:26 +02:00
|
|
|
|
|
|
|
{- 13 -}
|
|
|
|
type UnknownZone = { }
|
|
|
|
codecUnknownZone ∷ CA.JsonCodec UnknownZone
|
|
|
|
codecUnknownZone = CA.object "UnknownZone" (CAR.record { })
|
|
|
|
|
|
|
|
{- 14 -}
|
|
|
|
type DomainList = { domains :: Array String }
|
|
|
|
codecDomainList ∷ CA.JsonCodec DomainList
|
|
|
|
codecDomainList = CA.object "DomainList" (CAR.record { domains: CA.array CA.string })
|
|
|
|
|
|
|
|
{- 50 -}
|
|
|
|
type UnknownUser = { }
|
|
|
|
codecUnknownUser ∷ CA.JsonCodec UnknownUser
|
|
|
|
codecUnknownUser = CA.object "UnknownUser" (CAR.record { })
|
|
|
|
|
|
|
|
{- 51 -}
|
|
|
|
type NoOwnership = { }
|
|
|
|
codecNoOwnership ∷ CA.JsonCodec NoOwnership
|
|
|
|
codecNoOwnership = CA.object "NoOwnership" (CAR.record { })
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
|
|
|
|
-- All possible requests.
|
|
|
|
data RequestMessage
|
2023-06-17 16:04:26 +02:00
|
|
|
= MkLogin Login -- 0
|
|
|
|
| MkMaintenance Maintenance -- 7
|
|
|
|
| MkNewDomain NewDomain -- 9
|
|
|
|
| MkAddOrUpdateZone AddOrUpdateZone -- 10
|
|
|
|
| MkDeleteZone DeleteZone -- 11
|
|
|
|
| MkGetZone GetZone -- 12
|
|
|
|
| MkUserDomains UserDomains -- 13
|
|
|
|
| MkAddRR AddRR -- 14
|
|
|
|
| MkUpdateRR UpdateRR -- 15
|
|
|
|
| MkDeleteRR DeleteRR -- 16
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
-- All possible answers from the authentication daemon (authd).
|
|
|
|
data AnswerMessage
|
2023-06-17 16:04:26 +02:00
|
|
|
= MkError Error -- 0
|
|
|
|
| MkSuccess Success -- 1
|
|
|
|
| MkErrorInvalidToken ErrorInvalidToken -- 2
|
|
|
|
| MkDomainAlreadyExists DomainAlreadyExists -- 3
|
2023-06-18 02:11:16 +02:00
|
|
|
| MkErrorUserNotLogged ErrorUserNotLogged -- 4
|
2023-06-17 16:04:26 +02:00
|
|
|
| MkInvalidZone InvalidZone -- 10
|
|
|
|
| MkDomainChanged DomainChanged -- 11
|
|
|
|
| MkZone Zone -- 12
|
|
|
|
| MkUnknownZone UnknownZone -- 13
|
|
|
|
| MkDomainList DomainList -- 14
|
|
|
|
| MkUnknownUser UnknownUser -- 50
|
|
|
|
| MkNoOwnership NoOwnership -- 51
|
|
|
|
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
encode ∷ RequestMessage -> Tuple UInt String
|
|
|
|
encode m = case m of
|
2023-06-17 18:07:24 +02:00
|
|
|
(MkLogin request) -> get_tuple 0 codecLogin request
|
|
|
|
(MkMaintenance request) -> get_tuple 7 codecMaintenance request
|
|
|
|
(MkNewDomain request) -> get_tuple 9 codecNewDomain request
|
|
|
|
(MkAddOrUpdateZone request) -> get_tuple 10 codecAddOrUpdateZone request
|
|
|
|
(MkDeleteZone request) -> get_tuple 11 codecDeleteZone request
|
|
|
|
(MkGetZone request) -> get_tuple 12 codecGetZone request
|
|
|
|
(MkUserDomains request) -> get_tuple 13 codecUserDomains request
|
|
|
|
(MkAddRR request) -> get_tuple 14 codecAddRR request
|
|
|
|
(MkUpdateRR request) -> get_tuple 15 codecUpdateRR request
|
|
|
|
(MkDeleteRR request) -> get_tuple 16 codecDeleteRR request
|
2023-06-17 18:16:52 +02:00
|
|
|
where
|
|
|
|
get_tuple :: forall a. Int -> CA.JsonCodec a -> a -> Tuple UInt String
|
|
|
|
get_tuple num codec request = Tuple (fromInt num) (J.stringify $ CA.encode codec request)
|
2023-06-16 18:54:07 +02:00
|
|
|
|
|
|
|
data DecodeError
|
|
|
|
= JSONERROR String
|
|
|
|
| UnknownError String
|
|
|
|
| UnknownNumber
|
|
|
|
|
|
|
|
decode :: Int -> String -> Either DecodeError AnswerMessage
|
|
|
|
decode number string
|
|
|
|
= case number of
|
2023-06-17 16:04:26 +02:00
|
|
|
0 -> error_management codecError MkError
|
|
|
|
1 -> error_management codecSuccess MkSuccess
|
|
|
|
2 -> error_management codecErrorInvalidToken MkErrorInvalidToken
|
|
|
|
3 -> error_management codecDomainAlreadyExists MkDomainAlreadyExists
|
2023-06-18 02:11:16 +02:00
|
|
|
4 -> error_management codecErrorUserNotLogged MkErrorUserNotLogged
|
2023-06-17 16:04:26 +02:00
|
|
|
10 -> error_management codecInvalidZone MkInvalidZone
|
|
|
|
11 -> error_management codecDomainChanged MkDomainChanged
|
|
|
|
12 -> error_management codecZone MkZone
|
|
|
|
13 -> error_management codecUnknownZone MkUnknownZone
|
|
|
|
14 -> error_management codecDomainList MkDomainList
|
|
|
|
50 -> error_management codecUnknownUser MkUnknownUser
|
|
|
|
51 -> error_management codecNoOwnership MkNoOwnership
|
2023-06-16 18:54:07 +02:00
|
|
|
_ -> Left UnknownNumber
|
|
|
|
where
|
|
|
|
-- Signature is required since the compiler's guess is wrong.
|
|
|
|
error_management :: forall a. CA.JsonCodec a -> (a -> AnswerMessage) -> Either DecodeError AnswerMessage
|
|
|
|
error_management codec f
|
|
|
|
= case (parseDecodeJSON codec string) of
|
|
|
|
(Left err) -> Left (JSONERROR err)
|
|
|
|
(Right v) -> Right (f v)
|
|
|
|
|
|
|
|
parseDecodeJSON :: forall a. CA.JsonCodec a -> String -> Either String a
|
|
|
|
parseDecodeJSON codec str = do
|
|
|
|
json <- JSONParser.jsonParser str
|
|
|
|
lmap CA.printJsonDecodeError (CA.decode codec json)
|
|
|
|
|
|
|
|
serialize :: RequestMessage -> Effect ArrayBuffer
|
|
|
|
serialize request
|
|
|
|
= case (encode request) of
|
|
|
|
(Tuple messageTypeNumber string) -> IPC.toTypedIPC messageTypeNumber string
|
|
|
|
|
|
|
|
deserialize :: ArrayBuffer -> Effect (Either DecodeError AnswerMessage)
|
|
|
|
deserialize arraybuffer
|
|
|
|
= do
|
|
|
|
value <- liftEffect $ IPC.fromTypedIPC arraybuffer
|
|
|
|
pure $ case (value) of
|
|
|
|
Left err -> Left (UnknownError $ show err)
|
|
|
|
Right (Tuple messageTypeNumber string) -> case (decode (toInt messageTypeNumber) string) of
|
|
|
|
Left parsingError -> Left parsingError
|
|
|
|
Right answerMessage -> Right answerMessage
|