-- |Results of route table lookups.
module Web.Route.Invertible.Result
  ( RouteResult(..)
  , routeResult
  ) where

import qualified Data.ByteString.Char8 as BSC
import Data.Typeable (Typeable)
import Network.HTTP.Types.Header (ResponseHeaders, hAllow)
import Network.HTTP.Types.Status (Status, notFound404, methodNotAllowed405, internalServerError500)

import Web.Route.Invertible.Parameter
import Web.Route.Invertible.Method

-- |The result of looking up a request in a routing map.
data RouteResult a
  = RouteNotFound -- ^No route was found to handle this request: 404
  | AllowedMethods [Method] -- ^No route was found to handle this request, but there are routes for other methods: 405
  | RouteResult a -- ^A route was found to handle this request
  | MultipleRoutes -- ^Multiple (conflicting) routes were found to handle this request: 500
  deriving (RouteResult a -> RouteResult a -> Bool
(RouteResult a -> RouteResult a -> Bool)
-> (RouteResult a -> RouteResult a -> Bool) -> Eq (RouteResult a)
forall a. Eq a => RouteResult a -> RouteResult a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RouteResult a -> RouteResult a -> Bool
$c/= :: forall a. Eq a => RouteResult a -> RouteResult a -> Bool
== :: RouteResult a -> RouteResult a -> Bool
$c== :: forall a. Eq a => RouteResult a -> RouteResult a -> Bool
Eq, Int -> RouteResult a -> ShowS
[RouteResult a] -> ShowS
RouteResult a -> String
(Int -> RouteResult a -> ShowS)
-> (RouteResult a -> String)
-> ([RouteResult a] -> ShowS)
-> Show (RouteResult a)
forall a. Show a => Int -> RouteResult a -> ShowS
forall a. Show a => [RouteResult a] -> ShowS
forall a. Show a => RouteResult a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [RouteResult a] -> ShowS
$cshowList :: forall a. Show a => [RouteResult a] -> ShowS
show :: RouteResult a -> String
$cshow :: forall a. Show a => RouteResult a -> String
showsPrec :: Int -> RouteResult a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> RouteResult a -> ShowS
Show, Typeable)

instance Functor RouteResult where
  fmap :: (a -> b) -> RouteResult a -> RouteResult b
fmap a -> b
_ RouteResult a
RouteNotFound = RouteResult b
forall a. RouteResult a
RouteNotFound
  fmap a -> b
_ (AllowedMethods [Method]
m) = [Method] -> RouteResult b
forall a. [Method] -> RouteResult a
AllowedMethods [Method]
m
  fmap a -> b
f (RouteResult a
x) = b -> RouteResult b
forall a. a -> RouteResult a
RouteResult (a -> b
f a
x)
  fmap a -> b
_ RouteResult a
MultipleRoutes = RouteResult b
forall a. RouteResult a
MultipleRoutes

instance Semigroup (RouteResult a) where
  RouteResult a
RouteNotFound <> :: RouteResult a -> RouteResult a -> RouteResult a
<> RouteResult a
r = RouteResult a
r
  AllowedMethods [Method]
_ <> r :: RouteResult a
r@(RouteResult a
_) = RouteResult a
r
  AllowedMethods [Method]
a <> AllowedMethods [Method]
b = [Method] -> RouteResult a
forall a. [Method] -> RouteResult a
AllowedMethods ([Method] -> RouteResult a) -> [Method] -> RouteResult a
forall a b. (a -> b) -> a -> b
$ [Method] -> [Method] -> [Method]
forall a. Ord a => [a] -> [a] -> [a]
unionSorted [Method]
a [Method]
b
  r :: RouteResult a
r@(RouteResult a
_) <> AllowedMethods [Method]
_ = RouteResult a
r
  RouteResult a
MultipleRoutes <> RouteResult a
_ = RouteResult a
forall a. RouteResult a
MultipleRoutes
  RouteResult a
r <> RouteResult a
RouteNotFound = RouteResult a
r
  RouteResult a
_ <> RouteResult a
_ = RouteResult a
forall a. RouteResult a
MultipleRoutes

instance Monoid (RouteResult a) where
  mempty :: RouteResult a
mempty = RouteResult a
forall a. RouteResult a
RouteNotFound
  mappend :: RouteResult a -> RouteResult a -> RouteResult a
mappend = RouteResult a -> RouteResult a -> RouteResult a
forall a. Semigroup a => a -> a -> a
(<>)

unionSorted :: Ord a => [a] -> [a] -> [a]
unionSorted :: [a] -> [a] -> [a]
unionSorted al :: [a]
al@(a
a:[a]
ar) bl :: [a]
bl@(a
b:[a]
br) = case a -> a -> Ordering
forall a. Ord a => a -> a -> Ordering
compare a
a a
b of
  Ordering
LT -> a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
unionSorted [a]
ar [a]
bl
  Ordering
EQ -> a
aa -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
unionSorted [a]
ar [a]
br
  Ordering
GT -> a
ba -> [a] -> [a]
forall a. a -> [a] -> [a]
:[a] -> [a] -> [a]
forall a. Ord a => [a] -> [a] -> [a]
unionSorted [a]
al [a]
br
unionSorted [] [a]
l = [a]
l
unionSorted [a]
l [] = [a]
l

-- |Convert a result to an appropriate HTTP status and headers.
-- It is up to the user to provide an appropriate body (if any).
routeResult :: RouteResult a -> Either (Status, ResponseHeaders) a
routeResult :: RouteResult a -> Either (Status, ResponseHeaders) a
routeResult RouteResult a
RouteNotFound = (Status, ResponseHeaders) -> Either (Status, ResponseHeaders) a
forall a b. a -> Either a b
Left (Status
notFound404, [])
routeResult (AllowedMethods [Method]
m) = (Status, ResponseHeaders) -> Either (Status, ResponseHeaders) a
forall a b. a -> Either a b
Left (Status
methodNotAllowed405, [(HeaderName
hAllow, ByteString -> [ByteString] -> ByteString
BSC.intercalate (Char -> ByteString
BSC.singleton Char
',') ([ByteString] -> ByteString) -> [ByteString] -> ByteString
forall a b. (a -> b) -> a -> b
$ (Method -> ByteString) -> [Method] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map Method -> ByteString
forall s a. Parameter s a => a -> s
renderParameter [Method]
m)])
routeResult (RouteResult a
a) = a -> Either (Status, ResponseHeaders) a
forall a b. b -> Either a b
Right a
a
routeResult RouteResult a
MultipleRoutes = (Status, ResponseHeaders) -> Either (Status, ResponseHeaders) a
forall a b. a -> Either a b
Left (Status
internalServerError500, [])