diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,19 @@ +Copyright © 2018-2021 Athae Eredh Siniath and Others + +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/core-webserver-servant.cabal b/core-webserver-servant.cabal new file mode 100644 --- /dev/null +++ b/core-webserver-servant.cabal @@ -0,0 +1,50 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.34.4. +-- +-- see: https://github.com/sol/hpack + +name: core-webserver-servant +version: 0.1.0.0 +synopsis: Interoperability with Servant +description: This is part of a library to help build command-line programs, both tools and + longer-running daemons. + . + This package in particular adds wrappers around the __servant__ library + commonly used for exposing web services APIs and allows your handlers to + be written in the Program monad from __core-program__. +category: System +stability: experimental +homepage: https://github.com/aesiniath/unbeliever#readme +bug-reports: https://github.com/aesiniath/unbeliever/issues +author: Carlos D'Agostino +maintainer: Andrew Cowie +copyright: © 2021-2022 Athae Eredh Siniath and Others +license: MIT +license-file: LICENSE +build-type: Simple +tested-with: + GHC == 8.10.7 + +source-repository head + type: git + location: https://github.com/aesiniath/unbeliever + +library + exposed-modules: + Core.Webserver.Servant + hs-source-dirs: + lib + ghc-options: -Wall -Wwarn -fwarn-tabs + build-depends: + base >=4.11 && <5 + , core-program + , core-telemetry + , core-webserver-warp + , mtl + , safe-exceptions + , servant + , servant-server + , vault + , wai + default-language: Haskell2010 diff --git a/lib/Core/Webserver/Servant.hs b/lib/Core/Webserver/Servant.hs new file mode 100644 --- /dev/null +++ b/lib/Core/Webserver/Servant.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_HADDOCK prune #-} + +{- | +Support integrating web services created by __servant__ with handlers defined +in the 'Program' monad. This is a thin wrapper which creates an 'Application' +which can be used with 'Core.Webserver.Warp.launchWebserver'. + +@ +import "Core.Program" +import "Core.Webserver.Servant" +import "Core.Webserver.Warp" + +import MyServer (api, routes) + +main :: 'IO' () +main = do + 'Core.Program.Execute.execute' $ do + application <- 'prepareRoutes' api routes + 'launchWebserver' 8080 application +@ +-} +module Core.Webserver.Servant ( + prepareRoutes, +) where + +import Control.Exception.Safe (try) +import Control.Monad.Except (ExceptT (..)) +import Core.Program +import Core.System (Exception (..), throw) +import Core.Webserver.Warp +import Data.Proxy (Proxy) +import GHC.Base (Type) +import Network.Wai (Application) +import Servant (Handler (..), ServerT) +import Servant.Server (HasServer, hoistServer, serve) +import Core.Telemetry.Observability (clearMetrics) + +data ContextNotFoundInRequest = ContextNotFoundInRequest deriving (Show) + +instance Exception ContextNotFoundInRequest where + displayException _ = "Context was not found in request. This is a serious error." + +{- | +Convert a __servant__ API and set of handlers into a __warp__ 'Application'. + +This 'Application' must be used with 'Core.Webserver.Warp.launchWebserver' so +that the necessary internal connections are made. + +Usage is straight forward: + +@ + application <- 'prepareRoutes' api routes + 'launchWebserver' 8080 application +@ + +This code creates an Application which has sufficient information to unlift +back to the 'Program' monad so that your handlers can be take advantage of the +logging and telemetry facilities of __core-program__ and __core-telemetry__. +-} +prepareRoutes :: + forall τ (api :: Type). + HasServer api '[] => + Proxy api -> + ServerT api (Program τ) -> + Program τ Application +prepareRoutes proxy (routes :: ServerT api (Program τ)) = + pure application + where + application :: Application + application = \request sendResponse -> do + -- The type application in `contextFromRequest` is important, as + -- otherwise the compiler cannot infer that the type of + -- `transformProgram` is of the same `τ` as the one in `Program τ` + + -- This exception will happen in the case where this is not being run + -- by `launchWebserver`, since we need the Context to be stashed in + -- the request by the Middleware there. + + context <- case contextFromRequest @τ request of + Just context' -> pure context' + Nothing -> throw ContextNotFoundInRequest + serve + proxy + (hoistServer proxy (transformProgram context) routes) + request + sendResponse + + transformProgram :: Context τ -> Program τ α -> Handler α + transformProgram context program = + let output = + try $ + subProgram context $ do + clearMetrics + program + in Handler (ExceptT output)