{-# LANGUAGE FlexibleContexts #-}

-- | The flow to create a subdomain is:
--
-- 1. Create client with @client <- createClient@. When client is dropped, all
-- entries are deleted
-- 2. Get current hostname @parentHostName <- getHostName client@
-- 3. Create entry group @entryGroup <- entryGroupNew client@
-- 4. Add record to entry group: @entryGroupAddRecord client entryGroup "your
-- host name" parentHostName@
-- 5. Commit: @entryGroupCommit client entryGroup@
--
-- If you want to delete subdomain, you either drop the client, or call
-- @entryGroupReset@. Dropping the entry group does nothing.
--
-- To check if name is already taken, use @resolveHostName@
module Avahi
    ( Client
    , createClient
    , dropClient
    , getHostName
    , EntryGroup
    , entryGroupNew
    , entryGroupReset
    , entryGroupAddRecord
    , entryGroupCommit
    , resolveHostName
    , makeRdata
    ) where

import Control.Monad (void)
import DBus (ObjectPath, fromVariant, methodCall, methodCallDestination, toVariant)
import DBus.Client (Client, call_, connectSystem, disconnect)
import DBus.Internal.Message (MethodReturn (..), methodCallBody)
import Data.ByteString (ByteString, split)
import Data.Int (Int32)
import Data.MonoTraversable (oconcat, olength)
import Data.Sequences (cons, snoc)
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Word (Word16, Word32)

createClient :: IO Client
createClient = connectSystem

dropClient :: Client -> IO ()
dropClient = disconnect

getHostName :: Client -> IO Text
getHostName client = do
    call_
        client
        (methodCall "/" "org.freedesktop.Avahi.Server" "GetHostNameFqdn")
            { methodCallDestination = Just "org.freedesktop.Avahi"
            }
        >>= pure . methodReturnBody
        >>= \case
            [hostname] -> case fromVariant hostname of
                Just x -> pure x
                Nothing -> error $ "Unexpected return type: " <> show hostname
            other -> error $ "Unexpected return pack: length = " <> show (length other)

newtype EntryGroup = EntryGroup ObjectPath
    deriving (Eq, Show)

entryGroupNew :: Client -> IO EntryGroup
entryGroupNew client =
    call_
        client
        (methodCall "/" "org.freedesktop.Avahi.Server" "EntryGroupNew")
            { methodCallDestination = Just "org.freedesktop.Avahi"
            }
        >>= pure . methodReturnBody
        >>= \case
            [path] -> case fromVariant path of
                Just x -> pure . EntryGroup $ x
                Nothing -> error $ "Unexpected return type: " <> show path
            other -> error $ "Unexpected return pack: length = " <> show (length other)

entryGroupReset :: Client -> EntryGroup -> IO ()
entryGroupReset client (EntryGroup path) =
    void $
        call_
            client
            (methodCall path "org.freedesktop.Avahi.EntryGroup" "Reset")
                { methodCallDestination = Just "org.freedesktop.Avahi"
                }

entryGroupAddRecord :: Client -> EntryGroup -> Text -> Text -> IO ()
entryGroupAddRecord client (EntryGroup path) cname parentHostName =
    void $
        call_
            client
            (methodCall path "org.freedesktop.Avahi.EntryGroup" "AddRecord")
                { methodCallDestination = Just "org.freedesktop.Avahi"
                , methodCallBody =
                    [ toVariant (-1 :: Int32) -- interface = IF_UNSPEC
                    , toVariant (-1 :: Int32) -- protocol = PROTO_UNSPEC
                    , toVariant (0 :: Word32) -- flags = mempty
                    , toVariant cname
                    , toVariant (1 :: Word16) -- clazz = AVAHI_DNS_CLASS_IN
                    , toVariant (5 :: Word16) -- type = AVAHI_DNS_TYPE_CNAME
                    , toVariant ttl
                    , toVariant . makeRdata $ parentHostName
                    ]
                }
  where
    ttl = 60 :: Word32

resolveHostName
    :: Client
    -> Text
    -> IO (Text, Text)
    -- ^ name, address
resolveHostName client hostname =
    call_
        client
        (methodCall "/" "org.freedesktop.Avahi.Server" "ResolveHostName")
            { methodCallDestination = Just "org.freedesktop.Avahi"
            , methodCallBody =
                [ toVariant (-1 :: Int32) -- interface = IF_UNSPEC
                , toVariant (-1 :: Int32) -- protocol = PROTO_UNSPEC
                , toVariant hostname
                , toVariant (-1 :: Int32) -- aprotocol = PROTO_UNSPEC
                , toVariant (0 :: Word32) -- flags = mempty
                ]
            }
        >>= pure . methodReturnBody
        >>= \case
            [_interface, _protocol, name, _aprotocol, address, _flags] ->
                case (fromVariant name, fromVariant address) of
                    (Just a, Just b) -> pure (a, b)
                    _err -> error $ "Unexpected return type: " <> show (name, address)
            other -> error $ "Unexpected return pack: length = " <> show (length other)

entryGroupCommit :: Client -> EntryGroup -> IO ()
entryGroupCommit client (EntryGroup path) =
    void $
        call_
            client
            (methodCall path "org.freedesktop.Avahi.EntryGroup" "Commit")
                { methodCallDestination = Just "org.freedesktop.Avahi"
                }

makeRdata :: Text -> ByteString
makeRdata = flip snoc 0 . oconcat . map prefixWithLength . split dot . encodeUtf8
  where
    dot = fromIntegral . fromEnum $ '.'
    prefixWithLength bs = fromIntegral (olength bs) `cons` bs