diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,63 @@ +# Webby + +An easy to use Haskell web-server inspired by Scotty. + +# Build + +Clone the repo and run `stack build` + +# Example + +``` haskell +module Main where + +import qualified Data.Text as T +import qualified Network.Wai.Handler.Warp as W +import UnliftIO (liftIO) +import qualified UnliftIO.Exception as E + +import Webby + +main :: IO () +main = do + let routes = [ get "/api/a" (text "a") + , get "/api/b" (text "b") + , post "/api/capture/:id" (do idVal :: Int <- getCapture "id" + text $ T.pack $ show idVal + ) + , get "/api/showEnv" (do env <- getAppEnv + json env + ) + , get "/aaah" (liftIO $ E.throwString "oops!") + ] + + webbyApp <- mkWebbyApp (3::Int) routes + putStrLn "Starting webserver..." + W.runEnv 7000 webbyApp +``` + +You can try the example above, by cloning the repo and running the +example: + +``` shell +$ examples/Basic.hs +``` + +In another shell, let's `curl` the server: + +``` shell +$ curl http://localhost:7000/api/a +a +$ curl http://localhost:7000/api/b +b +$ curl -XPOST http://localhost:7000/api/capture/32 +32 +$ curl http://localhost:7000/api/showEnv +MyEnv +$ curl http://localhost:7000/aaah +Control.Exception.Safe.throwString called with: + +oops! +Called from: + throwString (examples/Basic.hs:32:42 in main:Main) +``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Webby.hs b/src/Webby.hs new file mode 100644 --- /dev/null +++ b/src/Webby.hs @@ -0,0 +1,53 @@ +module Webby + ( WebbyM + + -- * Routing and handler functions + , RoutePattern + , Routes + , mkRoute + , post + , get + , put + + -- * Captures + , Captures + , captures + , getCapture + + -- * Request parsing + , flag + , header + , headers + , jsonData + , param + , param_ + , params + , request + , requestBodyLength + + -- * Response modification + , setStatus + , addHeader + , setHeader + , blob + , json + , text + , stream + + -- * Application + , mkWebbyApp + + -- * Application context + , WEnv + , getAppEnv + , runAppEnv + + -- * Handler flow control + , finish + + -- * Exceptions thrown + , WebbyError(..) + ) where + +import Webby.Server +import Webby.Types diff --git a/src/Webby/Route.hs b/src/Webby/Route.hs new file mode 100644 --- /dev/null +++ b/src/Webby/Route.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE BangPatterns #-} +module Webby.Route where + +-- This modules contains the data structure and utilities to process +-- route patterns and lookup request paths internally in Webby. + +import qualified Data.HashMap.Strict as H + +import Webby.Types +import WebbyPrelude + + +data HashTrie a = HashTrie { handlerMay :: Maybe a + , litSubtree :: H.HashMap Text (HashTrie a) + , capMay :: Maybe (Text, HashTrie a) + } + deriving (Eq, Show) + +emptyHashTrie :: HashTrie a +emptyHashTrie = HashTrie Nothing H.empty Nothing + +-- | addItem adds a route to the HashTrie, only if the route does not +-- already exist, and the route does not have overlapping captures. +-- +-- An overlapping capture happens when there are two routes with +-- captures at the same position, for example: +-- @/person/:name@ +-- @/person/:id@ +-- +-- Note that @/person/:name@ and @/address/:name@ are not overlapping +-- captures as they have different leading components. +addItem :: ([PathSegment], a) -> HashTrie a -> Maybe (HashTrie a) +addItem ([], !handler) !trie = + -- If there are no path segments remaining, set handler at the + -- current node of the HashTrie + case handlerMay trie of + Nothing -> Just $ trie { handlerMay = Just handler } + Just _ -> Nothing +addItem (b:bs, !handler) !trie = + case b of + -- For a literal path segment, lookup and insert in the + -- litSubtree. + Literal p -> + let ltrie = litSubtree trie + child = H.lookupDefault emptyHashTrie p ltrie + in do nchild <- addItem (bs, handler) child + let nltrie = H.insert p nchild ltrie + return $ trie { litSubtree = nltrie } + + -- For a capture path segment, insert into the capture child of + -- the current node (if it doesn't exist). + Capture p -> + case capMay trie of + Nothing -> do ntrie <- addItem (bs, handler) emptyHashTrie + return $ trie { capMay = Just (p, ntrie) } + Just _ -> Nothing + +-- | lookupItem lookup the path segments in the tree and returns a +-- handler if a match is found along with a map of captures found. +lookupItem :: [Text] -> HashTrie a + -> Maybe (Captures, a) +lookupItem !bs' !trie' = lookupItemWithCaptures bs' trie' H.empty + where + lookupItemWithCaptures [] !trie !h = do hdlr <- handlerMay trie + return (h, hdlr) + lookupItemWithCaptures (b:bs) !trie !h = + let litChildMay = H.lookup b $ litSubtree trie + captureLookup = do (capKey, childTrie) <- capMay trie + lookupItemWithCaptures bs childTrie $ + H.insert capKey b h + in -- At lookup we always prefer a literal match over a + -- capture if both are present at node. + maybe captureLookup + (\childTrie -> lookupItemWithCaptures bs childTrie h) + litChildMay + +routePattern2PathSegments :: RoutePattern -> [PathSegment] +routePattern2PathSegments (RoutePattern mthd ps) = + (Literal $ decodeUtf8Lenient mthd) : ps + +mkRoutesHashTrie :: Routes a -> Maybe (HashTrie (WebbyM a ())) +mkRoutesHashTrie rs = foldl combine (Just emptyHashTrie) rs + where + + combine Nothing _ = Nothing + combine (Just h) (rpat, handler) = + let pathSegments = routePattern2PathSegments rpat + in addItem (pathSegments, handler) h diff --git a/src/Webby/Server.hs b/src/Webby/Server.hs new file mode 100644 --- /dev/null +++ b/src/Webby/Server.hs @@ -0,0 +1,248 @@ +module Webby.Server where + + +import qualified Control.Monad.Logger as Log +import qualified Data.Aeson as A +import qualified Data.Binary.Builder as Bu +import qualified Data.ByteString.Lazy as LB +import qualified Data.HashMap.Strict as H +import qualified Data.List as L +import qualified Data.Text as T +import Network.HTTP.Types.URI (queryToQueryText) +import qualified System.Log.FastLogger as FLog +import System.Log.FastLogger.Date (newTimeCache) +import qualified UnliftIO.Concurrent as Conc +import qualified UnliftIO.Exception as E +import Web.HttpApiData + +import WebbyPrelude + +import Webby.Route +import Webby.Types + +-- | Retrieve the app environment given to the application at +-- initialization. +getAppEnv :: WebbyM appEnv appEnv +getAppEnv = asks weAppEnv + +runAppEnv :: ReaderT appEnv (WebbyM appEnv) a -> WebbyM appEnv a +runAppEnv appFn = do + env <- getAppEnv + runReaderT appFn env + +-- | Retrieve all path captures +captures :: WebbyM appEnv Captures +captures = asks weCaptures + +-- | Retrieve a particular capture (TODO: extend?) +getCapture :: (FromHttpApiData a) => Text -> WebbyM appEnv a +getCapture capName = do + cs <- captures + case H.lookup capName cs of + Nothing -> throwIO $ WebbyMissingCapture capName + Just cap -> either (throwIO . WebbyParamParseError capName . show) + return $ + parseUrlPiece cap + +setStatus :: Status -> WebbyM appEnv () +setStatus sts = do + wVar <- asks weResp + Conc.modifyMVar_ wVar $ \wr -> return $ wr { wrStatus = sts} + +addHeader :: Header -> WebbyM appEnv () +addHeader h = do + wVar <- asks weResp + Conc.modifyMVar_ wVar $ + \wr -> do let hs = wrHeaders wr + return $ wr { wrHeaders = hs ++ [h] } + +-- similar to addHeader but replaces a header +setHeader :: Header -> WebbyM appEnv () +setHeader (k, v) = do + wVar <- asks weResp + Conc.modifyMVar_ wVar $ + \wr -> do let hs = wrHeaders wr + ohs = filter ((/= k) . fst) hs + return $ wr { wrHeaders = ohs ++ [(k, v)] } + +resp400 :: Text -> WebbyM appEnv a +resp400 msg = do + setStatus status400 + json $ A.object [ "error" A..= A.String msg ] + finish + +params :: WebbyM appEnv [(Text, Text)] +params = do + qparams <- (queryToQueryText . queryString) <$> request + return $ fmap (\(q, mv) -> (,) q $ fromMaybe "" mv) qparams + +flag :: Text -> WebbyM appEnv Bool +flag name = (isJust . L.lookup name) <$> params + +param :: (FromHttpApiData a) => Text -> WebbyM appEnv (Maybe a) +param p = do ps <- params + case L.lookup p ps of + Nothing -> return Nothing + Just myParam -> either (throwIO . WebbyParamParseError p . show) + (return . Just) $ + parseQueryParam myParam + +param_ :: (FromHttpApiData a) => Text -> WebbyM appEnv a +param_ p = do myParam <- param p + maybe (resp400 $ T.concat [p, " missing in params"]) + return myParam + +header :: HeaderName -> WebbyM appEnv (Maybe Text) +header n = do + hs <- requestHeaders <$> request + return $ headMay $ map (decodeUtf8Lenient . snd) $ filter ((n == ) . fst) hs + +request :: WebbyM appEnv Request +request = asks weRequest + +headers :: WebbyM appEnv [Header] +headers = requestHeaders <$> request + +requestBodyLength :: WebbyM appEnv (Maybe Int64) +requestBodyLength = do + hMay <- header hContentLength + return $ do val <- toS <$> hMay + parseInt val + +finish :: WebbyM appEnv a +finish = E.throwIO FinishThrown + +blob :: ByteString -> WebbyM appEnv () +blob bs = do + setHeader (hContentType, "application/octet-stream") + wVar <- asks weResp + Conc.modifyMVar_ wVar $ + \wr -> return $ wr { wrRespData = Right $ Bu.fromByteString bs } + +text :: Text -> WebbyM appEnv () +text txt = do + setHeader (hContentType, "text/plain; charset=utf-8") + wVar <- asks weResp + Conc.modifyMVar_ wVar $ + \wr -> return $ wr { wrRespData = Right $ Bu.fromByteString $ + encodeUtf8 txt } + +jsonData :: A.FromJSON a => WebbyM appEnv a +jsonData = do + req <- request + body <- liftIO $ lazyRequestBody req + either (throwIO . WebbyJSONParseError . T.pack) return $ A.eitherDecode body + +json :: A.ToJSON b => b -> WebbyM appEnv () +json j = do + setHeader (hContentType, "application/json; charset=utf-8") + wVar <- asks weResp + Conc.modifyMVar_ wVar $ + \wr -> return $ wr { wrRespData = Right $ Bu.fromLazyByteString $ + A.encode j } + +stream :: StreamingBody -> WebbyM appEnv () +stream s = do + wVar <- asks weResp + Conc.modifyMVar_ wVar $ + \wr -> return $ wr { wrRespData = Left s } + +-- | matchRequest uses a looks up a data structure built from the +-- configured routes. +matchRequest :: Request -> HashTrie a -> Maybe (Captures, a) +matchRequest req trie = + let mthd = requestMethod req + path = pathInfo req + lookupPath = decodeUtf8Lenient mthd : path + in lookupItem lookupPath trie + +errorResponse404 :: WebbyM appEnv () +errorResponse404 = setStatus status404 + +invalidRoutesErr :: [Char] +invalidRoutesErr = "Invalid route specification: contains duplicate routes or routes with overlapping capture patterns." + +-- | Use this function, to create a WAI application. It takes a +-- user/application defined `appEnv` data type and a list of +-- routes. If none of the requests match a request, a default 404 +-- response is returned. +mkWebbyApp :: appEnv -> Routes appEnv -> IO Application +mkWebbyApp appEnv routes = do + lset <- FLog.newStdoutLoggerSet FLog.defaultBufSize + routeTrie <- maybe (E.throwString invalidRoutesErr) return $ + mkRoutesHashTrie routes + return $ mkApp lset routeTrie + + where + + mkApp lset trie req respond = do + let defaultHandler = errorResponse404 + (cs, handler) = fromMaybe (H.empty, defaultHandler) $ + matchRequest req trie + + timeFn <- newTimeCache "%Y-%m-%dT%H:%M:%S " + wEnv <- do v <- Conc.newMVar defaultWyResp + return $ WEnv v cs req appEnv lset timeFn + + (do runWebbyM wEnv handler + webbyReply wEnv respond) `E.catches` + [ -- Handles Webby' exceptions while parsing parameters + -- and request body + E.Handler (\(ex :: WebbyError) -> case ex of + wmc@(WebbyMissingCapture _) -> + respond $ responseLBS status404 [] $ + toS $ displayException wmc + + _ -> respond $ responseLBS status400 [] $ + toS $ displayException ex + ) + + -- Handles Webby's finish statement + , E.Handler (\(_ :: FinishThrown) -> webbyReply wEnv respond) + + -- Handles any other exception thrown in the handler + , E.Handler (\(ex :: E.SomeException) -> do + Log.runStdoutLoggingT $ Log.logInfoN (show ex) + respond $ responseLBS status500 [] (show ex)) + ] + + webbyReply wEnv respond' = do + let wVar = weResp wEnv + wr <- Conc.takeMVar wVar + case wrRespData wr of + Left s -> respond' $ responseStream (wrStatus wr) (wrHeaders wr) s + Right b -> do + let clen = LB.length $ Bu.toLazyByteString b + respond' $ responseBuilder (wrStatus wr) + (wrHeaders wr ++ [(hContentLength, show clen)]) b + + +text2PathSegments :: Text -> [PathSegment] +text2PathSegments path = + let toSegment s = maybe (Literal s) Capture $ + ":" `T.stripPrefix` s + + path' = maybe path identity $ T.stripPrefix "/" path + + in map toSegment $ bool (T.splitOn "/" path') [] $ path' == "" + +-- | Create a route for a user-provided HTTP request method, pattern +-- and handler function. +mkRoute :: Method -> Text -> WebbyM appEnv () + -> (RoutePattern, WebbyM appEnv ()) +mkRoute m p h = (RoutePattern m (text2PathSegments p), h) + +-- | Create a route for a POST request method, given the path pattern +-- and handler. +post :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ()) +post = mkRoute methodPost + +-- | Create a route for a GET request method, given the path pattern +-- and handler. +get :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ()) +get = mkRoute methodGet + +-- | Create a route for a PUT request method, given the path pattern +-- and handler. +put :: Text -> WebbyM appEnv () -> (RoutePattern, WebbyM appEnv ()) +put = mkRoute methodPut diff --git a/src/Webby/Types.hs b/src/Webby/Types.hs new file mode 100644 --- /dev/null +++ b/src/Webby/Types.hs @@ -0,0 +1,104 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Webby.Types where + +import qualified Control.Monad.Logger as Log +import qualified Data.Binary.Builder as Bu +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import System.Log.FastLogger (FormattedTime) +import qualified System.Log.FastLogger as FLog +import qualified UnliftIO as U +import qualified UnliftIO.Concurrent as Conc + +import WebbyPrelude + +-- | A data type to represent parts of the response constructed in the +-- handler when servicing a request. +data WyResp = WyResp { wrStatus :: Status + , wrHeaders :: ResponseHeaders + , wrRespData :: Either StreamingBody Bu.Builder + , wrResponded :: Bool + } + +defaultWyResp :: WyResp +defaultWyResp = WyResp status200 [] (Right Bu.empty) False + +-- | The reader environment used by the web framework. It is +-- parameterized by the application's environment data type. +data WEnv appEnv = WEnv { weResp :: Conc.MVar WyResp + , weCaptures :: Captures + , weRequest :: Request + , weAppEnv :: appEnv + , weLoggerSet :: FLog.LoggerSet + , weLogTime :: IO FormattedTime + } + +-- | The main monad transformer stack used in the web-framework. +-- +-- The type of a handler for a request is `WebbyM appEnv ()`. The +-- `appEnv` parameter is used by the web application to store an +-- (read-only) environment. For e.g. it can be used to store a +-- database connection pool. +newtype WebbyM appEnv a = WebbyM + { unWebbyM :: ReaderT (WEnv appEnv) (ResourceT IO) a + } + deriving (Functor, Applicative, Monad, MonadIO, MonadReader (WEnv appEnv)) + +instance U.MonadUnliftIO (WebbyM appData) where + askUnliftIO = WebbyM $ ReaderT $ + \(w :: WEnv appData) -> U.withUnliftIO $ + \u -> return $ + U.UnliftIO (U.unliftIO u . flip runReaderT w . unWebbyM) + +instance Log.MonadLogger (WebbyM env) where + monadLoggerLog loc src lvl msg = do + lset <- asks weLoggerSet + ltime <- asks weLogTime + tstr <- liftIO ltime + let logstr = Log.toLogStr tstr <> + (Log.defaultLogStr loc src lvl $ Log.toLogStr msg) + liftIO $ FLog.pushLogStr lset logstr + +runWebbyM :: WEnv w -> WebbyM w a -> IO a +runWebbyM env = runResourceT . flip runReaderT env . unWebbyM + +-- A route pattern specifies a HTTP method and a list of path segments +-- that must match. +data RoutePattern = RoutePattern Method [PathSegment] + deriving (Eq, Show) + +-- | The Routes of a web-application are a list of mappings from a +-- `RoutePattern` to a handler function. +type Routes appEnv = [(RoutePattern, WebbyM appEnv ())] + +-- | Captures are simply extracted path elements in a HashMap +type Captures = H.HashMap Text Text + +data PathSegment = Literal Text + | Capture Text + deriving (Eq, Show) + +-- | Internal type used to terminate handler processing by throwing and +-- catching an exception. +data FinishThrown = FinishThrown + deriving (Show) + +instance U.Exception FinishThrown + +-- | Various kinds of errors thrown by this library - these can be +-- caught by handler code. +data WebbyError = WebbyJSONParseError Text + | WebbyParamParseError { wppeParamName :: Text + , wppeErrMsg :: Text + } + | WebbyMissingCapture Text + deriving Show + +instance U.Exception WebbyError where + displayException (WebbyParamParseError pName msg) = + T.unpack $ sformat ("Param parse error: " % st % " " % st) pName msg + + displayException (WebbyJSONParseError _) = "Invalid JSON body" + + displayException (WebbyMissingCapture capName) = + T.unpack $ sformat (st % " missing") capName diff --git a/src/WebbyPrelude.hs b/src/WebbyPrelude.hs new file mode 100644 --- /dev/null +++ b/src/WebbyPrelude.hs @@ -0,0 +1,33 @@ +module WebbyPrelude + ( module Exports + + -- | Custom prelude functions + , decodeUtf8Lenient + , parseInt + ) where + +import Control.Monad.Trans.Resource as Exports (ResourceT, + liftResourceT, + runResourceT) +import Network.HTTP.Types as Exports +import Network.Wai as Exports +import Protolude as Exports hiding (get, put, (%)) + +import Data.Text.Encoding as Exports (encodeUtf8) + +-- Imports for custom functionality coded in this module. +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import qualified Data.Text.Read as TR + +-- Text formatting +import Formatting as Exports (format, sformat, (%)) +import Formatting.ShortFormatters as Exports (d, sh, st, t) + +-- Decode UTF8 leniently (by replacing an invalid input byte with the +-- Unicode replacement character U+FFFD). +decodeUtf8Lenient :: ByteString -> Text +decodeUtf8Lenient = decodeUtf8With lenientDecode + +parseInt :: Integral a => Text -> Maybe a +parseInt t' = hush $ fmap fst $ TR.decimal t' diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,37 @@ +import Test.Tasty (TestTree, defaultMain, testGroup) +import Test.Tasty.HUnit ((@?=)) +import qualified Test.Tasty.HUnit as HUnit +-- import qualified Test.Tasty.QuickCheck as QC + +import Webby.Server +import Webby.Types +import WebbyPrelude + +import Webby.RouteTest + +main :: IO () +main = defaultMain tests + +tests :: TestTree +tests = testGroup "Webby Tests" [text2PathSegmentsTest, testHashTrie] + +text2PathSegmentsTest :: TestTree +text2PathSegmentsTest = testGroup "text2PathSegments" [text2PathSegmentsUT] + where + text2PathSegmentsUT :: TestTree + text2PathSegmentsUT = HUnit.testCase "Unit tests" $ do + text2PathSegments "" @?= [] + + text2PathSegments "/" @?= [] + + text2PathSegments "/ab" @?= [Literal "ab"] + + text2PathSegments "ab" @?= [Literal "ab"] + + text2PathSegments "/ab/bc" @?= [Literal "ab", Literal "bc"] + + text2PathSegments ":ab/bc" @?= [Capture "ab", Literal "bc"] + + text2PathSegments "/:ab/bc" @?= [Capture "ab", Literal "bc"] + + text2PathSegments "/ab/:bc/cd" @?= [Literal "ab", Capture "bc", Literal "cd"] diff --git a/test/Webby/RouteTest.hs b/test/Webby/RouteTest.hs new file mode 100644 --- /dev/null +++ b/test/Webby/RouteTest.hs @@ -0,0 +1,55 @@ +module Webby.RouteTest where + +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.HUnit ((@?=)) +import qualified Test.Tasty.HUnit as HUnit + +import qualified Data.HashMap.Strict as H + +import Webby.Route +import Webby.Types +import WebbyPrelude + +testHashTrie :: TestTree +testHashTrie = testGroup "HashTrie tests" [htAddItem, htLookupItem] + +htAddItem :: TestTree +htAddItem = HUnit.testCase "Unit Test - Add Item" $ do + let n = 1 :: Int + leaf = HashTrie (Just n) H.empty Nothing + addItem ([], n) emptyHashTrie @?= + Just leaf + + addItem ([Literal "ab"], n) emptyHashTrie @?= + Just (HashTrie Nothing (H.fromList [("ab", leaf)]) Nothing) + + let tnode = HashTrie Nothing (H.fromList [("cd", leaf)]) Nothing + addItem ([Literal "ab", Literal "cd"], n) emptyHashTrie @?= + Just (HashTrie Nothing (H.fromList [("ab", tnode)]) Nothing) + + -- capture test! + addItem ([Capture "ab", Literal "cd"], n) emptyHashTrie @?= + Just (HashTrie Nothing H.empty (Just ("ab", tnode))) + + -- TODO: capture test with overlapping capture and literal pattern + +htLookupItem :: TestTree +htLookupItem = HUnit.testCase "Unit Test - Lookup Item" $ do + lookupItem [] emptyHashTrie @?= (Nothing :: Maybe (Captures, Int)) + + let n = 1 :: Int + leaf = HashTrie (Just n) H.empty Nothing + lookupItem [] leaf @?= Just (H.empty, n) + + let trie1 = HashTrie Nothing (H.fromList [("ab", leaf)]) Nothing + lookupItem ["a"] trie1 @?= Nothing + lookupItem ["ab"] trie1 @?= Just (H.empty, n) + + -- capture test! + let tnode = HashTrie Nothing (H.fromList [("cd", leaf)]) Nothing + trie2 = HashTrie Nothing H.empty (Just ("ab", tnode)) + lookupItem ["abc"] trie2 @?= Nothing + lookupItem ["captureValue", "cd"] trie2 @?= + Just (H.fromList [("ab", "captureValue")], n) + + -- TODO: capture test with overlapping capture and literal pattern diff --git a/webby.cabal b/webby.cabal new file mode 100644 --- /dev/null +++ b/webby.cabal @@ -0,0 +1,105 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.1. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 4f81f8a7502f5cce8bbeea48a56ceb91bc52428d3b45594d74a22c035108c56c + +name: webby +version: 0.1.0.0 +synopsis: A super-simple web server framework +description: A super-simple, easy to use web server framework inspired by + Scotty. The goals of the project are: (1) Be easy to use (2) Allow + graceful exception handling (3) Parse request parameters easily and + in a typed manner. +category: Web +maintainer: aditya.mmy@gmail.com +license: Apache-2.0 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + +flag dev + manual: True + default: False + +library + hs-source-dirs: + src + default-extensions: FlexibleInstances MultiParamTypeClasses NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections + ghc-options: -Wall + build-depends: + aeson + , base >=4.7 && <5 + , binary + , bytestring + , fast-logger + , formatting + , http-api-data + , http-types + , monad-logger + , mtl + , protolude + , resourcet + , text + , unliftio + , unordered-containers + , wai + , wai-extra + , warp + if flag(dev) + ghc-options: -Werror + exposed-modules: + Webby + other-modules: + Webby.Route + Webby.Server + Webby.Types + WebbyPrelude + Paths_webby + default-language: Haskell2010 + +test-suite webby-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Webby + Webby.Route + Webby.Server + Webby.Types + WebbyPrelude + Webby.RouteTest + Paths_webby + hs-source-dirs: + src + test + default-extensions: FlexibleInstances MultiParamTypeClasses NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , base >=4.7 && <5 + , binary + , bytestring + , fast-logger + , formatting + , http-api-data + , http-types + , monad-logger + , mtl + , protolude + , resourcet + , tasty + , tasty-hunit + , tasty-quickcheck + , text + , unliftio + , unordered-containers + , wai + , wai-extra + , warp + , webby + if flag(dev) + ghc-options: -Werror + default-language: Haskell2010