Commits

Luke Plant committed 3d1e528

Renamed 'Web' to 'Ella', and trimmed repository to contain only the framework

Comments (0)

Files changed (43)

blog.cabal

-Name:           blog
-Version:        0.1
-Description:    Personal blog system
-License:        BSD3
-License-file:   LICENSE
-Author:         Luke Plant
-Maintainer:     L.Plant.98@cantab.net
-Cabal-Version:  >= 1.2
-Build-Type:     Simple
-
-Executable migrate
-  Build-Depends:
-        base,
-        haskell98,
-        HDBC-sqlite3,
-        HDBC,
-        containers,
-        utf8-string,
-        regex-pcre,
-        template,
-        regex-base,
-        bytestring
-  Main-is: Migrate.hs
-  hs-source-dirs: src
-
-Executable installdb
-  Build-Depends:
-        base,
-        haskell98,
-        HDBC-sqlite3,
-        HDBC
-  Main-is: Installdb.hs
-  hs-source-dirs: src
-
-Executable blog.cgi
-  Build-Depends:
-        base,
-        haskell98,
-        HDBC-sqlite3,
-        HDBC,
-        containers,
-        utf8-string,
-        regex-pcre,
-        regex-base,
-        xhtml,
-        network,
-        cgi
-  Main-is: BlogCgi.hs
-  hs-source-dirs: src
+Name:           ella
+Version:        0.1
+Description:    Django-inspired web framework
+License:        BSD3
+License-file:   LICENSE
+Author:         Luke Plant
+Maintainer:     L.Plant.98@cantab.net
+Cabal-Version:  >= 1.2
+Build-Type:     Simple
+
+Library
+  Build-Depends:
+        base,
+        bytestring,
+        haskell98,
+        containers,
+        utf8-string,
+        regex-pcre,
+        regex-base,
+        xhtml,
+        network,
+        cgi
+  Exposed-Modules:
+    Ella.Request, Ella.Response, Ella.GenUtils, Ella.Utils, Ella.Framework,
+    Ella.Processors.General
+  hs-source-dirs: src

src/Blog/Category.hs

-module Blog.Category where
-
-import Database.HDBC
-import Blog.DBUtils (makeSlugGeneric)
-import qualified Blog.DB as DB
-
-data Category = Category { uid :: Int,
-                           name :: String,
-                           slug :: String
-                         } deriving (Show, Eq)
-
-addCategory cn c =  do theslug <- makeCategorySlug cn c
-                       let c2 = c { slug = theslug }
-                       DB.doInsert cn "categories"
-                             ["name",
-                              "slug"]
-                             [toSql $ name c2,
-                              toSql $ slug c2]
-                       [[newid]] <- quickQuery cn "SELECT last_insert_rowid();" [];
-                       return c2 { uid = fromSql $ newid }
-
-makeCategorySlug cn cat = makeSlugGeneric cn (name cat) "categories"

src/Blog/DB.hs

-module Blog.DB where
-
-import Database.HDBC
-import Database.HDBC.Sqlite3 (connectSqlite3)
-import List
-import qualified Blog.Settings as Settings
-
-connect = connectSqlite3 Settings.sqlite_path
-
-doInsert conn table columns values = let stmnt = mkInsertStatement table columns
-                                     in run conn stmnt values
-
-mkInsertStatement table columns = let joinC = concat . intersperse ", "
-                                      colSql = joinC columns
-                                      valSql = joinC $ take (length columns) $ repeat "?"
-                                   in "INSERT INTO " ++ table ++ 
-                                      " (" ++ colSql ++ ")" ++
-                                      " VALUES " ++
-                                      " (" ++ valSql ++ ");"

src/Blog/DBUtils.hs

-module Blog.DBUtils where
-
-import Blog.Utils (regexReplace)
-import Database.HDBC
-import GHC.Unicode (toLower)
-import qualified Data.ByteString.Char8 as B
-
-slugFromTitle title = map toLower $ B.unpack $
-                      regexReplace (B.pack "-+$") (B.pack "") $
-                      regexReplace (B.pack "[^A-Za-z0-9]+") (B.pack "-") (B.pack title)
-
-makeSlugGeneric cn title table = makeSlugGeneric' cn (slugFromTitle title) table 1
-makeSlugGeneric' cn slugBase table iter = do
-  let slugAttempt =  (slugBase ++ makeSuffix iter);
-  [[SqlString c]] <- quickQuery cn ("SELECT count(slug) FROM " ++ table ++ " WHERE slug = ?") [toSql slugAttempt];
-  case c of
-    "0" -> return slugAttempt
-    _   -> makeSlugGeneric' cn slugBase table (iter + 1)
-
- where
-   makeSuffix 1 = ""
-   makeSuffix n = show n

src/Blog/Formats.hs

-module Blog.Formats where
-
-rawhtml = 1 :: Int
-plaintext = 2 :: Int

src/Blog/Links.hs

-module Blog.Links where
-
-import qualified Blog.Category as C
-import qualified Blog.Post as P
-import qualified Blog.Settings as Settings
-
--- These need to be manually synced with Blog.Routes.  They cannot
--- live in the same module due to an import cycle when the link
--- functions are used in the templates and views.
-
-indexLink          = Settings.root_url
-postLink p         = Settings.root_url ++ "posts/" ++ (P.slug p) ++ "/"
-categoriesLink     = Settings.root_url ++ "categories/"
-categoryLink c     = Settings.root_url ++ "categories/" ++ (C.slug c) ++ "/"

src/Blog/Post.hs

-module Blog.Post where
-
-import Database.HDBC
-import Blog.DBUtils (makeSlugGeneric)
-import qualified Blog.DB as DB
-
-data Post = Post {
-      uid :: Int,
-      title :: String,
-      slug :: String,
-      post_raw :: String,
-      post_formatted :: String,
-      summary_raw :: String,
-      summary_formatted :: String,
-      format_id :: Int,
-      timestamp :: Int,
-      comments_open :: Bool
-    } deriving (Show, Eq)
-
-addPost cn p = do theslug <- makePostSlug cn p
-                  let p2 = p { slug = theslug }
-                  DB.doInsert cn "posts" [
-                         "title",
-                         "slug",
-                         "post_raw",
-                         "post_formatted",
-                         "summary_raw",
-                         "summary_formatted",
-                         "format_id",
-                         "timestamp",
-                         "comments_open"
-                        ] [
-                         toSql $ title p2,
-                         toSql $ slug p2,
-                         toSql $ post_raw p2,
-                         toSql $ post_formatted p2,
-                         toSql $ summary_raw p2,
-                         toSql $ summary_formatted p2,
-                         toSql $ format_id p2,
-                         toSql $ timestamp p2,
-                         toSql $ comments_open p2
-                        ]
-                  [[newid]] <- quickQuery cn "SELECT last_insert_rowid();" []
-                  return p2 { uid = fromSql $ newid }
-
-makePostSlug cn p = makeSlugGeneric cn (title p) "posts"
-
-addPostCategory cn pc = do { DB.doInsert cn "post_categories"
-                             ["post_id",
-                              "category_id"]
-                             [toSql $ fst pc,
-                              toSql $ snd pc];
-                             return pc; }

src/Blog/Processors.hs

-module Blog.Processors
-    (canonicalUri
-    ) where
-
-import Data.List (isPrefixOf)
-import Web.Request
-import Web.Response
-import qualified Blog.Settings as Settings
-
-
-canonicalUri :: Request -> IO (Maybe Response)
-canonicalUri req =
-    return $ case requestUriRaw req of
-               Nothing -> Nothing
-               Just uri | Settings.prog_uri `isPrefixOf` uri
-                       -> let canonUri = Settings.root_url ++ drop (length Settings.prog_uri + length "/") uri
-                               in Just $ redirectResponse canonUri
-               _       -> Nothing

src/Blog/Routes.hs

-module Blog.Routes where
-
-import Blog.Views
-import Blog.Processors
-import Web.Framework
-import Web.Processors.General (addSlashRedirectView)
-import Web.GenUtils (apply)
-
--- * Routes
-
--- These need to be manually synced with Blog.Links
-
-views  = [ addSlashRedirectView
-         , canonicalUri
-         , empty                                      //-> mainIndex              $ []
-         , "posts/" <+/> stringParam                  //-> postView               $ []
-         , "posts/" <+/> empty                        //-> postsRedirectView      $ []
-         , "categories/" <+/> empty                   //-> categoriesView         $ []
-         , "categories/" <+/> stringParam             //-> categoryView           $ []
-         , "debug/" <+/> stringParam                  //-> debug                  $ []
-         ]

src/Blog/Settings.hs

-settingslocal.hs

src/Blog/Templates.hs

-{-# OPTIONS_GHC -fglasgow-exts #-}
-module Blog.Templates
-where
-
-import Blog.Links
-import Text.XHtml
-
-
--- | Holds variables for the 'page' template
---
--- fields should be limited to type class HTML, but that makes record
--- update syntax impossible with current GHC.
-data PageVars t1 t2 = {- (HTML t1, HTML t2) => -} PageVars
-    { ptitle :: t1
-    , pcontent :: t2
-    }
-
-defaultPageVars = PageVars { ptitle = ""
-                           , pcontent = ""
-                           }
-
--- Complete page template
-page vars =
-    (header
-     << (meta ! [httpequiv "Content-Type",
-                 content "text/html; charset=utf-8"]
-         +++ thelink ! [rel "alternate",
-                        thetype "application/rss+xml",
-                        title "RSS",
-                        href "/TODO"] << ""
-         +++ thelink ! [rel "StyleSheet",
-                        href "/newblog.css",
-                        thetype "text/css"] << ""
-         +++ thelink ! [rel "shortcut icon",
-                        href "/favicon.ico",
-                        thetype "image/x-icon"] << ""
-         +++ thetitle << fulltitle
-        ))
-    +++
-    body
-    << thediv ! [identifier "container"]
-           << ((thediv ! [identifier "maintitle"]
-                << thediv
-                       << "All Unkept")
-               +++
-               (thediv ! [identifier "toplinks"]
-                           << unordList [ HotLink indexLink (toHtml "Home") [theclass "first"]
-                                        , hotlink categoriesLink << "Categories"
-                                        , hotlink "/about/" << "About"
-                                        ])
-               +++
-               (thediv ! [identifier "content"]
-                           << pcontent vars)
-              )
-    where fulltitle = let pt = ptitle vars
-                      in if null pt
-                         then "All Unkept"
-                         else pt ++ " « All Unkept"
-
-
--- Page specific templates
-
-mainIndexPage = page $ defaultPageVars
-                { pcontent = h1 << "This is the title"
-                             +++
-                             p << "This is a test"
-                , ptitle = "This is the title"
-                }
-
-categoriesPage = page $ defaultPageVars
-                 { pcontent = h1 << "Categories"
-                              +++
-                              p << "TODO"
-                 , ptitle = "Categories"
-                 }

src/Blog/Utils.hs

-{-# OPTIONS_GHC -fbang-patterns  #-}
-module Blog.Utils where
-
-import Data.Char
-import System.Environment(getArgs)
-import Text.Regex.Base
-import Text.Regex.PCRE
-import qualified Data.ByteString.Char8 as B
-
-regexReplace !re !rep !source = go source []
- where go str res =
-         if B.null str
-             then B.concat . reverse $ res
-             else case (str =~~ re) :: Maybe (B.ByteString, B.ByteString, B.ByteString) of
-               Nothing -> B.concat . reverse $ (str:res)
-               Just (bef, _ , aft) -> go aft (rep:bef:res)
-
-split :: String -> Char -> [String]
-split [] delim = [""]
-split (c:cs) delim
-   | c == delim = "" : rest
-   | otherwise = (c : head rest) : tail rest
-   where
-       rest = split cs delim

src/Blog/Views.hs

-{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
-module Blog.Views where
-
-import Web.Request
-import Web.Response
-import Web.Utils (addHtml)
-import Web.GenUtils (utf8)
-import Blog.Templates
-import Blog.Links
-
-standardResponse html = buildResponse [
-                         addHtml html
-                        ] utf8HtmlResponse
-
-mainIndex :: Request -> IO (Maybe Response)
-mainIndex req = return $ Just $ standardResponse mainIndexPage
-
-debug path req = return $ Just $ buildResponse [
-                  addContent "Path:\n"
-                 , addContent $ utf8 path
-                 , addContent "\n\nRequest:\n"
-                 , addContent $ utf8 $ show req
-                 ] utf8TextResponse
-
-postsRedirectView req = return $ Just $ redirectResponse indexLink :: IO (Maybe Response)
-
--- TODO
-
-dummyView req = return $ Just $ standardResponse ("TODO" :: String) :: IO (Maybe Response)
-
-categoriesView req = return $ Just $ standardResponse categoriesPage :: IO (Maybe Response)
-categoryView slug = dummyView
-postView slug = dummyView
-

src/Blog/settingslive.hs

-module Blog.Settings where
-
-sqlite_path = "/home/lukeplantuk/public_html/cgi-bin/data/test1.db"
-

src/Blog/settingslocal.hs

-module Blog.Settings where
-
-sqlite_path = "/home/luke/httpd/lukeplant.me.uk/web/cgi-bin/data/test1.db"
-root_url = "/testblog/"
-prog_uri = "/cgi-bin/blog.cgi" -- Used for redirecting
-
--- Testing
-testdb_sqlite_path = "/home/luke/devel/haskell/haskellblog/testsuite/test.db"
-
--- Migration time settings:
-
-old_data_path = "/home/luke/httpd/lukeplant.me.uk/web/blog/data/"
-redirect_file_template = "/home/luke/devel/haskell/haskellblog/src/blog.php.tpl"
-redirect_file_output = "/home/luke/devel/haskell/haskellblog/src/blog.php"

src/BlogCgi.hs

-import Blog.Routes
-import Web.Framework
-
-main :: IO ()
-main = dispatchCGI views defaultDispatchOptions

src/Ella/Framework.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
+module Ella.Framework (
+                      -- * Dispatching
+                      dispatchCGI
+                     , dispatchRequest
+                     , DispatchOptions(..)
+                     , defaultDispatchOptions
+                     , default404
+                     , View
+                     -- * Routing mechanism
+                     -- $routing
+                     , route
+                     , (//->)
+                     -- * Matchers
+                     , fixedString
+                     , intParam
+                     , stringParam
+                     , anyPath
+                     , empty
+                     , (</>)
+                     , (</+>)
+                     , (<+/>)
+                     )
+
+where
+
+import Control.Monad ((>=>))
+import Data.List (isPrefixOf)
+import Ella.GenUtils (apply)
+import Ella.Response
+import Ella.Request
+import System.IO (stdout, hClose)
+import qualified Data.ByteString.Lazy.Char8 as BS
+
+-- * Dispatching
+
+data DispatchOptions = DispatchOptions {
+      notFoundHandler :: Request -> IO Response
+    -- ^ function that will return a 404 page in the case of no view functions matching
+    , requestOptions :: RequestOptions
+    -- ^ options passed to buildCGIRequest
+}
+
+type View = Request -> IO (Maybe Response)
+
+-- * Defaults
+
+default404 = buildResponse [
+              setStatus 404,
+              addContent "<h1>404 Not Found</h1>\n<p>Sorry, the page you requested could not be found.</p>"
+             ] utf8HtmlResponse
+
+defaultRequestOptions = RequestOptions {
+                          encoding = utf8Encoding
+                        }
+
+defaultDispatchOptions = DispatchOptions {
+                           notFoundHandler = const $ return $ default404
+                         , requestOptions = defaultRequestOptions
+                         }
+
+-- Dispatching
+
+-- | 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
+
+-- | 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)
+  resp' <- dispatchRequest views req
+  resp <- case resp' of
+            Nothing -> notFoundHandler opts $ req
+            Just x -> return x
+  BS.hPut stdout (formatResponse resp)
+  hClose stdout
+
+-- 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          $ []
+-- >          , intParam </> stringParam               //-> 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]
+--
+-- The right hand argument of //-> is a 'view like' function, of type
+-- View OR a -> View OR a -> b -> View etc,
+-- where View = Request -> IO (Maybe Response)
+
+-- 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 passed 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 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 -- just define your own matchers.
+--
+-- 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.
+
+-- | Match a string at the beginning of the path
+fixedString :: String -> (String, a) -> Maybe (String, a)
+fixedString s (path, f) = if s `isPrefixOf` path
+                          then Just (drop (length s) path, f)
+                          else Nothing
+
+-- | Convenience no-op matcher, useful for when you only want to match
+-- a fixed string, or to match an empty string.
+empty :: (String, a) -> Maybe (String, a)
+empty = Just
+
+
+-- | matcher that matches any remaining path
+anyPath (path, f) = Just ("", f)
+
+nextChunk path = let (start, end) = break (== '/') path
+                 in case end of
+                      [] -> Nothing
+                      x:rest -> Just (start, rest)
+
+-- | Matcher that captures a string component followed by a forward slash
+stringParam :: (String, String -> a) -> Maybe (String, a)
+stringParam (path, f) = do
+  (chunk, rest) <- nextChunk path
+  Just (rest, f chunk)
+
+-- | Matcher that captures an integer component followed by a forward slash
+intParam :: (String, Int -> a) -> Maybe (String, a)
+intParam (path, f) = do
+  (chunk, rest) <- nextChunk path
+  let parses = reads chunk :: [(Int, String)]
+  case parses of
+    [(val, "")] -> Just (rest, f val)
+    otherwise -> Nothing
+
+-- | Combine two matchers
+(</>) :: ((String, a) -> Maybe (String, b)) -- ^ LH matcher
+      -> ((String, b) -> Maybe (String, c)) -- ^ RH matcher
+      -> ((String, a) -> Maybe (String, c))
+(</>) = (>=>) -- It turns out that this does the job!
+
+-- | Convenience operator for combining a fixed string after a matcher
+matcher </+> str = matcher </> (fixedString str)
+-- | Convenience operator for combining a matcher after a fixed string
+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 :: ((String, a) -> Maybe (String, View)) -- ^ matcher
+      -> a                                     -- ^ view-like function
+      -> [View -> View]                        -- ^ optional view decorators (processors)
+      -> View
+route matcher f decs =
+    \req -> let match = matcher (pathInfo req, f)
+            in case match of
+                 Nothing -> return Nothing
+                 Just (remainder, view) -> if null remainder
+                                           then (apply decs view) req
+                                           else return Nothing
+-- | Alias for 'route'
+(//->) = route

src/Ella/GenUtils.hs

+-- | General utility functions that do not depend on other functions
+-- in Web modules
+module Ella.GenUtils
+
+where
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.UTF8 as UTF8
+
+import GHC.Exts( IsString(..) )
+instance IsString ByteString where
+    fromString = UTF8.fromString
+
+utf8 = UTF8.fromString
+
+-- | Apply a list of transformation functions to an object
+apply :: [a -> a] -- ^ List of functions
+      -> a        -- ^ Initial value
+      -> a
+apply fs init = foldl (flip ($)) init fs
+
+-- | Same as apply with arguments flipped
+with = flip apply

src/Ella/Processors/General.hs

+module Ella.Processors.General
+    ( addSlashRedirectView
+    )
+
+where
+
+import Data.List (isSuffixOf)
+import Ella.Request
+import Ella.Response
+
+-- ** View processors
+
+--  These take a view function and return a view function.
+--  Alternatively, take a view function and a request and return an IO
+--  (Maybe Response).  This allows them to do both request
+--  pre-processing and response post-processing.  They will be usually
+--  be used as \'decorators\' when defining routes.
+
+-- ** View functions
+
+--  These are straightforward view functions which happen to work as a
+--  kind of pre-handler.  They are installed using routes, usually
+--  before all the others.  These usually do redirects, for example
+--  addSlashRedirectView
+
+-- ** Response processors
+
+--  These take a response and the original request object, and return
+--  a possibly modified response.  This can be useful for
+--  post-processing, or adding headers etc.
+
+
+-- | Returns a responseRedirect if the the request URI does not end
+-- with a slash.  Should be installed before all other routes.
+
+-- TODO
+-- need to include query string, and think about how to handle
+-- POSTs etc
+addSlashRedirectView :: Request -> IO (Maybe Response)
+addSlashRedirectView req =
+    let uri = requestUriRaw req
+    in return $ case uri of
+                  Nothing ->  Nothing -- Can't do a redirect if we don't know original URI
+                  Just "" ->  Nothing -- Don't redirect if empty
+                  Just x | ("/" `isSuffixOf` x) -> Nothing -- slash is already there
+                  Just x  ->  Just $ redirectResponse (x ++ "/")

src/Ella/Request.hs

+module Ella.Request (
+                    -- * Encodings
+                    Encoding(..)
+                   , utf8Encoding
+                    -- * Requests
+                   , Request
+                   , RequestOptions(..)
+                    -- ** Components of Request
+                   , requestMethod
+                   , pathInfo
+                   , requestUriRaw
+                   , environment
+                    -- ** Constructors for Request
+                   , mkRequest, buildCGIRequest
+                   -- * Escaping
+                   , escapePath
+                   , escapePathWithEnc
+                   )
+
+where
+
+import qualified Data.Map as Map
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as BS
+import qualified Data.ByteString.Lazy.UTF8 as UTF8
+import Data.Maybe
+import Network.URI (escapeURIString, isUnescapedInURI)
+import System.Environment (getEnvironment)
+import System.IO (stdin)
+
+-- Encodings
+
+data Encoding = Encoding {
+      name :: String
+    -- ^ descriptive name of the encoding
+    , decoder :: ByteString -> String
+    -- ^ convert ByteString to unicode string
+    , encoder :: String -> ByteString
+    -- ^ convert unicode string to ByteString
+    }
+
+instance Eq Encoding where
+    x == y = name x == name y
+
+instance Show Encoding where
+    show x = "Encoding " ++ name x
+
+-- Defaults
+
+utf8Encoding = Encoding {
+                 name = "UTF8"
+               , decoder = UTF8.toString
+               , encoder = UTF8.fromString
+               }
+
+
+-- | Options that affect the way that HTTP requests are handled
+data RequestOptions = RequestOptions {
+      encoding :: Encoding -- ^ Handles request encoding translation
+    } deriving (Eq, Show)
+
+data Request = Request {
+      environment :: Map.Map String String
+    , requestBody :: ByteString
+    , requestEncoding :: Encoding
+    } deriving (Show, Eq)
+
+-- | Create a Request object
+mkRequest :: [(String, String)] -- ^ association list of environment variables
+          -> ByteString -- ^ lazy ByteString containing request body
+          -> Encoding -- ^ Encoding to use for request
+          -> Request
+mkRequest env body enc
+    = let envMap = Map.fromList env
+      in Request {
+               environment = envMap
+             , requestBody = body
+             , requestEncoding = enc
+             }
+
+-- | Returns the request method (GET, POST etc) of the request
+requestMethod :: Request -> String
+requestMethod request = fromJust $ Map.lookup "REQUEST_METHOD" $ environment request
+
+-- | Returns the path info of the request, with any leading forward slash removed,
+-- and percent encoded chars interpreted according to the encoding.
+pathInfo request = let pi = Map.lookup "PATH_INFO" $ environment request
+                       -- Normalise to having no leading slash
+                       adjusted = case pi of
+                                    Nothing -> ""
+                                    Just ('/':rest) -> rest
+                                    Just path -> path
+                   in repack adjusted (requestEncoding request)
+
+-- | Repacks bytes in a string according to an encoding
+--
+-- PATH_INFO and other vars contains Haskell strings, but they
+-- contain uninterpreted byte sequences instead of Unicode chars.  We
+-- re-pack as bytes (BS.pack discards anything > \255), and then
+-- re-interpret.
+repack str encoding = let bytes = BS.pack str
+                      in (decoder encoding) bytes
+
+-- | Returns the URI requested by the client, with percent encoding intact
+requestUriRaw :: Request -> Maybe String
+requestUriRaw request = Map.lookup "REQUEST_URI" $ environment request
+
+
+-- | Creates a Request object according to the CGI protocol
+buildCGIRequest :: RequestOptions -- ^ options which determine how the HTTP request is interpreted
+                -> IO Request
+buildCGIRequest opts = do
+  env <- getEnvironment
+  body <- BS.hGetContents stdin
+  return $ mkRequest env body (encoding opts)
+
+
+-- | Escapes a string of bytes with percent encoding
+escapePath :: ByteString -> String
+-- Borrowed from Network.URI
+escapePath bs = escapeURIString isUnescapedInURIPath $ BS.unpack bs
+  where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#"
+
+-- | Escapes a unicode string with percent encoding, using the supplied
+-- bytestring/string Encoder
+escapePathWithEnc :: String -> Encoding -> String
+escapePathWithEnc s enc = escapePath (encoder enc $ s)
+

src/Ella/Response.hs

+module Ella.Response ( Response
+                    , content
+                    , headers
+                    , addContent
+                    , textResponse
+                    , utf8TextResponse
+                    , htmlResponse
+                    , utf8HtmlResponse
+                    , emptyResponse
+                    , redirectResponse
+                    , formatResponse
+                    , setStatus
+                    , setHeader
+                    , buildResponse
+                    , HeaderName(HeaderName)
+                    ) where
+
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as BS
+import Data.List (intersperse)
+import Network.CGI.Protocol (Headers, HeaderName(HeaderName))
+import Network.CGI (ContentType(ContentType), showContentType)
+import Ella.GenUtils (apply)
+
+data Response = Response {
+      content :: ByteString
+    , headers :: Headers
+    , status :: Int
+    } deriving (Show, Eq)
+
+--
+-- * Creating responses
+--
+
+emptyResponse = Response { content = BS.empty
+                         , headers = []
+                         , status = 200
+                         }
+
+addContent :: ByteString -> Response -> Response
+addContent c resp = resp { content =  BS.append (content resp) c }
+
+setStatus :: Int -> Response -> Response
+setStatus s resp = resp { status = s }
+
+setHeader :: String -> String -> Response -> Response
+setHeader h val resp = let headername = HeaderName h
+                           removed = filter ((/= headername) . fst) (headers resp)
+                           updated = removed ++ [(headername, val)]
+                       in resp { headers = updated }
+
+---
+--- * Shortcuts for common defaults
+---
+
+{-
+TODO
+ - add utility functions for writing HTML
+ - add encoding/charset to response, so that it can automatically
+   convert HTML to the correct encoding.
+-}
+
+contentTypeName = HeaderName "Content-type"
+textContent charset = "text/plain; charset=" ++ charset
+htmlContent charset = "text/html; charset=" ++ charset
+
+textResponse charset = emptyResponse {
+                         headers = [(contentTypeName, textContent charset)]
+                       }
+
+htmlResponse charset = emptyResponse {
+                         headers = [(contentTypeName, htmlContent charset)]
+                       }
+
+utf8TextResponse = textResponse "UTF-8"
+
+-- | Create an empty response for sending HTML, UTF-8 encoding
+utf8HtmlResponse = htmlResponse "UTF-8"
+
+-- | Build a Response from a list of Response transformation functions
+-- and an initial Response
+buildResponse :: [Response -> Response] -> Response -> Response
+buildResponse = apply
+
+allHeaders resp =
+    let statusHeader = (HeaderName "Status", show $ status resp)
+    in headers resp ++ [statusHeader]
+
+-- | Convert a Response into the format needed for HTTP
+-- Copied from Network.CGI.Protocol, thank you Bjorn Bringert :-)
+formatResponse :: Response -> ByteString
+formatResponse resp =
+    -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle
+    -- just LF if there are CRs in the content.
+    unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- allHeaders resp]
+                ++ [BS.empty, content resp])
+  where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n")
+
+
+-- | Create an HTTP 302 redirect
+redirectResponse location =
+    buildResponse [ setStatus 302
+                  , setHeader "Location" location
+                  ] emptyResponse

src/Ella/Utils.hs

+module Ella.Utils ( addHtml
+                 )
+
+where
+
+import Text.XHtml (renderHtml)
+import Ella.Response (addContent)
+import Ella.GenUtils (utf8)
+
+-- Utility functions
+addHtml html resp = addContent (utf8 $ renderHtml html) resp

src/Installdb.hs

-import Control.Exception
-import Control.Monad
-import Database.HDBC
-import qualified Blog.DB as DB
-
-main :: IO ()
-main = runSql >>= putStr
-
-runSql :: IO String
-runSql = catchDyn (do
-	             c <- DB.connect
-		     createTables c
-                     commit c
-                     return "OK\n"
-                  )
-                   (\e -> return $ show (e :: SqlError))
-
-createTables :: IConnection conn => conn -> IO ()
-createTables c = do
-  let commands =
-          ["\n\
-           \  CREATE TABLE metainfo (\n\
-           \    key TEXT,\n\
-           \    value TEXT\n\
-           \  );",
-           "\n\
-           \  CREATE TABLE formats (\n\
-           \    id INTEGER PRIMARY KEY,\n\
-           \    name TEXT,\n\
-           \    posts_enabled INTEGER,\n\
-           \    comments_enabled INTEGER\n\
-           \  );",
-           "\n\
-           \  CREATE TABLE posts (\n\
-           \    id INTEGER PRIMARY KEY AUTOINCREMENT,\n\
-           \    title TEXT,\n\
-           \    slug TEXT,\n\
-           \    post_raw TEXT,\n\
-           \    post_formatted TEXT,\n\
-           \    summary_raw TEXT,\n\
-           \    summary_formatted TEXT,\n\
-           \    format_id INTEGER REFERENCES formats(id),\n\
-           \    timestamp INTEGER,\n\
-           \    comments_open INTEGER\n\
-           \  );",
-           "\n\
-           \  CREATE TABLE categories (\n\
-           \    id INTEGER PRIMARY KEY AUTOINCREMENT,\n\
-           \    name TEXT,\n\
-           \    slug TEXT\n\
-           \  );",
-           "\n\
-           \  CREATE TABLE post_categories (\n\
-           \    post_id INTEGER REFERENCES posts(id),\n\
-           \    category_id INTEGER REFERENCES categories(id)\n\
-           \  );",
-           "\n\
-           \  CREATE TABLE comments (\n\
-           \    id INTEGER PRIMARY KEY AUTOINCREMENT,\n\
-           \    post_id INTEGER REFERENCES posts(id),\n\
-           \    timestamp INTEGER,\n\
-           \    name TEXT,\n\
-           \    email TEXT,\n\
-           \    text_raw TEXT,\n\
-           \    text_formatted TEXT,\n\
-           \    format_id INTEGER REFERENCES format(id)\n\
-           \  ); \n\
-           \ "]
-  sequence_ $ map (\cmd -> run c cmd []) commands

src/Migrate.hs

-import Blog.Utils (regexReplace, split)
-import Data.Maybe (fromJust)
-import Data.Ord (comparing)
-import Database.HDBC
-import List (sortBy, intersperse)
-import Monad (liftM)
-import Text.Template (readTemplate, renderToFile)
-import qualified Blog.Category as C
-import qualified Blog.DB as DB
-import qualified Blog.Formats as Formats
-import qualified Blog.Post as P
-import qualified Blog.Links as Links
-import qualified Blog.Settings as Settings
-import qualified Data.ByteString.Char8 as B
-import qualified Data.ByteString.Lazy.UTF8 as UTF8
-import qualified Data.Map as Map
--- Migration script for the old data
-
--- Read a table of newline/tab delimited data,
--- padding columns to specified amount
-readTable :: FilePath -> IO [[String]]
-readTable filename = do f <- readFile filename
-                        let lines = filter (/= "") $ splitRows f
-                            arr = map (padCols . splitCols) lines
-                        return arr
-    where
-      splitRows s = split s '\n'
-      splitCols s = split s '\t'
-      padCols = (++ (repeat ""))
-
-makeItems :: String          -- Filename to parse
-          -> ([String] -> a) -- function that takes a list of data and creates an item
-          -> IO [a]
-makeItems filename constructor = do
-  rows <- readTable (Settings.old_data_path ++ filename)
-  return $ map constructor rows
-
-readCategories = makeItems "categories.txt" mkCat
-    where mkCat row = C.Category { C.uid = read (row !! 0),
-                                   C.name = row !! 1,
-                                   C.slug = ""}
-
-readPosts = makeItems "posts.txt" mkPost
-            >>= mapM addFullText
-            >>= return . sortBy (comparing P.timestamp)
-    where mkPost row = P.Post { P.uid = read (row !! 0),
-                                P.title = row !! 1,
-                                P.slug = "",
-                                P.post_raw = "",
-                                P.post_formatted = "",
-                                P.summary_raw = row !! 4,
-                                P.summary_formatted = row !! 4,
-                                P.format_id = Formats.rawhtml,
-                                P.timestamp = read (row !! 2),
-                                P.comments_open = True
-                              }
-          addFullText p = do let dataFile = Settings.old_data_path ++ "posts/" ++ (show $ P.uid p)
-                             f <- readFile dataFile
-                             let fixed = fixCodes f
-                             return p { P.post_raw = fixed,
-                                        P.post_formatted = fixed }
-          fixCodes txt = B.unpack $ regexReplace (B.pack "&#10;") (B.pack "\n") (B.pack txt)
-
-readPostCategories = makeItems "postcategories.txt" mkPostCategory
-    where mkPostCategory row = (read (row !! 0),
-                                read (row !! 1)) :: (Int, Int)
-
-writeItems cn writer items = mapM (writer cn) items
-
-utf8 = UTF8.fromString
-
-makePHPMap amap = "array(" ++
-                  (concat $ intersperse ",\n" $ map arrayPair $ Map.toList amap)
-                  ++ ")"
-    where arrayPair (a,b) = (show a) ++ " => " ++ (show b) -- doesn't handle
-                                                           -- funny chars, but
-                                                           -- it works for now
-
-createRedirectFile postUrlMap categoryUrlMap = do
-    tpl <- readTemplate Settings.redirect_file_template
-    let ctx = Map.fromList ([(utf8 "postIdsToUrls",
-                              utf8 $ makePHPMap postUrlMap),
-                             (utf8 "categoryIdsToUrls",
-                              utf8 $ makePHPMap categoryUrlMap)])
-    renderToFile Settings.redirect_file_output tpl ctx
-
-main = handleSqlError $ do
-  cn <- DB.connect
-  origCats <- readCategories
-  newCats <- writeItems cn C.addCategory origCats
-  origPosts <- readPosts
-  newPosts <- writeItems cn P.addPost origPosts
-  -- we need the new/old IDs of posts/categories to rewrite comments tables
-  -- and the post/categories m2m
-  let post_id_map = Map.fromList $ zip (map P.uid origPosts) (map P.uid newPosts)
-  let cat_id_map = Map.fromList $ zip (map C.uid origCats) (map C.uid newCats)
-  postCategories' <- readPostCategories
-  let postCategories = correctIds postCategories' post_id_map cat_id_map
-  writeItems cn P.addPostCategory postCategories
-
-  let postUrlMap = Map.fromList $ zip (map (show . P.uid) origPosts)
-                                      (map Links.postLink newPosts)
-  let categoryUrlMap = Map.fromList $ zip (map (show . C.uid) origCats)
-                                          (map Links.categoryLink newCats)
-  createRedirectFile postUrlMap categoryUrlMap
-  commit cn
-  return ()
-
-    where correctIds pcs p_id_map c_id_map =
-              map (\(p_id, c_id) -> (fromJust $ Map.lookup p_id p_id_map,
-                                     fromJust $ Map.lookup c_id c_id_map)) pcs

src/Web/Framework.hs

-{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
-module Web.Framework (
-                      -- * Dispatching
-                      dispatchCGI
-                     , dispatchRequest
-                     , DispatchOptions(..)
-                     , defaultDispatchOptions
-                     , default404
-                     , View
-                     -- * Routing mechanism
-                     -- $routing
-                     , route
-                     , (//->)
-                     -- * Matchers
-                     , fixedString
-                     , intParam
-                     , stringParam
-                     , anyPath
-                     , empty
-                     , (</>)
-                     , (</+>)
-                     , (<+/>)
-                     )
-
-where
-
-import Control.Monad ((>=>))
-import Data.List (isPrefixOf)
-import Web.GenUtils (apply)
-import Web.Response
-import Web.Request
-import System.IO (stdout, hClose)
-import qualified Data.ByteString.Lazy.Char8 as BS
-
--- * Dispatching
-
-data DispatchOptions = DispatchOptions {
-      notFoundHandler :: Request -> IO Response
-    -- ^ function that will return a 404 page in the case of no view functions matching
-    , requestOptions :: RequestOptions
-    -- ^ options passed to buildCGIRequest
-}
-
-type View = Request -> IO (Maybe Response)
-
--- * Defaults
-
-default404 = buildResponse [
-              setStatus 404,
-              addContent "<h1>404 Not Found</h1>\n<p>Sorry, the page you requested could not be found.</p>"
-             ] utf8HtmlResponse
-
-defaultRequestOptions = RequestOptions {
-                          encoding = utf8Encoding
-                        }
-
-defaultDispatchOptions = DispatchOptions {
-                           notFoundHandler = const $ return $ default404
-                         , requestOptions = defaultRequestOptions
-                         }
-
--- Dispatching
-
--- | 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
-
--- | 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)
-  resp' <- dispatchRequest views req
-  resp <- case resp' of
-            Nothing -> notFoundHandler opts $ req
-            Just x -> return x
-  BS.hPut stdout (formatResponse resp)
-  hClose stdout
-
--- 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          $ []
--- >          , intParam </> stringParam               //-> 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]
---
--- The right hand argument of //-> is a 'view like' function, of type
--- View OR a -> View OR a -> b -> View etc,
--- where View = Request -> IO (Maybe Response)
-
--- 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 passed 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 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 -- just define your own matchers.
---
--- 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.
-
--- | Match a string at the beginning of the path
-fixedString :: String -> (String, a) -> Maybe (String, a)
-fixedString s (path, f) = if s `isPrefixOf` path
-                          then Just (drop (length s) path, f)
-                          else Nothing
-
--- | Convenience no-op matcher, useful for when you only want to match
--- a fixed string, or to match an empty string.
-empty :: (String, a) -> Maybe (String, a)
-empty = Just
-
-
--- | matcher that matches any remaining path
-anyPath (path, f) = Just ("", f)
-
-nextChunk path = let (start, end) = break (== '/') path
-                 in case end of
-                      [] -> Nothing
-                      x:rest -> Just (start, rest)
-
--- | Matcher that captures a string component followed by a forward slash
-stringParam :: (String, String -> a) -> Maybe (String, a)
-stringParam (path, f) = do
-  (chunk, rest) <- nextChunk path
-  Just (rest, f chunk)
-
--- | Matcher that captures an integer component followed by a forward slash
-intParam :: (String, Int -> a) -> Maybe (String, a)
-intParam (path, f) = do
-  (chunk, rest) <- nextChunk path
-  let parses = reads chunk :: [(Int, String)]
-  case parses of
-    [(val, "")] -> Just (rest, f val)
-    otherwise -> Nothing
-
--- | Combine two matchers
-(</>) :: ((String, a) -> Maybe (String, b)) -- ^ LH matcher
-      -> ((String, b) -> Maybe (String, c)) -- ^ RH matcher
-      -> ((String, a) -> Maybe (String, c))
-(</>) = (>=>) -- It turns out that this does the job!
-
--- | Convenience operator for combining a fixed string after a matcher
-matcher </+> str = matcher </> (fixedString str)
--- | Convenience operator for combining a matcher after a fixed string
-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 :: ((String, a) -> Maybe (String, View)) -- ^ matcher
-      -> a                                     -- ^ view-like function
-      -> [View -> View]                        -- ^ optional view decorators (processors)
-      -> View
-route matcher f decs =
-    \req -> let match = matcher (pathInfo req, f)
-            in case match of
-                 Nothing -> return Nothing
-                 Just (remainder, view) -> if null remainder
-                                           then (apply decs view) req
-                                           else return Nothing
--- | Alias for 'route'
-(//->) = route

src/Web/GenUtils.hs

--- | General utility functions that do not depend on other functions
--- in Web modules
-module Web.GenUtils
-
-where
-
-import Data.ByteString.Lazy.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.UTF8 as UTF8
-
-import GHC.Exts( IsString(..) )
-instance IsString ByteString where
-    fromString = UTF8.fromString
-
-utf8 = UTF8.fromString
-
--- | Apply a list of transformation functions to an object
-apply :: [a -> a] -- ^ List of functions
-      -> a        -- ^ Initial value
-      -> a
-apply fs init = foldl (flip ($)) init fs
-
--- | Same as apply with arguments flipped
-with = flip apply

src/Web/Processors/General.hs

-module Web.Processors.General
-    ( addSlashRedirectView
-    )
-
-where
-
-import Data.List (isSuffixOf)
-import Web.Request
-import Web.Response
-
--- ** View processors
-
---  These take a view function and return a view function.
---  Alternatively, take a view function and a request and return an IO
---  (Maybe Response).  This allows them to do both request
---  pre-processing and response post-processing.  They will be usually
---  be used as \'decorators\' when defining routes.
-
--- ** View functions
-
---  These are straightforward view functions which happen to work as a
---  kind of pre-handler.  They are installed using routes, usually
---  before all the others.  These usually do redirects, for example
---  addSlashRedirectView
-
--- ** Response processors
-
---  These take a response and the original request object, and return
---  a possibly modified response.  This can be useful for
---  post-processing, or adding headers etc.
-
-
--- | Returns a responseRedirect if the the request URI does not end
--- with a slash.  Should be installed before all other routes.
-
--- TODO
--- need to include query string, and think about how to handle
--- POSTs etc
-addSlashRedirectView :: Request -> IO (Maybe Response)
-addSlashRedirectView req =
-    let uri = requestUriRaw req
-    in return $ case uri of
-                  Nothing ->  Nothing -- Can't do a redirect if we don't know original URI
-                  Just "" ->  Nothing -- Don't redirect if empty
-                  Just x | ("/" `isSuffixOf` x) -> Nothing -- slash is already there
-                  Just x  ->  Just $ redirectResponse (x ++ "/")

src/Web/Request.hs

-module Web.Request (
-                    -- * Encodings
-                    Encoding(..)
-                   , utf8Encoding
-                    -- * Requests
-                   , Request
-                   , RequestOptions(..)
-                    -- ** Components of Request
-                   , requestMethod
-                   , pathInfo
-                   , requestUriRaw
-                   , environment
-                    -- ** Constructors for Request
-                   , mkRequest, buildCGIRequest
-                   -- * Escaping
-                   , escapePath
-                   , escapePathWithEnc
-                   )
-
-where
-
-import qualified Data.Map as Map
-import Data.ByteString.Lazy.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as BS
-import qualified Data.ByteString.Lazy.UTF8 as UTF8
-import Data.Maybe
-import Network.URI (escapeURIString, isUnescapedInURI)
-import System.Environment (getEnvironment)
-import System.IO (stdin)
-
--- Encodings
-
-data Encoding = Encoding {
-      name :: String
-    -- ^ descriptive name of the encoding
-    , decoder :: ByteString -> String
-    -- ^ convert ByteString to unicode string
-    , encoder :: String -> ByteString
-    -- ^ convert unicode string to ByteString
-    }
-
-instance Eq Encoding where
-    x == y = name x == name y
-
-instance Show Encoding where
-    show x = "Encoding " ++ name x
-
--- Defaults
-
-utf8Encoding = Encoding {
-                 name = "UTF8"
-               , decoder = UTF8.toString
-               , encoder = UTF8.fromString
-               }
-
-
--- | Options that affect the way that HTTP requests are handled
-data RequestOptions = RequestOptions {
-      encoding :: Encoding -- ^ Handles request encoding translation
-    } deriving (Eq, Show)
-
-data Request = Request {
-      environment :: Map.Map String String
-    , requestBody :: ByteString
-    , requestEncoding :: Encoding
-    } deriving (Show, Eq)
-
--- | Create a Request object
-mkRequest :: [(String, String)] -- ^ association list of environment variables
-          -> ByteString -- ^ lazy ByteString containing request body
-          -> Encoding -- ^ Encoding to use for request
-          -> Request
-mkRequest env body enc
-    = let envMap = Map.fromList env
-      in Request {
-               environment = envMap
-             , requestBody = body
-             , requestEncoding = enc
-             }
-
--- | Returns the request method (GET, POST etc) of the request
-requestMethod :: Request -> String
-requestMethod request = fromJust $ Map.lookup "REQUEST_METHOD" $ environment request
-
--- | Returns the path info of the request, with any leading forward slash removed,
--- and percent encoded chars interpreted according to the encoding.
-pathInfo request = let pi = Map.lookup "PATH_INFO" $ environment request
-                       -- Normalise to having no leading slash
-                       adjusted = case pi of
-                                    Nothing -> ""
-                                    Just ('/':rest) -> rest
-                                    Just path -> path
-                   in repack adjusted (requestEncoding request)
-
--- | Repacks bytes in a string according to an encoding
---
--- PATH_INFO and other vars contains Haskell strings, but they
--- contain uninterpreted byte sequences instead of Unicode chars.  We
--- re-pack as bytes (BS.pack discards anything > \255), and then
--- re-interpret.
-repack str encoding = let bytes = BS.pack str
-                      in (decoder encoding) bytes
-
--- | Returns the URI requested by the client, with percent encoding intact
-requestUriRaw :: Request -> Maybe String
-requestUriRaw request = Map.lookup "REQUEST_URI" $ environment request
-
-
--- | Creates a Request object according to the CGI protocol
-buildCGIRequest :: RequestOptions -- ^ options which determine how the HTTP request is interpreted
-                -> IO Request
-buildCGIRequest opts = do
-  env <- getEnvironment
-  body <- BS.hGetContents stdin
-  return $ mkRequest env body (encoding opts)
-
-
--- | Escapes a string of bytes with percent encoding
-escapePath :: ByteString -> String
--- Borrowed from Network.URI
-escapePath bs = escapeURIString isUnescapedInURIPath $ BS.unpack bs
-  where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#"
-
--- | Escapes a unicode string with percent encoding, using the supplied
--- bytestring/string Encoder
-escapePathWithEnc :: String -> Encoding -> String
-escapePathWithEnc s enc = escapePath (encoder enc $ s)
-

src/Web/Response.hs

-module Web.Response ( Response
-                    , content
-                    , headers
-                    , addContent
-                    , textResponse
-                    , utf8TextResponse
-                    , htmlResponse
-                    , utf8HtmlResponse
-                    , emptyResponse
-                    , redirectResponse
-                    , formatResponse
-                    , setStatus
-                    , setHeader
-                    , buildResponse
-                    , HeaderName(HeaderName)
-                    ) where
-
-import Data.ByteString.Lazy.Char8 (ByteString)
-import qualified Data.ByteString.Lazy.Char8 as BS
-import Data.List (intersperse)
-import Network.CGI.Protocol (Headers, HeaderName(HeaderName))
-import Network.CGI (ContentType(ContentType), showContentType)
-import Web.GenUtils (apply)
-
-data Response = Response {
-      content :: ByteString
-    , headers :: Headers
-    , status :: Int
-    } deriving (Show, Eq)
-
---
--- * Creating responses
---
-
-emptyResponse = Response { content = BS.empty
-                         , headers = []
-                         , status = 200
-                         }
-
-addContent :: ByteString -> Response -> Response
-addContent c resp = resp { content =  BS.append (content resp) c }
-
-setStatus :: Int -> Response -> Response
-setStatus s resp = resp { status = s }
-
-setHeader :: String -> String -> Response -> Response
-setHeader h val resp = let headername = HeaderName h
-                           removed = filter ((/= headername) . fst) (headers resp)
-                           updated = removed ++ [(headername, val)]
-                       in resp { headers = updated }
-
----
---- * Shortcuts for common defaults
----
-
-{-
-TODO
- - add utility functions for writing HTML
- - add encoding/charset to response, so that it can automatically
-   convert HTML to the correct encoding.
--}
-
-contentTypeName = HeaderName "Content-type"
-textContent charset = "text/plain; charset=" ++ charset
-htmlContent charset = "text/html; charset=" ++ charset
-
-textResponse charset = emptyResponse {
-                         headers = [(contentTypeName, textContent charset)]
-                       }
-
-htmlResponse charset = emptyResponse {
-                         headers = [(contentTypeName, htmlContent charset)]
-                       }
-
-utf8TextResponse = textResponse "UTF-8"
-
--- | Create an empty response for sending HTML, UTF-8 encoding
-utf8HtmlResponse = htmlResponse "UTF-8"
-
--- | Build a Response from a list of Response transformation functions
--- and an initial Response
-buildResponse :: [Response -> Response] -> Response -> Response
-buildResponse = apply
-
-allHeaders resp =
-    let statusHeader = (HeaderName "Status", show $ status resp)
-    in headers resp ++ [statusHeader]
-
--- | Convert a Response into the format needed for HTTP
--- Copied from Network.CGI.Protocol, thank you Bjorn Bringert :-)
-formatResponse :: Response -> ByteString
-formatResponse resp =
-    -- NOTE: we use CRLF since lighttpd mod_fastcgi can't handle
-    -- just LF if there are CRs in the content.
-    unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- allHeaders resp]
-                ++ [BS.empty, content resp])
-  where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n")
-
-
--- | Create an HTTP 302 redirect
-redirectResponse location =
-    buildResponse [ setStatus 302
-                  , setHeader "Location" location
-                  ] emptyResponse

src/Web/Utils.hs

-module Web.Utils ( addHtml
-                 )
-
-where
-
-import Text.XHtml (renderHtml)
-import Web.Response (addContent)
-import Web.GenUtils (utf8)
-
--- Utility functions
-addHtml html resp = addContent (utf8 $ renderHtml html) resp

src/blog.php.tpl

-<?php
-  // DO NOT EDIT THE FILE blog.php DIRECTLY!
-
-  // PHP file that does redirects to the new URLs.  This could be
-  // implemented using a .htaccess redirect rule and a Haskell CGI
-  // script that parsed and rewrote the URLs.  However, that script
-  // would still need access to the mapping between old ids (not
-  // stored in the new database) and the new URLs/ids.  So it is
-  // simpler to do it in a single PHP file.
-
-  // The file blog.php is produced from the blog.php.tpl file.  The
-  // template language uses dollar substitutions, and dollar signs
-  // must be escaped by doubling.
-
-$$postMap = ${postIdsToUrls};
-
-$$catMap = ${categoryIdsToUrls};
-
-
-?>

testsuite/tests/Main.hs

-import qualified Tests.Blog.DBUtils as DBUtils
-import qualified Tests.Web.Request as Request
-import qualified Tests.Web.Response as Response
-import qualified Tests.Web.Framework as Framework
-import qualified Tests.Web.Processors.General as GeneralProcessors
+import qualified Tests.Ella.Request as Request
+import qualified Tests.Ella.Response as Response
+import qualified Tests.Ella.Framework as Framework
+import qualified Tests.Ella.Processors.General as GeneralProcessors
 import Test.HUnit
 
 main = runTestTT (test [
-                    DBUtils.tests
                   , Request.tests
                   , Response.tests
                   , Framework.tests

testsuite/tests/Tests/Blog/DBUtils.hs

-module Tests.Blog.DBUtils
-
-where
-
-import Blog.DBUtils
-import Database.HDBC
-import Test.HUnit
-import qualified Tests.Blog.TestDB as TestDB
-
-makeTestSlugTable cn = do
-  quickQuery cn "CREATE TABLE slugs (id INTEGER PRIMARY KEY AUTOINCREMENT, title TEXT, slug TEXT);" []
-
-insertSlug cn title slug = do
-  quickQuery cn "INSERT INTO slugs (title, slug) VALUES (?, ?);" [toSql title, toSql slug]
-
-slugFromTitle1 =  "this-is-a-title" ~=? (slugFromTitle "This is a % $ /title ^£$")
-makeSlugGeneric1 = do
-  cn <- TestDB.connect;
-  makeTestSlugTable cn
-  slug1 <- makeSlugGeneric cn "This is a title" "slugs"
-  assertEqual "" "this-is-a-title" slug1
-  insertSlug cn "This is a title" slug1
-  slug2 <- makeSlugGeneric cn "This is a title" "slugs"
-  insertSlug cn "This is a title" slug2
-  assertEqual "" "this-is-a-title2" slug2
-
-tests = test [
-         slugFromTitle1,
-         TestCase makeSlugGeneric1
-        ]

testsuite/tests/Tests/Blog/TestDB.hs

-module Tests.Blog.TestDB where
-
-import Database.HDBC.Sqlite3 (connectSqlite3)
-import qualified Blog.Settings as Settings
-
-connect = connectSqlite3 Settings.testdb_sqlite_path

testsuite/tests/Tests/Ella/Framework.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
+module Tests.Ella.Framework
+
+where
+
+import qualified Data.ByteString.Lazy.Char8 as BS
+import Test.HUnit
+import Ella.Framework
+import Ella.Request
+import Ella.Response
+import Data.Maybe (isNothing, isJust)
+import Control.Monad (liftM, (>=>))
+import Ella.GenUtils (utf8)
+
+req1 = mkGetReq "/posts/"
+resp1 = buildResponse [ addContent "resp1" ] utf8HtmlResponse
+resp2 = buildResponse [ addContent "resp2" ] utf8HtmlResponse
+
+mkGetReq path = mkRequest [("REQUEST_METHOD","GET")
+                          ,("PATH_INFO", path)
+                          ,("REQUEST_URI", escapePathWithEnc path utf8Encoding)
+                          ] "" utf8Encoding
+
+alwaysFailView = const (return Nothing)
+alwaysSucceedView1 = const (return $ Just resp1)
+alwaysSucceedView2 = const (return $ Just resp2)
+
+viewWithStringParam1 :: String -> Request -> IO (Maybe Response)
+viewWithStringParam1 p req = return $ Just $ viewWithStringParam1' p
+viewWithStringParam1' p = buildResponse [
+                           addContent $ utf8 ("Got: " ++ p)
+                          ] utf8HtmlResponse
+
+viewWithIntParam1 :: Int -> Request -> IO (Maybe Response)
+viewWithIntParam1 p req = return $ Just $ viewWithIntParam1' p
+viewWithIntParam1' p = buildResponse [
+                        addContent $ utf8 ("Got integer: " ++ show p)
+                       ] utf8HtmlResponse
+
+viewWithIntParam2 :: Int -> Request -> IO (Maybe Response)
+viewWithIntParam2 p req = return $ Just $ viewWithIntParam2' p
+viewWithIntParam2' p = buildResponse [
+                        addContent $ utf8 ("2: Got integer: " ++ show p)
+                       ] utf8HtmlResponse
+
+viewWithIntAndStringParam1 :: Int -> String -> Request -> IO (Maybe Response)
+viewWithIntAndStringParam1 i s req = return $ Just $ viewWithIntAndStringParam1' i s
+viewWithIntAndStringParam1' i s = buildResponse [
+                                   addContent $ utf8 ("Got integer: " ++ show i ++
+                                                      " and string: " ++ s)
+                                  ] utf8HtmlResponse
+
+viewWithIntStringInt1 :: Int -> String -> Int -> Request -> IO (Maybe Response)
+viewWithIntStringInt1 i s i2 req = return $ Just $ viewWithIntStringInt1' i s i2
+viewWithIntStringInt1' i s i2 = buildResponse [
+                                 addContent $ utf8 ("Got integer 1: " ++ show i ++
+                                                    " and string: " ++ s ++
+                                                    " and integer 2: "++ show i2)
+                                ] utf8HtmlResponse
+
+-- Some of the syntax below is complicated by the fact that the
+-- functions being tested all use the IO monad in their type
+-- signatures (tho' in these tests they don't actually need any IO),
+-- and you cannot pattern match against IO actions.
+
+testDispatchRequest1 = (dispatchRequest [] req1
+                        >>= return . isNothing)
+                       ~? "With no views, nothing is dispatched"
+
+testDispatchRequest2 = (dispatchRequest  [alwaysFailView] req1
+                        >>= return . isNothing)
+                       ~? "Should get Nothing if all view return Nothing"
+
+testDispatchRequest3 = (do
+                         resp <- dispatchRequest [alwaysFailView,
+                                                  alwaysSucceedView1,
+                                                  alwaysSucceedView2] req1
+                         return $ (resp == (Just resp1) && resp /= (Just resp2)))
+                       ~? "Dispatch should return first that succeeds"
+
+testFixedStringSucceed = ((route (fixedString "posts/") alwaysSucceedView1 [] $ req1)
+                          >>= return . (== (Just resp1)))
+                         ~? "fixedString should leave view as is if the path matches completely"
+
+testFixedStringFail = ((route (fixedString "bar/") alwaysSucceedView1 [] $ req1)
+                          >>= return . isNothing)
+                         ~? "fixedString should return Nothing if the path does not match"
+
+testRouteToAnyPath = ((route anyPath alwaysSucceedView1 [] $ req1)
+                      >>= return . (== Just resp1))
+                     ~? "routeTo leaves a view alone if matcher always succeeds"
+
+testRouteToNotAllMatched = ((route (fixedString "po") alwaysSucceedView1 [] $ req1)
+                            >>= return . isNothing)
+                           ~? "routeTo does not route to a view if the match does not exhaust the path"
+
+routes = [
+           empty                                  //-> alwaysSucceedView1         $ []
+         , "posts/" <+/> empty                    //-> alwaysSucceedView2         $ []
+         , intParam                               //-> viewWithIntParam1          $ []
+         , stringParam                            //-> viewWithStringParam1       $ []
+         , intParam </+> "test/"                  //-> viewWithIntParam2          $ []
+         , "test/" <+/> intParam                  //-> viewWithIntParam2          $ []
+         -- NB line below has to come after 'intParam </+> "test/"' line
+         , intParam </> stringParam               //-> viewWithIntAndStringParam1 $ []
+         , intParam </> stringParam </> intParam  //-> viewWithIntStringInt1      $ []
+         ]
+
+testRoutes1 = (do
+                Just resp <- dispatchRequest routes (mkGetReq "1/")
+                return $ content resp == "Got integer: 1")
+               ~? "Testing int parameter dispatch"
+
+testRoutes2 = (do
+                Just resp <- dispatchRequest routes (mkGetReq "1/test/")
+                return $ content resp == "2: Got integer: 1")
+               ~? "Testing int parameter dispatch with fixed string"
+
+testRoutes3 = (do
+                Just resp <- dispatchRequest routes (mkGetReq "1/Joe/3/")
+                return $ content resp == "Got integer 1: 1 and string: Joe and integer 2: 3")
+               ~? "Testing multiparameter dispatch"
+
+testRoutes4 = (do
+                Just resp <- dispatchRequest routes (mkGetReq "10/foo/")
+                return $ content resp == "Got integer: 10 and string: foo")
+               ~? "Testing stringParam dispatch"
+
+testRoutes5 = (do
+                Just resp <- dispatchRequest routes (mkGetReq "test/20/")
+                return $ content resp == "2: Got integer: 20")
+               ~? "Testing fixed string with integer"
+
+testRoutes6 = (do
+                Just resp <- dispatchRequest routes (mkGetReq "posts/")
+                return $ resp == resp2)
+               ~? "Testing fixed string with empty"
+
+testRoutes7 = (do
+                Just resp <- dispatchRequest routes (mkGetReq "")
+                return $ resp == resp1)
+               ~? "Testing empty matcher"
+
+tests = test [
+         testDispatchRequest1
+        , testDispatchRequest2
+        , testDispatchRequest3
+        , testFixedStringSucceed
+        , testFixedStringFail
+        , testRouteToAnyPath
+        , testRouteToNotAllMatched
+        , testRoutes1
+        , testRoutes2
+        , testRoutes3
+        , testRoutes4
+        , testRoutes5
+        , testRoutes6
+        , testRoutes7
+        ]

testsuite/tests/Tests/Ella/Processors/General.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
+module Tests.Ella.Processors.General
+
+where
+
+import Data.Maybe (fromJust)
+import Ella.Processors.General
+import Ella.GenUtils ()
+import Ella.Response
+import Ella.Request
+import Test.HUnit
+import Tests.Ella.Framework (mkGetReq)
+
+testAddSlashRedirectView1 =
+    (do
+      resp <- addSlashRedirectView (mkGetReq "/posts")
+      return (resp == (Just $ redirectResponse "/posts/"))
+    ) ~? "addSlashRedirectView should add a slash if not present at end"
+
+
+testAddSlashRedirectView2 =
+    (do
+      resp <- addSlashRedirectView (mkGetReq "/posts/")
+      return (resp == Nothing)
+    ) ~? "addSlashRedirectView should not redirect if slash present at end"
+
+testAddSlashRedirectView3 =
+    (do
+      resp <- addSlashRedirectView (mkRequest
+                                    [("REQUEST_METHOD", "GET")
+                                    ,("PATH_INFO", "/posts")
+                                    ,("REQUEST_URI","/foo/posts")]
+                                    "" utf8Encoding)
+      return (resp == (Just $ redirectResponse "/foo/posts/"))
+    ) ~? "addSlashRedirectView should redirect based on request URI, not path info"
+
+
+
+tests = test [ testAddSlashRedirectView1
+             , testAddSlashRedirectView2
+             , testAddSlashRedirectView3
+             ]

testsuite/tests/Tests/Ella/Request.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
+module Tests.Ella.Request
+
+where
+
+import Ella.Request
+import Test.HUnit
+import Ella.GenUtils () -- for IsString instance
+
+testMethod = "GET" ~=? requestMethod (mkRequest [("REQUEST_METHOD","GET")] "" utf8Encoding)
+testPath = "foo/bar" ~=? pathInfo (mkRequest [("PATH_INFO", "/foo/bar")] "" utf8Encoding)
+testPathMissing = "" ~=? pathInfo (mkRequest [] "" utf8Encoding)
+testPathUtf8 = "\233" ~=? pathInfo (mkRequest [("PATH_INFO", "\195\169")] "" utf8Encoding)
+testRequestUriRaw = Just "/root/foo/%C3%A9/" ~=? requestUriRaw (mkRequest [("REQUEST_URI","/root/foo/%C3%A9/")
+                                                                          ,("PATH_INFO","/foo/\195\169/")] "" utf8Encoding)
+
+tests = test [
+          testMethod
+        , testPath
+        , testPathMissing
+        , testPathUtf8
+        , testRequestUriRaw
+        ]

testsuite/tests/Tests/Ella/Response.hs

+{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
+module Tests.Ella.Response
+
+where
+
+import Ella.Response
+import Test.HUnit
+import Data.ByteString.Lazy.Char8 (ByteString)
+import qualified Data.ByteString.Lazy.Char8 as BS
+import Data.List (sort)
+
+testAddContent1 = "“Hello”" ~=? (content $ addContent "“Hello”" $ emptyResponse)
+
+testAddContent2 = "Hello world" ~=? (content $ addContent " world" $ addContent "Hello" $ emptyResponse)
+
+testBuildResponse = "hello world" ~=? (content $
+                                       buildResponse [ addContent "hello"
+                                                     , addContent " world"
+                                                     ] utf8HtmlResponse)
+
+testFormatResponse = "Content-type: text/html; charset=UTF-8\r\n\
+                     \Status: 200\r\n\
+                     \\r\n\
+                     \<h1>Test</h1>" ~=?
+                     (formatResponse $ buildResponse [
+                                          addContent "<h1>Test</h1>"
+                                         ] utf8HtmlResponse)
+
+testFormatResponse2 = "Content-type: text/html; charset=UTF-8\r\n\
+                      \Status: 404\r\n\
+                      \\r\n\
+                      \<h1>404 Not Found</h1>" ~=?
+                      (formatResponse $ buildResponse [
+                                           addContent "<h1>404 Not Found</h1>"
+                                          , setStatus 404
+                                          ] utf8HtmlResponse)
+
+-- insert
+testSetHeader1 = [(HeaderName "Header1", "value 1")] ~=?
+                 (headers $ setHeader "Header1" "value 1" emptyResponse)
+
+-- update
+testSetHeader2 = [(HeaderName "Header1", "value 1.1"),
+                  (HeaderName "Header2", "value 2")] ~=?
+                 (sort $ headers $ buildResponse [ setHeader "Header1" "value 1"
+                                                 , setHeader "Header2" "value 2"
+                                                 , setHeader "Header1" "value 1.1"
+                                                 ] emptyResponse)
+
+-- Replacement should be case insensitive
+testSetHeader3 = [(HeaderName "Header1", "value 1.1")] ~=?
+                 (sort $ headers $ buildResponse [ setHeader "Header1" "value 1"
+                                                 , setHeader "header1" "value 1.1"
+                                                 ] emptyResponse)
+
+testRedirectResponse = "Location: /foo/bar/\r\n\
+                        \Status: 302\r\n\
+                        \\r\n" ~=?
+                        (formatResponse $ redirectResponse "/foo/bar/")
+
+tests = test [
+          testAddContent1
+        , testAddContent2
+        , testBuildResponse
+        , testFormatResponse
+        , testFormatResponse2
+        , testSetHeader1
+        , testSetHeader2
+        , testSetHeader3
+        , testRedirectResponse
+        ]

testsuite/tests/Tests/Web/Framework.hs

-{-# OPTIONS_GHC -fglasgow-exts -XOverloadedStrings #-}
-module Tests.Web.Framework
-
-where
-
-import qualified Data.ByteString.Lazy.Char8 as BS
-import Test.HUnit
-import Web.Framework
-import Web.Request
-import Web.Response
-import Data.Maybe (isNothing, isJust)
-import Control.Monad (liftM, (>=>))
-import Web.GenUtils (utf8)
-
-req1 = mkGetReq "/posts/"
-resp1 = buildResponse [ addContent "resp1" ] utf8HtmlResponse
-resp2 = buildResponse [ addContent "resp2" ] utf8HtmlResponse
-
-mkGetReq path = mkRequest [("REQUEST_METHOD","GET")
-                          ,("PATH_INFO", path)
-                          ,("REQUEST_URI", escapePathWithEnc path utf8Encoding)
-                          ] "" utf8Encoding
-
-alwaysFailView = const (return Nothing)
-alwaysSucceedView1 = const (return $ Just resp1)
-alwaysSucceedView2 = const (return $ Just resp2)
-
-viewWithStringParam1 :: String -> Request -> IO (Maybe Response)
-viewWithStringParam1 p req = return $ Just $ viewWithStringParam1' p
-viewWithStringParam1' p = buildResponse [
-                           addContent $ utf8 ("Got: " ++ p)
-                          ] utf8HtmlResponse
-
-viewWithIntParam1 :: Int -> Request -> IO (Maybe Response)
-viewWithIntParam1 p req = return $ Just $ viewWithIntParam1' p
-viewWithIntParam1' p = buildResponse [
-                        addContent $ utf8 ("Got integer: " ++ show p)
-                       ] utf8HtmlResponse
-
-viewWithIntParam2 :: Int -> Request -> IO (Maybe Response)
-viewWithIntParam2 p req = return $ Just $ viewWithIntParam2' p
-viewWithIntParam2' p = buildResponse [
-                        addContent $ utf8 ("2: Got integer: " ++ show p)
-                       ] utf8HtmlResponse
-
-viewWithIntAndStringParam1 :: Int -> String -> Request -> IO (Maybe Response)
-viewWithIntAndStringParam1 i s req = return $ Just $ viewWithIntAndStringParam1' i s
-viewWithIntAndStringParam1' i s = buildResponse [