-
-In this example, 'routeTop' matches if the 'Network.Wai.Request's
-'Network.Wai.pathInfo' is empty, which means the requested path is \"\/\" (as
-in this case), or the rest of the path has been consumed by previous 'Route's.
-'routeName' matches if the next component in the path (specifically the 'head'
-of 'Network.Wai.pathInfo') matches the argument (and if so, removes it). Check
-out "Web.Simple.Router" for more complete documentation of these and other
-'Route's.
-
-For many apps it will be convenient to use even higher level routing APIs. The
-modules "Web.Frank" and "Web.Sinatra" provide Sinatra-like and RESTful APIs,
-respectively. Both modules are implement purely in terms of 'Route's and you
-can easily implement your own patterns as well.
-
--}
-
diff --git a/Web/Simple/Auth.hs b/Web/Simple/Auth.hs
deleted file mode 100644
--- a/Web/Simple/Auth.hs
+++ /dev/null
@@ -1,70 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- | Provides HTTP Basic Authentication.
-module Web.Simple.Auth
- ( AuthRouter
- , basicAuthRoute, basicAuth, authRewriteReq
- ) where
-
-import Control.Monad
-import Data.ByteString.Base64
-import qualified Data.ByteString.Char8 as S8
-import Data.Maybe
-import Network.HTTP.Types
-import Network.Wai
-import Web.Simple.Responses
-import Web.Simple.Controller
-
--- | An 'AuthRouter' authenticates a 'Request' and, if successful, forwards the
--- 'Request' to the 'Routeable'.
-type AuthRouter r a = (Request -> S8.ByteString
- -> S8.ByteString
- -> Controller r (Maybe Request))
- -> Controller r a
- -> Controller r a
-
--- | An 'AuthRouter' that uses HTTP basic authentication to authenticate a request
--- in a particular realm.
-basicAuthRoute :: String -> AuthRouter r a
-basicAuthRoute realm testAuth next = do
- req <- request
- let authStr = fromMaybe "" $ lookup hAuthorization (requestHeaders req)
- when (S8.take 5 authStr /= "Basic") requireAuth
-
- case fmap (S8.split ':') $ decode $ S8.drop 6 authStr of
- Right (user:pwd:[]) -> do
- mfin <- testAuth req user pwd
- maybe requireAuth (\finReq -> localRequest (const finReq) next) mfin
- _ -> requireAuth
- where requireAuth = respond $ requireBasicAuth realm
-
--- | Wraps an 'AuthRouter' to take a simpler authentication function (that just
--- just takes a username and password, and returns 'True' or 'False'). It also
--- adds an \"X-User\" header to the 'Request' with the authenticated user\'s
--- name (the first argument to the authentication function).
-authRewriteReq :: AuthRouter r a
- -> (S8.ByteString -> S8.ByteString -> Controller r Bool)
- -> Controller r a
- -> Controller r a
-authRewriteReq authRouter testAuth rt =
- authRouter (\req user pwd -> do
- success <- testAuth user pwd
- if success then
- return $ Just $ transReq req user
- else return Nothing) rt
- where transReq req user = req
- { requestHeaders = ("X-User", user):(requestHeaders req)}
-
--- | A 'Route' that uses HTTP basic authentication to authenticate a request for a realm
--- with the given username ans password. The request is rewritten with an 'X-User' header
--- containing the authenticated username before being passed to the next 'Route'.
-basicAuth :: String
- -- ^ Realm
- -> S8.ByteString
- -- ^ Username
- -> S8.ByteString
- -- ^ Password
- -> Controller r a -> Controller r a
-basicAuth realm user pwd = authRewriteReq (basicAuthRoute realm)
- (\u p -> return $ u == user && p == pwd)
-
diff --git a/Web/Simple/Cache.hs b/Web/Simple/Cache.hs
deleted file mode 100644
--- a/Web/Simple/Cache.hs
+++ /dev/null
@@ -1,86 +0,0 @@
-{-# LANGUAGE TypeSynonymInstances, FlexibleInstances #-}
-
--- | Provides a general caching interface along with a simple in-memory
--- (process only) and file based cache implementations.
-module Web.Simple.Cache
- ( -- * Cache Interface
- Cache(..), fetchOr
- -- * Cache Implementations
- , FileSystemCache, newFileSystemCache
- , InMemCache, newInMemCache
- ) where
-
-import Control.Monad
-import Control.Monad.IO.Class
-import qualified Data.ByteString.Lazy.Char8 as L8
-import qualified Data.HashTable.IO as H
-import System.FilePath
-import System.Directory
-
--- | A class that captures a simple key-value caching interface. The keys are
--- simply 'String'\'s and values are simply 'ByteString'\'s.
-class Cache c where
- put :: MonadIO m => c -> String -> L8.ByteString -> m L8.ByteString
- -- ^ Store a value in the cache. The returned value should be the value that
- -- was just stored.
- fetch :: MonadIO m => c -> String -> m (Maybe L8.ByteString)
- -- ^ Retrieve a value from the cache.
- invalidate :: MonadIO m => c -> String -> m ()
- -- ^ Invalidate a potentially existing value in the cache. Depending on the
- -- implementation this may or may not free the space used by the key-value
- -- pair.
-
-fetchOr :: (Cache c, MonadIO m)
- => c
- -> String
- -> m L8.ByteString
- -> m L8.ByteString
-fetchOr c path act = do
- mcached <- fetch c path
- maybe (act >>= put c path) return mcached
-
--- | A file based cache implementation. Files are stored in subdirectories of
--- @fsCacheBase@.
-newtype FileSystemCache = FileSystemCache { fsCacheBase :: FilePath }
-
--- | Create a new @FileSystemCache@.
-newFileSystemCache :: FilePath -> FileSystemCache
-newFileSystemCache = FileSystemCache
-
-instance Cache FileSystemCache where
- put c path d = liftIO $ do
- let components = splitDirectories $ dropDrive path
- let fullPath = (fsCacheBase c):components
- createDirectoryIfMissing True $
- joinPath $ reverse $ tail $ reverse fullPath
- L8.writeFile (joinPath fullPath) d
- return d
-
- fetch c path = liftIO $ do
- let components = splitDirectories $ dropDrive path
- let fullPath = joinPath $ (fsCacheBase c):components
- exists <- doesFileExist fullPath
- if exists then
- fmap Just $ L8.readFile fullPath
- else return Nothing
-
- invalidate c path = liftIO $ do
- let components = splitDirectories $ dropDrive path
- let fullPath = joinPath $ (fsCacheBase c):components
- exists <- doesFileExist fullPath
- when exists $
- removeFile fullPath
-
--- | An in-memory cache implementation. The current processes heap space is
--- simply used as the cache.
-newtype InMemCache = InMemCache (H.BasicHashTable String L8.ByteString)
-
--- | Create a new @InMemCache@.
-newInMemCache :: MonadIO m => m InMemCache
-newInMemCache = liftIO $ fmap InMemCache H.new
-
-instance Cache InMemCache where
- put (InMemCache h) path d = liftIO $ H.insert h path d >> return d
- fetch (InMemCache h) = liftIO . (H.lookup h)
- invalidate (InMemCache h) = liftIO . (H.delete h)
-
diff --git a/Web/Simple/Controller.hs b/Web/Simple/Controller.hs
deleted file mode 100644
--- a/Web/Simple/Controller.hs
+++ /dev/null
@@ -1,428 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE DeriveDataTypeable #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-{- | 'Controller' provides a convenient syntax for writting 'Application'
- code as a Monadic action with access to an HTTP request as well as app
- specific data (e.g. a database connection pool, app configuration etc.)
- This module also defines some
- helper functions that leverage this feature. For example, 'redirectBack'
- reads the underlying request to extract the referer and returns a redirect
- response:
-
- @
- myController = do
- ...
- if badLogin then
- redirectBack
- else
- ...
- @
--}
-module Web.Simple.Controller
- (
- -- * Example
- -- $Example
- -- * Controller Monad
- Controller(..), runController, runControllerIO
- , controllerApp, controllerState, localState
- , request, localRequest, respond
- -- * Common Routes
- , routeHost, routeTop, routeMethod, routeAccept
- , routePattern, routeName, routeVar
- -- * Inspecting query
- , Parseable
- , queryParam, queryParam', queryParams
- , readQueryParam, readQueryParam', readQueryParams
- , parseForm
- -- * Redirection via referrer
- , redirectBack
- , redirectBackOr
- -- * Exception handling
- , ControllerException
- , module Control.Exception.Peel
- -- * Integrating other WAI components
- , ToApplication(..)
- , fromApp
- -- * Low-level utilities
- , body
- -- , guard, guardM, guardReq
- ) where
-
-import Control.Applicative
-import Control.Exception.Peel
-import Control.Monad hiding (guard)
-import Control.Monad.IO.Class
-import Control.Monad.IO.Peel
-import qualified Data.ByteString as S
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.ByteString.Lazy.Char8 as L8
-import Data.Conduit
-import qualified Data.Conduit.List as CL
-import Data.List (find)
-import Data.Maybe
-import Data.Text (Text)
-import qualified Data.Text as T
-import qualified Data.Text.Encoding as T
-import Data.Typeable
-import Network.HTTP.Types
-import Network.Wai
-import Network.Wai.Parse
-import Web.Simple.Responses
-
--- | The Controller Monad is both a Reader-like monad which, when run, computes
--- either a 'Response' or a result. Within the Controller Monad, the remainder
--- of the computation can be short-circuited by 'respond'ing with a 'Response'.
-newtype Controller r a =
- Controller ((r,Request) -> ResourceT IO (Either Response a))
-
-instance Functor (Controller r) where
- fmap f (Controller act) = Controller $ \st -> do
- eaf <- act st
- case eaf of
- Left resp -> return $ Left resp
- Right result -> return $ Right $ f result
-
-instance Applicative (Controller r) where
- pure a = Controller $ \_ -> return $ Right a
- (Controller fn) <*> (Controller act) =
- Controller $ \st -> do
- eact <- act st
- case eact of
- Left resp -> return $ Left resp
- Right result -> do
- ef <- fn st
- either (return . Left) (\f -> return . Right $ f result) ef
-
-instance Monad (Controller r) where
- return = pure
- (Controller act) >>= fn = Controller $ \st -> do
- eres <- act st
- case eres of
- Left resp -> return $ Left resp
- Right result -> do
- let (Controller fres) = fn result
- fres st
-
-instance MonadIO (Controller r) where
- liftIO act = Controller $ \_ -> fmap Right $ liftIO act
-
-hoistEither :: Either Response a -> Controller r a
-hoistEither eith = Controller $ \_ -> return eith
-
-instance MonadPeelIO (Controller r) where
- peelIO = do
- r <- controllerState
- req <- request
- return $ \ctrl -> do
- res <- runControllerIO ctrl r req
- return $ hoistEither res
-
-ask :: Controller r (r, Request)
-ask = Controller $ \rd -> return (Right rd)
-
--- | Extract the request
-request :: Controller r Request
-request = liftM snd ask
-
-local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a
-local f (Controller act) = Controller $ \st -> act (f st)
-
--- | Modify the request for the given computation
-localRequest :: (Request -> Request) -> Controller r a -> Controller r a
-localRequest f = local (\(r,req) -> (r, f req))
-
--- | Extract the application-specific state
-controllerState :: Controller r r
-controllerState = liftM fst ask
-
--- | Modify the application state for the given computation
-localState :: (r -> r) -> Controller r a -> Controller r a
-localState f = local (\(r,req) -> (f r, req))
-
--- | Convert the controller into an 'Application'
-controllerApp :: r -> Controller r a -> Application
-controllerApp r ctrl req =
- runController ctrl r req >>=
- either return (const $ return notFound)
-
-runController :: Controller r a -> r -> Request -> ResourceT IO (Either Response a)
-runController (Controller fun) r req = fun (r,req)
-
--- | Run a 'Controller' in the @IO@ monad
-runControllerIO :: Controller r a -> r -> Request -> IO (Either Response a)
-runControllerIO ctrl r = runResourceT . runController ctrl r
-
--- | Decline to handle the request
---
--- @pass >> c === c@
--- @c >> pass === c@
-pass :: Controller r ()
-pass = Controller $ \_ -> return (Right ())
-
--- | Provide a response
---
--- @respond r >>= f === respond r@
-respond :: Response -> Controller r a
-respond resp = Controller $ \_ -> return $ Left resp
-
-
--- | Lift an application to a controller
-fromApp :: ToApplication a => a -> Controller r ()
-fromApp app = Controller (\(_, req) -> Left `fmap` ((toApp app) req))
-
--- | Matches on the hostname from the 'Request'. The route only succeeds on
--- exact matches.
-routeHost :: S.ByteString -> Controller r a -> Controller r ()
-routeHost host = guardReq $ (host ==) . serverName
-
--- | Matches if the path is empty.
---
--- Note that this route checks that 'pathInfo'
--- is empty, so it works as expected in nested contexts that have
--- popped components from the 'pathInfo' list.
-routeTop :: Controller r a -> Controller r ()
-routeTop = guardReq $ \req -> null (pathInfo req) ||
- (T.length . head $ pathInfo req) == 0
-
--- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')
-routeMethod :: StdMethod -> Controller r a -> Controller r ()
-routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod
-
--- | Matches if the request's Content-Type exactly matches the given string
-routeAccept :: S8.ByteString -> Controller r a -> Controller r ()
-routeAccept contentType = guardReq (isJust . find matching . requestHeaders)
- where matching hdr = fst hdr == hAccept && snd hdr == contentType
-
--- | Routes the given URL pattern. Patterns can include
--- directories as well as variable patterns (prefixed with @:@) to be added
--- to 'queryString' (see 'routeVar')
---
--- * \/posts\/:id
---
--- * \/posts\/:id\/new
---
--- * \/:date\/posts\/:category\/new
---
-routePattern :: S.ByteString -> Controller r a -> Controller r ()
-routePattern pattern route =
- let patternParts = map T.unpack $ decodePathSegments pattern
- in foldr mkRoute (route >> return ()) patternParts
- where mkRoute (':':varName) = routeVar (S8.pack varName)
- mkRoute name = routeName (S8.pack name)
-
--- | Matches if the first directory in the path matches the given 'ByteString'
-routeName :: S.ByteString -> Controller r a -> Controller r ()
-routeName name next = do
- req <- request
- if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req
- then localRequest popHdr next >> return ()
- else pass
- where popHdr req = req { pathInfo = (tail . pathInfo $ req) }
-
--- | Always matches if there is at least one directory in 'pathInfo' but and
--- adds a parameter to 'queryString' where the key is the first parameter and
--- the value is the directory consumed from the path.
-routeVar :: S.ByteString -> Controller r a -> Controller r ()
-routeVar varName next = do
- req <- request
- case pathInfo req of
- [] -> pass
- x:_ | T.null x -> pass
- | otherwise -> localRequest popHdr next >> return ()
- where popHdr req = req {
- pathInfo = (tail . pathInfo $ req)
- , queryString = (varName, Just (varVal req)):(queryString req)}
- varVal req = S8.pack . T.unpack . head . pathInfo $ req
-
---
--- query parameters
---
-
--- | Looks up the parameter name in the request's query string and returns the
--- @Parseable@ value or 'Nothing'.
---
--- For example, for a request with query string: \"?foo=bar&baz=7\",
--- @queryParam \"foo\"@
--- would return @Just "bar"@, but
--- @queryParam \"zap\"@
--- would return @Nothing@.
-queryParam :: Parseable a
- => S8.ByteString -- ^ Parameter name
- -> Controller r (Maybe a)
-queryParam varName = do
- qr <- liftM queryString request
- return $ case lookup varName qr of
- Just p -> Just $ parse $ fromMaybe S.empty p
- _ -> Nothing
-
--- | Like 'queryParam', but throws an exception if the parameter is not present.
-queryParam' :: Parseable a
- => S.ByteString -> Controller r a
-queryParam' varName =
- queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return
-
--- | Selects all values with the given parameter name
-queryParams :: Parseable a
- => S.ByteString -> Controller r [a]
-queryParams varName = request >>= return .
- map (parse . fromMaybe S.empty . snd) .
- filter ((== varName) . fst) .
- queryString
-
--- | The class of types into which query parameters may be converted
-class Parseable a where
- parse :: S8.ByteString -> a
-
-instance Parseable S8.ByteString where
- parse = id
-instance Parseable String where
- parse = S8.unpack
-instance Parseable Text where
- parse = T.decodeUtf8
-
--- | Like 'queryParam', but further processes the parameter value with @read@.
--- If that conversion fails, an exception is thrown.
-readQueryParam :: Read a
- => S8.ByteString -- ^ Parameter name
- -> Controller r (Maybe a)
-readQueryParam varName =
- queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)
-
--- | Like 'readQueryParam', but throws an exception if the parameter is not present.
-readQueryParam' :: Read a
- => S8.ByteString -- ^ Parameter name
- -> Controller r a
-readQueryParam' varName =
- queryParam' varName >>= readParamValue varName
-
--- | Like 'queryParams', but further processes the parameter values with @read@.
--- If any read-conversion fails, an exception is thrown.
-readQueryParams :: Read a
- => S8.ByteString -- ^ Parameter name
- -> Controller r [a]
-readQueryParams varName =
- queryParams varName >>= mapM (readParamValue varName)
-
-readParamValue :: Read a => S8.ByteString -> Text -> Controller r a
-readParamValue varName =
- maybe (err $ "cannot read parameter: " ++ show varName) return .
- readMay . T.unpack
- where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of
- [x] -> Just x
- _ -> Nothing
-
--- | Parses a HTML form from the request body. It returns a list of 'Param's as
--- well as a list of 'File's, which are pairs mapping the name of a /file/ form
--- field to a 'FileInfo' pointing to a temporary file with the contents of the
--- upload.
---
--- @
--- myController = do
--- (prms, files) <- parseForm
--- let mPicFile = lookup \"profile_pic\" files
--- case mPicFile of
--- Just (picFile) -> do
--- sourceFile (fileContent picFile) $$
--- sinkFile (\"images/\" ++ (fileName picFile))
--- respond $ redirectTo \"/\"
--- Nothing -> redirectBack
--- @
-parseForm :: Controller r ([Param], [(S.ByteString, FileInfo FilePath)])
-parseForm = Controller $ \(_, req) -> do
- Right `fmap` parseRequestBody tempFileBackEnd req
-
--- | Reads and returns the body of the HTTP request.
-body :: Controller r L8.ByteString
-body = Controller $ \(_, req) -> do
- Right `fmap` (requestBody req $$ CL.consume >>= return . L8.fromChunks)
-
--- | Returns the value of the given request header or 'Nothing' if it is not
--- present in the HTTP request.
-requestHeader :: HeaderName -> Controller r (Maybe S8.ByteString)
-requestHeader name = request >>= return . lookup name . requestHeaders
-
--- | Redirect back to the referer. If the referer header is not present
--- redirect to root (i.e., @\/@).
-redirectBack :: Controller r ()
-redirectBack = redirectBackOr (redirectTo "/")
-
--- | Redirect back to the referer. If the referer header is not present
--- fallback on the given 'Response'.
-redirectBackOr :: Response -- ^ Fallback response
- -> Controller r ()
-redirectBackOr def = do
- mrefr <- requestHeader "referer"
- case mrefr of
- Just refr -> respond $ redirectTo $ S8.unpack refr
- Nothing -> respond def
-
--- guard
-
-guard :: Bool -> Controller r a -> Controller r ()
-guard b c = if b then c >> return () else pass
-
-guardM :: Controller r Bool -> Controller r a -> Controller r ()
-guardM b c = b >>= flip guard c
-
-guardReq :: (Request -> Bool) -> Controller r a -> Controller r ()
-guardReq f = guardM (liftM f request)
-
--- | The class of types that can be converted to an 'Application'
-class ToApplication r where
- toApp :: r -> Application
-
-instance ToApplication Application where
- toApp = id
-
-instance ToApplication Response where
- toApp = const . return
-
-data ControllerException = ControllerException String
- deriving (Typeable)
-
-instance Show ControllerException where
- show (ControllerException msg) = "Controller: " ++ msg
-
-instance Exception ControllerException
-
-err :: String -> Controller r a
-err = throwIO . ControllerException
-
-{- $Example
- #example#
-
-The most basic 'Routeable' types are 'Application' and 'Response'. Reaching
-either of these types marks a termination in the routing lookup. This module
-exposes a monadic type 'Route' which makes it easy to create routing logic
-in a DSL-like fashion.
-
-'Route's are concatenated using the '>>' operator (or using do-notation).
-In the end, any 'Routeable', including a 'Route' is converted to an
-'Application' and passed to the server using 'mkRoute':
-
-@
-
- mainAction :: Controller () ()
- mainAction = ...
-
- signinForm :: Controller () ()
- signinForm req = ...
-
- login :: Controller () ()
- login = ...
-
- updateProfile :: Controller () ()
- updateProfile = ...
-
- main :: IO ()
- main = run 3000 $ controllerApp () $ do
- routeTop mainAction
- routeName \"sessions\" $ do
- routeMethod GET signinForm
- routeMethod POST login
- routeMethod PUT $ routePattern \"users/:id\" updateProfile
- routeAll $ responseLBS status404 [] \"Are you in the right place?\"
-@
-
--}
diff --git a/Web/Simple/Responses.hs b/Web/Simple/Responses.hs
deleted file mode 100644
--- a/Web/Simple/Responses.hs
+++ /dev/null
@@ -1,138 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module defines some convenience functions for creating responses.
-module Web.Simple.Responses
- ( ok, okHtml, okJson
- , movedTo, redirectTo
- , badRequest, requireBasicAuth, forbidden
- , notFound
- , serverError
- ) where
-
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.ByteString.Lazy.Char8 as L8
-import Network.HTTP.Types
-import Network.Wai
-
--- | Type alias for 'S8.ByteString'
-type ContentType = S8.ByteString
-
--- | Creates a 200 (OK) 'Response' with the given content-type and resposne
--- body
-ok :: ContentType -> L8.ByteString -> Response
-ok contentType body =
- responseLBS status200 [(hContentType, contentType)] body
-
--- | Helper to make responses with content-type \"text/html\"
-mkHtmlResponse :: Status -> [Header] -> L8.ByteString -> Response
-mkHtmlResponse stat hdrs =
- responseLBS stat ((hContentType, S8.pack "text/html"):hdrs)
-
--- | Creates a 200 (OK) 'Response' with content-type \"text/html\" and the
--- given resposne body
-okHtml :: L8.ByteString -> Response
-okHtml body =
- mkHtmlResponse status200 [] body
-
--- | Creates a 200 (OK) 'Response' with content-type \"application/json\" and the
--- given resposne body
-okJson :: L8.ByteString -> Response
-okJson = ok (S8.pack "application/json")
-
--- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to
--- that URL.
-movedTo :: String -> Response
-movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html
- where html = L8.concat
- [L8.pack
- "\n\
- \\n\
- \301 Moved Permanently\n\
- \\n\
- \Moved Permanently
\n\
- \The document has moved here\n\
- \\n"]
-
--- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL.
-redirectTo :: String -> Response
-redirectTo url = mkHtmlResponse status303 [(hLocation, S8.pack url)] html
- where html = L8.concat
- [L8.pack
- "\n\
- \
\n\
- \303 See Other\n\
- \\n\
- \See Other
\n\
- \The document has moved here\n\
- \\n"]
-
--- | Returns a 400 (Bad Request) 'Response'.
-badRequest :: Response
-badRequest = mkHtmlResponse status400 [] html
- where html = L8.concat
- [L8.pack
- "\n\
- \
\n\
- \400 Bad Request\n\
- \\n\
- \Bad Request
\n\
- \Your request could not be understood.
\n\
- \\n"]
-
--- | Returns a 401 (Authorization Required) 'Response' requiring basic
--- authentication in the given realm.
-requireBasicAuth :: String -> Response
-requireBasicAuth realm = mkHtmlResponse status401
- [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html
- where html = L8.concat
- [L8.pack
- "\n\
- \\n\
- \401 Authorization Required\n\
- \\n\
- \Authorization Required
\n\
- \\n"]
-
--- | Returns a 403 (Forbidden) 'Response'.
-forbidden :: Response
-forbidden = mkHtmlResponse status403 [] html
- where html = L8.concat
- [L8.pack
- "\n\
- \\n\
- \403 Forbidden\n\
- \\n\
- \Forbidden
\n\
- \You don't have permission to access this page.
\n\
- \\n"]
-
--- | Returns a 404 (Not Found) 'Response'.
-notFound :: Response
-notFound = mkHtmlResponse status404 [] html
- where html = L8.concat
- [L8.pack
- "\n\
- \\n\
- \404 Not Found\n\
- \\n\
- \Not Found
\n\
- \The requested URL was not found on this server.
\n\
- \\n"]
-
--- | Returns a 500 (Server Error) 'Response'.
-serverError :: L8.ByteString -> Response
-serverError message = mkHtmlResponse status500 [] html
- where html = L8.concat
- [L8.pack
- "\n\
- \\n\
- \500 Internal Server Error\n\
- \\n\
- \Internal Server Error
\n\
- \", message,
- "
\n"]
-
diff --git a/simple.cabal b/simple.cabal
--- a/simple.cabal
+++ b/simple.cabal
@@ -1,8 +1,5 @@
--- Initial wai-routes.cabal generated by cabal init. For further
--- documentation, see http://haskell.org/cabal/users-guide/
-
name: simple
-version: 0.5.0
+version: 0.6.0
synopsis: A minimalist web framework for the WAI server interface
description:
@@ -27,17 +24,19 @@
@
.
See "Web.Simple" for a more detailed introduction.
-license: GPL-3
+homepage: http://simple.cx
+license: LGPL-3
license-file: LICENSE
author: Amit Levy, Daniel B. Giffin
maintainer: amit@amitlevy.com
category: Web
build-type: Simple
-cabal-version: >=1.9.2
+cabal-version: >=1.10
data-files: template/*.tmpl
executable smpl
+ hs-source-dirs: src
Main-Is: smpl.hs
ghc-options: -Wall
build-depends:
@@ -50,16 +49,18 @@
, directory
, filepath
, process
+ , setenv
, stringsearch
+ default-language: Haskell2010
library
+ hs-source-dirs: src
build-depends:
base < 6
, base64-bytestring
, conduit
, directory
, filepath
- , hashtables
, wai
, wai-extra
, http-types
@@ -73,13 +74,13 @@
exposed-modules:
Web.Simple,
Web.Simple.Auth,
- Web.Simple.Cache,
Web.Simple.Controller,
Web.Simple.Responses,
Web.Frank,
Web.REST
+ default-language: Haskell2010
source-repository head
type: git
- location: anonymous@gitstar.com:alevy/wai-lite.git
+ location: anonymous@gitstar.com:alevy/simple.git
diff --git a/smpl.hs b/smpl.hs
deleted file mode 100644
--- a/smpl.hs
+++ /dev/null
@@ -1,58 +0,0 @@
-{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
-
--- | The `smpl` utility for helping a user setup a Simple web project.
-module Main (main) where
-
-import Prelude hiding (writeFile, FilePath)
-import Control.Monad
-import qualified Data.ByteString.Char8 as S8
-import qualified Data.ByteString.Lazy.Char8 as L8
-import qualified Data.ByteString.Lazy.Search as L8
-import System.Console.CmdArgs
-import System.Directory
-import System.FilePath
-import System.Environment
-import System.Process
-
-import Paths_simple
-
-data Smpl =
- Server
- { port :: Int
- , moduleName :: String
- } |
- Create { appName :: String }
- deriving (Show, Data, Typeable)
-
-main :: IO ()
-main = do
- myenv <- getEnvironment
- let myport = maybe 3000 read $ lookup "PORT" myenv
- let develMode = cmdArgsMode $ modes
- [ Server { port = myport &= typ "PORT"
- , moduleName = "Main" &= typ "MODULE"
- &= explicit &= name "module"
- } &= auto
- , Create { appName = "" &= argPos 0 &= typ "APP_NAME" } ]
- smpl <- cmdArgsRun develMode
- case smpl of
- Server p m -> void $
- rawSystem "wai-handler-devel" [show p, m, "app"]
- Create myAppName -> createApplication myAppName
-
-createApplication :: String -> IO ()
-createApplication myAppName = do
- createDirectory myAppName
- let mappings = [("pkgname", myAppName)]
- copyTemplate ("template" "Main_hs.tmpl")
- (myAppName "Main.hs") mappings
- copyTemplate ("template" "package_cabal.tmpl")
- (myAppName myAppName ++ ".cabal") mappings
-
-copyTemplate :: FilePath -> FilePath -> [(String, String)] -> IO ()
-copyTemplate orig target mappings = do
- tmpl <- getDataFileName orig >>= L8.readFile
- L8.writeFile target $
- (flip . flip foldl) tmpl mappings $ \accm (key, val) ->
- L8.replace (S8.pack $ "{{" ++ key ++ "}}") (L8.pack val) accm
-
diff --git a/src/Web/Frank.hs b/src/Web/Frank.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Frank.hs
@@ -0,0 +1,58 @@
+{- |
+Frank is a Sinatra-inspired DSL (see ) for creating
+routes. It is composable with all 'ToApplication' types, but is designed to be used
+with 'Network.Wai.Controller's. Each verb ('get', 'post', 'put', etc') takes a
+URL pattern of the form \"\/dir\/:paramname\/dir\" (see 'routePattern' for
+details) and a 'ToApplication':
+
+@
+ main :: IO ()
+ main = run 3000 $ controllerApp () $ do
+ get \"\/\" $ do
+ req <- request
+ return $ okHtml $ fromString $
+ \"Welcome Home \" ++ (show $ serverName req)
+ get \"\/user\/:id\" $ do
+ userId \<- queryParam \"id\" >>= fromMaybe \"\"
+ return $ ok \"text/json\" $ fromString $
+ \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\"
+ put \"\/user\/:id\" $ do
+ ...
+@
+
+-}
+module Web.Frank
+ ( get
+ , post
+ , put
+ , delete
+ , options
+ ) where
+
+import Network.HTTP.Types
+import Web.Simple.Controller
+import qualified Data.ByteString as S
+
+-- | Helper method
+frankMethod :: StdMethod -> S.ByteString -> Controller r a -> Controller r ()
+frankMethod method pattern = routeMethod method . routePattern pattern . routeTop
+
+-- | Matches the GET method on the given URL pattern
+get :: S.ByteString -> Controller r a -> Controller r ()
+get = frankMethod GET
+
+-- | Matches the POST method on the given URL pattern
+post :: S.ByteString -> Controller r a -> Controller r ()
+post = frankMethod POST
+
+-- | Matches the PUT method on the given URL pattern
+put :: S.ByteString -> Controller r a -> Controller r ()
+put = frankMethod PUT
+
+-- | Matches the DELETE method on the given URL pattern
+delete :: S.ByteString -> Controller r a -> Controller r ()
+delete = frankMethod DELETE
+
+-- | Matches the OPTIONS method on the given URL pattern
+options :: S.ByteString -> Controller r a -> Controller r ()
+options = frankMethod OPTIONS
diff --git a/src/Web/REST.hs b/src/Web/REST.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/REST.hs
@@ -0,0 +1,87 @@
+{-# LANGUAGE FlexibleInstances, OverloadedStrings #-}
+module Web.REST
+ ( REST(..), RESTController, rest, routeREST
+ , index, show, create, update, delete
+ , edit, new
+ ) where
+
+import Prelude hiding (show)
+
+import Control.Monad
+import Control.Monad.Trans.State
+import Data.Functor.Identity
+import Web.Simple.Responses
+import Web.Simple.Controller
+import Network.HTTP.Types
+
+data REST r = REST
+ { restIndex :: Controller r ()
+ , restShow :: Controller r ()
+ , restCreate :: Controller r ()
+ , restUpdate :: Controller r ()
+ , restDelete :: Controller r ()
+ , restEdit :: Controller r ()
+ , restNew :: Controller r ()
+ }
+
+defaultREST :: REST r
+defaultREST = REST
+ { restIndex = respond $ notFound
+ , restShow = respond $ notFound
+ , restCreate = respond $ notFound
+ , restUpdate = respond $ notFound
+ , restDelete = respond $ notFound
+ , restEdit = respond $ notFound
+ , restNew = respond $ notFound
+ }
+
+type RESTControllerM r a = StateT (REST r) Identity a
+
+rest :: RESTControllerM r a -> REST r
+rest rcontroller = snd . runIdentity $ runStateT rcontroller defaultREST
+
+routeREST :: REST r -> Controller r ()
+routeREST rst = do
+ routeMethod GET $ do
+ routeTop $ restIndex rst
+ routeName "new" $ restNew rst
+ routeVar "id" $ do
+ routeTop $ restShow rst
+ routeName "edit" $ restEdit rst
+
+ routeMethod POST $ routeTop $ restCreate rst
+
+ routeMethod DELETE $ routeVar "id" $ restDelete rst
+
+ routeMethod PUT $ routeVar "id" $ restUpdate rst
+
+type RESTController r = RESTControllerM r ()
+
+index :: Controller r a -> RESTController r
+index route = modify $ \controller ->
+ controller { restIndex = void route }
+
+create :: Controller r a -> RESTController r
+create route = modify $ \controller ->
+ controller { restCreate = void route }
+
+edit :: Controller r a -> RESTController r
+edit route = modify $ \controller ->
+ controller { restEdit = void route }
+
+new :: Controller r a -> RESTController r
+new route = modify $ \controller ->
+ controller { restNew = void route }
+
+show :: Controller r a -> RESTController r
+show route = modify $ \controller ->
+ controller { restShow = void route }
+
+update :: Controller r a -> RESTController r
+update route = modify $ \controller ->
+ controller { restUpdate = void route }
+
+delete :: Controller r a -> RESTController r
+delete route = modify $ \controller ->
+ controller { restDelete = void route }
+
diff --git a/src/Web/Simple.hs b/src/Web/Simple.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Simple.hs
@@ -0,0 +1,258 @@
+{- |
+
+
+/Simple/ is based on WAI - an standard interface for communicating between web
+servers (like warp) and web applications. You can use /Simple/ completely
+independently (and of course, use any WAI server to run it). Alternatively, you
+can embed existing existing WAI applications inside an app built with /Simple/,
+and embed an app built with simple in another WAI app.
+
+All the components in /Simple/ are designed to be small and simple
+enough to understand, replaceable, and work as well independantly as they do
+together.
+
+-}
+module Web.Simple (
+ module Web.Simple.Responses
+ , module Web.Simple.Controller
+ , module Network.Wai
+ -- * Overview
+ -- $Overview
+
+ -- * Tutorial
+ -- $Tutorial
+
+ -- ** Controllers
+ -- $Controllers
+
+ -- ** Routing
+ -- $Routing
+ ) where
+
+import Network.Wai
+import Web.Simple.Responses
+import Web.Simple.Controller
+
+{- $Overview
+ #overview#
+
+WAI applications are functions of type 'Network.Wai.Application' - given a
+client 'Network.Wai.Request' they return a 'Network.Wai.Response' to return to
+the client (i.e. an HTTP status code, headers, body etc\'). A /Simple/
+application 'Controller' -- a wrapper around WAI\'s 'Network.Wai.Application'
+either returns a monadic value, or a 'Network.Wai.Response'. This allows
+'Controller's to be chained together to create arbitrary complex routes. If a
+'Controller' \"matches\" a route (e.g., based on the HTTP path, hostname,
+cookies etc), it can 'respond' which shortcircuits the remaining execution and
+immediately send the response back to the client. If none, of the 'Controller's
+match, an HTTP 404 (NOT FOUND) response will be returned.
+
+For example, this is a trivial \Simple\ app that notices whether the incoming
+request was for the hostname \"hackage.haskell.org\" or \"www.haskell.org\":
+
+@
+ routeHost \"hackage.haskell.org\" $ do
+ respond $ okHtml \"Welcome to Hackage\"
+
+ routeHost \"www.haskell.org\" $ do
+ respond $ okHtml \"You\'ve reached the Haskell Language home page\"
+@
+
+'routeHost' is a combinator that matches the a request based on the \"Host\"
+header and defers to the passed in 'Controller' or returns '()'. There are
+other built-in combinators for matching based on the request path, the HTTP
+method, and it\'s easy to write your own combinators. You can chain such
+combinators together monadically or using 'mappend' (since 'Controller' is an
+instance of 'Monoid'). A typical /Simple/ app looks something like this:
+
+@
+ controllerApp () $ do
+ routeTop $ do
+ ... handle home page ...
+ routeName \"posts\" $ do
+ routeMethod GET $
+ ... get all posts ...
+ routeMethod POST $
+ ... create new post ...
+@
+
+where 'controllerApp' generates an 'Network.Wai.Application' from a 'Controller'
+returning a 404 (not found) response if all routes fail.
+
+This package also includes the "Web.Frank" module which provide an API to create
+applications similar to the Sinatra framework for Ruby, and the "Web.REST"
+module to create RESTful applications similar to Ruby on Rails. Neither of
+these modules is \"special\", in the sense that they are merely implemented in
+terms of 'Controller's. The example above could be rewritten using "Web.Frank"
+as such:
+
+@
+ controllerApp () $ do
+ get \"/\" $ do
+ ... display home page ...
+ get \"/posts\" $ do
+ ... get all posts ...
+ post \"/posts\" $ do
+ ... create new post ...
+@
+
+\Simple\ is broken down into the following modules:
+
+@
+ Web
+ |-- "Web.Simple" - Re-exports most common modules
+ | |-- "Web.Simple.Controller" - Base monad and built-in routing combinators
+ | |-- "Web.Simple.Responses" - Common HTTP responses
+ | |-- "Web.Simple.Auth" - 'Controller's for authentication
+ | |-- "Web.Simple.Cache" - in memory and filesystem cache utilities
+ |-- "Web.Frank" - Sinatra style 'Route's
+ +-- "Web.REST" - Monad for creating RESTful controllers
+@
+
+-}
+
+{- $Tutorial
+#tutorial#
+
+/Simple/ comes with a utility called \smpl\ which automates some common tasks
+like creating a new application, running migrations and launching a development
+server. To create a new /Simple/ app in a directory called \"example_app\", run:
+
+@
+ $ smpl create example_app
+@
+
+This will create a directory called \"example_app\" containing a /.cabal/ file
+and and a single Haskell source file, \"Main.hs\":
+
+@
+\{\-\# LANGUAGE OverloadedStrings #\-\}
+
+module Main where
+
+import Web.Simple
+import Network.Wai.Handler.Warp
+import System.Posix.Env
+
+app :: (Application -> IO ()) -> IO ()
+app runner = runner $ do
+ -- TODO: App initialization code here
+ controllerApp () $ do
+ respond $ okHtml \"Hello World\"
+
+main :: IO ()
+main = do
+ port <- read \`fmap\` getEnvDefault \"PORT\" \"3000\"
+ app (run port)
+@
+
+The `app` function is the entry point to your application. The argument is a
+function that knows how to run a `Network.Wai.Application` -- for example,
+warp's run method. `mkRouter` transforms a `Routeable` into an
+`Network.Wai.Application`. The boilerplate is just a `Response` with the body
+\"Hello World\" (and content-type \"text/html\"). To run a development server
+on port 3000:
+
+@
+ $ cd example_app
+ $ smpl
+@
+
+Pointing your browser to should display
+\"Hello World\"!
+-}
+
+{- $Controllers
+#controllers#
+
+What is this 'controllerApp' business? The basic type in /Simple/ is a
+'Controller' which contains both a 'Request' and app specific state.
+'controllerApp' takes an initial application state (/unit/ in the example above)
+and transforms a 'Controller' into a WAI 'Application' so it can be run by a
+server like warp.
+
+A 'Controller' is a 'Monad' that can perform actions in 'IO' (using 'liftIO'),
+access the underlying 'request' or application state (via 'controllerState').
+Finally, a 'Controller' can 'respond' to a request. 'respond' short-circuits
+the rest of the computation and returns the 'Response' to the client.
+'controllerApp' transforms a 'Controller' into a WAI application by running the
+'Controller'. If the 'Controller' does not call 'respond', 'controllerApp'
+defaults to responding to the client with a 404 not found. For example:
+
+@
+controllerApp () $ do
+ liftIO $ putStrLn \"Responding to request\"
+ respond $ okHtml \"Hello World\"
+ liftIO $ putStrLn \"This message is never actually printed\"
+@
+
+When run, this code will always print the first message
+(\"Responding to request\") and respond with a 200 page containing \"Hello
+World\", but never print the second message. Short-circuiting the computation
+in this way allows us to respond in different ways based on the request:
+
+@
+controllerApp () $ do
+ path \<- rawPathInfo \<$> request
+ when (path == \"/timeofday\") $ do
+ timeStr \<- liftIO $ S8.pack . show \<$> getClockTime
+ respond $ okHtml timeStr
+ when (path == \"/whoami\") $
+ user \<- liftIO $ S8.pack \<$> getLoginName
+ respond $ okHtml user
+@
+
+This controller will respond with the current time if the path \"/timeofday\"
+is requested, and the user running the server if the path \"/whoami\" is
+requested. If neither of those paths match, it will respond with a 404
+(NOT FOUND).
+
+ -}
+
+{- $Routing
+#routing#
+
+An app that does the same thing for every request is not very useful (well, it
+might be, but if it is, even /Simple/ is not simple enough for you). We want to
+build applications that do perform different actions based on properties of the
+client\'s request - e.g., the path requests, GET or POST requests, the \"Host\"
+header, etc\'. /Simple/\'s 'Controller's are flexible to accomplish this.
+'Controller's encapsulate a function from a 'Request' to 'Either' a 'Response'
+or some monadic value.
+
+For example, let\'s extend the example using the 'Monad' syntax:
+
+@
+controllerApp () $ do
+ routeTop $ do
+ routeHost \"localhost\" $ respond $ okHtml \"Hello, localhost!\"
+ routeHost \"test.lvh.me\" $ respond $ okHtml \"Hello, test.lvh.me!\"
+ routeName \"advice\" $ okHtml \"Be excellent to each other!\"
+@
+
+Now, the app will respond differently depending on whether the client is
+requesting the host name \"localhost\" or \"test.lvh.me\", or if the requested
+path is \"\/advice\" rather than \"\/\". Take it for a spin in the browser (make
+sure `smpl` is still running):
+
+ *
+
+ *
+
+ *
+
+In this example, 'routeTop' matches if the 'Network.Wai.Request's
+'Network.Wai.pathInfo' is empty, which means the requested path is \"\/\" (as
+in this case), or the rest of the path has been consumed by previous 'Route's.
+'routeName' matches if the next component in the path (specifically the 'head'
+of 'Network.Wai.pathInfo') matches the argument (and if so, removes it). Check
+out "Web.Simple.Router" for more complete documentation of these and other
+'Route's.
+
+For many apps it will be convenient to use even higher level routing APIs. The
+modules "Web.Frank" and "Web.Sinatra" provide Sinatra-like and RESTful APIs,
+respectively. Both modules are implement purely in terms of 'Route's and you
+can easily implement your own patterns as well.
+
+-}
+
diff --git a/src/Web/Simple/Auth.hs b/src/Web/Simple/Auth.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Simple/Auth.hs
@@ -0,0 +1,70 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | Provides HTTP Basic Authentication.
+module Web.Simple.Auth
+ ( AuthRouter
+ , basicAuthRoute, basicAuth, authRewriteReq
+ ) where
+
+import Control.Monad
+import Data.ByteString.Base64
+import qualified Data.ByteString.Char8 as S8
+import Data.Maybe
+import Network.HTTP.Types
+import Network.Wai
+import Web.Simple.Responses
+import Web.Simple.Controller
+
+-- | An 'AuthRouter' authenticates a 'Request' and, if successful, forwards the
+-- 'Request' to the 'Routeable'.
+type AuthRouter r a = (Request -> S8.ByteString
+ -> S8.ByteString
+ -> Controller r (Maybe Request))
+ -> Controller r a
+ -> Controller r a
+
+-- | An 'AuthRouter' that uses HTTP basic authentication to authenticate a request
+-- in a particular realm.
+basicAuthRoute :: String -> AuthRouter r a
+basicAuthRoute realm testAuth next = do
+ req <- request
+ let authStr = fromMaybe "" $ lookup hAuthorization (requestHeaders req)
+ when (S8.take 5 authStr /= "Basic") requireAuth
+
+ case fmap (S8.split ':') $ decode $ S8.drop 6 authStr of
+ Right (user:pwd:[]) -> do
+ mfin <- testAuth req user pwd
+ maybe requireAuth (\finReq -> localRequest (const finReq) next) mfin
+ _ -> requireAuth
+ where requireAuth = respond $ requireBasicAuth realm
+
+-- | Wraps an 'AuthRouter' to take a simpler authentication function (that just
+-- just takes a username and password, and returns 'True' or 'False'). It also
+-- adds an \"X-User\" header to the 'Request' with the authenticated user\'s
+-- name (the first argument to the authentication function).
+authRewriteReq :: AuthRouter r a
+ -> (S8.ByteString -> S8.ByteString -> Controller r Bool)
+ -> Controller r a
+ -> Controller r a
+authRewriteReq authRouter testAuth rt =
+ authRouter (\req user pwd -> do
+ success <- testAuth user pwd
+ if success then
+ return $ Just $ transReq req user
+ else return Nothing) rt
+ where transReq req user = req
+ { requestHeaders = ("X-User", user):(requestHeaders req)}
+
+-- | A 'Route' that uses HTTP basic authentication to authenticate a request for a realm
+-- with the given username ans password. The request is rewritten with an 'X-User' header
+-- containing the authenticated username before being passed to the next 'Route'.
+basicAuth :: String
+ -- ^ Realm
+ -> S8.ByteString
+ -- ^ Username
+ -> S8.ByteString
+ -- ^ Password
+ -> Controller r a -> Controller r a
+basicAuth realm user pwd = authRewriteReq (basicAuthRoute realm)
+ (\u p -> return $ u == user && p == pwd)
+
diff --git a/src/Web/Simple/Controller.hs b/src/Web/Simple/Controller.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Simple/Controller.hs
@@ -0,0 +1,437 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE FlexibleInstances #-}
+
+{- | 'Controller' provides a convenient syntax for writting 'Application'
+ code as a Monadic action with access to an HTTP request as well as app
+ specific data (e.g. a database connection pool, app configuration etc.)
+ This module also defines some
+ helper functions that leverage this feature. For example, 'redirectBack'
+ reads the underlying request to extract the referer and returns a redirect
+ response:
+
+ @
+ myController = do
+ ...
+ if badLogin then
+ redirectBack
+ else
+ ...
+ @
+-}
+module Web.Simple.Controller
+ (
+ -- * Example
+ -- $Example
+ -- * Controller Monad
+ Controller(..), runController, runControllerIO
+ , controllerApp, controllerState, putState
+ , request, localRequest, respond
+ , requestHeader
+ -- * Common Routes
+ , routeHost, routeTop, routeMethod, routeAccept
+ , routePattern, routeName, routeVar
+ -- * Inspecting query
+ , Parseable
+ , queryParam, queryParam', queryParams
+ , readQueryParam, readQueryParam', readQueryParams
+ , parseForm
+ -- * Redirection via referrer
+ , redirectBack
+ , redirectBackOr
+ -- * Exception handling
+ , ControllerException
+ , module Control.Exception.Peel
+ -- * Integrating other WAI components
+ , ToApplication(..)
+ , fromApp
+ -- * Low-level utilities
+ , body
+ -- , guard, guardM, guardReq
+ ) where
+
+import Control.Applicative
+import Control.Exception.Peel
+import Control.Monad hiding (guard)
+import Control.Monad.IO.Class
+import Control.Monad.IO.Peel
+import qualified Data.ByteString as S
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Data.Conduit
+import qualified Data.Conduit.List as CL
+import Data.List (find)
+import Data.Maybe
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import Data.Typeable
+import Network.HTTP.Types
+import Network.Wai
+import Network.Wai.Parse
+import Web.Simple.Responses
+
+
+type ControllerState r = (r, Request)
+
+-- | The Controller Monad is both a State-like monad which, when run, computes
+-- either a 'Response' or a result. Within the Controller Monad, the remainder
+-- of the computation can be short-circuited by 'respond'ing with a 'Response'.
+newtype Controller r a =
+ Controller (ControllerState r ->
+ ResourceT IO (Either Response a, ControllerState r))
+
+instance Functor (Controller r) where
+ fmap f (Controller act) = Controller $ \st0 -> do
+ (eaf, st) <- act st0
+ case eaf of
+ Left resp -> return (Left resp, st)
+ Right result -> return (Right $ f result, st)
+
+instance Applicative (Controller r) where
+ pure a = Controller $ \st -> return $ (Right a, st)
+ (<*>) = ap
+
+instance Monad (Controller r) where
+ return = pure
+ (Controller act) >>= fn = Controller $ \st0 -> do
+ (eres, st) <- act st0
+ case eres of
+ Left resp -> return (Left resp, st)
+ Right result -> do
+ let (Controller fres) = fn result
+ fres st
+
+instance MonadIO (Controller r) where
+ liftIO act = Controller $ \st -> liftIO act >>= \r -> return (Right r, st)
+
+liftResourceT :: ResourceT IO a -> Controller r a
+liftResourceT act = Controller $ \st -> do
+ a <- act
+ return (Right a, st)
+
+hoistEither :: Either Response a -> Controller r a
+hoistEither eith = Controller $ \st -> return (eith, st)
+
+instance MonadPeelIO (Controller r) where
+ peelIO = do
+ r <- controllerState
+ req <- request
+ return $ \ctrl -> do
+ res <- runControllerIO ctrl r req
+ return $ hoistEither res
+
+ask :: Controller r (r, Request)
+ask = Controller $ \rd -> return (Right rd, rd)
+
+-- | Extract the request
+request :: Controller r Request
+request = liftM snd ask
+
+local :: ((r, Request) -> (r, Request)) -> Controller r a -> Controller r a
+local f (Controller act) = Controller $ \st@(_, r) -> do
+ (eres, (req, _)) <- act (f st)
+ return (eres, (req, r))
+
+-- | Modify the request for the given computation
+localRequest :: (Request -> Request) -> Controller r a -> Controller r a
+localRequest f = local (\(r,req) -> (r, f req))
+
+-- | Extract the application-specific state
+controllerState :: Controller r r
+controllerState = liftM fst ask
+
+putState :: r -> Controller r ()
+putState r = Controller $ \(_, req) -> return (Right (), (r, req))
+
+-- | Convert the controller into an 'Application'
+controllerApp :: r -> Controller r a -> Application
+controllerApp r ctrl req =
+ runController ctrl r req >>=
+ either return (const $ return notFound)
+
+runController :: Controller r a -> r -> Request -> ResourceT IO (Either Response a)
+runController (Controller fun) r req = fst `fmap` fun (r,req)
+
+-- | Run a 'Controller' in the @IO@ monad
+runControllerIO :: Controller r a -> r -> Request -> IO (Either Response a)
+runControllerIO ctrl r = runResourceT . runController ctrl r
+
+-- | Decline to handle the request
+--
+-- @pass >> c === c@
+-- @c >> pass === c@
+pass :: Controller r ()
+pass = Controller $ \st -> return (Right (), st)
+
+-- | Provide a response
+--
+-- @respond r >>= f === respond r@
+respond :: Response -> Controller r a
+respond resp = Controller $ \st -> return (Left resp, st)
+
+
+-- | Lift an application to a controller
+fromApp :: ToApplication a => a -> Controller r ()
+fromApp app = do
+ req <- request
+ resp <- liftResourceT $ (toApp app) req
+ respond resp
+
+-- | Matches on the hostname from the 'Request'. The route only succeeds on
+-- exact matches.
+routeHost :: S.ByteString -> Controller r a -> Controller r ()
+routeHost host = guardReq $ (host ==) . serverName
+
+-- | Matches if the path is empty.
+--
+-- Note that this route checks that 'pathInfo'
+-- is empty, so it works as expected in nested contexts that have
+-- popped components from the 'pathInfo' list.
+routeTop :: Controller r a -> Controller r ()
+routeTop = guardReq $ \req -> null (pathInfo req) ||
+ (T.length . head $ pathInfo req) == 0
+
+-- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT')
+routeMethod :: StdMethod -> Controller r a -> Controller r ()
+routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod
+
+-- | Matches if the request's Content-Type exactly matches the given string
+routeAccept :: S8.ByteString -> Controller r a -> Controller r ()
+routeAccept contentType = guardReq (isJust . find matching . requestHeaders)
+ where matching hdr = fst hdr == hAccept && snd hdr == contentType
+
+-- | Routes the given URL pattern. Patterns can include
+-- directories as well as variable patterns (prefixed with @:@) to be added
+-- to 'queryString' (see 'routeVar')
+--
+-- * \/posts\/:id
+--
+-- * \/posts\/:id\/new
+--
+-- * \/:date\/posts\/:category\/new
+--
+routePattern :: S.ByteString -> Controller r a -> Controller r ()
+routePattern pattern route =
+ let patternParts = map T.unpack $ decodePathSegments pattern
+ in foldr mkRoute (route >> return ()) patternParts
+ where mkRoute (':':varName) = routeVar (S8.pack varName)
+ mkRoute name = routeName (S8.pack name)
+
+-- | Matches if the first directory in the path matches the given 'ByteString'
+routeName :: S.ByteString -> Controller r a -> Controller r ()
+routeName name next = do
+ req <- request
+ if (length $ pathInfo req) > 0 && S8.unpack name == (T.unpack . head . pathInfo) req
+ then localRequest popHdr next >> return ()
+ else pass
+ where popHdr req = req { pathInfo = (tail . pathInfo $ req) }
+
+-- | Always matches if there is at least one directory in 'pathInfo' but and
+-- adds a parameter to 'queryString' where the key is the first parameter and
+-- the value is the directory consumed from the path.
+routeVar :: S.ByteString -> Controller r a -> Controller r ()
+routeVar varName next = do
+ req <- request
+ case pathInfo req of
+ [] -> pass
+ x:_ | T.null x -> pass
+ | otherwise -> localRequest popHdr next >> return ()
+ where popHdr req = req {
+ pathInfo = (tail . pathInfo $ req)
+ , queryString = (varName, Just (varVal req)):(queryString req)}
+ varVal req = S8.pack . T.unpack . head . pathInfo $ req
+
+--
+-- query parameters
+--
+
+-- | Looks up the parameter name in the request's query string and returns the
+-- @Parseable@ value or 'Nothing'.
+--
+-- For example, for a request with query string: \"?foo=bar&baz=7\",
+-- @queryParam \"foo\"@
+-- would return @Just "bar"@, but
+-- @queryParam \"zap\"@
+-- would return @Nothing@.
+queryParam :: Parseable a
+ => S8.ByteString -- ^ Parameter name
+ -> Controller r (Maybe a)
+queryParam varName = do
+ qr <- liftM queryString request
+ return $ case lookup varName qr of
+ Just p -> Just $ parse $ fromMaybe S.empty p
+ _ -> Nothing
+
+-- | Like 'queryParam', but throws an exception if the parameter is not present.
+queryParam' :: Parseable a
+ => S.ByteString -> Controller r a
+queryParam' varName =
+ queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return
+
+-- | Selects all values with the given parameter name
+queryParams :: Parseable a
+ => S.ByteString -> Controller r [a]
+queryParams varName = request >>= return .
+ map (parse . fromMaybe S.empty . snd) .
+ filter ((== varName) . fst) .
+ queryString
+
+-- | The class of types into which query parameters may be converted
+class Parseable a where
+ parse :: S8.ByteString -> a
+
+instance Parseable S8.ByteString where
+ parse = id
+instance Parseable String where
+ parse = S8.unpack
+instance Parseable Text where
+ parse = T.decodeUtf8
+
+-- | Like 'queryParam', but further processes the parameter value with @read@.
+-- If that conversion fails, an exception is thrown.
+readQueryParam :: Read a
+ => S8.ByteString -- ^ Parameter name
+ -> Controller r (Maybe a)
+readQueryParam varName =
+ queryParam varName >>= maybe (return Nothing) (liftM Just . readParamValue varName)
+
+-- | Like 'readQueryParam', but throws an exception if the parameter is not present.
+readQueryParam' :: Read a
+ => S8.ByteString -- ^ Parameter name
+ -> Controller r a
+readQueryParam' varName =
+ queryParam' varName >>= readParamValue varName
+
+-- | Like 'queryParams', but further processes the parameter values with @read@.
+-- If any read-conversion fails, an exception is thrown.
+readQueryParams :: Read a
+ => S8.ByteString -- ^ Parameter name
+ -> Controller r [a]
+readQueryParams varName =
+ queryParams varName >>= mapM (readParamValue varName)
+
+readParamValue :: Read a => S8.ByteString -> Text -> Controller r a
+readParamValue varName =
+ maybe (err $ "cannot read parameter: " ++ show varName) return .
+ readMay . T.unpack
+ where readMay s = case [x | (x,rst) <- reads s, ("", "") <- lex rst] of
+ [x] -> Just x
+ _ -> Nothing
+
+-- | Parses a HTML form from the request body. It returns a list of 'Param's as
+-- well as a list of 'File's, which are pairs mapping the name of a /file/ form
+-- field to a 'FileInfo' pointing to a temporary file with the contents of the
+-- upload.
+--
+-- @
+-- myController = do
+-- (prms, files) <- parseForm
+-- let mPicFile = lookup \"profile_pic\" files
+-- case mPicFile of
+-- Just (picFile) -> do
+-- sourceFile (fileContent picFile) $$
+-- sinkFile (\"images/\" ++ (fileName picFile))
+-- respond $ redirectTo \"/\"
+-- Nothing -> redirectBack
+-- @
+parseForm :: Controller r ([Param], [(S.ByteString, FileInfo FilePath)])
+parseForm = do
+ req <- request
+ liftResourceT $ parseRequestBody tempFileBackEnd req
+
+-- | Reads and returns the body of the HTTP request.
+body :: Controller r L8.ByteString
+body = do
+ req <- request
+ liftResourceT $ L8.fromChunks `fmap` (requestBody req $$ CL.consume)
+
+-- | Returns the value of the given request header or 'Nothing' if it is not
+-- present in the HTTP request.
+requestHeader :: HeaderName -> Controller r (Maybe S8.ByteString)
+requestHeader name = request >>= return . lookup name . requestHeaders
+
+-- | Redirect back to the referer. If the referer header is not present
+-- redirect to root (i.e., @\/@).
+redirectBack :: Controller r ()
+redirectBack = redirectBackOr (redirectTo "/")
+
+-- | Redirect back to the referer. If the referer header is not present
+-- fallback on the given 'Response'.
+redirectBackOr :: Response -- ^ Fallback response
+ -> Controller r ()
+redirectBackOr def = do
+ mrefr <- requestHeader "referer"
+ case mrefr of
+ Just refr -> respond $ redirectTo refr
+ Nothing -> respond def
+
+-- guard
+
+guard :: Bool -> Controller r a -> Controller r ()
+guard b c = if b then c >> return () else pass
+
+guardM :: Controller r Bool -> Controller r a -> Controller r ()
+guardM b c = b >>= flip guard c
+
+guardReq :: (Request -> Bool) -> Controller r a -> Controller r ()
+guardReq f = guardM (liftM f request)
+
+-- | The class of types that can be converted to an 'Application'
+class ToApplication r where
+ toApp :: r -> Application
+
+instance ToApplication Application where
+ toApp = id
+
+instance ToApplication Response where
+ toApp = const . return
+
+data ControllerException = ControllerException String
+ deriving (Typeable)
+
+instance Show ControllerException where
+ show (ControllerException msg) = "Controller: " ++ msg
+
+instance Exception ControllerException
+
+err :: String -> Controller r a
+err = throwIO . ControllerException
+
+{- $Example
+ #example#
+
+The most basic 'Routeable' types are 'Application' and 'Response'. Reaching
+either of these types marks a termination in the routing lookup. This module
+exposes a monadic type 'Route' which makes it easy to create routing logic
+in a DSL-like fashion.
+
+'Route's are concatenated using the '>>' operator (or using do-notation).
+In the end, any 'Routeable', including a 'Route' is converted to an
+'Application' and passed to the server using 'mkRoute':
+
+@
+
+ mainAction :: Controller () ()
+ mainAction = ...
+
+ signinForm :: Controller () ()
+ signinForm req = ...
+
+ login :: Controller () ()
+ login = ...
+
+ updateProfile :: Controller () ()
+ updateProfile = ...
+
+ main :: IO ()
+ main = run 3000 $ controllerApp () $ do
+ routeTop mainAction
+ routeName \"sessions\" $ do
+ routeMethod GET signinForm
+ routeMethod POST login
+ routeMethod PUT $ routePattern \"users/:id\" updateProfile
+ routeAll $ responseLBS status404 [] \"Are you in the right place?\"
+@
+
+-}
diff --git a/src/Web/Simple/Responses.hs b/src/Web/Simple/Responses.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/Simple/Responses.hs
@@ -0,0 +1,138 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+-- | This module defines some convenience functions for creating responses.
+module Web.Simple.Responses
+ ( ok, okHtml, okJson
+ , movedTo, redirectTo
+ , badRequest, requireBasicAuth, forbidden
+ , notFound
+ , serverError
+ ) where
+
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy.Char8 as L8
+import Network.HTTP.Types
+import Network.Wai
+
+-- | Type alias for 'S8.ByteString'
+type ContentType = S8.ByteString
+
+-- | Creates a 200 (OK) 'Response' with the given content-type and resposne
+-- body
+ok :: ContentType -> L8.ByteString -> Response
+ok contentType body =
+ responseLBS status200 [(hContentType, contentType)] body
+
+-- | Helper to make responses with content-type \"text/html\"
+mkHtmlResponse :: Status -> [Header] -> L8.ByteString -> Response
+mkHtmlResponse stat hdrs =
+ responseLBS stat ((hContentType, S8.pack "text/html"):hdrs)
+
+-- | Creates a 200 (OK) 'Response' with content-type \"text/html\" and the
+-- given resposne body
+okHtml :: L8.ByteString -> Response
+okHtml body =
+ mkHtmlResponse status200 [] body
+
+-- | Creates a 200 (OK) 'Response' with content-type \"application/json\" and the
+-- given resposne body
+okJson :: L8.ByteString -> Response
+okJson = ok (S8.pack "application/json")
+
+-- | Given a URL returns a 301 (Moved Permanently) 'Response' redirecting to
+-- that URL.
+movedTo :: String -> Response
+movedTo url = mkHtmlResponse status301 [(hLocation, S8.pack url)] html
+ where html = L8.concat
+ [L8.pack
+ "\n\
+ \\n\
+ \301 Moved Permanently\n\
+ \\n\
+ \Moved Permanently
\n\
+ \The document has moved here\n\
+ \\n"]
+
+-- | Given a URL returns a 303 (See Other) 'Response' redirecting to that URL.
+redirectTo :: S8.ByteString -> Response
+redirectTo url = mkHtmlResponse status303 [(hLocation, url)] html
+ where html = L8.concat
+ [L8.pack
+ "\n\
+ \
\n\
+ \303 See Other\n\
+ \\n\
+ \See Other
\n\
+ \The document has moved here\n\
+ \\n"]
+
+-- | Returns a 400 (Bad Request) 'Response'.
+badRequest :: Response
+badRequest = mkHtmlResponse status400 [] html
+ where html = L8.concat
+ [L8.pack
+ "\n\
+ \
\n\
+ \400 Bad Request\n\
+ \\n\
+ \Bad Request
\n\
+ \Your request could not be understood.
\n\
+ \\n"]
+
+-- | Returns a 401 (Authorization Required) 'Response' requiring basic
+-- authentication in the given realm.
+requireBasicAuth :: String -> Response
+requireBasicAuth realm = mkHtmlResponse status401
+ [("WWW-Authenticate", S8.concat ["Basic realm=", S8.pack . show $ realm])] html
+ where html = L8.concat
+ [L8.pack
+ "\n\
+ \\n\
+ \401 Authorization Required\n\
+ \\n\
+ \Authorization Required
\n\
+ \\n"]
+
+-- | Returns a 403 (Forbidden) 'Response'.
+forbidden :: Response
+forbidden = mkHtmlResponse status403 [] html
+ where html = L8.concat
+ [L8.pack
+ "\n\
+ \\n\
+ \403 Forbidden\n\
+ \\n\
+ \Forbidden
\n\
+ \You don't have permission to access this page.
\n\
+ \\n"]
+
+-- | Returns a 404 (Not Found) 'Response'.
+notFound :: Response
+notFound = mkHtmlResponse status404 [] html
+ where html = L8.concat
+ [L8.pack
+ "\n\
+ \\n\
+ \404 Not Found\n\
+ \\n\
+ \Not Found
\n\
+ \The requested URL was not found on this server.
\n\
+ \\n"]
+
+-- | Returns a 500 (Server Error) 'Response'.
+serverError :: L8.ByteString -> Response
+serverError message = mkHtmlResponse status500 [] html
+ where html = L8.concat
+ [L8.pack
+ "\n\
+ \\n\
+ \500 Internal Server Error\n\
+ \\n\
+ \Internal Server Error
\n\
+ \", message,
+ "
\n"]
+
diff --git a/src/smpl.hs b/src/smpl.hs
new file mode 100644
--- /dev/null
+++ b/src/smpl.hs
@@ -0,0 +1,103 @@
+{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-}
+
+-- | The `smpl` utility for helping a user setup a Simple web project.
+module Main (main) where
+
+import Prelude hiding (writeFile, FilePath)
+import Data.Char
+import qualified Data.ByteString.Char8 as S8
+import qualified Data.ByteString.Lazy.Char8 as L8
+import qualified Data.ByteString.Lazy.Search as L8
+import System.Console.CmdArgs
+import System.Directory
+import System.FilePath
+import System.Environment
+import System.Exit
+import System.SetEnv
+import System.Process
+
+import Paths_simple
+
+data Smpl =
+ Server
+ { port :: Int
+ , moduleName :: String
+ } |
+ Create { appDir :: FilePath }
+ deriving (Show, Data, Typeable)
+
+main :: IO ()
+main = do
+ setEnv "ENV" "development"
+ myenv <- getEnvironment
+ let myport = maybe 3000 read $ lookup "PORT" myenv
+ let develMode = cmdArgsMode $ modes
+ [ Server { port = myport &= typ "PORT"
+ , moduleName = "Application" &= typ "MODULE"
+ &= explicit &= name "module"
+ } &= auto
+ , Create { appDir = "" &= argPos 0 &= typ "app_dir" } ]
+ smpl <- cmdArgsRun develMode
+ case smpl of
+ Server p m -> do
+ exitCode <- rawSystem "wai-handler-devel" [show p, m, "app"]
+ case exitCode of
+ ExitFailure 127 -> do
+ putStrLn "You must install wai-handler devel first"
+ exitWith $ ExitFailure 1
+ _ -> exitWith exitCode
+ Create dir -> createApplication dir
+
+humanize :: String -> String
+humanize = capitalize
+ where go [] = []
+ go ('_':xs) = ' ':(capitalize xs)
+ go (x:xs) = x:(go xs)
+ capitalize [] = []
+ capitalize x@('_':_) = go x
+ capitalize (x:xs) = (toUpper x):(go xs)
+
+moduleCase :: String -> String
+moduleCase = capitalize
+ where go [] = []
+ go ('_':xs) = capitalize xs
+ go (x:xs) = x:(go xs)
+ capitalize [] = []
+ capitalize ('_':xs) = go xs
+ capitalize (x:xs) = (toUpper x):(go xs)
+
+createApplication :: FilePath -> IO ()
+createApplication dir = do
+ let myAppName = takeBaseName $ dropTrailingPathSeparator dir
+ modName = moduleCase myAppName
+ mappings = [ ("appname", myAppName)
+ , ("name", humanize myAppName)
+ , ("module", modName)]
+
+ createDirectory dir
+ createDirectory $ dir "db"
+ createDirectory $ dir "db" "migrations"
+ createDirectory $ dir "views"
+ createDirectory $ dir "templates"
+ createDirectory $ dir modName
+
+ copyTemplate ("template" "Main_hs.tmpl")
+ (dir "Main.hs") mappings
+ copyTemplate ("template" "Application_hs.tmpl")
+ (dir "Application.hs") mappings
+ copyTemplate ("template" "package_cabal.tmpl")
+ (dir myAppName ++ ".cabal") mappings
+ copyTemplate ("template" "main_html.tmpl")
+ (dir "templates" "main.html") mappings
+ copyTemplate ("template" "index_html.tmpl")
+ (dir "views" "index.html") mappings
+ copyTemplate ("template" "Common_hs.tmpl")
+ (dir modName "Common.hs") mappings
+
+copyTemplate :: FilePath -> FilePath -> [(String, String)] -> IO ()
+copyTemplate orig target mappings = do
+ tmpl <- getDataFileName orig >>= L8.readFile
+ L8.writeFile target $
+ (flip . flip foldl) tmpl mappings $ \accm (key, val) ->
+ L8.replace (S8.pack $ "{{" ++ key ++ "}}") (L8.pack val) accm
+
diff --git a/template/Application_hs.tmpl b/template/Application_hs.tmpl
new file mode 100644
--- /dev/null
+++ b/template/Application_hs.tmpl
@@ -0,0 +1,14 @@
+{-# LANGUAGE OverloadedStrings #-}
+module Application where
+
+import {{module}}.Common
+import Web.Simple
+
+app :: (Application -> IO ()) -> IO ()
+app runner = do
+ settings <- newAppSettings
+
+ runner $ controllerApp settings $ do
+ -- TODO: routes go here
+ respond $ okHtml "Hello World"
+
diff --git a/template/Common_hs.tmpl b/template/Common_hs.tmpl
new file mode 100644
--- /dev/null
+++ b/template/Common_hs.tmpl
@@ -0,0 +1,41 @@
+module {{module}}.Common where
+
+import Control.Applicative
+import Web.Simple
+
+-- Uncomment the following lines for database, templates, and session support
+--import Web.Simple.PostgreSQL
+--import Web.Simple.Templates
+--import Web.Simple.Session
+
+type AppSettings = ()
+
+newAppSettings :: IO AppSettings
+newAppSettings = return ()
+
+{- Replace the above code with this comment block for database, templates and
+ - session support. Don't forget to uncomment the relevant packages in the
+ - cabal file and the import statements at the top of this file.
+
+data AppSettings = AppSettings { appDB :: PostgreSQLConn
+ , appSession :: Maybe Session }
+
+newAppSettings :: IO AppSettings
+newAppSettings = do
+ db <- createPostgreSQLConn
+ return $ AppSettings { appDB = db , appSession = Nothing }
+
+instance HasPostgreSQL AppSettings where
+ postgreSQLConn = appDB
+
+instance HasSession AppSettings where
+ getSession = appSession
+ setSession sess = do
+ cs <- controllerState
+ putState $ cs { appSession = Just sess }
+
+instance HasTemplates AppSettings where
+ defaultLayout = Just <$> getTemplate "templates/main.html"
+
+-}
+
diff --git a/template/Main_hs.tmpl b/template/Main_hs.tmpl
--- a/template/Main_hs.tmpl
+++ b/template/Main_hs.tmpl
@@ -1,17 +1,14 @@
{-# LANGUAGE OverloadedStrings #-}
module Main where
-import Web.Simple
-import Network.Wai.Handler.Warp
-import System.Posix.Env
-app runner = do
- -- TODO: App initialization code goes here
- runner $ controllerApp () $ do
- -- TODO: routes go here
- respond $ okHtml "Hello World"
+import Application
+import Network.Wai.Handler.Warp
+import Network.Wai.Middleware.RequestLogger
+import System.Environment
main :: IO ()
main = do
- port <- read `fmap` getEnvDefault "PORT" "3000"
- app (run port)
+ env <- getEnvironment
+ let port = maybe 3000 read $ lookup "PORT" env
+ app (run port . logStdout)
diff --git a/template/index_html.tmpl b/template/index_html.tmpl
new file mode 100644
--- /dev/null
+++ b/template/index_html.tmpl
@@ -0,0 +1,1 @@
+Welcome to your new app! This file lives in "e;views/index.html"e;
diff --git a/template/main_html.tmpl b/template/main_html.tmpl
new file mode 100644
--- /dev/null
+++ b/template/main_html.tmpl
@@ -0,0 +1,28 @@
+
+
+
+
+ {{name}}
+
+
+
+
+$yield$
+
+
diff --git a/template/package_cabal.tmpl b/template/package_cabal.tmpl
--- a/template/package_cabal.tmpl
+++ b/template/package_cabal.tmpl
@@ -1,4 +1,4 @@
-name: {{pkgname}}
+name: {{module}}
version: 0.0.0.0
--author: YOUR NAME
--maintainer: your@email.com
@@ -6,13 +6,17 @@
build-type: Simple
cabal-version: >=1.8
-executable {{pkgname}}
+executable {{appname}}
main-is: Main.hs
ghc-options: -threaded -O2
build-depends:
base
- , simple >= 0.5.0
- , unix
+ , simple >= 0.6.0
, wai
+ , wai-extra
, warp
+ -- uncomment for database, session and template support
+ -- , simple-postgresql-orm
+ -- , simple-session
+ -- , simple-templates