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 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 {- 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.JsonCodec Login codecLogin = CA.object "Login" (CAR.record { token: CA.string }) {- 7 -} type Maintenance = { subject :: MaintenanceSubject.MaintenanceSubject, value :: Maybe Int } codecMaintenance ∷ CA.JsonCodec Maintenance codecMaintenance = CA.object "Maintenance" (CAR.record { subject: MaintenanceSubject.codec, value: CAR.optional CA.int }) {- 9 -} type NewDomain = { domain :: String } codecNewDomain ∷ CA.JsonCodec NewDomain codecNewDomain = CA.object "NewDomain" (CAR.record { domain: CA.string }) {- 10 -} type DeleteDomain = { domain :: String } codecDeleteDomain ∷ CA.JsonCodec DeleteDomain codecDeleteDomain = CA.object "DeleteDomain" (CAR.record { domain: CA.string }) {- 11 -} type AddOrUpdateZone = { zone :: DNSZone.DNSZone } codecAddOrUpdateZone ∷ CA.JsonCodec AddOrUpdateZone codecAddOrUpdateZone = CA.object "AddOrUpdateZone" (CAR.record { zone: DNSZone.codec }) {- 12 -} type GetZone = { domain :: String } codecGetZone ∷ CA.JsonCodec GetZone codecGetZone = CA.object "GetZone" (CAR.record { domain: CA.string }) {- 13 -} type UserDomains = {} codecUserDomains ∷ CA.JsonCodec UserDomains codecUserDomains = CA.object "UserDomains" (CAR.record {}) {- 14 -} type AddRR = { domain :: String, rr :: ResourceRecord.ResourceRecord } codecAddRR ∷ CA.JsonCodec AddRR codecAddRR = CA.object "AddRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec }) {- 15 -} type UpdateRR = { domain :: String, rr :: ResourceRecord.ResourceRecord } codecUpdateRR ∷ CA.JsonCodec UpdateRR codecUpdateRR = CA.object "UpdateRR" (CAR.record { domain: CA.string, rr: ResourceRecord.codec }) {- 16 -} type DeleteRR = { domain :: String, rrid :: Int } codecDeleteRR ∷ CA.JsonCodec DeleteRR codecDeleteRR = CA.object "DeleteRR" (CAR.record { domain: CA.string, rrid: CA.int }) {- RESPONSES -} {- 0 -} -- type Error = { reason :: String | Array(String) } type Error = { reason :: String } codecError ∷ CA.JsonCodec Error codecError = CA.object "Error" (CAR.record { reason: CA.string }) {- 1 -} type Success = { } codecSuccess ∷ CA.JsonCodec Success codecSuccess = CA.object "Success" (CAR.record { }) {- 2 -} type ErrorInvalidToken = { } codecErrorInvalidToken ∷ CA.JsonCodec ErrorInvalidToken codecErrorInvalidToken = CA.object "ErrorInvalidToken" (CAR.record { }) {- 3 -} type DomainAlreadyExists = { } codecDomainAlreadyExists ∷ CA.JsonCodec DomainAlreadyExists codecDomainAlreadyExists = CA.object "DomainAlreadyExists" (CAR.record { }) {- 4 -} type ErrorUserNotLogged = { } codecErrorUserNotLogged ∷ CA.JsonCodec ErrorUserNotLogged codecErrorUserNotLogged = CA.object "ErrorUserNotLogged" (CAR.record { }) {- 5 -} type DomainNotFound = { } codecDomainNotFound :: CA.JsonCodec DomainNotFound codecDomainNotFound = CA.object "DomainNotFound" (CAR.record { }) {- 6 -} type RRNotFound = { } codecRRNotFound :: CA.JsonCodec RRNotFound codecRRNotFound = CA.object "RRNotFound" (CAR.record { }) {- 7 -} type UnacceptableDomain = { } codecUnacceptableDomain :: CA.JsonCodec UnacceptableDomain codecUnacceptableDomain = CA.object "UnacceptableDomain" (CAR.record { }) {- 8 -} type InvalidDomainName = { } codecInvalidDomainName :: CA.JsonCodec InvalidDomainName codecInvalidDomainName = CA.object "InvalidDomainName" (CAR.record { }) {- 9 -} type DomainDeleted = { domain :: String } codecDomainDeleted :: CA.JsonCodec DomainDeleted codecDomainDeleted = CA.object "DomainDeleted" (CAR.record { domain: CA.string }) {- 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 }) {- 11 -} type DomainChanged = { } codecDomainChanged ∷ CA.JsonCodec DomainChanged codecDomainChanged = CA.object "DomainChanged" (CAR.record { }) {- 12 -} type Zone = { zone :: DNSZone.DNSZone } codecZone ∷ CA.JsonCodec Zone codecZone = CA.object "Zone" (CAR.record { zone: DNSZone.codec }) {- 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 }) {- 15 -} type AcceptedDomains = { domains :: Array String } codecAcceptedDomains ∷ CA.JsonCodec AcceptedDomains codecAcceptedDomains = CA.object "AcceptedDomains" (CAR.record { domains: CA.array CA.string }) {- 16 -} type Logged = { accepted_domains :: Array String, my_domains :: Array String } codecLogged ∷ CA.JsonCodec Logged codecLogged = CA.object "Logged" (CAR.record { accepted_domains: CA.array CA.string , my_domains: CA.array CA.string }) {- 17 -} type DomainAdded = { domain :: String } codecDomainAdded ∷ CA.JsonCodec DomainAdded codecDomainAdded = CA.object "DomainAdded" (CAR.record { domain: CA.string }) {- 18 -} type RRDeleted = { rrid :: Int } codecRRDeleted ∷ CA.JsonCodec RRDeleted codecRRDeleted = CA.object "RRDeleted" (CAR.record { rrid: CA.int }) {- 19 -} type RRAdded = { domain :: String, rr :: ResourceRecord.ResourceRecord } codecRRAdded ∷ CA.JsonCodec RRAdded codecRRAdded = CA.object "RRAdded" (CAR.record { domain: CA.string, rr: ResourceRecord.codec }) {- 20 -} -- For now, Error is just an alias on String. -- type InvalidZone = { errors : Array(Storage::Zone::Error) } type InvalidRR = { errors :: Array String } codecInvalidRR ∷ CA.JsonCodec InvalidRR codecInvalidRR = CA.object "InvalidRR" (CAR.record { errors: CA.array CA.string }) {- 21 -} type RRUpdated = { domain :: String, rr :: ResourceRecord.ResourceRecord } codecRRUpdated ∷ CA.JsonCodec RRUpdated codecRRUpdated = CA.object "RRUpdated" (CAR.record { domain: CA.string, rr: ResourceRecord.codec }) {- 21 -} type RRReadOnly = { domain :: String, rr :: ResourceRecord.ResourceRecord } codecRRReadOnly ∷ CA.JsonCodec RRReadOnly codecRRReadOnly = CA.object "RRReadOnly" (CAR.record { domain: CA.string, rr: ResourceRecord.codec }) {- 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 { }) -- All possible requests. data RequestMessage = MkLogin Login -- 0 | MkMaintenance Maintenance -- 7 | MkNewDomain NewDomain -- 9 | MkDeleteDomain DeleteDomain -- 10 | MkAddOrUpdateZone AddOrUpdateZone -- 11 | MkGetZone GetZone -- 12 | MkUserDomains UserDomains -- 13 | MkAddRR AddRR -- 14 | MkUpdateRR UpdateRR -- 15 | MkDeleteRR DeleteRR -- 16 -- All possible answers from the authentication daemon (authd). data AnswerMessage = MkError Error -- 0 | MkSuccess Success -- 1 | MkErrorInvalidToken ErrorInvalidToken -- 2 | MkDomainAlreadyExists DomainAlreadyExists -- 3 | MkErrorUserNotLogged ErrorUserNotLogged -- 4 | MkDomainNotFound DomainNotFound -- 5 | MkRRNotFound RRNotFound -- 6 | MkUnacceptableDomain UnacceptableDomain -- 7 | MkInvalidDomainName InvalidDomainName -- 8 | MkDomainDeleted DomainDeleted -- 9 | MkInvalidZone InvalidZone -- 10 | MkDomainChanged DomainChanged -- 11 | MkZone Zone -- 12 | MkUnknownZone UnknownZone -- 13 | MkDomainList DomainList -- 14 | MkAcceptedDomains AcceptedDomains -- 15 | MkLogged Logged -- 16 | MkDomainAdded DomainAdded -- 17 | MkRRDeleted RRDeleted -- 18 | MkRRAdded RRAdded -- 19 | MkInvalidRR InvalidRR -- 20 | MkRRUpdated RRUpdated -- 21 | MkRRReadOnly RRReadOnly -- 22 | MkUnknownUser UnknownUser -- 50 | MkNoOwnership NoOwnership -- 51 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 (MkDeleteDomain request) -> get_tuple 10 codecDeleteDomain request (MkAddOrUpdateZone request) -> get_tuple 11 codecAddOrUpdateZone 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 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 0 -> error_management codecError MkError 1 -> error_management codecSuccess MkSuccess 2 -> error_management codecErrorInvalidToken MkErrorInvalidToken 3 -> error_management codecDomainAlreadyExists MkDomainAlreadyExists 4 -> error_management codecErrorUserNotLogged MkErrorUserNotLogged 5 -> error_management codecDomainNotFound MkDomainNotFound 6 -> error_management codecRRNotFound MkRRNotFound 7 -> error_management codecUnacceptableDomain MkUnacceptableDomain 8 -> error_management codecInvalidDomainName MkInvalidDomainName 9 -> error_management codecDomainDeleted MkDomainDeleted 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 15 -> error_management codecAcceptedDomains MkAcceptedDomains 16 -> error_management codecLogged MkLogged 17 -> error_management codecDomainAdded MkDomainAdded 18 -> error_management codecRRDeleted MkRRDeleted 19 -> error_management codecRRAdded MkRRAdded 20 -> error_management codecInvalidRR MkInvalidRR 21 -> error_management codecRRUpdated MkRRUpdated 22 -> error_management codecRRReadOnly MkRRReadOnly 50 -> error_management codecUnknownUser MkUnknownUser 51 -> error_management codecNoOwnership MkNoOwnership _ -> 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