simple-1.0.0/src/0000755000000000000000000000000013644662024011765 5ustar0000000000000000simple-1.0.0/src/Web/0000755000000000000000000000000013644650606012505 5ustar0000000000000000simple-1.0.0/src/Web/Simple/0000755000000000000000000000000013644671545013743 5ustar0000000000000000simple-1.0.0/src/Web/Simple/Controller/0000755000000000000000000000000013644671546016067 5ustar0000000000000000simple-1.0.0/template/0000755000000000000000000000000013644642616013016 5ustar0000000000000000simple-1.0.0/test/0000755000000000000000000000000013644642616012162 5ustar0000000000000000simple-1.0.0/src/Web/Simple.hs0000644000000000000000000002175412356347745014311 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {- | /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 Web.Simple.Controller.Exception , module Web.Simple.Static , module Network.Wai -- * Overview -- $Overview -- * Tutorial -- $Tutorial -- ** Controllers -- $Controllers -- ** Routing -- $Routing ) where import Network.Wai import Web.Simple.Responses import Web.Simple.Controller import Web.Simple.Controller.Exception import Web.Simple.Static {- $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. -} simple-1.0.0/src/Web/Simple/Auth.hs0000644000000000000000000000517612310231135015161 0ustar0000000000000000{-# 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) simple-1.0.0/src/Web/Simple/Controller.hs0000644000000000000000000002156513644660753016432 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-} {-# 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, T.ControllerT(..) , controllerApp, controllerState, putState , request, localRequest, respond , requestHeader -- * Common Routes , routeHost, routeTop, routeMethod, routeAccept , routePattern, routeName, routeVar -- * Inspecting query , T.Parseable , queryParam, queryParam', queryParams , readQueryParam, readQueryParam', readQueryParams , parseForm -- * Redirection via referrer , redirectBack , redirectBackOr -- * Exception handling , T.ControllerException -- * Low-level utilities , body , hoistEither ) where import Control.Monad.IO.Class import Blaze.ByteString.Builder import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Text (Text) import Network.HTTP.Types import Network.Wai import Network.Wai.Parse import Web.Simple.Controller.Trans (ControllerT) import qualified Web.Simple.Controller.Trans as T import Web.Simple.Responses -- | 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'. type Controller s = ControllerT s IO hoistEither :: Either Response a -> Controller s a hoistEither = T.hoistEither -- | Extract the request request :: Controller s Request request = T.request -- | Modify the request for the given computation localRequest :: (Request -> Request) -> Controller s a -> Controller s a localRequest = T.localRequest -- | Extract the application-specific state controllerState :: Controller s s controllerState = T.controllerState putState :: s -> Controller s () putState = T.putState -- | Convert the controller into an 'Application' controllerApp :: s -> Controller s a -> Application controllerApp s ctrl req responseFunc = do resp <- T.controllerApp s ctrl req responseFunc resp -- | Provide a response -- -- @respond r >>= f === respond r@ respond :: Response -> Controller s a respond = T.respond -- | Matches on the hostname from the 'Request'. The route only succeeds on -- exact matches. routeHost :: S.ByteString -> Controller s a -> Controller s () routeHost = T.routeHost -- | 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 s a -> Controller s () routeTop = T.routeTop -- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT') routeMethod :: StdMethod -> Controller s a -> Controller s () routeMethod = T.routeMethod -- | Matches if the request's Content-Type exactly matches the given string routeAccept :: S8.ByteString -> Controller s a -> Controller s () routeAccept = T.routeAccept -- | 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 :: Text -> Controller s a -> Controller s () routePattern = T.routePattern -- | Matches if the first directory in the path matches the given 'ByteString' routeName :: Text -> Controller s a -> Controller s () routeName = T.routeName -- | 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 :: Text -> Controller s a -> Controller s () routeVar = T.routeVar -- -- 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 :: T.Parseable a => S8.ByteString -- ^ Parameter name -> Controller s (Maybe a) queryParam = T.queryParam -- | Like 'queryParam', but throws an exception if the parameter is not present. queryParam' :: T.Parseable a => S.ByteString -> Controller s a queryParam' = T.queryParam' -- | Selects all values with the given parameter name queryParams :: T.Parseable a => S.ByteString -> Controller s [a] queryParams = T.queryParams -- | 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 s (Maybe a) readQueryParam = T.readQueryParam -- | Like 'readQueryParam', but throws an exception if the parameter is not present. readQueryParam' :: Read a => S8.ByteString -- ^ Parameter name -> Controller s a readQueryParam' = T.readQueryParam' -- | 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 s [a] readQueryParams = T.readQueryParams -- | 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. -- -- @ -- myControllerT = 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 s ([Param], [(S.ByteString, FileInfo L.ByteString)]) parseForm = do req <- request liftIO $ parseRequestBody lbsBackEnd req -- | Reads and returns the body of the HTTP request. body :: Controller s L8.ByteString body = do bodyProducer <- getRequestBodyChunk `fmap` request liftIO $ do result <- consume mempty bodyProducer return $ toLazyByteString result where consume bldr prod = do next <- prod if S.null next then return bldr else consume (mappend bldr (fromByteString next)) prod -- | Returns the value of the given request header or 'Nothing' if it is not -- present in the HTTP request. requestHeader :: HeaderName -> Controller s (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 s a 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 s a redirectBackOr def = do mrefr <- requestHeader "referer" case mrefr of Just refr -> respond $ redirectTo refr Nothing -> respond def {- $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?\" @ -} simple-1.0.0/src/Web/Simple/Controller/Exception.hs0000644000000000000000000000207012376211317020343 0ustar0000000000000000module Web.Simple.Controller.Exception where import qualified Control.Exception as E import Control.Monad.Trans.Control import Web.Simple.Controller onException :: Controller s a -> Controller s b -> Controller s a onException act handler = control $ \runInM -> do runInM act `E.onException` runInM handler finally :: Controller s a -> Controller s b -> Controller s a finally act next = control $ \runInM -> E.mask $ \restore -> do r <- restore (runInM act) `E.onException` (runInM next) _ <- runInM next return r bracket :: Controller s a -> (a -> Controller s b) -> (a -> Controller s c) -> Controller s c bracket aquire release act = control $ \runInM -> E.mask $ \restore -> do let release' a = runInM $ restoreM a >>= release a <- runInM aquire r <- (restore $ runInM $ restoreM a >>= act) `E.onException` release' a _ <- release' a return r handle :: E.Exception e => (e -> Controller s a) -> Controller s a -> Controller s a handle handler act = control $ \runInM -> do E.handle (runInM . handler) $ runInM act simple-1.0.0/src/Web/Simple/Controller/Trans.hs0000644000000000000000000003243513644661323017511 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE TypeFamilies #-} {- | 'ControllerT' 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: @ myControllerT = do ... if badLogin then redirectBack else ... @ -} module Web.Simple.Controller.Trans where import Control.Exception import Control.Monad hiding (guard) import Control.Monad.Base import Control.Monad.IO.Class import Control.Monad.Reader.Class import Control.Monad.State.Class import Control.Monad.Trans.Class import Control.Monad.Trans.Control import Control.Applicative import qualified Data.ByteString as S import qualified Data.ByteString.Char8 as S8 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 Web.Simple.Responses -- | The ControllerT Monad is both a State-like monad which, when run, computes -- either a 'Response' or a result. Within the ControllerT Monad, the remainder -- of the computation can be short-circuited by 'respond'ing with a 'Response'. newtype ControllerT s m a = ControllerT { runController :: s -> Request -> m (Either Response a, s) } instance Functor m => Functor (ControllerT s m) where fmap f (ControllerT act) = ControllerT $ \st0 req -> go `fmap` act st0 req where go (eaf, st) = case eaf of Left resp -> (Left resp, st) Right result -> (Right $ f result, st) instance (Monad m, Functor m) => Applicative (ControllerT s m) where pure = return (<*>) = ap instance Monad m => Monad (ControllerT s m) where return a = ControllerT $ \st _ -> return $ (Right a, st) (ControllerT act) >>= fn = ControllerT $ \st0 req -> do (eres, st) <- act st0 req case eres of Left resp -> return (Left resp, st) Right result -> do let (ControllerT fres) = fn result fres st req instance (Functor m, Monad m) => Alternative (ControllerT s m) where empty = respond notFound (<|>) = (>>) instance Monad m => MonadPlus (ControllerT s m) where mzero = respond notFound mplus = flip (>>) instance MonadTrans (ControllerT s) where lift act = ControllerT $ \st _ -> act >>= \r -> return (Right r, st) instance Monad m => MonadState s (ControllerT s m) where get = ControllerT $ \s _ -> return (Right s, s) put s = ControllerT $ \_ _ -> return (Right (), s) instance Monad m => MonadReader Request (ControllerT s m) where ask = ControllerT $ \st req -> return (Right req, st) local f (ControllerT act) = ControllerT $ \st req -> act st (f req) instance MonadIO m => MonadIO (ControllerT s m) where liftIO = lift . liftIO instance Monad m => MonadFail (ControllerT s m) where fail = err instance (Applicative m, Monad m, MonadBase m m) => MonadBase m (ControllerT s m) where liftBase = liftBaseDefault instance MonadBaseControl m m => MonadBaseControl m (ControllerT s m) where type StM (ControllerT s m) a = (Either Response a, s) liftBaseWith fn = ControllerT $ \st req -> do res <- fn $ \act -> runController act st req return (Right res, st) restoreM (a, s) = ControllerT $ \_ _ -> return (a, s) hoistEither :: Monad m => Either Response a -> ControllerT s m a hoistEither eith = ControllerT $ \st _ -> return (eith, st) -- | Extract the request request :: Monad m => ControllerT s m Request request = ask -- | Modify the request for the given computation localRequest :: Monad m => (Request -> Request) -> ControllerT s m a -> ControllerT s m a localRequest = local -- | Extract the application-specific state controllerState :: Monad m => ControllerT s m s controllerState = get putState :: Monad m => s -> ControllerT s m () putState = put -- | Convert the controller into an 'Application' controllerApp :: Monad m => s -> ControllerT s m a -> SimpleApplication m controllerApp s ctrl req = runController ctrl s req >>= either return (const $ return notFound) . fst -- | Provide a response -- -- @respond r >>= f === respond r@ respond :: Monad m => Response -> ControllerT s m a respond resp = hoistEither $ Left resp -- | Lift an application to a controller fromApp :: Monad m => (Request -> m Response) -> ControllerT s m () fromApp app = do req <- request resp <- lift $ app req respond resp -- | Matches on the hostname from the 'Request'. The route only succeeds on -- exact matches. routeHost :: Monad m => S.ByteString -> ControllerT s m a -> ControllerT s m () routeHost host = guardReq $ \req -> Just host == requestHeaderHost req -- | 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 :: Monad m => ControllerT s m a -> ControllerT s m () routeTop = guardReq $ \req -> null (pathInfo req) || (T.length . head $ pathInfo req) == 0 -- | Matches on the HTTP request method (e.g. 'GET', 'POST', 'PUT') routeMethod :: Monad m => StdMethod -> ControllerT s m a -> ControllerT s m () routeMethod method = guardReq $ (renderStdMethod method ==) . requestMethod -- | Matches if the request's Content-Type exactly matches the given string routeAccept :: Monad m => S8.ByteString -> ControllerT s m a -> ControllerT s m () 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 :: Monad m => Text -> ControllerT s m a -> ControllerT s m () routePattern pattern route = let patternParts = decodePathSegments (T.encodeUtf8 pattern) in foldr mkRoute (route >> return ()) patternParts where mkRoute name = case T.uncons name of Just (':', varName) -> routeVar varName _ -> routeName name -- | Matches if the first directory in the path matches the given 'ByteString' routeName :: Monad m => Text -> ControllerT s m a -> ControllerT s m () routeName name next = do req <- request if (length $ pathInfo req) > 0 && name == (head . pathInfo) req then localRequest popHdr next >> return () else return () 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 :: Monad m => Text -> ControllerT s m a -> ControllerT s m () routeVar varName next = do req <- request case pathInfo req of [] -> return () x:_ | T.null x -> return () | otherwise -> localRequest popHdr next >> return () where popHdr req = req { pathInfo = (tail . pathInfo $ req) , queryString = (T.encodeUtf8 varName, Just (varVal req)):(queryString req)} varVal req = T.encodeUtf8 . 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 :: (Monad m, Parseable a) => S8.ByteString -- ^ Parameter name -> ControllerT s m (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' :: (Monad m, Parseable a) => S.ByteString -> ControllerT s m a queryParam' varName = queryParam varName >>= maybe (err $ "no parameter " ++ show varName) return -- | Selects all values with the given parameter name queryParams :: (Monad m, Parseable a) => S.ByteString -> ControllerT s m [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 :: (Monad m, Read a) => S8.ByteString -- ^ Parameter name -> ControllerT s m (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' :: (Monad m, Read a) => S8.ByteString -- ^ Parameter name -> ControllerT s m 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 :: (Monad m, Read a) => S8.ByteString -- ^ Parameter name -> ControllerT s m [a] readQueryParams varName = queryParams varName >>= mapM (readParamValue varName) readParamValue :: (Monad m, Read a) => S8.ByteString -> Text -> ControllerT s m 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 -- | Returns the value of the given request header or 'Nothing' if it is not -- present in the HTTP request. requestHeader :: Monad m => HeaderName -> ControllerT s m (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 :: Monad m => ControllerT s m () redirectBack = redirectBackOr (redirectTo "/") -- | Redirect back to the referer. If the referer header is not present -- fallback on the given 'Response'. redirectBackOr :: Monad m => Response -- ^ Fallback response -> ControllerT s m () redirectBackOr def = do mrefr <- requestHeader "referer" case mrefr of Just refr -> respond $ redirectTo refr Nothing -> respond def -- | Like 'Application', but with 'm' as the underlying monad type SimpleApplication m = Request -> m Response -- | Like 'Application', but with 'm' as the underlying monad type SimpleMiddleware m = SimpleApplication m -> SimpleApplication m -- guard guard :: Monad m => Bool -> ControllerT s m a -> ControllerT s m () guard b c = if b then c >> return () else return () guardM :: Monad m => ControllerT s m Bool -> ControllerT s m a -> ControllerT s m () guardM b c = b >>= flip guard c guardReq :: Monad m => (Request -> Bool) -> ControllerT s m a -> ControllerT s m () guardReq f = guardM (liftM f request) data ControllerException = ControllerException String deriving (Typeable) instance Show ControllerException where show (ControllerException msg) = "ControllerT: " ++ msg instance Exception ControllerException err :: String -> ControllerT s m a err = throw . 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 :: ControllerT () () mainAction = ... signinForm :: ControllerT () () signinForm req = ... login :: ControllerT () () login = ... updateProfile :: ControllerT () () 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?\" @ -} simple-1.0.0/src/Web/Simple/Responses.hs0000644000000000000000000001233112335001453016235 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings #-} -- | This module defines some convenience functions for creating responses. module Web.Simple.Responses ( ok, okHtml, okJson, okXml , 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") -- | Creates a 200 (OK) 'Response' with content-type \"application/xml\" and the -- given resposne body okXml :: L8.ByteString -> Response okXml = ok (S8.pack "application/xml") -- | 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"] simple-1.0.0/src/Web/Simple/Static.hs0000644000000000000000000000153613644642616015530 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Web.Simple.Static where import Control.Monad import Control.Monad.IO.Class import qualified Data.Text as T import Network.Wai import Network.HTTP.Types import Network.Mime import Web.Simple.Controller import System.Directory import System.FilePath serveStatic :: FilePath -> Controller a () serveStatic baseDir = do req <- request let fp = foldl () baseDir (map T.unpack $ pathInfo req) exists <- liftIO $ doesFileExist fp when exists $ do respond $ responseFile status200 [(hContentType, defaultMimeLookup $ T.pack $ takeFileName fp)] fp Nothing when (null $ takeExtension fp) $ do let fpIdx = fp "index.html" existsIdx <- liftIO $ doesFileExist fpIdx when existsIdx $ do respond $ responseFile status200 [(hContentType, "text/html")] fpIdx Nothing simple-1.0.0/src/Web/Simple/Templates.hs0000644000000000000000000001327413644642616016241 0ustar0000000000000000{-# LANGUAGE Trustworthy #-} {-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-} {-# LANGUAGE DefaultSignatures #-} module Web.Simple.Templates ( HasTemplates(..), render, renderPlain, renderLayout, renderLayoutTmpl , defaultGetTemplate, defaultFunctionMap, defaultLayoutObject , H.fromList , Function(..), ToFunction(..), FunctionMap ) where import Control.Monad.IO.Class import Data.Aeson import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L import qualified Data.HashMap.Strict as H import qualified Data.Text as T import Data.Text.Encoding import qualified Data.Vector as V import Network.Mime import System.FilePath import Web.Simple.Controller.Trans (ControllerT, respond) import Web.Simple.Responses (ok) import Web.Simple.Templates.Language class Monad m => HasTemplates m hs where -- | The layout to use by default. Layouts are just templates that embed -- views. They are rendered with the a global object containing the rendered -- view in the \"yield\" field, and the object the view was rendered with in -- the \"page\" field. By default, no template is used. defaultLayout :: ControllerT hs m (Maybe Template) defaultLayout = return Nothing -- | The directory to look for views passed to 'render'. This defaults to -- \"views\", so -- -- @ -- render \"index.html.tmpl\" ... -- @ -- -- will look for a view template in \"views/index.html.tmpl\". viewDirectory :: ControllerT hs m FilePath viewDirectory = return "views" -- | A map of pure functions that can be called from within a template. See -- 'FunctionMap' and 'Function' for details. functionMap :: ControllerT hs m FunctionMap functionMap = return defaultFunctionMap -- | Function to use to get a template. By default, it looks in the -- 'viewDirectory' for the given file name and compiles the file into a -- template. This can be overriden to, for example, cache compiled templates -- in memory. getTemplate :: FilePath -> ControllerT hs m Template default getTemplate :: MonadIO m => FilePath -> ControllerT hs m Template getTemplate = defaultGetTemplate -- | The `Value` passed to a layout given the rendered view template and the -- value originally passed to the view template. By default, produces an -- `Object` with "yield", containing the rendered view, and "page", containing -- the value originally passed to the view. layoutObject :: (ToJSON pageContent, ToJSON pageVal) => pageContent -> pageVal -> ControllerT hs m Value layoutObject = defaultLayoutObject defaultLayoutObject :: (HasTemplates m hs, ToJSON pageContent, ToJSON pageVal) => pageContent -> pageVal -> ControllerT hs m Value defaultLayoutObject pageContent pageVal = return $ object ["yield" .= pageContent, "page" .= pageVal] -- | Render a view using the layout named by the first argument. renderLayout :: (HasTemplates m hs, ToJSON a) => FilePath -> FilePath -> a -> ControllerT hs m () renderLayout lfp fp val = do layout <- getTemplate lfp viewDir <- viewDirectory view <- getTemplate (viewDir fp) let mime = defaultMimeLookup $ T.pack $ takeFileName fp renderLayoutTmpl layout view val mime -- | Same as 'renderLayout' but uses already compiled layouts. renderLayoutTmpl :: (HasTemplates m hs, ToJSON a) => Template -> Template -> a -> S.ByteString -> ControllerT hs m () renderLayoutTmpl layout view val mime = do fm <- functionMap let pageContent = renderTemplate view fm $ toJSON val value <- layoutObject pageContent val let result = renderTemplate layout fm value respond $ ok mime $ L.fromChunks . (:[]) . encodeUtf8 $ result -- | Renders a view template with the default layout and a global used to -- evaluate variables in the template. render :: (HasTemplates m hs , Monad m, ToJSON a) => FilePath -- ^ Template to render -> a -- ^ Aeson `Value` to pass to the template -> ControllerT hs m () render fp val = do mlayout <- defaultLayout case mlayout of Nothing -> renderPlain fp val Just layout -> do viewDir <- viewDirectory view <- getTemplate (viewDir fp) let mime = defaultMimeLookup $ T.pack $ takeFileName fp renderLayoutTmpl layout view val mime -- | Same as 'render' but without a template. renderPlain :: (HasTemplates m hs, ToJSON a) => FilePath -- ^ Template to render -> a -- ^ Aeson `Value` to pass to the template -> ControllerT hs m () renderPlain fp val = do fm <- functionMap dir <- viewDirectory tmpl <- getTemplate (dir fp) let pageContent = L.fromChunks . (:[]) . encodeUtf8 $ renderTemplate tmpl fm $ toJSON val let mime = defaultMimeLookup $ T.pack $ takeFileName fp respond $ ok mime pageContent defaultGetTemplate :: (HasTemplates m hs, MonadIO m) => FilePath -> ControllerT hs m Template defaultGetTemplate fp = do contents <- liftIO $ S.readFile fp case compileTemplate . decodeUtf8 $ contents of Left str -> fail str Right tmpl -> return tmpl defaultFunctionMap :: FunctionMap defaultFunctionMap = H.fromList [ ("length", toFunction valueLength) , ("null", toFunction valueNull)] valueLength :: Value -> Value valueLength (Array arr) = toJSON $ V.length arr valueLength (Object obj) = toJSON $ H.size obj valueLength (String str) = toJSON $ T.length str valueLength Null = toJSON (0 :: Int) valueLength _ = error "length only valid for arrays, objects and strings" valueNull :: Value -> Value valueNull (Array arr) = toJSON $ V.null arr valueNull (Object obj) = toJSON $ H.null obj valueNull (String str) = toJSON $ T.null str valueNull Null = toJSON True valueNull _ = error "null only valid for arrays, objects and strings" simple-1.0.0/src/Web/Frank.hs0000644000000000000000000000403213644650606014101 0ustar0000000000000000{-# LANGUAGE Safe #-} {- | 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 respond $ okHtml $ fromString $ \"Welcome Home \" ++ (show $ serverName req) get \"\/user\/:id\" $ do userId \<- queryParam \"id\" >>= fromMaybe \"\" respond $ ok \"text/json\" $ fromString $ \"{\\\"myid\\\": \" ++ (show userId) ++ \"}\" put \"\/user\/:id\" $ do ... @ -} module Web.Frank ( get , post , put , patch , delete , options ) where import Network.HTTP.Types import Web.Simple.Controller.Trans import Data.Text (Text) -- | Helper method frankMethod :: Monad m => StdMethod -> Text -> ControllerT s m a -> ControllerT s m () frankMethod method pattern = routeMethod method . routePattern pattern . routeTop -- | Matches the GET method on the given URL pattern get :: Monad m => Text -> ControllerT s m a -> ControllerT s m () get = frankMethod GET -- | Matches the POST method on the given URL pattern post :: Monad m => Text -> ControllerT s m a -> ControllerT s m () post = frankMethod POST -- | Matches the PUT method on the given URL pattern put :: Monad m => Text -> ControllerT s m a -> ControllerT s m () put = frankMethod PUT -- | Matches the PATCH method on the given URL pattern patch :: Monad m => Text -> ControllerT s m a -> ControllerT s m () patch = frankMethod PATCH -- | Matches the DELETE method on the given URL pattern delete :: Monad m => Text -> ControllerT s m a -> ControllerT s m () delete = frankMethod DELETE -- | Matches the OPTIONS method on the given URL pattern options :: Monad m => Text -> ControllerT s m a -> ControllerT s m () options = frankMethod OPTIONS simple-1.0.0/src/Web/REST.hs0000644000000000000000000000550513644650577013632 0ustar0000000000000000{-# LANGUAGE Safe, FlexibleInstances, OverloadedStrings #-} {- | REST is a DSL for creating routes using RESTful HTTP verbs. See -} module Web.REST ( REST(..), RESTController, rest, routeREST , index, show, create, update, delete , edit, new ) where import Prelude hiding (show) import Control.Monad.Trans.State import Data.Functor.Identity import Web.Simple.Responses import Web.Simple.Controller.Trans import Network.HTTP.Types -- | Type used to encode a REST controller. data REST m s = REST { restIndex :: ControllerT s m () , restShow :: ControllerT s m () , restCreate :: ControllerT s m () , restUpdate :: ControllerT s m () , restDelete :: ControllerT s m () , restEdit :: ControllerT s m () , restNew :: ControllerT s m () } -- | Default state, returns @404@ for all verbs. defaultREST :: Monad m => REST m s defaultREST = REST { restIndex = respond $ notFound , restShow = respond $ notFound , restCreate = respond $ notFound , restUpdate = respond $ notFound , restDelete = respond $ notFound , restEdit = respond $ notFound , restNew = respond $ notFound } -- | Monad used to encode a REST controller incrementally. type RESTControllerM m r a = StateT (REST m r) Identity a rest :: Monad m => RESTControllerM m r a -> REST m r rest rcontroller = snd . runIdentity $ runStateT rcontroller defaultREST routeREST :: Monad m => REST m s -> ControllerT s m () 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 m r = RESTControllerM m r () -- | GET \/ index :: ControllerT s m () -> RESTController m s index route = modify $ \controller -> controller { restIndex = route } -- | POST \/ create :: ControllerT s m () -> RESTController m s create route = modify $ \controller -> controller { restCreate = route } -- | GET \/:id\/edit edit :: ControllerT s m () -> RESTController m s edit route = modify $ \controller -> controller { restEdit = route } -- | GET \/new new :: ControllerT s m () -> RESTController m s new route = modify $ \controller -> controller { restNew = route } -- | GET \/:id show :: ControllerT s m () -> RESTController m s show route = modify $ \controller -> controller { restShow = route } -- | PUT \/:id update :: ControllerT s m () -> RESTController m s update route = modify $ \controller -> controller { restUpdate = route } -- | DELETE \/:id delete :: ControllerT s m () -> RESTController m s delete route = modify $ \controller -> controller { restDelete = route } simple-1.0.0/src/smpl.hs0000644000000000000000000001245013644661672013306 0ustar0000000000000000{-# LANGUAGE DeriveDataTypeable, OverloadedStrings #-} -- | The `smpl` utility for helping a user setup a Simple web project. module Main (main) where import Prelude hiding (writeFile, FilePath, all) import Control.Monad (when) import Data.Aeson import Data.Char import qualified Data.ByteString.Char8 as S8 import qualified Data.Text.Encoding as T import Data.Version import System.Console.CmdArgs import System.Directory import System.FilePath import System.Environment (getEnvironment) import System.SetEnv (setEnv) import System.Exit import System.Process import Web.Simple.Templates.Language import Paths_simple data Smpl = Server { port :: Int , moduleName :: String } | Create { appDir :: FilePath , includeTemplates :: Bool , includePostgresql :: Bool , includeSessions :: Bool , includeAll :: Bool } deriving (Show, Data, Typeable) main :: IO () main = do setEnv "ENV" "development" myenv <- getEnvironment let myport = maybe 3000 read $ lookup "PORT" myenv let develModes = modes [ Server { port = myport &= typ "PORT" , moduleName = "Application" &= typ "MODULE" &= explicit &= name "module" } &= auto &= help "Run a development server" &= details [ "You must have wai-handler-devel installed " ++ "to run this command"] , Create { appDir = "" &= argPos 0 &= typ "app_dir" , includeTemplates = False &= help "include templates" &= explicit &= name "templates" &= groupname "Plugins" , includePostgresql = False &= help "include postgresql-orm" &= explicit &= name "postgresql" , includeSessions = False &= help "include cookie-based sessions" &= explicit &= name "sessions" , includeAll = False &= help ("include templates, cookie-based " ++ "sessions and postgresql") &= explicit &= name "all"} &= help "Create a new application in app_dir"] smpl <- cmdArgsRun $ cmdArgsMode $ develModes &= (summary $ "Simple web framework " ++ (showVersion version)) 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 tmpls pg sess all -> createApplication dir (all || tmpls) (all || sess) (all || pg) 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 -> Bool -> Bool -> Bool -> IO () createApplication dir tmpls sessions postgresql = do let myAppName = takeBaseName $ dropTrailingPathSeparator dir modName = moduleCase myAppName mappings = object [ "appname" .= myAppName , "name" .= humanize myAppName , "module" .= modName , "include_templates" .= tmpls , "include_sessions" .= sessions , "include_postgresql" .= postgresql] createDirectory dir 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" "Common_hs.tmpl") (dir modName "Common.hs") mappings when postgresql $ do createDirectory $ dir "db" createDirectory $ dir "db" "migrations" when tmpls $ do createDirectory $ dir "views" createDirectory $ dir "layouts" copyTemplate ("template" "main_html.tmpl") (dir "layouts" "main.html") mappings copyTemplate ("template" "index_html.tmpl") (dir "views" "index.html") mappings copyTemplate :: FilePath -> FilePath -> Value -> IO () copyTemplate orig target mappings = do etmpl <- compileTemplate <$> T.decodeUtf8 <$> (S8.readFile =<< getDataFileName orig) case etmpl of Left err -> fail err Right tmpl -> S8.writeFile target $ T.encodeUtf8 $ renderTemplate tmpl mempty mappings simple-1.0.0/test/Spec.hs0000644000000000000000000001115013644642616013406 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Control.Monad import Control.Monad.IO.Class import Control.Monad.Trans import Control.Monad.Trans.Control import Test.Hspec import Test.Hspec.Contrib.HUnit import Network.Wai import Web.Simple.Controller.Trans import Web.Simple.Responses main :: IO () main = hspec $ do describe "ControllerT#routeName" $ do it "matches route when name is correct" $ do let ctrl = do routeName "hello" $ respond $ okHtml "" lift $ expectationFailure "Path should have matched" controllerApp () ctrl $ defaultRequest { pathInfo = ["hello"] } return () it "doesn't match route when name is incorrect" $ do let ctrl = do routeName "yello" $ lift $ expectationFailure "Path should have matched" controllerApp () ctrl $ defaultRequest { pathInfo = ["hello"] } return () it "doesn't match route when path is empty" $ do let ctrl = do routeName "yello" $ lift $ expectationFailure "Path should have matched" controllerApp () ctrl $ defaultRequest { pathInfo = [] } return () it "pops one directory from pathInfo when inside block" $ do let ctrl = do routeName "hello" $ do pi <- pathInfo `fmap` request lift $ pi `shouldBe` ["world"] pi <- pathInfo `fmap` request lift $ pi `shouldBe` ["hello", "world"] controllerApp () ctrl $ defaultRequest { pathInfo = ["hello", "world"] } return () describe "ControllerT#routeVar" $ do it "matches route if pathInfo not empty" $ do let ctrl = do routeVar "hello" $ respond $ okHtml "" lift $ expectationFailure "Path should have matched" controllerApp () ctrl $ defaultRequest { pathInfo = ["blarg"] } return () it "doesn't match route when path is empty" $ do let ctrl = do routeVar "yello" $ lift $ expectationFailure "Path should have matched" controllerApp () ctrl $ defaultRequest { pathInfo = [] } return () it "queues value of first path directory in query param" $ do let ctrl = do routeVar "foo" $ do qs <- queryParam "foo" lift $ qs `shouldBe` Just ("hello" :: String) controllerApp () ctrl $ defaultRequest { pathInfo = ["hello", "world"] } return () it "pops one directory from pathInfo when inside block" $ do let ctrl = do routeVar "foo" $ do pi <- pathInfo `fmap` request lift $ pi `shouldBe` ["world"] pi <- pathInfo `fmap` request lift $ pi `shouldBe` ["hello", "world"] controllerApp () ctrl $ defaultRequest { pathInfo = ["hello", "world"] } return () describe "ControllerT#routeTop" $ do it "matches when path is empty" $ do let ctrl = do routeTop $ respond $ okHtml "Yey!" lift $ expectationFailure "Top should have matched" controllerApp () ctrl $ defaultRequest return () it "fails when path is not empty" $ do let ctrl = do routeTop $ lift $ expectationFailure "Top should not have matched" controllerApp () ctrl $ defaultRequest { pathInfo = ["blah"] } return () describe "ControllerT#routeHost" $ do it "matches when host header is the same" $ do let ctrl = do routeHost "www.example.com" $ respond $ okHtml "Yey!" lift $ expectationFailure "Host should have matched" controllerApp () ctrl $ defaultRequest { requestHeaderHost = Just "www.example.com" } return () it "fails when host header is not the same" $ do let ctrl = do routeHost "www.example2.com" $ do lift $ expectationFailure "Host should not have matched" controllerApp () ctrl $ defaultRequest { requestHeaderHost = Just "www.example.com" } return () it "fails when host header is not present" $ do let ctrl = do routeHost "www.example.com" $ do lift $ expectationFailure "Host should not have matched" controllerApp () ctrl $ defaultRequest { requestHeaderHost = Nothing } return () describe "MonadBaseControl instance" $ do it "Preserves state changes in inner block" $ do let expected = 1234 ctrl = do putState 555 res <- liftBaseWith $ \f -> do f $ putState expected restoreM res s <- snd `fmap` runController ctrl 0 defaultRequest s `shouldBe` expected simple-1.0.0/template/package_cabal.tmpl0000644000000000000000000000100313644642616016423 0ustar0000000000000000name: $appname$ version: 0.0.0.0 --author: YOUR NAME --maintainer: your@email.com category: Web build-type: Simple cabal-version: >=1.8 executable $appname$ main-is: Main.hs ghc-options: -threaded -O2 build-depends: base , simple >= 0.8.0 , wai , wai-extra , warp$if(include_sessions)$ , simple-session >= 0.8.0$endif$$if(include_postgresql)$ , simple-postgresql-orm >= 0.8.0 , postgresql-orm$endif$ simple-1.0.0/template/Main_hs.tmpl0000644000000000000000000000046012250447622015262 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Main where import Application import Network.Wai.Handler.Warp import Network.Wai.Middleware.RequestLogger import System.Environment main :: IO () main = do env <- getEnvironment let port = maybe 3000 read $$ lookup "PORT" env app (run port . logStdout) simple-1.0.0/template/index_html.tmpl0000644000000000000000000000011112250447622016030 0ustar0000000000000000Welcome to your new app! This file lives in "views/index.html" simple-1.0.0/template/Application_hs.tmpl0000644000000000000000000000064612252137377016654 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} module Application where import $module$.Common import Web.Simple $if(include_templates)$import Web.Simple.Templates$endif$ app :: (Application -> IO ()) -> IO () app runner = do settings <- newAppSettings runner $$ controllerApp settings $$ do routeTop $$ $if(include_templates)$render "index.html" ()$else$respond $$ okHtml "Hello World"$endif$ -- TODO: routes go here simple-1.0.0/template/Common_hs.tmpl0000644000000000000000000000224712347134057015635 0ustar0000000000000000$if(include_templates)${-# LANGUAGE MultiParamTypeClasses #-}$endif$ module $module$.Common where import Control.Applicative import Web.Simple $if(include_templates)$import Web.Simple.Templates$endif$ $if(include_sessions)$import Web.Simple.Session$endif$ $if(include_postgresql)$import Web.Simple.PostgreSQL$endif$ data AppSettings = AppSettings { $if(include_postgresql)$appDB :: PostgreSQLConn$if(include_sessions)$ , appSession :: Maybe Session$endif$$else$$if(include_sessions)$appSession :: Maybe Session$endif$$endif$ } newAppSettings :: IO AppSettings newAppSettings = do $if(include_postgresql)$db <- createPostgreSQLConn$endif$ return $$ AppSettings$if(include_postgresql)$ db$endif$$if(include_sessions)$ Nothing$endif$ $if(include_postgresql)$ instance HasPostgreSQL AppSettings where postgreSQLConn = appDB $endif$$if(include_sessions)$ instance HasSession AppSettings where getSession = appSession setSession sess = do cs <- controllerState putState $$ cs { appSession = Just sess } $endif$$if(include_templates)$ instance HasTemplates IO AppSettings where defaultLayout = Just <$$> getTemplate "layouts/main.html" $endif$ simple-1.0.0/template/main_html.tmpl0000644000000000000000000000073712250447622015663 0ustar0000000000000000 $name$

$name$

$$yield$$ simple-1.0.0/LICENSE0000644000000000000000000001674412243540600012204 0ustar0000000000000000 GNU LESSER GENERAL PUBLIC LICENSE Version 3, 29 June 2007 Copyright (C) 2007 Free Software Foundation, Inc. Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. This version of the GNU Lesser General Public License incorporates the terms and conditions of version 3 of the GNU General Public License, supplemented by the additional permissions listed below. 0. Additional Definitions. As used herein, "this License" refers to version 3 of the GNU Lesser General Public License, and the "GNU GPL" refers to version 3 of the GNU General Public License. "The Library" refers to a covered work governed by this License, other than an Application or a Combined Work as defined below. An "Application" is any work that makes use of an interface provided by the Library, but which is not otherwise based on the Library. Defining a subclass of a class defined by the Library is deemed a mode of using an interface provided by the Library. A "Combined Work" is a work produced by combining or linking an Application with the Library. The particular version of the Library with which the Combined Work was made is also called the "Linked Version". The "Minimal Corresponding Source" for a Combined Work means the Corresponding Source for the Combined Work, excluding any source code for portions of the Combined Work that, considered in isolation, are based on the Application, and not on the Linked Version. The "Corresponding Application Code" for a Combined Work means the object code and/or source code for the Application, including any data and utility programs needed for reproducing the Combined Work from the Application, but excluding the System Libraries of the Combined Work. 1. Exception to Section 3 of the GNU GPL. You may convey a covered work under sections 3 and 4 of this License without being bound by section 3 of the GNU GPL. 2. Conveying Modified Versions. If you modify a copy of the Library, and, in your modifications, a facility refers to a function or data to be supplied by an Application that uses the facility (other than as an argument passed when the facility is invoked), then you may convey a copy of the modified version: a) under this License, provided that you make a good faith effort to ensure that, in the event an Application does not supply the function or data, the facility still operates, and performs whatever part of its purpose remains meaningful, or b) under the GNU GPL, with none of the additional permissions of this License applicable to that copy. 3. Object Code Incorporating Material from Library Header Files. The object code form of an Application may incorporate material from a header file that is part of the Library. You may convey such object code under terms of your choice, provided that, if the incorporated material is not limited to numerical parameters, data structure layouts and accessors, or small macros, inline functions and templates (ten or fewer lines in length), you do both of the following: a) Give prominent notice with each copy of the object code that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the object code with a copy of the GNU GPL and this license document. 4. Combined Works. You may convey a Combined Work under terms of your choice that, taken together, effectively do not restrict modification of the portions of the Library contained in the Combined Work and reverse engineering for debugging such modifications, if you also do each of the following: a) Give prominent notice with each copy of the Combined Work that the Library is used in it and that the Library and its use are covered by this License. b) Accompany the Combined Work with a copy of the GNU GPL and this license document. c) For a Combined Work that displays copyright notices during execution, include the copyright notice for the Library among these notices, as well as a reference directing the user to the copies of the GNU GPL and this license document. d) Do one of the following: 0) Convey the Minimal Corresponding Source under the terms of this License, and the Corresponding Application Code in a form suitable for, and under terms that permit, the user to recombine or relink the Application with a modified version of the Linked Version to produce a modified Combined Work, in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source. 1) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (a) uses at run time a copy of the Library already present on the user's computer system, and (b) will operate properly with a modified version of the Library that is interface-compatible with the Linked Version. e) Provide Installation Information, but only if you would otherwise be required to provide such information under section 6 of the GNU GPL, and only to the extent that such information is necessary to install and execute a modified version of the Combined Work produced by recombining or relinking the Application with a modified version of the Linked Version. (If you use option 4d0, the Installation Information must accompany the Minimal Corresponding Source and Corresponding Application Code. If you use option 4d1, you must provide the Installation Information in the manner specified by section 6 of the GNU GPL for conveying Corresponding Source.) 5. Combined Libraries. You may place library facilities that are a work based on the Library side by side in a single library together with other library facilities that are not Applications and are not covered by this License, and convey such a combined library under terms of your choice, if you do both of the following: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities, conveyed under the terms of this License. b) Give prominent notice with the combined library that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 6. Revised Versions of the GNU Lesser General Public License. The Free Software Foundation may publish revised and/or new versions of the GNU Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library as you received it specifies that a certain numbered version of the GNU Lesser General Public License "or any later version" applies to it, you have the option of following the terms and conditions either of that published version or of any later version published by the Free Software Foundation. If the Library as you received it does not specify a version number of the GNU Lesser General Public License, you may choose any version of the GNU Lesser General Public License ever published by the Free Software Foundation. If the Library as you received it specifies that a proxy can decide whether future versions of the GNU Lesser General Public License shall apply, that proxy's public statement of acceptance of any version is permanent authorization for you to choose that version for the Library. simple-1.0.0/Setup.hs0000644000000000000000000000005612243540600012620 0ustar0000000000000000import Distribution.Simple main = defaultMain simple-1.0.0/simple.cabal0000644000000000000000000000633613644674772013500 0ustar0000000000000000name: simple version: 1.0.0 synopsis: A minimalist web framework for the WAI server interface description: \Simple\ is \"framework-less\" web framework for Haskell web applications based on the WAI server interface (e.g. for use with the warp server). \Simple\ does not enforce a particular structure or paradigm for web applications. Rather, \Simple\ contains tools to help you create your own patterns (or re-create existing ones). \Simple\ is minimalist, providing a lightweight base - the most basic \Simple\ app is little more than a WAI `Application` with some routing logic. Everything else (e.g. authentication, controllers, persistence, caching etc\') is provided in composable units, so you can include only the ones you need in your app, and easily replace with your own components. . To get started, create an app skeleton with the `smpl` utility: . @ $ cabal install simple $ smpl create my_app_name $ cd my_app_name $ smpl @ . See "Web.Simple" for a more detailed introduction. homepage: http://simple.cx Bug-Reports: http://github.com/alevy/simple/issues license: LGPL-3 license-file: LICENSE author: Amit Levy, Daniel B. Giffin maintainer: amit@amitlevy.com category: Web build-type: Simple cabal-version: >=1.10 extra-source-files: LICENSE CHANGELOG.md data-files: template/*.tmpl executable smpl hs-source-dirs: src Main-Is: smpl.hs ghc-options: -Wall -fno-warn-unused-do-bind default-language: Haskell2010 build-depends: base < 6 , aeson , attoparsec , bytestring , cmdargs , directory , filepath , process , setenv , simple-templates >= 1.0.0 , text , unordered-containers , vector other-modules: Paths_simple library hs-source-dirs: src build-depends: base < 6 , aeson , base64-bytestring , blaze-builder , bytestring , directory , filepath , mime-types , monad-control >= 1.0.0.0 , mtl , simple-templates >= 0.7.0 , wai >= 3.0 , wai-extra , http-types , text , transformers , transformers-base , unordered-containers , vector ghc-options: -Wall -fno-warn-unused-do-bind exposed-modules: Web.Simple, Web.Simple.Auth, Web.Simple.Controller, Web.Simple.Controller.Exception, Web.Simple.Controller.Trans, Web.Simple.Responses, Web.Simple.Static, Web.Simple.Templates, Web.Frank, Web.REST default-language: Haskell2010 test-suite test-simple type: exitcode-stdio-1.0 hs-source-dirs: test, src main-is: Spec.hs default-language: Haskell2010 build-depends: base < 6 , aeson , base64-bytestring , blaze-builder , bytestring , directory , filepath , mime-types , monad-control >= 1.0.0.0 , mtl , simple-templates >= 0.7.0 , wai >= 3.0 , wai-extra , http-types , hspec , hspec-contrib , text , transformers , transformers-base , unordered-containers , vector other-modules: Web.Simple.Controller.Trans, Web.Simple.Responses source-repository head type: git location: http://github.com/alevy/simple.git simple-1.0.0/CHANGELOG.md0000644000000000000000000000044513644642616013017 0ustar0000000000000000# Version 0.11.1 (2016-01-11) * Fixes test dependencies that precluded tests from compiling # Version 0.11.0.0 (2015-11-23) * Minimize methods in `HasTemplates` and extract everything else into functions * Add `layoutObject` method that allows customizing the value passed to the layout