Site.hs

module Web.Routes.Site where

import Data.ByteString
import Data.Monoid
import Data.Text (Text)
import Web.Routes.Base (decodePathInfo, encodePathInfo)

{-|

A site groups together the three functions necesary to make an application:

* A function to convert from the URL type to path segments.

* A function to convert from path segments to the URL, if possible.

* A function to return the application for a given URL.

There are two type parameters for Site: the first is the URL datatype, the
second is the application datatype. The application datatype will depend upon
your server backend.
-}
data Site url a
    = Site {
           {-|
               Return the appropriate application for a given URL.

               The first argument is a function which will give an appropriate
               URL (as a String) for a URL datatype. This is usually
               constructed by a combination of 'formatPathSegments' and the
               prepending of an absolute application root.

               Well behaving applications should use this function to
               generating all internal URLs.
           -}
             handleSite         :: (url -> [(Text, Maybe Text)] -> Text) -> url -> a
           -- | This function must be the inverse of 'parsePathSegments'.
           , formatPathSegments :: url -> ([Text], [(Text, Maybe Text)])
           -- | This function must be the inverse of 'formatPathSegments'.
           , parsePathSegments  :: [Text] -> Either String url
           }

-- | Override the \"default\" URL, ie the result of 'parsePathSegments' [].
setDefault :: url -> Site url a -> Site url a
setDefault defUrl (Site handle format parse) =
    Site handle format parse'
  where
    parse' [] = Right defUrl
    parse' x = parse x

instance Functor (Site url) where
  fmap f site = site { handleSite = \showFn u -> f (handleSite site showFn u) }

-- | Retrieve the application to handle a given request.
runSite :: Text -- ^ application root, with trailing slash
        -> Site url a
        -> ByteString -- ^ path info, leading slash stripped
        -> (Either String a)
runSite approot site pathInfo =
    case parsePathSegments site $ decodePathInfo pathInfo of
        (Left errs) -> (Left errs)
        (Right url) -> Right $ handleSite site showFn url
  where
    showFn url qs =
        let (pieces, qs') = formatPathSegments site url
        in approot `mappend` (encodePathInfo pieces (qs ++ qs'))