web-inv-route-0.1: test/Main.hs

{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import Data.Maybe (fromJust)
import Network.URI (parseURI)
import System.Exit (exitSuccess, exitFailure)
import qualified Test.HUnit as U

import Web.Route.Invertible
import Web.Route.Invertible.URI

getThing :: RouteAction Int String
getThing = routeMethod GET *< routePath ("thing" *< parameter) `RouteAction` \i ->
  "get thing" ++ show i

getThingQ :: RouteAction (Int, Char) String
getThingQ = routeMethod GET *< routePath ("thing" *< parameter) >*< routeQuery "type" parameter `RouteAction` \(i, c) ->
  "get thing" ++ show i ++ ":" ++ [c]

getThing2 :: RouteAction (Int, Int) String
getThing2 = routeMethod GET *< routePath ("thing" *< parameter >*< parameter) `RouteAction` \(i, sub) ->
  "get thing" ++ show i ++ "." ++ show sub

putThing :: RouteAction Int String
putThing = routeMethod PUT *< routePath ("thing" *< parameter) `RouteAction` \i ->
  "put thing" ++ show i

postThing :: RouteAction String String
postThing = routeMethod POST *< routePath ("thing" *< parameter) `RouteAction` \i ->
  "post thing=" ++ i

anyThingSub :: RouteAction (Int, [Int]) String
anyThingSub = routePath ("thing" *< parameter >* "sub" >*< manyI parameter) `RouteAction` \(i, l) ->
  "thing" ++ show i ++ " sub" ++ concatMap ((' ' :) . show) l

ignoredThing :: RouteAction Int String
ignoredThing = routeMethod GET *< routePath ("things" *< parameter >* wildcard ["ign" :: String]) `RouteAction` \i ->
  "ignore thing" ++ show i

complex :: RouteAction () String
complex = (routeMethod GET *< routeSecure False) *< (routePath "foo" *< routeHost ("foo" *< "com")) `RouteAction` \() ->
  "complex"

things :: RouteMap String
things = routes
  [ routeNormCase getThing
  , routeNormCase getThingQ
  , routeNormCase putThing
  , routeNormCase postThing
  , routeNormCase getThing2
  , routeNormCase anyThingSub
  , routeNormCase ignoredThing
  , routeNormCase complex
  ]

-- req :: Method -> String -> Request
-- req m = uriRequest m . fromJust . parseURI

rte :: Method -> String -> RouteResult String
rte m u = lookupRoute (uriRequest m $ fromJust $ parseURI u) things

req :: RouteAction r a -> r -> (Method, String)
req a = fmap show . routeActionURI a

tests :: U.Test
tests = U.test
  [ rte GET "http:/thing/0"           U.~?= RouteResult "get thing0"
  , rte GET "http:/thing/-3?type=x"   U.~?= RouteResult "get thing-3:x"
  , req getThingQ (98, '=')           U.~?= (GET, "http:/thing/98?type=%3D")
  , rte PUT "http:/thing/09"          U.~?= RouteResult "put thing9"
  , req postThing "foo"               U.~?= (POST, "http:/thing/foo")
  , rte OPTIONS "http:/thing/xxx"     U.~?= AllowedMethods [POST]
  , rte PUT "http:/thing/0/sub/12/34" U.~?= RouteResult "thing0 sub 12 34"
  , rte GET "http:/things/0/12/34"    U.~?= RouteResult "ignore thing0"
  , req ignoredThing (-3)             U.~?= (GET, "http:/things/-3/ign")
  , rte POST "http://foo.com/foo"     U.~?= AllowedMethods [GET]
  , rte POST "http:/foo"              U.~?= RouteNotFound
  ]

main :: IO ()
main = do
  r <- U.runTestTT tests
  if U.errors r == 0 && U.failures r == 0
    then exitSuccess
    else exitFailure