425 lines
17 KiB
Plaintext
425 lines
17 KiB
Plaintext
module App.Message.DNSManagerDaemon where
|
|
|
|
import Prelude (bind, pure, show, ($))
|
|
|
|
import App.Type.DomainInfo as DomainInfo
|
|
|
|
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.Type.PermissionLevel as PermissionLevel
|
|
import App.Type.MaintenanceSubject as MaintenanceSubject
|
|
|
|
import Effect.Class (liftEffect)
|
|
import Data.Argonaut.Parser as JSONParser
|
|
import Data.Bifunctor (lmap)
|
|
|
|
import App.Message.IPC as IPC
|
|
import App.Type.DNSZone as DNSZone
|
|
import App.Type.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 })
|
|
|
|
{- 1 -}
|
|
type DeleteUser = { user_id :: Maybe Int }
|
|
codecDeleteUser ∷ CA.JsonCodec DeleteUser
|
|
codecDeleteUser = CA.object "DeleteUser" (CAR.record { user_id: CAR.optional CA.int })
|
|
|
|
{- 6 -}
|
|
type GetOrphanDomains = { }
|
|
codecGetOrphanDomains ∷ CA.JsonCodec GetOrphanDomains
|
|
codecGetOrphanDomains = CA.object "GetOrphanDomains" (CAR.record { })
|
|
|
|
{- 7 -}
|
|
type Maintenance = { subject :: MaintenanceSubject.MaintenanceSubject
|
|
, int :: Maybe Int
|
|
, string :: Maybe String
|
|
}
|
|
codecMaintenance ∷ CA.JsonCodec Maintenance
|
|
codecMaintenance = CA.object "Maintenance" (CAR.record { subject: MaintenanceSubject.codec
|
|
, int: CAR.optional CA.int
|
|
, string: CAR.optional CA.string
|
|
})
|
|
|
|
{- 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 })
|
|
|
|
{- 17 -}
|
|
type AskGeneratedZoneFile = { domain :: String }
|
|
codecAskGeneratedZoneFile ∷ CA.JsonCodec AskGeneratedZoneFile
|
|
codecAskGeneratedZoneFile = CA.object "AskGeneratedZoneFile" (CAR.record { domain: CA.string })
|
|
|
|
{- 18 -}
|
|
type NewToken = { domain :: String, rrid :: Int }
|
|
codecNewToken ∷ CA.JsonCodec NewToken
|
|
codecNewToken = CA.object "NewToken" (CAR.record { domain: CA.string, rrid: CA.int })
|
|
|
|
{- 100 -}
|
|
type GenerateAllZoneFiles = {}
|
|
codecGenerateAllZoneFiles ∷ CA.JsonCodec GenerateAllZoneFiles
|
|
codecGenerateAllZoneFiles = CA.object "GenerateAllZoneFiles" (CAR.record {})
|
|
|
|
{- 101 -}
|
|
type GenerateZoneFile = { domain :: String }
|
|
codecGenerateZoneFile ∷ CA.JsonCodec GenerateZoneFile
|
|
codecGenerateZoneFile = CA.object "GenerateZoneFile" (CAR.record { domain: CA.string })
|
|
|
|
{- 250 -}
|
|
type KeepAlive = { }
|
|
codecKeepAlive ∷ CA.JsonCodec KeepAlive
|
|
codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
|
|
|
|
{-
|
|
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 DomainInfo.DomainInfo, admin :: Boolean }
|
|
codecLogged ∷ CA.JsonCodec Logged
|
|
codecLogged = CA.object "Logged" (CAR.record { accepted_domains: CA.array CA.string
|
|
, my_domains: CA.array DomainInfo.codec
|
|
, admin: CA.boolean
|
|
})
|
|
|
|
{- 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 })
|
|
|
|
{- 22 -}
|
|
type RRReadOnly = { domain :: String, rr :: ResourceRecord.ResourceRecord }
|
|
codecRRReadOnly ∷ CA.JsonCodec RRReadOnly
|
|
codecRRReadOnly = CA.object "RRReadOnly" (CAR.record { domain: CA.string, rr: ResourceRecord.codec })
|
|
|
|
{- 23 -}
|
|
type GeneratedZoneFile = { domain :: String, zonefile :: String }
|
|
codecGeneratedZoneFile ∷ CA.JsonCodec GeneratedZoneFile
|
|
codecGeneratedZoneFile = CA.object "GeneratedZoneFile" (CAR.record { domain: CA.string, zonefile: CA.string })
|
|
|
|
{- 24 -}
|
|
type OrphanDomainList = { domains :: Array String }
|
|
codecOrphanDomainList ∷ CA.JsonCodec OrphanDomainList
|
|
codecOrphanDomainList = CA.object "OrphanDomainList" (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 { })
|
|
|
|
{- 52 -}
|
|
type InsufficientRights = { }
|
|
codecInsufficientRights ∷ CA.JsonCodec InsufficientRights
|
|
codecInsufficientRights = CA.object "InsufficientRights" (CAR.record { })
|
|
|
|
{- 250 -}
|
|
--type KeepAlive = { }
|
|
--codecKeepAlive ∷ CA.JsonCodec KeepAlive
|
|
--codecKeepAlive = CA.object "KeepAlive" (CAR.record { })
|
|
|
|
|
|
-- All possible requests.
|
|
data RequestMessage
|
|
= MkLogin Login -- 0
|
|
| MkDeleteUser DeleteUser -- 1
|
|
| MkGetOrphanDomains GetOrphanDomains -- 6
|
|
| 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
|
|
| MkAskGeneratedZoneFile AskGeneratedZoneFile -- 17
|
|
| MkNewToken NewToken -- 18
|
|
--| MkUseToken UseToken -- 19
|
|
| MkGenerateAllZoneFiles GenerateAllZoneFiles -- 100
|
|
| MkGenerateZoneFile GenerateZoneFile -- 101
|
|
| MkKeepAlive KeepAlive -- 250
|
|
|
|
-- 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
|
|
| MkGeneratedZoneFile GeneratedZoneFile -- 23
|
|
| MkOrphanDomainList OrphanDomainList -- 24
|
|
| MkUnknownUser UnknownUser -- 50
|
|
| MkNoOwnership NoOwnership -- 51
|
|
| MkInsufficientRights InsufficientRights -- 52
|
|
| GotKeepAlive KeepAlive -- 250
|
|
|
|
encode ∷ RequestMessage -> Tuple UInt String
|
|
encode m = case m of
|
|
(MkLogin request) -> get_tuple 0 codecLogin request
|
|
(MkDeleteUser request) -> get_tuple 1 codecDeleteUser request
|
|
(MkGetOrphanDomains request) -> get_tuple 6 codecGetOrphanDomains 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
|
|
(MkAskGeneratedZoneFile request) -> get_tuple 17 codecAskGeneratedZoneFile request
|
|
(MkNewToken request) -> get_tuple 18 codecNewToken request
|
|
--(MkUseToken request) -> get_tuple 19 codecUseToken request
|
|
(MkGenerateAllZoneFiles request) -> get_tuple 100 codecGenerateAllZoneFiles request
|
|
(MkGenerateZoneFile request) -> get_tuple 101 codecGenerateZoneFile request
|
|
(MkKeepAlive request) -> get_tuple 250 codecKeepAlive 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
|
|
23 -> error_management codecGeneratedZoneFile MkGeneratedZoneFile
|
|
24 -> error_management codecOrphanDomainList MkOrphanDomainList
|
|
50 -> error_management codecUnknownUser MkUnknownUser
|
|
51 -> error_management codecNoOwnership MkNoOwnership
|
|
52 -> error_management codecInsufficientRights MkInsufficientRights
|
|
250 -> error_management codecKeepAlive GotKeepAlive
|
|
_ -> 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
|