{-# 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' { unUrlMap :: [(Path, a)] }

instance Functor UrlMap' where
    fmap f (UrlMap' xs) = UrlMap' (fmap (\(p, a) -> (p, f a)) xs)

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

instance Alternative UrlMap' where
    empty                         = UrlMap' empty
    (UrlMap' xs) <|> (UrlMap' ys) = UrlMap' (xs <|> 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' prefix thing = UrlMap' [(prefix, toApplication thing)]

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

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

class ToApplication a where
    toApplication :: a -> Application

instance ToApplication Application where
    toApplication = id

instance ToApplication UrlMap where
    toApplication urlMap req sendResponse =
        case try (pathInfo req) (unUrlMap urlMap) of
            Just (newPath, app) ->
                app (req { pathInfo = newPath
                         , rawPathInfo = makeRaw newPath
                         }) sendResponse
            Nothing ->
                sendResponse $ responseLBS
                    status404
                    [(hContentType, "text/plain")]
                    "Not found\n"

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

mapUrls :: UrlMap -> Application
mapUrls = toApplication