TSIGKeys.hs

-- |
-- Module: PowerDNS.API.TSIGKeys
-- Description: TSIGKeys endpoints for PowerDNS API
--
-- Implementation of the API endpoints described at [PowerDNS TSIGKeys API](https://doc.powerdns.com/authoritative/http-api/tsigkey.html)

{-# LANGUAGE DataKinds          #-}
{-# LANGUAGE DeriveAnyClass     #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric      #-}
{-# LANGUAGE RecordWildCards    #-}
{-# LANGUAGE OverloadedStrings  #-}
{-# LANGUAGE TypeOperators      #-}
{-# LANGUAGE CPP                #-}
module PowerDNS.API.TSIGKeys
  (
  -- * API
    TSIGKeysAPI(..)

  -- * Data types
  , TSIGKey(..)
  , TSIGAlgorithm(..)
  )
where

import           Data.Char (toLower)
import           Data.Functor ((<&>))
import           Data.Data (Data)
import           Control.Monad.Fail (MonadFail)

import           Control.DeepSeq (NFData)
import           Data.Aeson ( FromJSON(..), ToJSON(..), Value(String), allNullaryToStringTag
                            , constructorTagModifier, defaultOptions
                            , genericParseJSON
                            , genericToJSON, withObject, object
                            , (.:), (.:?), (.=)
                            )
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as BS64
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import           Servant.API
import           Servant.API.Generic

---------------------------------------------------------------------------------------

data TSIGKeysAPI f = TSIGKeysAPI
  { apiListTSIGKeys  :: f :- "servers" :> Capture "server_id" T.Text :> "tsigkeys"
                          :> Get '[JSON] [TSIGKey]

  , apiCreateTSIGKey :: f :- "servers" :> Capture "server_id" T.Text :> "tsigkeys"
                          :> ReqBody '[JSON] TSIGKey
                          :> PostCreated '[JSON] TSIGKey

  , apiGetTSIGKey    :: f :- "servers" :> Capture "server_id" T.Text :> "tsigkeys" :> Capture "tsigkey_id" T.Text
                          :> Get '[JSON] TSIGKey

  , apiUpdateTSIGKey :: f :- "servers" :> Capture "server_id" T.Text :> "tsigkeys" :> Capture "tsigkey_id" T.Text
                          :> ReqBody '[JSON] TSIGKey
                          :> Put '[JSON] TSIGKey

  , apiDeleteTSIGKey :: f :- "servers" :> Capture "server_id" T.Text :> "tsigkeys" :> Capture "tsigkey_id" T.Text
                          :> DeleteNoContent
  } deriving Generic

----------------------------------------------------------------------------------------

data TSIGKey = TSIGKey
  { tsk_name :: T.Text
  , tsk_id :: T.Text
  , tsk_algorithm :: Maybe TSIGAlgorithm
  , tsk_key :: Maybe BS.ByteString
  -- ^ Unlike the original PowerDNS API we do not require the key to be base64 encoded.
  } deriving (Eq, Ord, Show, Generic, NFData, Data)

instance ToJSON TSIGKey where
  toJSON key = object [ "name" .= tsk_name key
                      , "id" .= tsk_id key
                      , "type" .= String "TSIGKey"
                      , "algorithm" .= tsk_algorithm key
                      , "key" .= (tsk_key key <&> encode64)
                      ]

instance FromJSON TSIGKey where
  parseJSON = withObject "TSIGKey" $ \o -> do
    tsk_name      <- o .: "name"
    tsk_id        <- o .: "id"
    tsk_algorithm <- o .:? "algorithm"
    tsk_key       <- o .:? "key" >>= traverse decode64
    pure TSIGKey{..}

encode64 :: BS.ByteString -> T.Text
encode64 = T.decodeUtf8 . BS64.encode

decode64 :: MonadFail m => T.Text -> m BS.ByteString
decode64 i = case BS64.decode (T.encodeUtf8 i) of
  Left err -> fail err
  Right k  -> pure k  

----------------------------------------------------------------------------------------

-- | Supported algorithms according to [PowerDNS TSIG Documentation](https://doc.powerdns.com/authoritative/tsig.html#tsig)
data TSIGAlgorithm = HMAC_MD5
                   | HMAC_SHA1
                   | HMAC_SHA224
                   | HMAC_SHA256
                   | HMAC_SHA384
                   | HMAC_SHA512
                   deriving (Eq, Ord, Show, Generic, NFData, Data)

instance ToJSON TSIGAlgorithm where
  toJSON = genericToJSON defaultOptions { allNullaryToStringTag = True
                                        , constructorTagModifier = algo
                                        }

instance FromJSON TSIGAlgorithm where
  parseJSON = genericParseJSON defaultOptions { allNullaryToStringTag = True
                                              , constructorTagModifier = algo
                                              }

algo :: String -> String
algo = fmap (\c -> if c == '_' then '-' else toLower c)