    {-# 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