Test.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

import           Data.Typeable
import           GHC.TypeLits
import           Servant.API
import           Test.Hspec

type family PickContentType (contentType :: *) (api :: *) where
  PickContentType contentType (a :<|> b) =
    PickContentType contentType a :<|> PickContentType contentType b
  PickContentType contentType ((path :: Symbol) :> api) =
    PickContentType contentType api
  PickContentType contentType (Verb method status (contentType ': rest) result) =
    Verb method status '[contentType] result
  PickContentType contentType (Verb method status (notMatching ': rest) result) =
    PickContentType contentType (Verb method status rest result)
  PickContentType contentType (Verb method status '[] result) =
    Verb method status '[] result

type Api =
  "a" :> Get '[JSON, PlainText, OctetStream] Int :<|>
  "b" :> Get '[PlainText, JSON] Int

main :: IO ()
main = hspec $ do
  describe "PickContentType" $ do
    it "allows to pick the first content-type" $ do
      (Proxy :: Proxy (PickContentType PlainText Api))
        `shouldHaveType` ":<|> (Verb StdMethod * GET 200 (: * PlainText []) Int) (Verb StdMethod * GET 200 (: * PlainText []) Int)"

    it "returns endpoints with no content-types (unusable) if the wanted content-type is not allowed" $ do
      -- this will allow you to use content-types for APIs where not all endpoints support that
      -- content-type
      (Proxy :: Proxy (PickContentType OctetStream Api))
        `shouldHaveType` ":<|> (Verb StdMethod * GET 200 (: * OctetStream []) Int) (Verb StdMethod * GET 200 [] Int)"

shouldHaveType :: Typeable a => Proxy a -> String -> IO ()
shouldHaveType proxy typeString =
  show (typeRep proxy) `shouldBe` typeString