powerdns-0.4.3: spec/Spec.hs

{-# LANGUAGE OverloadedStrings #-}
import Control.Monad (unless)
import Data.Either (isRight)

import GHC.Stack (HasCallStack)

import Network.HTTP.Client (Manager, defaultManagerSettings, newManager)
import Servant.Client (ClientEnv, ClientM, mkClientEnv, runClientM)
import Servant.Client.Core (BaseUrl, ClientError(..), parseBaseUrl,
                            responseStatusCode)
import System.IO.Unsafe (unsafePerformIO)
import Test.Tasty
import Test.Tasty.HUnit

import PowerDNS.Client

{-# NOINLINE mgr #-}
mgr :: Manager
mgr = unsafePerformIO (newManager defaultManagerSettings)

{-# NOINLINE baseUrl #-}
baseUrl :: BaseUrl
baseUrl = unsafePerformIO (parseBaseUrl "127.0.0.1:8081")

envNoAuth :: ClientEnv
envNoAuth = mkClientEnv mgr baseUrl

envAuth :: ClientEnv
envAuth = applyXApiKey "secret" envNoAuth

main :: IO ()
main = defaultMain tree

tree :: TestTree
tree = testGroup "All specs" [ otherSpecs
                             , versionSpec
                             , authSpecs
                             , zoneSpecs
                             ]

run :: HasCallStack => ClientM a -> IO (Either ClientError a)
run = flip runClientM envAuth

runOk :: HasCallStack => ClientM a -> IO a
runOk c = do
  r <- run c
  assertRight "ClientM result" r

otherSpecs :: TestTree
otherSpecs = testGroup "Case-sensitivity"
    [ testCase "RRSet does case-insensitive compare on ASCII codepoints" $
        assertEqual "" (compare (RRSet "Foo." A (Just 0) Nothing Nothing Nothing)
                                (RRSet "foo." A (Just 0) Nothing Nothing Nothing))
                       EQ
    , testCase "RRSet does case-insensitive eq on ASCII codepoints" $
        assertEqual "" (RRSet "Foo." A (Just 0) Nothing Nothing Nothing)
                       (RRSet "foo." A (Just 0) Nothing Nothing Nothing)

    , testCase "RRSet does case-sensitive compare on non-ASCII codepoints" $
       assertEqual "" (compare (RRSet "\335." A (Just 0) Nothing Nothing Nothing)
                               (RRSet "\375." A (Just 0) Nothing Nothing Nothing))
                      LT


    , testCase "RRSet does case-sensitive eq on non-ASCII codepoints" $
       assertBool "" ((RRSet "\335." A (Just 0) Nothing Nothing Nothing) /=
                      (RRSet "\375." A (Just 0) Nothing Nothing Nothing))

    , testCase "Zone does case-insensitive comparison on ASCII codepoints" $
        assertEqual "" (empty { zone_name = Just "Foo." })
                       (empty { zone_name = Just "foo." })

    , testCase "Zone does case-sensitive comparison on non-ASCII codepoints" $
        assertBool "" ((empty { zone_name = Just "\335." }) /=
                       (empty { zone_name = Just "\375." }))

    ]

versionSpec :: TestTree
versionSpec = testCase "Verifies API version" $ do
    ver <- run listVersions
    assertEqual "API versions" ver (Right [Version 1 "/api/v1"])

zoneSpecs :: TestTree
zoneSpecs = testCaseSteps "Verifies zones can be created, displayed and deleted" $ \step -> do
    step "Ensure no zone is currently found"
    r1 <- run (listZones "localhost" Nothing Nothing)
    assertEqual "list of zones" (Right []) r1

    step "Create a new zone"
    r2 <- runOk (createZone "localhost" (Just True) new)
    zoneId <- assertJust "zone id" (zone_id r2)

    step "Check if zone is fetchable"
    runOk (getZone "localhost" zoneId (Just False))

    step "Add record to zone"
    runOk (updateZone "localhost" zoneId (patch added))

    step "Trigger notify"
    runOk (notifySlaves "localhost" zoneId)

    step "Trigger rectify"
    runOk (rectifyZone "localhost" zoneId)

    step "Delete a record"
    runOk (updateZone "localhost" zoneId (patch deleted))

    step "Delete zone"
    runOk (deleteZone "localhost" zoneId)

    step "Ensure no zone is left over"
    r <- run (listZones "localhost" Nothing Nothing)
    assertEqual "list of zones" (Right []) r

    step "Done"
  where
    new = empty { zone_name   = Just "test.space."
                , zone_kind   = Just Native
                , zone_type   = Just "zone"
                , zone_rrsets = Just init }

    init = [ RRSet { rrset_name = "magic.test.space."
                   , rrset_type = A
                   , rrset_ttl = Just 86003
                   , rrset_changetype = Nothing
                   , rrset_records = Just [Record "127.0.0.1" False]
                   , rrset_comments = Nothing
                   }
           ]

    patch what = empty { zone_type = Just "zone"
                       , zone_rrsets = Just what
                       }
    deleted = [ RRSet { rrset_name = "foo.test.space."
                      , rrset_type = AAAA
                      , rrset_ttl = Nothing
                      , rrset_changetype = Just Delete
                      , rrset_records = Just []
                      , rrset_comments = Nothing
                      }
            ]
    added = [ RRSet { rrset_name = "foo.test.space."
                    , rrset_type = AAAA
                    , rrset_ttl = Nothing
                    , rrset_changetype = Nothing
                    , rrset_records = Just [Record "::1" False]
                    , rrset_comments = Nothing
                    }
            ]

-- | Erases all server generated data from a zone. Used to test for equality.
cleanse :: Zone -> Zone
cleanse z = z { zone_id = Nothing
              , zone_url = Nothing
              , zone_serial = Nothing
              , zone_soa_edit = Nothing
              , zone_soa_edit_api = Nothing
              , zone_notified_serial = Nothing
              , zone_edited_serial = Nothing
              , zone_rrsets = Nothing
              , zone_master_tsig_key_ids = Nothing
              , zone_slave_tsig_key_ids = Nothing
              }

authSpecs :: TestTree
authSpecs = testGroup "Authentication specs"
  [ testCase "X-API-Key header is correctly set" $
      assertIsSuccess =<< runClientM listServers envAuth

  , testCase "Access without X-API-Key is rejected" $
      assertIs401 =<< runClientM listServers envNoAuth
  ]

assertPredicate :: Show s => String -> (s -> Bool) -> s -> Assertion
assertPredicate name p v =
  unless (p v) (assertFailure msg)
 where msg = "failed to satisfy predicate: " ++ name ++ "\n" ++
             "with value: " ++ show v

assertIs401 :: Show a => Either ClientError a -> Assertion
assertIs401 = assertPredicate "has HTTP status 401" (hasStatus 401)

hasStatus :: Int -> Either ClientError a -> Bool
hasStatus i (Left (FailureResponse _req resp)) |
   responseStatusCode resp == toEnum i = True
hasStatus _i _        = False

assertIsSuccess :: Show a => Either ClientError a -> Assertion
assertIsSuccess = assertPredicate "successful HTTP response" isRight

assertJust :: HasCallStack => String -> Maybe a -> IO a
assertJust preface = maybe (assertFailure msg) pure
 where msg = (if null preface then "" else preface ++ "\n") ++
             "Unexpected Nothing"

assertRight :: (Show a, HasCallStack) => String -> Either a b -> IO b
assertRight preface e = case e of
  Left e  -> assertFailure (msg e)
  Right r -> pure r
 where msg v = (if null preface then "" else preface ++ "\n") ++
               "Unexpected Left: " ++ show v