{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
{-# LANGUAGE ExistentialQuantification #-}
{- | This module gives you a way to mount applications under sub-URIs.
For example:

> bugsApp, helpdeskApp, apiV1, apiV2, mainApp :: Application
>
> myApp :: Application
> myApp = mapUrls $
>       mount "bugs"     bugsApp
>   <|> mount "helpdesk" helpdeskApp
>   <|> mount "api"
>           (   mount "v1" apiV1
>           <|> mount "v2" apiV2
>           )
>   <|> mountRoot mainApp

-}
module Network.Wai.UrlMap (
    UrlMap',
    UrlMap,
    mount',
    mount,
    mountRoot,
    mapUrls
) where

import Control.Applicative
import Data.List
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.ByteString as B
import Network.HTTP.Types
import Network.Wai

type Path = [Text]
newtype UrlMap' a = UrlMap' { UrlMap' a -> [(Path, a)]
unUrlMap :: [(Path, a)] }

instance Functor UrlMap' where
    fmap :: (a -> b) -> UrlMap' a -> UrlMap' b
fmap a -> b
f (UrlMap' [(Path, a)]
xs) = [(Path, b)] -> UrlMap' b
forall a. [(Path, a)] -> UrlMap' a
UrlMap' (((Path, a) -> (Path, b)) -> [(Path, a)] -> [(Path, b)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(Path
p, a
a) -> (Path
p, a -> b
f a
a)) [(Path, a)]
xs)

instance Applicative UrlMap' where
    pure :: a -> UrlMap' a
pure a
x                        = [(Path, a)] -> UrlMap' a
forall a. [(Path, a)] -> UrlMap' a
UrlMap' [([], a
x)]
    (UrlMap' [(Path, a -> b)]
xs) <*> :: UrlMap' (a -> b) -> UrlMap' a -> UrlMap' b
<*> (UrlMap' [(Path, a)]
ys) = [(Path, b)] -> UrlMap' b
forall a. [(Path, a)] -> UrlMap' a
UrlMap' [ (Path
p, a -> b
f a
y) |
                                              (Path
p, a
y) <- [(Path, a)]
ys,
                                              a -> b
f <- ((Path, a -> b) -> a -> b) -> [(Path, a -> b)] -> [a -> b]
forall a b. (a -> b) -> [a] -> [b]
map (Path, a -> b) -> a -> b
forall a b. (a, b) -> b
snd [(Path, a -> b)]
xs ]

instance Alternative UrlMap' where
    empty :: UrlMap' a
empty                         = [(Path, a)] -> UrlMap' a
forall a. [(Path, a)] -> UrlMap' a
UrlMap' [(Path, a)]
forall (f :: * -> *) a. Alternative f => f a
empty
    (UrlMap' [(Path, a)]
xs) <|> :: UrlMap' a -> UrlMap' a -> UrlMap' a
<|> (UrlMap' [(Path, a)]
ys) = [(Path, a)] -> UrlMap' a
forall a. [(Path, a)] -> UrlMap' a
UrlMap' ([(Path, a)]
xs [(Path, a)] -> [(Path, a)] -> [(Path, a)]
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> [(Path, a)]
ys)

type UrlMap = UrlMap' Application

-- | Mount an application under a given path. The ToApplication typeclass gives
-- you the option to pass either an 'Network.Wai.Application' or an 'UrlMap'
-- as the second argument.
mount' :: ToApplication a => Path -> a -> UrlMap
mount' :: Path -> a -> UrlMap
mount' Path
prefix a
thing = [(Path, Application)] -> UrlMap
forall a. [(Path, a)] -> UrlMap' a
UrlMap' [(Path
prefix, a -> Application
forall a. ToApplication a => a -> Application
toApplication a
thing)]

-- | A convenience function like mount', but for mounting things under a single
-- path segment.
mount :: ToApplication a => Text -> a -> UrlMap
mount :: Text -> a -> UrlMap
mount Text
prefix a
thing = Path -> a -> UrlMap
forall a. ToApplication a => Path -> a -> UrlMap
mount' [Text
prefix] a
thing

-- | Mount something at the root. Use this for the last application in the
-- block, to avoid 500 errors from none of the applications matching.
mountRoot :: ToApplication a => a -> UrlMap
mountRoot :: a -> UrlMap
mountRoot = Path -> a -> UrlMap
forall a. ToApplication a => Path -> a -> UrlMap
mount' []

try :: Eq a
    => [a] -- ^ Path info of request
    -> [([a], b)] -- ^ List of applications to match
    -> Maybe ([a], b)
try :: [a] -> [([a], b)] -> Maybe ([a], b)
try [a]
xs [([a], b)]
tuples = (Maybe ([a], b) -> ([a], b) -> Maybe ([a], b))
-> Maybe ([a], b) -> [([a], b)] -> Maybe ([a], b)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl Maybe ([a], b) -> ([a], b) -> Maybe ([a], b)
forall b. Maybe ([a], b) -> ([a], b) -> Maybe ([a], b)
go Maybe ([a], b)
forall a. Maybe a
Nothing [([a], b)]
tuples
    where
        go :: Maybe ([a], b) -> ([a], b) -> Maybe ([a], b)
go (Just ([a], b)
x) ([a], b)
_ = ([a], b) -> Maybe ([a], b)
forall a. a -> Maybe a
Just ([a], b)
x
        go Maybe ([a], b)
_ ([a]
prefix, b
y) = [a] -> [a] -> Maybe [a]
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix [a]
prefix [a]
xs Maybe [a] -> ([a] -> Maybe ([a], b)) -> Maybe ([a], b)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[a]
xs' -> ([a], b) -> Maybe ([a], b)
forall (m :: * -> *) a. Monad m => a -> m a
return ([a]
xs', b
y)

class ToApplication a where
    toApplication :: a -> Application

instance ToApplication Application where
    toApplication :: Application -> Application
toApplication = Application -> Application
forall a. a -> a
id

instance ToApplication UrlMap where
    toApplication :: UrlMap -> Application
toApplication UrlMap
urlMap Request
req Response -> IO ResponseReceived
sendResponse =
        case Path -> [(Path, Application)] -> Maybe (Path, Application)
forall a b. Eq a => [a] -> [([a], b)] -> Maybe ([a], b)
try (Request -> Path
pathInfo Request
req) (UrlMap -> [(Path, Application)]
forall a. UrlMap' a -> [(Path, a)]
unUrlMap UrlMap
urlMap) of
            Just (Path
newPath, Application
app) ->
                Application
app (Request
req { pathInfo :: Path
pathInfo = Path
newPath
                         , rawPathInfo :: ByteString
rawPathInfo = Path -> ByteString
makeRaw Path
newPath
                         }) Response -> IO ResponseReceived
sendResponse
            Maybe (Path, Application)
Nothing ->
                Response -> IO ResponseReceived
sendResponse (Response -> IO ResponseReceived)
-> Response -> IO ResponseReceived
forall a b. (a -> b) -> a -> b
$ Status -> ResponseHeaders -> ByteString -> Response
responseLBS
                    Status
status404
                    [(HeaderName
hContentType, ByteString
"text/plain")]
                    ByteString
"Not found\n"

        where
        makeRaw :: [Text] -> B.ByteString
        makeRaw :: Path -> ByteString
makeRaw = (ByteString
"/" ByteString -> ByteString -> ByteString
`B.append`) (ByteString -> ByteString)
-> (Path -> ByteString) -> Path -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
T.encodeUtf8 (Text -> ByteString) -> (Path -> Text) -> Path -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Path -> Text
T.intercalate Text
"/"

mapUrls :: UrlMap -> Application
mapUrls :: UrlMap -> Application
mapUrls = UrlMap -> Application
forall a. ToApplication a => a -> Application
toApplication