halogen-websocket-ipc-playzone/src/App/Messages/DNSManagerDaemon.purs

229 lines
8.1 KiB
Plaintext
Raw Normal View History

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
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
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 }
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 }
codecMaintenance = CA.object "Maintenance" (CAR.record { subject: MaintenanceSubject.codec, value: CAR.optional CA.int })
{- 9 -}
type NewDomain = { domain :: String }
codecNewDomain = CA.object "NewDomain" (CAR.record { domain: CA.string })
2023-06-16 18:54:07 +02:00
{- 10 -}
type AddOrUpdateZone = { zone :: DNSZone.DNSZone }
codecAddOrUpdateZone = CA.object "AddOrUpdateZone" (CAR.record { zone: DNSZone.codec })
2023-06-16 18:54:07 +02:00
{- 11 -}
type DeleteZone = { domain :: String }
codecDeleteZone = CA.object "DeleteZone" (CAR.record { domain: CA.string })
{- 12 -}
type GetZone = { domain :: String }
codecGetZone = CA.object "GetZone" (CAR.record { domain: CA.string })
{- 13 -}
type UserDomains = {}
codecUserDomains = CA.object "UserDomains" (CAR.record {})
{- 14 -}
type AddRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
codecAddRR = CA.object "AddRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
2023-06-16 18:54:07 +02:00
{- 15 -}
type UpdateRR = { domain :: String, rr :: ResourceRecord.ResourceRecord }
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 }
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 }
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-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
type Zone = { zone :: DNSZone.DNSZone }
2023-06-17 16:04:26 +02:00
codecZone ∷ CA.JsonCodec Zone
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
| 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
(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-16 18:54:07 +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)
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
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