diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Cackharot + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,169 @@ +# Chakra :: Web Api Template + +[![Hackage](https://img.shields.io/hackage/v/chakra.svg)](https://hackage.haskell.org/package/chakra) [![Build Status](https://github.com/cackharot/chakra/workflows/ci/badge.svg)](https://github.com/cackharot/chakra/actions?query=workflow%3Aci) [![Hackage Deps](https://img.shields.io/hackage-deps/v/chakra.svg)](http://packdeps.haskellers.com/reverse/chakra) + +A REST web api server template in Haskell. + +This serves as a base to create API projects that comes with the following features to avoid repeated bolierplate in each one. + +- Light weight & super fast Warp http server +- Supports HTTP 1.1 & HTTP/2 TLS by warp +- JSON as input/output serialization using Aeson library +- Structured logging (JSON) both application & HTTP request +- Define the REST interface using Servant library +- JWT (Bearer) token based authentication +- Application config via ENVIRONMENT variables (via dotenv & envy) +- Health & Info endpoints +- Prometheus metrics endpoint + +## TODO + +- [x] Integrate with RIO +- [x] Integrate with Servant +- [x] Integrate with FastLogger +- [x] Integrate with doenv & envy +- [x] Integrate with Prometheus +- [x] Integrate with wai-util +- [x] Setup JWT Authentication +- [x] JSON Error formatting +- [x] Setup HTTPS +- [ ] Setup PSQL/SqlLite pool with Presistent +- [x] Setup Stack template + +## Getting started + +To create a bare minimum API service all you need is below: + +```haskell +#!/usr/bin/env stack +{- stack --resolver lts-14.27 runghc + --package chakra +-} +{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators #-} +import RIO +import Chakra +import Servant + +type HelloRoute = "hello" :> QueryParam "name" Text :> Get '[PlainText] Text +type API = HelloRoute :<|> EmptyAPI + +hello :: Maybe Text -> BasicApp Text +hello name = do + let name' = fromMaybe "Sensei!" name + logInfo $ "Saying hello to " <> display name' + return $ "Hello " <> name' <> "!" + +main :: IO () +main = do + let infoDetail = InfoDetail "example" "dev" "0.1" "change me" + appEnv = appEnvironment infoDetail + appVer = appVersion infoDetail + appAPI = Proxy :: Proxy API + appServer = hello :<|> emptyServer + logFunc <- buildLogger appEnv appVer + middlewares <- chakraMiddlewares infoDetail + runChakraAppWithMetrics + middlewares + EmptyContext + (logFunc, infoDetail) + appAPI + appServer +``` + +### Usage + +Add this package to your application and refer `examples` directory for inspiration. + +```bash +# Create a new haskell app using stack's rio template +stack new UserApi rio +``` + +Edit the below files to include the dependencies + +```yaml +# Stack package.yaml +dependencies: +- base >= 4.11 && < 10 +- chakra +- rio +- servant-server + +# stack.yaml +resolver: lts-14.27 +packages: +- . +extra-deps: +- git: https://github.com/cackharot/haskell-web-api-template.git + commit: 70425ea54e4bc117582cdc0495f2b88827dbbf52 +- prometheus-metrics-ghc-1.0.1.1 +- wai-middleware-prometheus-1.0.0 +- servant-auth-0.4.0.0 +- servant-auth-server-0.4.6.0 +- servant-server-0.18.2 +- servant-0.18.2 +``` + +A stack project template is also available for bootstraping quickly + +```bash +stack new UserApi https://raw.githubusercontent.com/cackharot/haskell-web-api-template/main/chakra.hsfiles +``` + +## Build & Run + +```bash +make build +PORT=3000 make run + +open http://localhost:3000/health +``` + +### Endpoints + +Info: http://localhost:3000/info + +Health: http://localhost:3000/health + +Metrics: http://localhost:3000/metrics + +## Run tests + +```bash +make test +``` + +## HTTPS Setup + +Generate RootCA & localhost Public & Private key pair + +Be sure to edit `certs/domains.ext` file if you need more DNS aliases before executing these commands. + +```bash +openssl req -x509 -nodes -new -sha256 -days 1024 -newkey rsa:2048 -keyout "certs/RootCA.key" -out "certs/RootCA.pem" -subj "/C=US/CN=Localhost-Root-CA" +openssl x509 -outform pem -in "certs/RootCA.pem" -out "certs/RootCA.crt" + +openssl req -new -nodes -newkey rsa:2048 -keyout "certs/localhost.key" -out "certs/localhost.csr" -subj "/C=US/ST=NoWhere/L=NoWhere/O=Localhost-Certificates/CN=localhost.local" +openssl x509 -req -sha256 -days 1024 -in "certs/localhost.csr" -CA "certs/RootCA.pem" -CAkey "certs/RootCA.key" -CAcreateserial -extfile "certs/domains.ext" -out "certs/localhost.crt" +``` + +Once you have these keys then to start the server in https run the below command: + +```bash +/path/to/urapiexec --port 3443 --protocol http+tls --tlskey certs/localhost.key --tlscert certs/localhost.crt +``` + +open https://localhost:3443/health + +## JWT Authentication + +This template supports only authentication against standard JWT issued by Azure, Okta, Keybase & other OAuth JWT authentication providers. +However its easily customizable to authenticate against custom issued JWT token. This template does not issue a JWT token. + +The validate any incoming JWT's we need the public keys (provider by JWT issuer) to verify the payload and also need to verify the audiences. +These are configurable via ENV variables + +```bash +JWK_PATH="secrets/jwk.sig" +JWK_AUDIENCES="api://some-resource-id" +``` 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/chakra.cabal b/chakra.cabal new file mode 100644 --- /dev/null +++ b/chakra.cabal @@ -0,0 +1,193 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.33.0. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: ed84bd45513e7957dd1254d806c83022fb78ac260bef475addae82254f097b0b + +name: chakra +version: 0.1.0 +synopsis: A REST Web Api server template for building (micro)services. + +description: A REST Web Api server template, that serves as a reference + and avoids repetive boilerplate when building many (micro)services. + This combines best libraries available in Haskell web development, like RIO, warp, servant, etc., + and principles around 12-factor app. + . + Check @'Chakra'@ module documentation for example. + . + Idea is to provide Curated & Opinionated set of packages and + patterns to build well designed web api applications in Haskell. + . + Inspiration from Python Flask, ASP.NET Core + . + For more details, please see the README on Github at +category: Web +homepage: https://github.com/cackharot/haskell-web-api-template#readme +bug-reports: https://github.com/cackharot/haskell-web-api-template/issues +author: Cackharot +maintainer: cackharot@gmail.com +copyright: 2020 Cackharot +license: MIT +license-file: LICENSE +tested-with: GHC==8.8.4 +build-type: Simple +extra-source-files: + README.md + +source-repository head + type: git + location: https://github.com/cackharot/haskell-web-api-template + +library + exposed-modules: + Chakra + Chakra.Types + Chakra.App + Chakra.Config + Chakra.Logging + Chakra.Util + Chakra.JWT + Network.Wai.Middleware.Health + Network.Wai.Middleware.Info + other-modules: + Chakra.RequestLogging + Paths_chakra + hs-source-dirs: + src + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints + build-depends: + aeson + , ansi-terminal + , base >=4.11 && <10 + , bytestring + , cryptonite + , data-default + , data-has + , dotenv + , envy + , fast-logger + , http-types + , iproute + , jose + , lens + , mtl + , network + , network-uri + , options + , prometheus-client + , prometheus-metrics-ghc + , rio + , servant-auth >=0.4.0.0 + , servant-auth-server >=0.4.6.0 + , servant-server >=0.18.2 + , streaming-commons + , string-conversions + , text + , time + , transformers + , unordered-containers + , wai + , wai-cli + , wai-extra + , wai-middleware-prometheus + , warp + default-language: Haskell2010 + +executable chakra-exe + main-is: Main.hs + other-modules: + User + Paths_chakra + hs-source-dirs: + examples + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N -with-rtsopts=-T + build-depends: + aeson + , ansi-terminal + , base >=4.11 && <10 + , bytestring + , chakra + , cryptonite + , data-default + , data-has + , dotenv + , envy + , fast-logger + , http-types + , iproute + , jose + , lens + , mtl + , network + , network-uri + , options + , optparse-simple + , prometheus-client + , prometheus-metrics-ghc + , rio + , servant-auth >=0.4.0.0 + , servant-auth-server >=0.4.6.0 + , servant-server >=0.18.2 + , streaming-commons + , string-conversions + , text + , time + , transformers + , unordered-containers + , wai + , wai-cli + , wai-extra + , wai-middleware-prometheus + , warp + default-language: Haskell2010 + +test-suite chakra-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + UtilSpec + Paths_chakra + hs-source-dirs: + test + ghc-options: -Wall -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wpartial-fields -Wredundant-constraints -threaded -rtsopts -with-rtsopts=-N + build-depends: + aeson + , ansi-terminal + , base >=4.11 && <10 + , bytestring + , chakra + , cryptonite + , data-default + , data-has + , dotenv + , envy + , fast-logger + , hspec + , http-types + , iproute + , jose + , lens + , mtl + , network + , network-uri + , options + , prometheus-client + , prometheus-metrics-ghc + , rio + , servant-auth >=0.4.0.0 + , servant-auth-server >=0.4.6.0 + , servant-server >=0.18.2 + , streaming-commons + , string-conversions + , text + , time + , transformers + , unordered-containers + , wai + , wai-cli + , wai-extra + , wai-middleware-prometheus + , warp + default-language: Haskell2010 diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module Main (main) where + +import RIO +import Chakra +import Servant +import Configuration.Dotenv (defaultConfig, loadFile) +import qualified Data.Text as T +import Options.Applicative.Simple +import qualified Paths_chakra +import Servant.Auth.Server as SAS +import qualified User as U + +type API auths = (SAS.Auth auths AuthenticatedUser :> U.UserAPI) :<|> EmptyAPI + +appAPI :: Proxy (API '[SAS.JWT]) +appAPI = Proxy + +main :: IO () +main = do + hSetBuffering stdin LineBuffering + _ <- loadFile defaultConfig -- load .env file if available + -- Load the AppSettings data from ENV variables + withAppSettingsFromEnv $ \appSettings -> do + -- Override the version from cabal file + let ver = $(simpleVersion Paths_chakra.version) -- TH to get cabal project's git sha version + infoDetail = appSettings {appVersion = T.pack ver} + logFunc <- buildLogger (appEnvironment infoDetail) (appVersion infoDetail) + userRepo <- U.newInMemRepo + middlewares <- chakraMiddlewares infoDetail + jwtCfg <- getJWTAuthSettings + let cookieCfg = defaultCookieSettings {cookieIsSecure = SAS.NotSecure} + sctx = cookieCfg :. jwtCfg :. chakraErrorFormatters :. EmptyContext + appServer = U.server :<|> emptyServer + -- Run API server with JWT auth and in-mem user repo + runChakraAppWithMetrics + middlewares + sctx + (logFunc, infoDetail, userRepo) + appAPI + appServer diff --git a/examples/User.hs b/examples/User.hs new file mode 100644 --- /dev/null +++ b/examples/User.hs @@ -0,0 +1,112 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} + +module User (UserAppCtx, server, UserAPI, userAPI, newInMemRepo) where + +import RIO +import Chakra +import Data.Aeson +import Data.Has +import qualified Data.HashMap.Strict as B +import Servant +import Servant.Auth.Server as SAS + +newtype Name = Name Text + deriving (Eq, Show, Generic) + +newtype Email = Email Text + deriving (Eq, Show, Generic) + +data User = User + { _name :: !Name, + _email :: !Email + } + deriving (Eq, Show, Generic) + +instance ToJSON Name + +instance FromJSON Name + +instance ToJSON Email + +instance FromJSON Email + +instance ToJSON User + +instance FromJSON User + +data UserRepo = UserRepo + { _getUser :: !(Text -> IO (Maybe User)), + _getAllUsers :: !(IO [User]), + _insertUser :: !(Text -> User -> IO ()) + } + +class HasUserRepo env where + userRepoL :: Lens' env UserRepo + +instance {-# OVERLAPPABLE #-} Has UserRepo m => HasUserRepo m where + userRepoL = hasLens + +type UserAPI = + "users" + :> ( Get '[JSON] [User] + :<|> Capture "id" Text :> Get '[JSON] (Maybe User) + :<|> ReqBody '[JSON] User :> Post '[JSON] NoContent + ) + +userAPI :: Proxy UserAPI +userAPI = Proxy + +type UserAppCtx = (ModLogger, InfoDetail, UserRepo) + +type UserApp = RIO UserAppCtx + +server (SAS.Authenticated user) = getUsers :<|> findUserById :<|> createUser +server _ = throwUnauthorized :<|> const throwUnauthorized :<|> const throwUnauthorized + +newInMemRepo :: (MonadUnliftIO m) => m UserRepo +newInMemRepo = do + store <- liftIO $ atomically $ newTVar (B.fromList defaultUsers) + return $ + UserRepo + { _getUser = \uid -> do + u <- atomically $ readTVar store + return $ B.lookup uid u, + _getAllUsers = do + u <- atomically $ readTVar store + return $ B.elems u, + _insertUser = \uid u -> do + lst <- atomically $ readTVar store + atomically $ writeTVar store (B.insert uid u lst) + return () + } + +defaultUsers :: [(Text, User)] +defaultUsers = [("1234", User (Name "name1") (Email "email@test.com"))] + +getUsers :: UserApp [User] +getUsers = do + logWarn "Fetching users from db" + repo <- askObj + users <- liftIO $ _getAllUsers repo + return users + +findUserById :: Text -> UserApp (Maybe User) +findUserById userId = do + logInfoS "find" ("Find by id = " <> display userId) + repo <- askObj + mu <- liftIO $ _getUser repo $ userId + return mu + +createUser :: User -> UserApp NoContent +createUser u = do + logInfoS "create" "New user created" + repo <- askObj + liftIO $ _insertUser repo "33" u + return NoContent diff --git a/src/Chakra.hs b/src/Chakra.hs new file mode 100644 --- /dev/null +++ b/src/Chakra.hs @@ -0,0 +1,109 @@ +{-# OPTIONS_HADDOCK prune #-} +{-# LANGUAGE Trustworthy #-} + +{-| +This module re-exports all functionality of this package for easy use. +Users expected to import this module only. + +__Examples:__ + +@ +__import__ "Chakra" +@ + +== Getting started + +To create a bare minimum API service all you need is below: + +@ +\#!\/usr\/bin\/env stack +\{\- stack --resolver lts-14.27 runghc --package chakra \-\} +\{\-\# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators \#\-\} +import RIO +import Chakra +import Servant + +type HelloRoute = "hello" :> QueryParam "name" Text :> Get '[PlainText] Text +type API = HelloRoute :<|> EmptyAPI + +hello :: Maybe Text -> BasicApp Text +hello name = do + let name' = fromMaybe "Sensei!" name + logInfo $ "Saying hello to " <> display name' + return $ "Hello " <> name' <> "!" + +main :: IO () +main = do + let infoDetail = InfoDetail "example" "dev" "0.1" "change me" + appEnv = appEnvironment infoDetail + appVer = appVersion infoDetail + appAPI = Proxy :: Proxy API + appServer = hello :<|> emptyServer + logFunc <- buildLogger appEnv appVer + middlewares <- chakraMiddlewares infoDetail + runChakraAppWithMetrics + middlewares + EmptyContext + (logFunc, infoDetail) + appAPI + appServer +@ +-} +module Chakra + ( + -- $main + module Chakra.App, + -- $config + module Chakra.Config, + -- $jwt + module Chakra.JWT, + -- $logging + module Chakra.Logging, + -- $types + module Chakra.Types, + -- $util + module Chakra.Util, + module Chakra, + ) +where + +import Chakra.App +import Chakra.Config +import Chakra.JWT +import Chakra.Logging +import Chakra.Types +import Chakra.Util +import RIO + +-- | Basic application context, mostly used in examples. +-- For real life you need to create one for your application +type BasicAppCtx = (ModLogger, InfoDetail) + +-- | Nice type synonym to mark your servant handlers +-- For real life you need to create one for your application +type BasicApp = RIO BasicAppCtx + + +{- $codec + Main App functionalities +-} + +{- $config + Configuration reading from ENV utility functions +-} + +{- $logging + Logging related functionalities +-} + +{- $jwt + JWT based authentication functionalities +-} + +{- $types + Package defined Types +-} + +{- $util + Assorted conventient functions +-} diff --git a/src/Chakra/App.hs b/src/Chakra/App.hs new file mode 100644 --- /dev/null +++ b/src/Chakra/App.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# LANGUAGE NoImplicitPrelude #-} + +-- |Defines convenience functions to run a servant base api in wrap server +module Chakra.App + ( module Chakra.App, + ) +where + +import Control.Monad.Trans.Except (ExceptT (..)) +import Data.Aeson +import Data.Proxy +import Network.Wai +import Network.Wai.Cli +import Network.Wai.Middleware.Health (health) +import Network.Wai.Middleware.Info (info) +import qualified Network.Wai.Middleware.Prometheus as P +import qualified Prometheus as P +import qualified Prometheus.Metric.GHC as P +import RIO +import Chakra.RequestLogging +import Servant as X hiding (And, Handler) +import qualified Servant +import qualified Chakra.Types as T (InfoDetail (..)) +import Chakra.Util + +-- | Setup servant with custom context so that the handers can take custom effects/ctx +chakraApp :: + forall β χ ψ. + ( HasServer χ ψ, + HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters + ) => + -- |Servant Context e.g., EmptyContext + Context ψ -> + -- |Application Has stacking in tuple type e.g., (ModLogger,ModHttpClient,UserRepo) + β -> + -- | Servant API Proxy + Proxy χ -> + -- | Servant api handlers in `RIO β` monad + ServerT χ (RIO β) -> + -- | Returns WAI compatiable Application so you can run using wrap + Application +chakraApp sctx ctx api app = serveWithContext api sctx $ srv ctx + where + srv c = hoistServerWithContext api (Proxy @ψ) (runChakraHandler c) app + +-- | Starts the warp server with given middlewares, context, api definition and api server +-- Does not enable/registers GHC internal metrics +runChakraApp :: + ( MonadIO m, + HasServer χ ψ, + HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters + ) => + -- |WAI based middlewares + Middleware -> + -- |Servant Context e.g., EmptyContext + Context ψ -> + -- |Application Has stacking in tuple type e.g., (ModLogger,ModHttpClient,UserRepo) + β -> + -- | Servant API Proxy + Proxy χ -> + -- | Servant api handlers in `RIO β` monad + ServerT χ (RIO β) -> + -- Runs the resulting WAI application using wai-cli `defWaiMain` function + m () +runChakraApp middlewares sctx ctx api apiHandlers = + liftIO $ + defWaiMain $ middlewares $ chakraApp sctx ctx api apiHandlers + +-- | Starts the warp server with given middlewares, context, api definition and api server +-- Enables prometheus metrics (with GHC internal metrics) (Needs -with-rtsopts=-T) +runChakraAppWithMetrics :: + ( MonadIO m, + HasServer χ ψ, + HasContextEntry (ψ .++ DefaultErrorFormatters) ErrorFormatters + ) => + -- |WAI based middlewares + Middleware -> + -- |Servant Context e.g., EmptyContext + Context ψ -> + -- |Application Has stacking in tuple type e.g., (ModLogger,ModHttpClient,UserRepo) + β -> + -- | Servant API Proxy + Proxy χ -> + -- | Servant api handlers in `RIO β` monad + ServerT χ (RIO β) -> + -- Runs the resulting WAI application using wai-cli `defWaiMain` function + m () +runChakraAppWithMetrics middlewares sctx ctx api apiHandlers = do + _ <- registerMetrics + runChakraApp middlewares sctx ctx api apiHandlers + +-- | Return default set of middlewares applied +chakraMiddlewares :: T.InfoDetail -> IO Middleware +chakraMiddlewares infoDetail = do + logger <- + jsonRequestLogger (T.appEnvironment infoDetail) (T.appVersion infoDetail) + return $ logger . P.prometheus P.def . health . info jsonInfoDetail + where + jsonInfoDetail = encode infoDetail + +-- | Registers GHC runtime metrics so that /metrics endpoint will return rich GHC info +-- Requires `-with-rtsopts=-T` +registerMetrics :: MonadIO m => m P.GHCMetrics +registerMetrics = P.register P.ghcMetrics + +-- | Custom Servant Error formatter overrides to return in JSON format +chakraErrorFormatters :: ErrorFormatters +chakraErrorFormatters = + defaultErrorFormatters + { bodyParserErrorFormatter = jsonErrorFormatter, + notFoundErrorFormatter = notFoundFormatter + } + +-- | Natural transformation to run handlers in RIO monad instead of ServantT +runChakraHandler :: a -> RIO a h -> Servant.Handler h +runChakraHandler ctx a = Servant.Handler $ ExceptT $ try $ runReaderT (unRIO a) ctx diff --git a/src/Chakra/Config.hs b/src/Chakra/Config.hs new file mode 100644 --- /dev/null +++ b/src/Chakra/Config.hs @@ -0,0 +1,19 @@ +-- |Config utility module, uses System.Envy to read ENV values and builds a data +module Chakra.Config where + +import qualified System.Envy as Envy +import System.IO (hPutStrLn, stderr) + +-- | Read from ENVIRONMENT Variables and return your target `t` data +-- `t` should have a instance of FromEnv +-- Example: +-- @ +-- instance FromEnv MyAppSettings +-- @ +withAppSettingsFromEnv :: Envy.FromEnv t => (t -> IO ()) -> IO () +withAppSettingsFromEnv f = Envy.decodeEnv >>= callF + where + callF x = + case x of + Left e -> hPutStrLn stderr ("Error reading env: " ++ e) + Right c -> f c diff --git a/src/Chakra/JWT.hs b/src/Chakra/JWT.hs new file mode 100644 --- /dev/null +++ b/src/Chakra/JWT.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- |Contains JWT authentication settings +module Chakra.JWT where + +import Control.Lens (preview) +import Control.Monad.Except (Monad (return)) +import Crypto.JOSE (JWK, JWKSet (..)) +import Crypto.JWT (StringOrURI, string, uri) +import qualified Data.Aeson as Aeson +import Data.ByteString (readFile) +import qualified Data.Text as T +import Network.URI (parseURI) +import RIO (Eq ((==)), IO, Maybe (Just, Nothing), + Semigroup ((<>)), const, either, error, + fromMaybe, id, maybe, ($), (++)) +import Servant.Auth.Server (IsMatch (..), JWTSettings (..), + generateKey) +import System.Environment (lookupEnv) + +-- |Build JWT settings to be used in Servant Auth context +-- Looks for `JWK_AUDIENCES` and `JWK_PATH` in environment values +-- to load the sig file and value to verify the incoming jwt audience claim +getJWTAuthSettings :: IO JWTSettings +getJWTAuthSettings = do + jwkSet <- acquireJwks + signKey <- generateKey + audienceCfg <- lookupEnv "JWK_AUDIENCES" + let audMatches = maybe (const Matches) checkAud audienceCfg + checkAud audConfig = \tokenAud -> + if preview uri tokenAud == parseURI audConfig then + Matches + else if preview string tokenAud == Just (T.pack audConfig) then + Matches + else + DoesNotMatch + return $ buildJWTSettings signKey jwkSet audMatches + +buildJWTSettings :: JWK -> JWKSet -> (StringOrURI -> IsMatch) -> JWTSettings +buildJWTSettings signKey jwkSet audMatches = + JWTSettings + { signingKey = signKey, + jwtAlg = Nothing, + validationKeys = vkeys signKey jwkSet, + audienceMatches = audMatches + } + where + vkeys k (JWKSet x) = JWKSet (x ++ [k]) + +acquireJwks :: IO JWKSet +acquireJwks = do + envUrl <- lookupEnv "JWK_PATH" + let jwkPath = fromMaybe "secrets/jwk.sig" envUrl + fileContent <- readFile jwkPath + let parsed = Aeson.eitherDecodeStrict fileContent + return $ either (\e -> error $ "Invalid JWK file: " <> e) id parsed diff --git a/src/Chakra/Logging.hs b/src/Chakra/Logging.hs new file mode 100644 --- /dev/null +++ b/src/Chakra/Logging.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- |Logging utility functions +module Chakra.Logging + ( LogMessage, + ModLogger, + Formatter, + jsonFormatter, + newLogger, + buildLogger, + ) +where + +import Data.Aeson + ( ToJSON (toEncoding), + defaultOptions, + encode, + genericToEncoding, + ) +import Data.Has (Has (hasLens)) +import qualified Data.Text.Encoding as T +import RIO +import System.Log.FastLogger + +type ModLogger = LogFunc + +type Formatter = TimedFastLogger -> CallStack -> LogSource -> LogLevel -> Utf8Builder -> IO () + +data LogMessage = LogMessage + { message :: !Text, + logSource :: !Text, + callStack :: !Text, + timestamp :: !Text, + level :: !Text, + appVersion :: !Text, + appEnvironment :: !Text + } + deriving (Eq, Show, Generic) + +instance ToJSON LogMessage where + toEncoding = genericToEncoding defaultOptions + +instance ToLogStr LogMessage where + toLogStr a = (toLogStr . encode $ a) <> "\n" + +instance {-# OVERLAPPABLE #-} Has ModLogger a => HasLogFunc a where + logFuncL = hasLens + +-- | Creates a logger module using a given formatting function. +-- | Also returns the underlying TimedFastLogger for use outside of your app (e.g. in some WAI middleware). +newLogger :: LogType -> Formatter -> IO (TimedFastLogger, ModLogger) +newLogger logtype formatter = do + tc <- newTimeCache simpleTimeFormat' + (fl, _cleanupAction) <- newTimedFastLogger tc logtype + -- todo clean up + return (fl, mkLogFunc $ formatter fl) + +-- | Builds LogMessage and json encodes to string +jsonFormatter :: Text -> Text -> Formatter +jsonFormatter envName appVer logger cs src logLvl msg = logger buildJsonLogMsg + where + showLevel LevelDebug = "debug" + showLevel LevelInfo = "info" + showLevel LevelWarn = "warn" + showLevel LevelError = "error" + showLevel (LevelOther t) = "" <> t <> "" + buildJsonLogMsg t = + toLogStr $ + LogMessage + (utf8BuilderToText msg) + (utf8BuilderToText . displayBytesUtf8 . fromLogStr . toLogStr $ src) + (utf8BuilderToText $ displayCallStack cs) + (T.decodeUtf8 t) + (showLevel logLvl) + appVer + envName + +-- | Convenient function to create json formatted logger with appName & appVer values +buildLogger :: Text -> Text -> IO ModLogger +buildLogger envName appVer = do + (_, lf) <- newLogger (LogStderr defaultBufSize) (jsonFormatter envName appVer) + return lf diff --git a/src/Chakra/RequestLogging.hs b/src/Chakra/RequestLogging.hs new file mode 100644 --- /dev/null +++ b/src/Chakra/RequestLogging.hs @@ -0,0 +1,115 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- |Contains functions to log WAI request in JSON format +module Chakra.RequestLogging + (jsonRequestLogger) +where + +import Data.Aeson as X (KeyValue ((.=)), + ToJSON (toJSON), + Value (String), + encode, object) +import qualified Data.ByteString.Builder as BB (toLazyByteString) +import qualified Data.ByteString.Char8 as S8 +import Data.ByteString.Lazy (toStrict) +import Data.Default (Default (def)) +import Data.IP (fromHostAddress, + fromIPv4) +import qualified Data.Text as T +import Data.Text.Encoding (decodeUtf8With) +import Data.Text.Encoding.Error (lenientDecode) +import Data.Time (NominalDiffTime) +import Network.HTTP.Types as H (HttpVersion (HttpVersion), + QueryItem, + Status (statusCode)) +import Network.Socket (PortNumber, + SockAddr (..)) +import Network.Wai +import Network.Wai.Middleware.RequestLogger (OutputFormat (..), OutputFormatterWithDetails, + mkRequestLogger, + outputFormat) +import RIO (Text, Word32, + maybeToList) +import System.Log.FastLogger (toLogStr) +import Text.Printf (printf) + +-- | JSON formatted request log middleware for WAI applications +-- | it logs the given appName and appVer values +jsonRequestLogger :: Text -> Text -> IO Middleware +jsonRequestLogger envName appVer = + mkRequestLogger $ + def {outputFormat = CustomOutputFormatWithDetails (formatAsJSONCustom envName appVer)} + +formatAsJSONCustom :: Text -> Text -> OutputFormatterWithDetails +formatAsJSONCustom envName appVer date req status responseSize duration reqBody response = + toLogStr + (encode $ + object + [ "env" .= envName + , "appVersion" .= appVer + , "request" .= requestToJSON req reqBody (Just duration) + , "response" .= + object + [ "status" .= statusCode status + , "size" .= responseSize + , "body" .= + if statusCode status >= 400 + then Just . + decodeUtf8With lenientDecode . + toStrict . BB.toLazyByteString $ + response + else Nothing + ] + , "time" .= decodeUtf8With lenientDecode date + ]) <> + "\n" + +requestToJSON :: Request -> [S8.ByteString] -> Maybe NominalDiffTime -> Value +requestToJSON req reqBody duration = + object $ + [ "method" .= decodeUtf8With lenientDecode (requestMethod req) + , "path" .= decodeUtf8With lenientDecode (rawPathInfo req) + , "queryString" .= map queryItemToJSON (queryString req) + , "size" .= requestBodyLengthToJSON (requestBodyLength req) + , "body" .= decodeUtf8With lenientDecode (S8.concat reqBody) + , "remoteHost" .= sockToJSON (remoteHost req) + , "httpVersion" .= httpVersionToJSON (httpVersion req) + -- , "headers" .= requestHeadersToJSON (requestHeaders req) + ] <> + maybeToList + (("durationMs" .=) . + readAsDouble . printf "%.2f" . rationalToDouble . (* 1000) . toRational <$> + duration) + where + rationalToDouble :: Rational -> Double + rationalToDouble = fromRational + +readAsDouble :: String -> Double +readAsDouble = read + +queryItemToJSON :: QueryItem -> Value +queryItemToJSON (name, mValue) = + toJSON + ( decodeUtf8With lenientDecode name + , fmap (decodeUtf8With lenientDecode) mValue) + +word32ToHostAddress :: Word32 -> Text +word32ToHostAddress = T.intercalate "." . map (T.pack . show) . fromIPv4 . fromHostAddress + +sockToJSON :: SockAddr -> Value +sockToJSON (SockAddrInet pn ha) = + object ["port" .= portToJSON pn, "hostAddress" .= word32ToHostAddress ha] +sockToJSON (SockAddrInet6 pn _ ha _) = + object ["port" .= portToJSON pn, "hostAddress" .= ha] +sockToJSON (SockAddrUnix sock) = + object ["unix" .= sock] + +portToJSON :: PortNumber -> Value +portToJSON = toJSON . toInteger + +httpVersionToJSON :: HttpVersion -> Value +httpVersionToJSON (HttpVersion major minor) = String $ T.pack (show major) <> "." <> T.pack (show minor) + +requestBodyLengthToJSON :: RequestBodyLength -> Value +requestBodyLengthToJSON ChunkedBody = String "Unknown" +requestBodyLengthToJSON (KnownLength l) = toJSON l diff --git a/src/Chakra/Types.hs b/src/Chakra/Types.hs new file mode 100644 --- /dev/null +++ b/src/Chakra/Types.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} + +-- |Types +module Chakra.Types where + +import Data.Default +import qualified Data.Aeson as A +import qualified Data.Text as T +import RIO +import Servant.Auth.Server +import System.Envy + +data InfoDetail = InfoDetail + { appName :: !Text, + appEnvironment :: !Text, + appVersion :: !Text, + appDescription :: !Text + } + deriving (Show, Eq, Generic) + +instance FromEnv InfoDetail + +instance Default InfoDetail where + def = InfoDetail "example" "dev" "0.1" "change me" + +instance A.ToJSON InfoDetail where + toJSON = + A.genericToJSON + A.defaultOptions {A.fieldLabelModifier = A.camelTo2 '_' . drop 3} + +data AuthenticatedUser = AuthenticatedUser + { aud :: !Text, + iss :: !Text, + appid :: !Text, + aio :: !Text, + oid :: !Text, + sub :: !Text, + tid :: !Text + } + deriving (Show, Generic) + +instance A.ToJSON AuthenticatedUser + +instance A.FromJSON AuthenticatedUser + +instance ToJWT AuthenticatedUser + +instance FromJWT AuthenticatedUser where + decodeJWT m = case A.fromJSON . A.toJSON $ m of + A.Error e -> Left $ T.pack e + A.Success a -> Right a diff --git a/src/Chakra/Util.hs b/src/Chakra/Util.hs new file mode 100644 --- /dev/null +++ b/src/Chakra/Util.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE UnicodeSyntax #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +-- |As name suggests few utilities to make life easier +module Chakra.Util +where + +import Data.Aeson +import qualified Data.ByteString.Lazy as L (ByteString) +import Data.Has +-- import Data.Text.Encoding (decodeUtf8With) +-- import Data.Text.Encoding.Error (lenientDecode) +import Network.HTTP.Types (hContentType) +import Network.Wai +import RIO +import Servant + +-- | Construct plain ServerError Type with given status code and error text +errText :: ServerError -> L.ByteString -> ServerError +errText e t = + e {errHeaders = [(hContentType, "text/plain; charset=utf-8")], errBody = t} + +-- | Creates and throws a simple text/plain ServerError. +throwErrText :: MonadThrow u => ServerError -> L.ByteString -> u a +throwErrText e t = throwM $ errText e t + +-- | Throws Unauthorized error +throwUnauthorized :: MonadThrow u => u a +throwUnauthorized = throwM $ errText err401 "Unauthorized access!" + +-- | Custom JSON payload error formatter +jsonErrorFormatter :: ErrorFormatter +jsonErrorFormatter _tr _req err = + err400 {errBody = encode err, errHeaders = [("Content-Type", "application/json; charset=utf-8")]} + +-- | Custom JSON payload error formatter for 404 +notFoundFormatter :: NotFoundErrorFormatter +notFoundFormatter req = + err404 + { errBody = encode b + , errHeaders = [("Content-Type", "application/json; charset=utf-8")] + } + where + dl = decodeUtf8With lenientDecode + b = + object + [ "error_code" .= dl "404" + , "error_message" .= dl "NotFound" + , "path" .= dl (rawPathInfo req) + ] + +-- | Gets a value of any type from the context. +askObj :: (Has β α, MonadReader α μ) => μ β +askObj = asks getter + +-- | Gets a thing from a value of any type from the context. (Useful for configuration fields.) +askOpt :: (Has β α, MonadReader α μ) => (β -> ψ) -> μ ψ +askOpt f = asks $ f . getter diff --git a/src/Network/Wai/Middleware/Health.hs b/src/Network/Wai/Middleware/Health.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Health.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.Health + (health) +where + +import Network.HTTP.Types (methodGet, status200) +import Network.HTTP.Types.Header (hContentType) +import Network.Wai + +health :: Middleware +health app req sendResponse = + case rawPathInfo req of + "/health" -> + if getReq + then healthy + else next + _ -> next + where + next = app req sendResponse + getReq = requestMethod req == methodGet + healthy = sendResponse $ responseLBS status200 headers "Healthy" + headers = [(hContentType, "text/plain")] diff --git a/src/Network/Wai/Middleware/Info.hs b/src/Network/Wai/Middleware/Info.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wai/Middleware/Info.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE OverloadedStrings #-} +module Network.Wai.Middleware.Info + (info) +where + +import qualified Data.ByteString.Lazy as LB +import Network.HTTP.Types (methodGet, status200) +import Network.HTTP.Types.Header (hContentType) +import Network.Wai + +info :: LB.ByteString -> Middleware +info payload app req sendResponse = + case rawPathInfo req of + "/info" -> + if getReq + then returnInfo + else next + _ -> next + where + next = app req sendResponse + getReq = requestMethod req == methodGet + returnInfo = sendResponse $ responseLBS status200 headers payload + headers = [(hContentType, "application/json")] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/test/UtilSpec.hs b/test/UtilSpec.hs new file mode 100644 --- /dev/null +++ b/test/UtilSpec.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE NoImplicitPrelude #-} + +module UtilSpec (spec) where + +import RIO +import Test.Hspec +import Test.Hspec.QuickCheck + +spec :: Spec +spec = do + describe "Bool" $ do + it "works with True" $ + True `shouldBe` True + + it "works with False" $ + False `shouldBe` False + + it "works with True and False" $ + True `shouldBe` not False