Source

ella / src / Ella / Framework.hs

Luke Plant 3d1e528 


Luke Plant 95354f6 
Luke Plant 3d1e528 
Luke Plant a48ddc6 
Luke Plant 3d1e528 

Luke Plant 95354f6 
Luke Plant 3d1e528 
Luke Plant 42962fc 
Luke Plant 3d1e528 
Luke Plant a48ddc6 
Luke Plant 42962fc 
Luke Plant 3d1e528 




Luke Plant 9d348d3 

Luke Plant 3d1e528 
Luke Plant c7992ca 
Luke Plant 3d1e528 












Luke Plant a802780 
Luke Plant c7992ca 
Luke Plant 3d1e528 

Luke Plant 6bca1fd 
Luke Plant 3d1e528 
Luke Plant 30aa625 
Luke Plant 3d1e528 


Luke Plant 95354f6 

Luke Plant 372e678 





Luke Plant 95354f6 
Luke Plant 42962fc 
Luke Plant 95354f6 
Luke Plant 42962fc 
Luke Plant 95354f6 
Luke Plant 42962fc 

Luke Plant 95354f6 

Luke Plant 3d1e528 
Luke Plant 6bca1fd 


Luke Plant 3d1e528 
Luke Plant 42962fc 
Luke Plant 73f1a15 

Luke Plant 3d1e528 





Luke Plant 42962fc 

Luke Plant 3d1e528 




Luke Plant 95354f6 
Luke Plant 42962fc 
Luke Plant a48ddc6 




Luke Plant 95354f6 
Luke Plant 42962fc 
Luke Plant 3d1e528 



Luke Plant 95354f6 
Luke Plant 42962fc 
Luke Plant 3d1e528 
Luke Plant 6bca1fd 
Luke Plant 3d1e528 
Luke Plant 73f1a15 
Luke Plant 3d1e528 













Luke Plant a48ddc6 
Luke Plant 42962fc 
Luke Plant a48ddc6 



Luke Plant 3d1e528 







Luke Plant 6bca1fd 

Luke Plant a48ddc6 
Luke Plant 3d1e528 













Luke Plant c7992ca 
Luke Plant 3d1e528 











Luke Plant 53dc9f6 



Luke Plant cb79ef5 





Luke Plant 53dc9f6 
Luke Plant 42962fc 


Luke Plant 3d1e528 






Luke Plant 42962fc 
Luke Plant 3d1e528 







Luke Plant c7992ca 






Luke Plant 3d1e528 
Luke Plant c7992ca 











Luke Plant 3d1e528 




Luke Plant 9d348d3 












Luke Plant f335e65 
Luke Plant 9d348d3 


Luke Plant f141b54 
Luke Plant 9d348d3 
Luke Plant f141b54 
Luke Plant 9d348d3 
Luke Plant 3d1e528 
Luke Plant 9d348d3 



Luke Plant 3d1e528 


Luke Plant 9d348d3 
Luke Plant 3d1e528 


Luke Plant c7992ca 
Luke Plant 9d348d3 

Luke Plant 3d1e528 





Luke Plant c7992ca 









Luke Plant 3d1e528 
Luke Plant c7992ca 

Luke Plant 9d348d3 
Luke Plant c7992ca 
Luke Plant 3d1e528 

Luke Plant c7992ca 

Luke Plant 9d348d3 
Luke Plant f9afffa 

Luke Plant 3d1e528 
Luke Plant 9d348d3 


Luke Plant 3d1e528 


Luke Plant 9d348d3 
Luke Plant 42962fc 
Luke Plant 9d348d3 
Luke Plant 3d1e528 
Luke Plant 42962fc 
Luke Plant 3d1e528 
Luke Plant 42962fc 
Luke Plant 9d348d3 

Luke Plant 3d1e528 




Luke Plant 9f87208 


Luke Plant 3d1e528 

Luke Plant 9d348d3 
Luke Plant 3d1e528 

Luke Plant 9d348d3 


Luke Plant 372e678 
Luke Plant 9d348d3 
Luke Plant 372e678 




Luke Plant 3d1e528 
{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
module Ella.Framework (
                      -- * Dispatching
                      -- $dispatching
                      dispatchCGI
                     , sendResponseCGI
                     , dispatchRequest
                     , DispatchOptions(..)
                      -- * Defaults
                     , defaultDispatchOptions
                     , defaultRequestOptions
                     , default404
                     , default500
                     -- * Routing mechanism
                     , View
                     -- $routing
                     , route
                     , (//->)
                     -- * Matchers
                     , PartMatch
                     -- $matchers
                     , fixedString
                     , anyParam
                     , intParam
                     , stringParam
                     , anyPath
                     , empty
                     , (</>)
                     , (</+>)
                     , (<+/>)
                     )

where

import Control.Monad ((>=>))
import Data.List (isPrefixOf)
import Ella.GenUtils (apply, utf8, exactParse)
import Ella.Param
import Ella.Response
import Ella.Request
import Maybe (fromJust)
import System.IO (stdout, hClose)
import qualified Data.ByteString.Lazy as BS

-- * Dispatching

-- $dispatching
--
-- The main entry point for handling CGI requests is 'dispatchCGI'.
-- This creates a Request object according to the CGI protocol,
-- dispatches it to a list of views, returning a 404 if no view
-- matches.  This process can be customised using 'DispatchOptions'.
-- A set of defaults for this is provided, 'defaultDispatchOptions',
-- which can be used as a starting point and customised as needed.
--
-- 'dispatchCGI' does not do any error handling.  Since the type of
-- any error handling function will depend on the libraries being
-- used, it is easier to wrap the call to 'dispatchCGI' in your own
-- error handling.  For finer grained error handling, view decorator
-- functions can be used, as well as error handling within the view
-- function itself.

-- | Options for the dispatch process
data DispatchOptions = DispatchOptions {
      notFoundHandler :: View
    -- ^ function that will return a 404 page in the case of no view functions matching.
    -- It is defined as 'View' for simplicity - it should always return 'Just' something.
    , requestOptions :: RequestOptions
    -- ^ options passed to 'buildCGIRequest'
    , viewProcessors :: [View -> View]
    -- ^ view processors that should be applied to list of views.
}

type View = Request -> IO (Maybe Response)

-- * Defaults

-- | A basic 404 response that is used by 'defaultDispatchOptions'
default404 :: Response
default404 = buildResponse [
              setStatus 404,
              addContent "<h1>404 Not Found</h1>\n<p>Sorry, the page you requested could not be found.</p>"
             ] utf8HtmlResponse

-- | A basic 500 response, not used internally.
default500 :: String -> Response
default500 content = buildResponse [ setStatus 500
                                   , addContent "<h1>500 Internal Server Error</h1>\n"
                                   , addContent $ utf8 content
                                   ] utf8HtmlResponse

-- | Default options used for interpreting the request
defaultRequestOptions :: RequestOptions
defaultRequestOptions = RequestOptions {
                          encoding = utf8Encoding
                        }

-- | A set of DispatchOptions useful as a basis.
defaultDispatchOptions :: DispatchOptions
defaultDispatchOptions = DispatchOptions {
                           notFoundHandler = const $ return $ Just default404
                         , requestOptions = defaultRequestOptions
                         , viewProcessors = []
                         }

-- | Used by dispatchCGI, might be useful on its own, especially in testing
--
-- Effectively this reduces a list of view functions so that
-- they act as a single one
dispatchRequest :: [View] -> View
dispatchRequest [] req = return Nothing
dispatchRequest (v:vs) req = do
  resp <- v req
  case resp of
    Nothing -> dispatchRequest vs req
    x -> return x

-- | Sends a Response according to the CGI protocol
sendResponseCGI :: Response -> IO ()
sendResponseCGI resp = do
  BS.hPut stdout (formatResponse resp)
  hClose stdout

-- | Handle a CGI request using a list of possible views
-- If a view returns 'Nothing' the next will be tried,
-- and a 404 issued if all return nothing
dispatchCGI :: [View]           -- ^ list of views functions that will be tried in order
            -> DispatchOptions  -- ^ options to use in dispatching
            -> IO ()
dispatchCGI views opts = do
  req <- buildCGIRequest (requestOptions opts)
  m_resp <- (apply (viewProcessors opts) $ dispatchRequest $ views ++ [notFoundHandler opts]) req
  sendResponseCGI $ fromJust m_resp


-- Routing

-- $routing
--
-- The routing mechanism has been designed so that you can write code like the following:
--
-- > routes = [
-- >            empty                                  //-> indexView                 $ decs
-- >          , "posts/" <+/> empty                    //-> postsView                 $ []
-- >          , intParam                               //-> viewWithIntParam          $ []
-- >          , stringParam                            //-> viewWithStringParam       $ []
-- >          , intParam </+> "test/"                  //-> viewWithIntParam          $ []
-- >          , "test/" <+/> intParam                  //-> viewWithIntParam          $ []
-- >          , anyParam </> anyParam                  //-> viewWithIntAndStringParam $ []
-- >          , intParam </> stringParam </> intParam  //-> viewWithIntStringInt      $ []
-- >          ]
--
-- where:
--
-- >  postsView, indexView :: Request -> IO (Maybe Response)
-- >  viewWithStringParam :: String -> Request -> IO (Maybe Response)
-- >  viewWithIntParam :: Int -> Request -> IO (Maybe Response)
-- >  viewWithIntAndStringParam :: Int -> String -> Request -> IO (Maybe Response)
-- >  viewWithIntStringInt :: Int -> String -> Int -> Request -> IO (Maybe Response)
-- >  decs :: [View -> View]
--
-- These would correspond to URLs like the following:
--
-- > /
-- > /posts/
-- > /123/             123 captured
-- > /abc7/            "abc7" captured
-- > /123/test/        123 captured
-- > /test/123/        123 captured
-- > /123/abc7/        123 and "abc7" captured
-- > /123/abc7/456/    123, "abc7" and 456 captured
--
-- The right hand argument of '//->' is a 'view like' function, of type
-- 'View' OR @a -> 'View'@ OR @a -> b -> 'View'@ etc,
--
-- The left hand argument of '//->' is a \'matcher\' - it parses the
-- path of the Request, optionally capturing parameters and returning
-- a function that will adapt the right hand argument so that it has
-- type View.
--
-- Matchers can be composed using '</>'.  To match a fixed string
-- without capturing, use @fixedString "thestring"@. The operators
-- '</+>' amd '<+/>' are useful for combining fixed strings with other
-- matchers.  To match just a fixed string, you can use
--
-- > "thestring/" <+/> empty
--
-- instead of:
--
-- > fixedString "thestring/"
--
-- The result of the '//->' operator needs to be applied to a list of
-- \'view decorator\' functions, (which may be an empty list)
-- e.g. \'decs\' above.  These decorators take a View and return a
-- View, or alternatively they can be considered to take a View and a
-- Request and return an IO (Maybe Response).  These means they can be
-- used to do pre-processing of the request, and post-processing of
-- the response.
--
-- The routing mechanism is extensible in the types of parameters that
-- can be captured.  The easiest way is to define instances of
-- 'Param', and then use anyParam.  For more complex needs, for
-- example if you do not want the component to end in a forward slash,
-- just define your own matchers.
--
-- When defining routes as above, choosing 'anyParam' instead of
-- 'intParam' or 'stringParam' will produce exactly the same result.
-- With 'anyParam', the type will be determined by type inference.
-- With 'stringParam' etc., you are repeating the type information,
-- which is a DRY violation, but it may be useful for clarity, and you
-- will get a compilation error in the case of any mismatch.
--
-- NB. The Request object trims any leading slash on the path to normalise
-- it, and also to simplify this parsing stage, so do not attempt to match
-- an initial leading slash.


-- | type alias used to simplify signatures
type PartMatch a = (String, a, Request)

-- $matchers
--
-- Matching functions take a 'PartMatch' and return a @Maybe 'PartMatch'@.
-- The first component of 'PartMatch' is a String which is the
-- remaining part of the 'Ella.Request.pathInfo' still to be matched.
--
-- The second component of 'PartMatch' is a 'View' function, or a
-- function that returns a View when partially applied.  This allows for
-- matchers that also capture parameters (of different types) and feed
-- them to the view functions.  In this case, the 'PartMatch' output
-- will have a different type to the 'PartMatch' input.
--
-- The third component of 'PartMatch' is the entire 'Request' object.
-- This allows matchers to operate on other attributes of the 'Request'
-- e.g. only match GET requests.  It also allows them to alter
-- the Request object that a view function receives.

-- | Match a string at the beginning of the path
fixedString :: String -> PartMatch a -> Maybe (PartMatch a)
fixedString s (path, f, r) = if s `isPrefixOf` path
                             then Just (drop (length s) path, f, r)
                             else Nothing

-- | Convenience no-op matcher, useful for when you only want to match
-- a fixed string, or to match an empty string.
empty :: PartMatch a -> Maybe (PartMatch a)
empty = Just


-- | Matcher that matches any remaining path
anyPath :: PartMatch a -> Maybe (PartMatch a)
anyPath (path, f, r) = Just ("", f, r)

nextChunk path = let (start, end) = break (== '/') path
                 in case end of
                      [] -> Nothing
                      x:rest -> Just (start, rest)

-- | Matcher that matches any instance of Param followed by a forward slash.
--
-- If anyParam is used, the concrete type will be determined by type
-- inference from the view function.
anyParam :: (Param t) => PartMatch (t -> a) -> Maybe (PartMatch a)
anyParam (path, f, r) = do
  (chunk, rest) <- nextChunk path
  val <- capture chunk
  Just (rest, f val, r)

-- | Matcher that captures a string component followed by a forward slash
--
-- This is anyParam specialised to strings
stringParam :: PartMatch (String -> a) -> Maybe (PartMatch a)
stringParam = anyParam

-- | Matcher that captures an integer component followed by a forward slash
--
-- This is anyParam specialised to ints
intParam :: PartMatch (Int -> a) -> Maybe (PartMatch a)
intParam = anyParam

-- | Combine two matchers
(</>) :: (PartMatch a -> Maybe (PartMatch b)) -- ^ LH matcher
      -> (PartMatch b -> Maybe (PartMatch c)) -- ^ RH matcher
      -> (PartMatch a -> Maybe (PartMatch c))
(</>) = (>=>) -- It turns out that this does the job!

-- | Convenience operator for combining a fixed string after a matcher
(</+>) :: (PartMatch a -> Maybe (PartMatch b))  -- ^ matcher
       -> String                              -- ^ fixed string
       -> (PartMatch a -> Maybe (PartMatch b))
matcher </+> str = matcher </> (fixedString str)

-- | Convenience operator for combining a matcher after a fixed string
(<+/>) :: String                              -- ^ fixed string
       -> (PartMatch a -> Maybe (PartMatch b))  -- ^ matcher
       -> (PartMatch a -> Maybe (PartMatch b))
str <+/> matcher = (fixedString str) </> matcher

-- | Apply a matcher to a View (or View-like function that takes
-- additional parameters) to get a View that only responds to the
-- matched URLs
route :: (PartMatch a -> Maybe (PartMatch View)) -- ^ matcher
      -> a                                       -- ^ view-like function
      -> [View -> View]                          -- ^ optional view decorators (processors)
      -> View
route matcher f decs =
    \req -> let match = matcher (pathInfo req, f, req)
            in case match of
                 Nothing -> return Nothing
                 Just (remainder, view, req') -> if null remainder
                                                 then (apply decs view) req'
                                                 else return Nothing

-- | Alias for 'route', see above examples.
(//->) :: (PartMatch a -> Maybe (PartMatch View))
          -> a
          -> [View -> View]
          -> Request
          -> IO (Maybe Response)
(//->) = route