module Web.Twain ( -- * Twain to WAI twain, twain', twainApp, -- * Middleware and Routes. middleware, get, put, patch, post, delete, notFound, onException, addRoute, -- * Request and Parameters. env, param, param', paramMaybe, params, file, files, header, headers, request, -- * Responses. send, next, redirect301, redirect302, redirect303, text, html, json, xml, raw, status, withHeader, withCookie, withCookie', expireCookie, module Web.Twain.Types, module Network.HTTP.Types, ) where import Control.Exception (SomeException) import Data.Aeson (ToJSON) import qualified Data.Aeson as JSON import Data.ByteString.Char8 as Char8 import Data.ByteString.Lazy as BL import qualified Data.CaseInsensitive as CI import Data.Either.Combinators (rightToMaybe) import qualified Data.List as L import Data.Text as T import Data.Text.Encoding import Data.Time import Network.HTTP.Types import Network.Wai (Application, Middleware, Request, Response, mapResponseHeaders, mapResponseStatus, requestHeaders, responseLBS) import Network.Wai.Handler.Warp (Port, Settings, defaultSettings, runEnv, runSettings, setOnExceptionResponse, setPort) import Network.Wai.Parse (File, FileInfo, defaultParseRequestBodyOptions) import System.Environment (lookupEnv) import Web.Cookie import Web.Twain.Internal import Web.Twain.Types -- | Run a Twain app on `Port` using the given environment. -- -- If a PORT environment variable is set, it will take precendence. -- -- > twain 8080 "My App" $ do -- > middleware logger -- > get "/" $ do -- > appTitle <- env -- > send $ text ("Hello from " <> appTitle) -- > get "/greetings/:name" -- > name <- param "name" -- > send $ text ("Hello, " <> name) -- > notFound $ do -- > send $ status status404 $ text "Not Found" twain :: Port -> e -> TwainM e () -> IO () twain port env m = do mp <- lookupEnv "PORT" let p = maybe port read mp st = exec m env app = composeMiddleware $ middlewares st handler = onExceptionResponse st settings' = setOnExceptionResponse handler $ setPort p defaultSettings runSettings settings' app -- | Run a Twain app passing Warp `Settings`. twain' :: Settings -> e -> TwainM e () -> IO () twain' settings env m = do let st = exec m env app = composeMiddleware $ middlewares st settings' = setOnExceptionResponse (onExceptionResponse st) settings runSettings settings' app -- | Create a WAI `Application` from a Twain app and environment. twainApp :: e -> TwainM e () -> Application twainApp env m = composeMiddleware $ middlewares $ exec m env -- | Use the given middleware. The first declared is the outermost middleware -- (it has first access to request and last action on response). middleware :: Middleware -> TwainM e () middleware m = modify (\st -> st {middlewares = m : middlewares st}) get :: PathPattern -> RouteM e a -> TwainM e () get = addRoute (Just "GET") put :: PathPattern -> RouteM e a -> TwainM e () put = addRoute (Just "PUT") patch :: PathPattern -> RouteM e a -> TwainM e () patch = addRoute (Just "PATCH") post :: PathPattern -> RouteM e a -> TwainM e () post = addRoute (Just "POST") delete :: PathPattern -> RouteM e a -> TwainM e () delete = addRoute (Just "DELETE") -- | Add a route if nothing else is found. This matches any request, so it -- should go last. notFound :: RouteM e a -> TwainM e () notFound = addRoute Nothing (MatchPath (const (Just []))) -- | Render a `Response` on exceptions. onException :: (SomeException -> Response) -> TwainM e () onException handler = modify $ \st -> st {onExceptionResponse = handler} -- | Add a route matching `Method` (optional) and `PathPattern`. addRoute :: Maybe Method -> PathPattern -> RouteM e a -> TwainM e () addRoute method pat route = modify $ \st -> let m = routeMiddleware method pat route (environment st) in st {middlewares = m : middlewares st} -- | Get the app environment. env :: RouteM e e env = RouteM $ \st -> return $ Right (reqEnv st, st) -- | Get a parameter. Looks in query, path, cookie, and body (in that order). -- -- If no parameter is found, or parameter fails to parse, `next` is called -- which passes control to subsequent routes and middleware. param :: ParsableParam a => Text -> RouteM e a param name = do pM <- fmap snd . L.find ((==) name . fst) <$> params maybe next (either (const next) pure . parseParam) pM -- | Get a parameter or error if missing or parse failure. param' :: ParsableParam a => Text -> RouteM e (Either Text a) param' name = do pM <- fmap snd . L.find ((==) name . fst) <$> params return $ maybe (Left ("missing parameter: " <> name)) parseParam pM -- | Get an optional parameter. `Nothing` is returned for missing parameter or -- parse failure. paramMaybe :: ParsableParam a => Text -> RouteM e (Maybe a) paramMaybe name = do pM <- fmap snd . L.find ((==) name . fst) <$> params return $ maybe Nothing (rightToMaybe . parseParam) pM -- | Get all parameters from query, path, cookie, and body (in that order). params :: RouteM e [Param] params = fst <$> parseBody defaultParseRequestBodyOptions -- | Get uploaded `FileInfo`. file :: Text -> RouteM e (Maybe (FileInfo BL.ByteString)) file name = fmap snd . L.find ((==) (encodeUtf8 name) . fst) <$> files -- | Get all uploaded files. files :: RouteM e [File BL.ByteString] files = snd <$> parseBody defaultParseRequestBodyOptions -- | Get the value of a request `Header`. Header names are case-insensitive. header :: Text -> RouteM e (Maybe Text) header name = do let ciname = CI.mk (encodeUtf8 name) fmap (decodeUtf8 . snd) . L.find ((==) ciname . fst) <$> headers -- | Get the request headers. headers :: RouteM e [Header] headers = requestHeaders <$> request -- | Get the JSON value from request body. bodyJson :: JSON.FromJSON a => RouteM e (Either String a) bodyJson = do jsonE <- parseBodyJson case jsonE of Left e -> return (Left e) Right v -> case JSON.fromJSON v of JSON.Error e -> return (Left e) JSON.Success a -> return (Right a) -- | Get the WAI `Request`. request :: RouteM e Request request = reqWai <$> routeState -- | Send a `Response`. -- -- > send $ text "Hello, World!" -- -- Send an `html` response: -- -- > send $ html "