{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE FlexibleInstances #-}

-- | 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 qualified Data.ByteString as B
import Data.List (stripPrefix)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Types (hContentType, status404)
import Network.Wai (Application, Request (pathInfo, rawPathInfo), responseLBS)

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

instance Functor UrlMap' where
    fmap :: forall a b. (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 a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((a -> b) -> (Path, a) -> (Path, b)
forall a b. (a -> b) -> (Path, a) -> (Path, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f) [(Path, a)]
xs)

instance Applicative UrlMap' where
    pure :: forall a. a -> UrlMap' a
pure a
x = [(Path, a)] -> UrlMap' a
forall a. [(Path, a)] -> UrlMap' a
UrlMap' [([], a
x)]
    (UrlMap' [(Path, a -> b)]
xs) <*> :: forall a b. 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 :: forall a. UrlMap' a
empty = [(Path, a)] -> UrlMap' a
forall a. [(Path, a)] -> UrlMap' a
UrlMap' [(Path, a)]
forall a. [a]
forall (f :: * -> *) a. Alternative f => f a
empty
    (UrlMap' [(Path, a)]
xs) <|> :: forall a. 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 a. [a] -> [a] -> [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' :: forall a. ToApplication a => 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 :: forall a. ToApplication a => Text -> a -> UrlMap
mount Text
prefix = Path -> a -> UrlMap
forall a. ToApplication a => Path -> a -> UrlMap
mount' [Text
prefix]

-- | 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 :: forall a. ToApplication a => 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 :: forall a b. Eq a => [a] -> [([a], b)] -> Maybe ([a], b)
try [a]
xs = (Maybe ([a], b) -> ([a], b) -> Maybe ([a], b))
-> Maybe ([a], b) -> [([a], b)] -> Maybe ([a], b)
forall b a. (b -> a -> b) -> b -> [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
  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 a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \[a]
xs' -> ([a], b) -> Maybe ([a], b)
forall a. a -> Maybe a
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 = newPath
                        , rawPathInfo = makeRaw 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