rest-core-0.39.0.2: tests/Runner.hs

{-# LANGUAGE
    CPP
  , OverloadedStrings
  , RankNTypes
  , ScopedTypeVariables
  #-}
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif
import Control.Monad
import Control.Monad.Except
import Control.Monad.Identity
import Control.Monad.Reader
import Data.Aeson
import Data.Monoid
import Test.Framework (defaultMain)
import Test.Framework.Providers.HUnit (testCase)
import Test.HUnit (Assertion, assertEqual, assertFailure)
import qualified Data.HashMap.Strict  as H

import Rest hiding (input)
import Rest.Api hiding (route)
import Rest.Dictionary (Format (..), Ident (..))
import Rest.Driver.Perform (accept)
import Rest.Driver.Routing
import Rest.Driver.Types
import Rest.Resource
import qualified Rest.Api          as Rest
import qualified Rest.Container    as C
import qualified Rest.Driver.RestM as RM
import qualified Rest.Resource     as Res
import qualified Rest.Run          as Run

main :: IO ()
main =
  defaultMain [ testCase "Top level listing." testListing
              , testCase "Top level listing (trailing slash)." testListingTrailingSlash
              , testCase "Top level singleton." testToplevelSingleton
              , testCase "Unnamed single." testUnnamedSingle
              , testCase "Unnamed multi." testUnnamedMulti
              , testCase "Named singleton." testNamedSingleton
              , testCase "Named single by." testNamedSingleBy
              , testCase "Named listing." testNamedListing
              , testCase "Named listing by." testNamedListingBy
              , testCase "Create." testCreate
              , testCase "Create with listing." testCreateWithListing
              , testCase "Static action." testStaticAction
              , testCase "Simple subresource." testSubresource
              , testCase "Root router is skipped." testRootRouter
              , testCase "Multi-PUT." testMultiPut
              , testCase "Multi-POST" testMultiPost
              , testCase "Accept headers." testAcceptHeaders
              , testCase "Test listing count" testListingCount
              ]

listResource :: Resource IO IO Void () Void
listResource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler }
  where
    listHandler () = mkListing id $ \_ -> return []

testListing :: Assertion
testListing = checkRoute GET "resource" (Rest.root -/ Rest.route listResource)

testListingTrailingSlash :: Assertion
testListingTrailingSlash = checkRoute GET "resource/" (Rest.root -/ Rest.route listResource)

testToplevelSingleton :: Assertion
testToplevelSingleton = checkSingleRoute "resource" resource handler_
  where
    resource :: Resource IO IO () Void Void
    resource = mkResourceId { name = "resource", schema = Schema (Just (Single ())) (Named []) }
    handler_ = mkConstHandler id $ return ()

testUnnamedSingle :: Assertion
testUnnamedSingle = checkSingleRoute "resource/foo" resource handler_
  where
    resource :: Resource IO (ReaderT String IO) String Void Void
    resource = mkResourceReader { name = "resource", schema = Schema Nothing (Unnamed (Single (Id StringId id))) }
    handler_ = mkConstHandler stringO ask

testUnnamedMulti :: Assertion
testUnnamedMulti = checkRoute GET "resource/foo" (Rest.root -/ Rest.route resource)
  where
    resource :: Resource IO IO Void String Void
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Unnamed (Many (Id StringId id))), list = listHandler }
    listHandler (s :: String) = mkListing xmlJsonO $ \_rng -> return (void s)

testNamedSingleton :: Assertion
testNamedSingleton = checkSingleRoute "resource/foo" resource handler_
  where
    resource :: Resource IO IO () Void Void
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("foo", Right (Single (Singleton ())))]) }
    handler_ = mkConstHandler id $ return ()

testNamedSingleBy :: Assertion
testNamedSingleBy = checkSingleRoute "resource/foo/bar" resource handler_
  where
    resource :: Resource IO (ReaderT String IO) String Void Void
    resource = mkResourceReader { name = "resource", schema = Schema Nothing (Named [("foo", Right (Single (By (Id StringId id))))]) }
    handler_ = mkConstHandler stringO ask

testNamedListing :: Assertion
testNamedListing = checkRoute GET "resource/foo" (Rest.root -/ Rest.route resource)
  where
    resource :: Resource IO IO Void () Void
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("foo", Right (Many (Singleton ())))]), list = listHandler }
    listHandler () = mkListing id $ \_rng -> return []

testNamedListingBy :: Assertion
testNamedListingBy = checkRoute GET "resource/foo/bar" (Rest.root -/ Rest.route resource)
  where
    resource :: Resource IO IO Void String Void
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("foo", Right (Many (By (Id StringId id))))]), list = listHandler }
    listHandler (s :: String) = mkListing xmlJsonO $ \_rng -> return (void s)

testCreate :: Assertion
testCreate = checkRoute POST "resource" (root -/ Rest.route resource)
  where
    resource :: Resource IO IO Void Void Void
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named []), create = Just createHandler }
    createHandler = mkConstHandler id $ return ()

-- This one was added because the list handler didn't correctly fall
-- through to create, and testCreate didn't catch that because it
-- contains no list handler.

testCreateWithListing :: Assertion
testCreateWithListing = checkRoutes [(GET, "resource"), (POST, "resource")] (Rest.root -/ Rest.route resource)
  where
    resource :: Resource IO IO Void () Void
    resource = mkResourceId { name = "resource", schema = Schema (Just (Many ())) (Named []), list = listHandler, create = Just createHandler }
    createHandler = mkConstHandler id $ return ()
    listHandler () = mkListing id $ \_rng -> return []

testStaticAction :: Assertion
testStaticAction = checkRoute POST "resource/action" (Rest.root -/ Rest.route resource)
  where
    resource :: Resource IO IO () Void ()
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("action", Left ())]), statics = staticHandler }
    staticHandler () = mkConstHandler id $ return ()

testSubresource :: Assertion
testSubresource = checkRoute GET "resource/single/subresource" (Rest.root -/ Rest.route resource --/ Rest.route subResource)
  where
    resource :: Resource IO IO () Void Void
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("single", Right (Single (Singleton ())))]), get = Just getHandler }
    subResource :: Resource IO IO Void () Void
    subResource = mkResourceId { name = "subresource", schema = Schema (Just (Many ())) (Named []), list = listHandler }
    getHandler = mkConstHandler id $ return ()
    listHandler _ = mkListing id $ \_rng -> return []

testRootRouter :: Assertion
testRootRouter = checkRoute GET "resource/single" (Rest.root -/ Rest.route resource)
  where
    resource :: Resource IO IO () Void Void
    resource = mkResourceId { name = "resource", schema = Schema Nothing (Named [("single", Right (Single (Singleton ())))]), get = Just getHandler }
    getHandler = mkConstHandler id $ return ()

testMultiPut :: Assertion
testMultiPut = checkRouteSuccess PUT "resource/foo" (Rest.root -/ Rest.route resource)
  where
    resource :: Resource IO (ReaderT String IO) String Void Void
    resource = mkResourceReader
      { name   = "resource"
      , schema = Schema Nothing (Named [("foo", Right (Single (By (Id StringId id))))])
      , update = Just (mkConstHandler xmlJsonO (fmap void ask))
      }

testMultiPost :: Assertion
testMultiPost = checkRoute POST "" (Rest.root :: Rest.Router IO IO)

type Uri = String

checkSingleRoute :: (Applicative m, Monad m, Monad s)
                 => Uri -> Resource m s sid mid aid -> Handler s -> Assertion
checkSingleRoute uri resource handler_ =
  do checkRoute GET    uri (root -/ Rest.route resource { get = Just handler_ })
     checkRoute PUT    uri (root -/ Rest.route resource { update = Just handler_ })
     checkRoute DELETE uri (root -/ Rest.route resource { remove = Just handler_ })
     checkRoute GET    (uri <> "/select") (root -/ Rest.route resource { selects = [("select", handler_)] })
     checkRoute POST   (uri <> "/action") (root -/ Rest.route resource { actions = [("action", handler_)] })

checkRoute :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion
checkRoute method uri router = checkRouteWithIgnoredMethods [method] router method uri

checkRoutes :: (Applicative m, Monad m) => [(Method, Uri)] -> Rest.Router m s -> Assertion
checkRoutes reqs router =
  forM_ reqs $ uncurry $ checkRouteWithIgnoredMethods (map fst reqs) router

checkRouteWithIgnoredMethods :: (Applicative m, Monad m) => [Method] -> Rest.Router m s -> Method -> Uri -> Assertion
checkRouteWithIgnoredMethods ignoredMethods router method uri =
  do checkRouteSuccess method uri router
     forM_ (filter (not . (`elem` ignoredMethods)) allMethods) $ \badMethod -> checkRouteFailure badMethod uri router
     checkRouteFailure method (uri <> "/trailing") router

checkRouteFailure :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion
checkRouteFailure method uri router =
  case route (Just method) (splitUriString $ "v1.0/" <> uri) (Versioned [(Version 1 0 Nothing, Some1 router)]) of
    Left _  -> return ()
    Right _ -> assertFailure ("Should be no route to " ++ show method ++ " " ++ uri ++ ".")

checkRouteSuccess :: (Applicative m, Monad m) => Method -> Uri -> Rest.Router m s -> Assertion
checkRouteSuccess method uri router =
  case route (Just method) (splitUriString $ "v1.0/" <> uri) (Versioned [(Version 1 0 Nothing, Some1 router)]) of
    Left e  -> assertFailure ("No route to " ++ show method ++ " " ++ uri ++ ": " ++ show e)
    Right _ -> return ()

allMethods :: [Method]
allMethods = [GET, PUT, POST, DELETE]

testAcceptHeaders :: Assertion
testAcceptHeaders =
  do let fmt = accept (Just "text/json") Nothing Nothing
     assertEqual "Accept json format." [JsonFormat] fmt

testListingCount :: Assertion
testListingCount = assertEqual "listing count" (Right $ C.List 0 5 [1..5::Int]) (eitherDecode bs)
  where
    (bs, _meta) = runIdentity . RM.runRestM input $ Run.apiToHandler api
    input :: RM.RestInput
    input = RM.emptyInput
      { RM.parameters = H.fromList [("count", "5")]
      , RM.paths      = splitUriString "resource"
      , RM.headers    = H.fromList
          [ ("Accept"      , "application/json")
          , ("Content-Type", "application/json")
          ]
      }
    api :: Api (RM.RestM Identity)
    api = Unversioned (Some1 $ Rest.root -/ Rest.route resource)
    resource :: Resource (RM.RestM Identity) (RM.RestM Identity) String () Void
    resource = mkResourceId
      { Res.name   = "resource"
      , Res.schema = withListing () $ named []
      , Res.list   = const listHandler
      }
      where
      listHandler :: ListHandler (RM.RestM Identity)
      listHandler = mkListing jsonO h
        where
          h :: Range -> ExceptT Reason_ (RM.RestM Identity) [Int]
          h _rng = return [1..10]