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

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 { })


{- 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  -}
-- TODO
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 })

{- 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
 | MkInvalidZone         InvalidZone         -- 10
 | MkDomainChanged       DomainChanged       -- 11
 | MkZone                Zone                -- 12
 | MkUnknownZone         UnknownZone         -- 13
 | MkDomainList          DomainList          -- 14
 | MkAcceptedDomains     AcceptedDomains     -- 15
 | MkLogged              Logged              -- 16
 | 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
    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
    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