diff --git a/examples/Basic.hs b/examples/Basic.hs new file mode 100644 --- /dev/null +++ b/examples/Basic.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Main where + +import qualified Data.Text as T +import Network.HTTP.Types (status500) +import qualified Network.Wai.Handler.Warp as W +import Relude hiding (get, put) +import qualified UnliftIO.Exception as E +import Webby + +-- An example exception handler web-applications can install with webby +appExceptionHandler :: T.Text -> (E.SomeException -> WebbyM appEnv ()) +appExceptionHandler appName (exception :: E.SomeException) = do + setStatus status500 + let msg = appName <> " failed with " <> show exception + putTextLn msg + text msg + +newtype AppEnv = AppEnv Text + deriving (Eq, Show) + +-- To demonstrate that appEnv is avaliable via MonadReader interface and no +-- additional boiler-plate is required +class HasAppName env where + getAppName :: env -> Text + +instance HasAppName AppEnv where + getAppName (AppEnv name) = name + +fetchAppName :: (HasAppName env, MonadReader env m, MonadIO m) => m Text +fetchAppName = do + asks getAppName + +main :: IO () +main = do + -- Define the API routes handled by your web-application + let routes = + [ get "/api/a" (text "a\n"), + get "/api/b" (text "b\n"), + post + "/api/capture/:id" + ( do + idVal :: Int <- getCapture "id" + text (T.pack (show idVal) `T.append` "\n") + ), + get + "/api/isOdd/:val" + ( do + val :: Integer <- getCapture "val" + -- if val is odd return the number else we short-circuit the handler + unless (odd val) finish + text $ show val + ), + get + "/api/showAppName" + ( do + appName <- fetchAppName + text appName + ), + get "/aaah" (liftIO $ E.throwString "oops!") + ] + -- Set the routes definition and exception handler for your + -- web-application + webbyConfig = + setExceptionHandler (appExceptionHandler "MyApp") $ + setRoutes + routes + defaultWebbyServerConfig + -- Application environment in this example is a simple Text literal. + -- Usually, application environment would contain database connections + -- etc. + appEnv = AppEnv "test-webby" + + webbyApp <- mkWebbyApp appEnv webbyConfig + putStrLn "Starting webserver..." + W.runEnv 7000 webbyApp diff --git a/src/Prelude.hs b/src/Prelude.hs --- a/src/Prelude.hs +++ b/src/Prelude.hs @@ -13,7 +13,7 @@ ) import qualified Data.Text.Read as TR -- Text formatting -import Formatting as Exports ((%), format, sformat) +import Formatting as Exports (format, sformat, (%)) import Formatting.ShortFormatters as Exports (d, sh, st, t) import Network.HTTP.Types as Exports import Network.Wai as Exports @@ -21,7 +21,7 @@ import UnliftIO.Exception as Exports (throwIO) parseInt :: Integral a => Text -> Maybe a -parseInt t' = either (const Nothing) Just $ fmap fst $ TR.decimal t' +parseInt t' = either (const Nothing) (Just . fst) (TR.decimal t') headMay :: [a] -> Maybe a headMay [] = Nothing diff --git a/src/Webby/Server.hs b/src/Webby/Server.hs --- a/src/Webby/Server.hs +++ b/src/Webby/Server.hs @@ -65,12 +65,12 @@ -- | Get all request query params as a list of key-value pairs params :: WebbyM appEnv [(Text, Text)] params = do - qparams <- (queryToQueryText . queryString) <$> request + qparams <- queryToQueryText . queryString <$> request return $ fmap (\(q, mv) -> (,) q $ fromMaybe "" mv) qparams -- | Checks if the request contains the given query param flag :: Text -> WebbyM appEnv Bool -flag name = (isJust . L.lookup name) <$> params +flag name = isJust . L.lookup name <$> params -- | Gets the given query param's value param :: (FromHttpApiData a) => Text -> WebbyM appEnv (Maybe a) @@ -108,7 +108,7 @@ -- body. It returns an empty bytestring after the request body is -- consumed. getRequestBodyChunkAction :: WebbyM appEnv (WebbyM appEnv ByteString) -getRequestBodyChunkAction = (liftIO . getRequestBodyChunk) <$> asksWEnv weRequest +getRequestBodyChunkAction = liftIO . getRequestBodyChunk <$> asksWEnv weRequest -- | Get all the request headers headers :: WebbyM appEnv [Header] @@ -222,7 +222,7 @@ -- is returned. mkWebbyApp :: env -> WebbyServerConfig env -> IO Application mkWebbyApp env wsc = - return $ mkApp + return mkApp where shortCircuitHandler = [ -- Handler for FinishThrown exception to guide diff --git a/src/Webby/Types.hs b/src/Webby/Types.hs --- a/src/Webby/Types.hs +++ b/src/Webby/Types.hs @@ -47,7 +47,7 @@ newtype WebbyM appEnv a = WebbyM { unWebbyM :: ReaderT appEnv (ReaderT (WEnv appEnv) (ResourceT IO)) a } - deriving (Functor, Applicative, Monad, MonadIO, MonadReader appEnv, Un.MonadUnliftIO) + deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader appEnv, Un.MonadUnliftIO) runWebbyM :: WEnv w -> WebbyM w a -> IO a runWebbyM env = runResourceT . flip runReaderT env . flip runReaderT appEnv . unWebbyM @@ -56,7 +56,7 @@ -- | A route pattern represents logic to match a request to a handler. data RoutePattern = RoutePattern Method [Text] - deriving (Eq, Show) + deriving stock (Eq, Show) -- | A route is a pair of a route pattern and a handler. type Route env = (RoutePattern, WebbyM env ()) @@ -67,7 +67,7 @@ -- | Internal type used to terminate handler processing by throwing and -- catching an exception. data FinishThrown = FinishThrown - deriving (Show) + deriving stock (Show) instance U.Exception FinishThrown @@ -80,7 +80,7 @@ wppeErrMsg :: Text } | WebbyMissingCapture Text - deriving (Show) + deriving stock (Show) instance U.Exception WebbyError where displayException (WebbyParamParseError pName msg) = diff --git a/webby.cabal b/webby.cabal --- a/webby.cabal +++ b/webby.cabal @@ -1,13 +1,6 @@ -cabal-version: 2.0 - --- This file has been generated from package.yaml by hpack version 0.34.2. --- --- see: https://github.com/sol/hpack --- --- hash: f467aea047720d905ca753c3a8bc23a8f63cbaef9b3b2eb727db86ce12f1d57e - +cabal-version: 2.2 name: webby -version: 1.0.1 +version: 1.0.2 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 @@ -23,85 +16,118 @@ build-type: Simple extra-source-files: README.md + LICENSE + examples/*.hs source-repository head type: git location: https://github.com/donatello/webby -flag dev - manual: True - default: False +common base-settings + ghc-options: -Wall + -Wcompat + -Widentities + -Wincomplete-uni-patterns + -Wincomplete-record-updates + -haddock + if impl(ghc >= 8.0) + ghc-options: -Wredundant-constraints + if impl(ghc >= 8.2) + ghc-options: -fhide-source-paths -library - exposed-modules: - Webby + -- Add this when we have time. Fixing partial-fields requires major version + -- bump at this time. + -- if impl(ghc >= 8.4) + -- ghc-options: -Wpartial-fields + -- -Wmissing-export-lists + + if impl(ghc >= 8.8) + ghc-options: -Wmissing-deriving-strategies + -Werror=missing-deriving-strategies + + default-language: Haskell2010 + + default-extensions: + DerivingStrategies + FlexibleInstances + MultiParamTypeClasses + MultiWayIf + NoImplicitPrelude + OverloadedStrings + ScopedTypeVariables + TupleSections + other-modules: Prelude Webby.Server Webby.Types Paths_webby + autogen-modules: Paths_webby - hs-source-dirs: - src - default-extensions: FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections - ghc-options: -Wall build-depends: - aeson >=1.4 && <2 + aeson >=1.4 && <2.2 , base >=4.7 && <5 , binary >=0.8 && <1 , bytestring >=0.10 && <1 - , formatting >=6.3.7 && <6.4 - , http-api-data >=0.4 && <0.5 - , http-types >=0.12 && <0.13 + , formatting >=6.3.7 && <7.2 + , http-api-data >=0.4 && <0.6 + , http-types ==0.12.* , relude >=0.7 - , resourcet >=1.2 && <1.3 - , text >=1.2 && <1.3 + , resourcet ==1.2.* + , text >=1.2 && <2.1 , unliftio >=0.2.13 && <0.3 - , unliftio-core >=0.2 && <0.3 + , unliftio-core ==0.2.* , unordered-containers >=0.2.9 && <0.3 - , wai >=3.2 && <3.3 - mixins: - base hiding (Prelude) - if flag(dev) - ghc-options: -Wall -Werror - default-language: Haskell2010 + , wai ==3.2.* + mixins: base hiding (Prelude) + +library + import: + base-settings + exposed-modules: + Webby + hs-source-dirs: + src + test-suite webby-test + import: + base-settings type: exitcode-stdio-1.0 main-is: Spec.hs - other-modules: - Prelude - Webby - Webby.Server - Webby.Types - Paths_webby hs-source-dirs: src test - default-extensions: FlexibleInstances MultiParamTypeClasses MultiWayIf NoImplicitPrelude OverloadedStrings ScopedTypeVariables TupleSections ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N build-depends: - aeson >=1.4 && <2 - , base >=4.7 && <5 - , binary >=0.8 && <1 - , bytestring >=0.10 && <1 - , formatting >=6.3.7 && <6.4 - , http-api-data >=0.4 && <0.5 - , http-types >=0.12 && <0.13 - , relude >=0.7 - , resourcet >=1.2 && <1.3 - , tasty + tasty , tasty-hunit , tasty-quickcheck - , text >=1.2 && <1.3 - , unliftio >=0.2.13 && <0.3 - , unliftio-core >=0.2 && <0.3 - , unordered-containers >=0.2.9 && <0.3 - , wai >=3.2 && <3.3 , webby - mixins: - base hiding (Prelude) - if flag(dev) - ghc-options: -Wall -Werror - default-language: Haskell2010 + +Flag examples + Description: Build the examples + Default: False + Manual: True + +common examples-settings + ghc-options: -Wall -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + default-extensions: OverloadedStrings + build-depends: base >= 4.7 && < 5 + , http-types + , relude + , text + , warp + , webby + , unliftio + , unordered-containers + hs-source-dirs: examples + if !flag(examples) + buildable: False + +executable Basic + import: examples-settings + scope: private + main-is: Basic.hs