) 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-0.11.2/src/Web/Simple/ 0000755 0000000 0000000 00000000000 13076744455 014026 5 ustar 00 0000000 0000000 simple-0.11.2/src/Web/Simple/Auth.hs 0000644 0000000 0000000 00000005176 13076744455 015274 0 ustar 00 0000000 0000000 {-# 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-0.11.2/src/Web/Simple/Controller.hs 0000644 0000000 0000000 00000021612 13076744455 016507 0 ustar 00 0000000 0000000 {-# 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.Monoid
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 <- requestBody `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-0.11.2/src/Web/Simple/Templates.hs 0000644 0000000 0000000 00000013274 13076744455 016327 0 ustar 00 0000000 0000000 {-# 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-0.11.2/src/Web/Simple/Responses.hs 0000644 0000000 0000000 00000012331 13076744455 016343 0 ustar 00 0000000 0000000 {-# 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-0.11.2/src/Web/Simple/Static.hs 0000644 0000000 0000000 00000001536 13076744455 015616 0 ustar 00 0000000 0000000 {-# 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-0.11.2/src/Web/Simple/Controller/ 0000755 0000000 0000000 00000000000 13076744455 016151 5 ustar 00 0000000 0000000 simple-0.11.2/src/Web/Simple/Controller/Exception.hs 0000644 0000000 0000000 00000002070 13076744455 020442 0 ustar 00 0000000 0000000 module 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-0.11.2/src/Web/Simple/Controller/Trans.hs 0000644 0000000 0000000 00000032331 13076744455 017576 0 ustar 00 0000000 0000000 {-# 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 (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?\"
@
-}