curryer (empty) → 0.1.0.0

raw patch · 10 files changed

+499/−0 lines, 10 filesdep +aesondep +basedep +blaze-htmlsetup-changed

Dependencies added: aeson, base, blaze-html, bytestring, case-insensitive, containers, cookie, http-types, mtl, regex-pcre, text, transformers, wai, warp

Files

• LICENSE +30/−0
• README.md +1/−0
• Setup.hs +2/−0
• curryer.cabal +44/−0
• src/Web/Curryer.hs +101/−0
• src/Web/Curryer/Handler.hs +43/−0
• src/Web/Curryer/Internal/Utils.hs +55/−0
• src/Web/Curryer/Request.hs +110/−0
• src/Web/Curryer/Response.hs +71/−0
• src/Web/Curryer/Types.hs +42/−0

@@ -0,0 +1,30 @@+Copyright Chris Penner (c) 2017++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Chris Penner nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,1 @@+# curryer

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,44 @@+name:                curryer+version:             0.1.0.0+synopsis:            A simple HTTP server framework+-- description:+homepage:            https://github.com/ChrisPenner/curryer#readme+license:             BSD3+license-file:        LICENSE+author:              Chris Penner+maintainer:          christopher.penner@gmail.com+copyright:           2017 Chris Penner+category:            Web+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  ghc-options:         -Wall+  exposed-modules:     Web.Curryer+                       Web.Curryer.Handler+                       Web.Curryer.Response+                       Web.Curryer.Request+                       Web.Curryer.Internal.Utils+                       Web.Curryer.Types++  build-depends:       base >= 4.7 && < 5+                     , wai+                     , warp+                     , cookie+                     , mtl+                     , http-types+                     , bytestring+                     , text+                     , containers+                     , case-insensitive+                     , transformers+                     , regex-pcre+                     , blaze-html+                     , aeson+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/ChrisPenner/curryer

@@ -0,0 +1,101 @@+{-# language RankNTypes #-}+{-# language FlexibleContexts #-}+{-# language OverloadedStrings #-}+{-# language FlexibleInstances #-}+{-# language TypeApplications #-}+module Web.Curryer+  ( -- * Curryer Server+  run+  -- * Types+  , App+  , Handler++  -- * Handlers+  , route++  -- * Requests+  , getPath+  , getPathInfo+  , getMethod+  , getQueryString+  , getQueries+  , getQueriesMulti+  , getQuery+  , getQueryMulti+  , getHeaders+  , getBody+  , getCookies+  , getCookieMulti+  , getCookie+  , isSecure+  , waiRequest++  -- * Responses+  , ToResponse(..)+  , respond++  -- ** Wrapper Types+  , Json(..)++  -- * Utilities+  , addMiddleware++  -- * Exports+  -- | Re-exported types for your convenience+  , module Network.HTTP.Types.Status+  ) where++import qualified Network.Wai.Handler.Warp as W+import qualified Network.Wai as W+import Network.HTTP.Types.Status++import Control.Monad.Reader+import Control.Monad.Except++import qualified Data.Text as T++import Web.Curryer.Handler+import Web.Curryer.Request+import Web.Curryer.Response+import Web.Curryer.Types+import Web.Curryer.Internal.Utils++-- | Run an http server on the given port.+--+-- > -- Run app on port 3000+-- > main :: IO ()+-- > main = run 3000 app+run :: W.Port -> App () -> IO ()+run port app = W.run port warpApp+  where+    warpApp :: W.Request -> (W.Response -> IO W.ResponseReceived) -> IO W.ResponseReceived+    warpApp req resp = runCurryer app req >>= resp++-- | Run the app monad on a wai request to obtain a wai response+runCurryer :: App () -> W.Request -> IO W.Response+runCurryer app req = either id (const notFoundResp) <$> runExceptT unpackApp+  where+    unpackApp = do+      reqBody <- fmap fromLBS . liftIO $ W.strictRequestBody req+      runReaderT app ReqContext{request=req, requestBody=reqBody}++-- | Default 404 response+notFoundResp :: W.Response+notFoundResp = toResponse @(T.Text, Status) ("Not Found", notFound404)++-- | Run actions before your handlers and/or perform actions+-- following the response.+--+-- @after@ will only be run if a response is provided from some handler+addMiddleware :: App W.Request+              -- ^ The Action to run before a 'W.Request' is processed.+              -- The modified request which is returned will be passed to the app.+              -> (W.Response -> App W.Response)+              -- ^ Transform a 'W.Response' before it's sent+              -> App ()+              -- ^ The 'App' to wrap with middleware+              -> App ()+addMiddleware before after app = pre `catchError` post+  where+    post resp = after resp >>= throwError+    pre = before >>= \req -> local (\ctx -> ctx{request=req}) app

@@ -0,0 +1,43 @@+{-# language OverloadedStrings #-}+{-# language FlexibleContexts #-}+{-# language RankNTypes #-}+{-# language ViewPatterns #-}+module Web.Curryer.Handler+  ( route+  ) where++import Web.Curryer.Types+import Web.Curryer.Request+import Web.Curryer.Response+import Control.Monad+import Control.Monad.Trans+import qualified Data.Text as T++import Text.Regex.PCRE++-- | Run a handler on a matching route.+-- The handler may return any type which implements 'ToResponse'+--+-- If a route matches any actions following it in the App monad will not be run.+--+-- Route patterns support pcre regex but do not yet support url parameters.+--+-- In the following example if we call @helloHarry@ then the @helloHandler@+-- will run, but NOT the helloHarryHandler since a matching route+-- ceases further execution.+-- For this reason the order you define your routes in matters.+--+-- > app :: App ()+-- > app = do+-- >   route "/" indexHandler+-- >   route "/hello.*" helloHandler+-- >   route "/helloHarry" helloHarryHandler+route :: (ToResponse r) => Pattern -> Handler r -> App ()+route routePath handler = do+  path <- getPath+  liftIO . print $ "checking" `T.append` routePath+  when (routePath `matches` path) (handler >>= respond . toResponse)++-- | Determine whether a route matches a pattern+matches :: Route -> Pattern -> Bool+matches (T.unpack -> rt) (T.unpack -> pat) = ("^" ++ pat ++ "$") =~ rt

@@ -0,0 +1,55 @@+{-# language OverloadedStrings #-}+module Web.Curryer.Internal.Utils where++import Data.Bifunctor+import Data.Maybe+import qualified Data.Map as M+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import qualified Data.CaseInsensitive as CI++import qualified Network.HTTP.Types.Header as HTTP+import Network.HTTP.Types.URI++import Web.Curryer.Types++toBS :: T.Text -> BS.ByteString+toBS = T.encodeUtf8++toLBS :: T.Text -> LBS.ByteString+toLBS = LT.encodeUtf8 . LT.fromStrict++fromBS :: BS.ByteString -> T.Text+fromBS = T.decodeUtf8++fromLBS :: LBS.ByteString -> T.Text+fromLBS = LT.toStrict . LT.decodeUtf8++mkHeader :: T.Text -> T.Text -> HTTP.Header+mkHeader headerName headerVal = (CI.mk (toBS headerName), toBS headerVal)++convertHeaders :: HTTP.RequestHeaders -> HeaderMap+convertHeaders = M.fromListWith mappend . fmap (bimap mapName mapVal)+  where+    mapName = CI.map fromBS+    mapVal val = [fromBS val]++fromHeaderMap :: HeaderMap -> HTTP.ResponseHeaders+fromHeaderMap hm = do+  (headerName, values) <- M.toList hm+  [(CI.map toBS headerName, toBS value) | value <- values]++qsToList :: Query -> [(T.Text, Maybe T.Text)]+qsToList = fmap (bimap fromBS (fmap fromBS))++-- Get all occurances of query params+convertQueries :: Query -> MultiQueryMap+convertQueries = M.fromListWith (flip mappend) . fmap (second maybeToList) . qsToList++-- | Get last occurrance of each query param+simpleQuery :: Query -> QueryMap+simpleQuery = M.fromListWith (flip const) . fmap (second (fromMaybe "")) . qsToList

@@ -0,0 +1,110 @@+{-# language OverloadedStrings #-}+{-# language FlexibleContexts #-}+{-# language ConstraintKinds #-}+{-# language RankNTypes #-}+module Web.Curryer.Request+  ( getPath+  , getPathInfo+  , getMethod+  , getQueryString+  , getQueries+  , getQueriesMulti+  , getQuery+  , getQueryMulti+  , getHeaders+  , getBody+  , getCookies+  , getCookieMulti+  , getCookie+  , isSecure+  , waiRequest+  ) where++import Control.Monad.Reader+import Data.Maybe+import Data.Bifunctor+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.CaseInsensitive as CI++import Web.Cookie+import qualified Network.Wai as W++import Web.Curryer.Internal.Utils+import Web.Curryer.Types++type ReqReader m = MonadReader ReqContext m++fromReq :: ReqReader m => (W.Request -> a) -> m a+fromReq getter = asks (getter . request)++-- | Calls through to 'W.rawPathInfo'; returns the full path of the current+-- request (without the query string)+getPath :: ReqReader m => m T.Text+getPath = fromBS <$> fromReq W.rawPathInfo++-- | Gets the HTTP method of the current request+getMethod :: ReqReader m => m T.Text+getMethod = fromBS <$> fromReq W.requestMethod++-- | Calls through to 'W.rawQueryString'; returns the full path of the current+-- request (without the query string)+getQueryString :: ReqReader m => m T.Text+getQueryString = fromBS <$> fromReq W.rawQueryString++-- | Gets full body of the request+getBody  :: ReqReader m => m T.Text+getBody = asks requestBody++-- | Gets the headers of the request+getHeaders :: ReqReader m => m HeaderMap+getHeaders = convertHeaders <$> fromReq W.requestHeaders++-- | Gets all key/values from the query string+getQueriesMulti :: ReqReader m => m MultiQueryMap+getQueriesMulti = convertQueries <$> fromReq W.queryString++-- | Get the last set value for each query+--+-- If a query is set without a value (e.g. "/?key") it will appear in the+-- map with a value of @""@+getQueries :: ReqReader m => m QueryMap+getQueries = simpleQuery <$>fromReq W.queryString++-- | Get the value for a given query. A query which was passed without a value+-- (e.g. "/?key") will return @Just ""@+getQuery :: ReqReader m => T.Text -> m (Maybe T.Text)+getQuery key = M.lookup key <$> getQueries++-- | Gets all values provided for a given query key+getQueryMulti :: ReqReader m => T.Text -> m [T.Text]+getQueryMulti key = fromMaybe [] . M.lookup key <$> getQueriesMulti++-- | Gets a map of cookies sent with the request.+getCookies :: ReqReader m => m (M.Map T.Text [T.Text])+getCookies = do+  headers <- getHeaders+  return $ case M.lookup (CI.mk "Cookie") headers of+             Just [cookieHeader] -> M.fromListWith mappend . fmap (second (:[])) . parseCookiesText . toBS $ cookieHeader+             _ -> M.empty++-- | Get all values set for a specific cookie+getCookieMulti :: ReqReader m => T.Text -> m [T.Text]+getCookieMulti key = fromMaybe [] . M.lookup key <$> getCookies++-- | Get the value for a cookie if it is set+getCookie :: ReqReader m => T.Text -> m (Maybe T.Text)+getCookie key = listToMaybe <$> getCookieMulti key++-- | Calls through to 'W.isSecure'+isSecure :: ReqReader m => m Bool+isSecure = fromReq W.isSecure++-- | Calls through to 'W.pathInfo'.+-- Returns the path's individual '/' separated chunks. '+getPathInfo :: ReqReader m => m [T.Text]+getPathInfo = fromReq W.pathInfo++-- | Exposes the underlying 'W.Request'.+waiRequest :: ReqReader m =>  m W.Request+waiRequest = asks request

@@ -0,0 +1,71 @@+{-# language FlexibleInstances #-}+{-# language OverloadedStrings #-}+{-# language UndecidableInstances #-}+module Web.Curryer.Response+  ( ToResponse(..)+  , Json(..)+  , respond+  ) where++import Data.Function ((&))+import Control.Monad.Except+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import Data.Aeson as Aeson++import Network.Wai as W+import Network.HTTP.Types.Status++import Text.Blaze.Html (Html)+import Text.Blaze.Html.Renderer.Text (renderHtml)++import Web.Curryer.Internal.Utils+import Web.Curryer.Types++-- | A simple newtype wrapper you can use to wrap values, signifying+-- they should be JSON encoded sent with the "application/json"+-- Content-Type.+newtype Json a = Json a+  deriving Show++-- | This class represents all types which can be converted into a valid+-- 'W.Response'. Feel free to implement additional instances for your own+-- data-types.+class ToResponse c where+  toResponse :: c -> W.Response++instance ToResponse String where+  toResponse = mkResponse ok200 "text/plain" . T.pack++instance ToResponse T.Text where+  toResponse = mkResponse ok200 "text/plain"++instance ToResponse Html where+  toResponse = mkResponse ok200 "text/html" . TL.toStrict . renderHtml++instance ToResponse Aeson.Value where+  toResponse = mkResponse ok200 "application/json" . fromLBS . encode++instance (ToJSON a) => ToResponse (Json a) where+  toResponse (Json obj) = toResponse (toJSON obj)++instance ToResponse W.Response where+  toResponse = id++instance (ToResponse b) => ToResponse (b, Status) where+  toResponse (b, status) = toResponse (b, status, mempty :: HeaderMap)++instance (ToResponse b) => ToResponse (b, Status, HeaderMap) where+  toResponse (b, status, hm) =+        toResponse b+      & mapResponseStatus (const status)+      & mapResponseHeaders (++ fromHeaderMap hm)++mkResponse :: Status -> ContentType -> T.Text -> W.Response+mkResponse status contentType body =+  W.responseLBS status [mkHeader "Content-Type" contentType] (toLBS body)++-- | Respond to the client immediately. Any statements following this one+-- in the App or Handler Monads will not be run.+respond :: ToResponse r => r -> App ()+respond =  throwError . toResponse

@@ -0,0 +1,42 @@+module Web.Curryer.Types where++import Control.Monad.Reader+import Control.Monad.Except+import Network.Wai as W+import qualified Data.Text as T+import qualified Data.Map as M+import qualified Data.CaseInsensitive as CI++-- | The main application definiton monad, sequence your+-- route handlers and/or middleware in this monad+type App a = ReaderT ReqContext (ExceptT W.Response IO) a++-- | Handler is an alias for 'App', currently provided for semantic reasons,+-- but the two may diverge in the future.+type Handler a = App a++-- | A regex pattern for route matching.+type Pattern = T.Text++-- | A route as Text+type Route = T.Text++-- | A map of case insensitive header names to all provided values for that+-- header.+type HeaderMap = M.Map (CI.CI T.Text) [T.Text]++-- | A map of query parameter names to all values provided for that parameter+type MultiQueryMap = M.Map T.Text [T.Text]++-- | A map of query parameter names to the last-provided value for that+-- parameter+type QueryMap = M.Map T.Text T.Text++-- | A request or response's Content-Type value+type ContentType = T.Text++-- | Context provided when handling any request+data ReqContext = ReqContext+  { requestBody :: T.Text+  , request :: W.Request+  }