version 0.1.3.0: servant

* Extract Wai/Warp helpers into separate module

* Add cabal.project

* CBDINFRA-84 Initial servant support

CBDINFRA-92 DerivingVia ToJSON + FromJSON + ToSchema
CBDINFRA-96 Examples in Swagger

* CBDINFRA-87 Add CBD auth for Servant

* Add sample servant app

* CBD Auth, openapi3

* Run server with middlewares

* Add runServantServerWithContext

* Generalize MonadWebError instance

* Add servant-swagger-ui

* Add RawM combinator

* stylish-haskell

* version 0.1.3.0: servant

CHANGELOG.md

@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
 
 ## [Unreleased]
 
+## [0.1.3.0] - 2020-10-14
+### Added
+- `servant` support.
+
 ## [0.1.2.3] - 2020-08-17
 ### Added
 - `defaultHandleLog400` middleware to log response bodies of 4xx and 5xx responses.

app/ServantApp.hs

@@ -0,0 +1,42 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE TypeOperators     #-}
+
+import Data.Aeson         (encode)
+import Data.OpenApi       (OpenApi)
+import Data.Proxy         (Proxy (..))
+import Data.Text          (Text)
+import Servant            (Description, Get, Handler, JSON, PlainText, Post, ReqBody, Summary,
+                           (:<|>) (..), (:>))
+import Servant.OpenAPI.UI (OpenApiSchemaUI, openapiSchemaUIServer)
+import Servant.OpenApi    (toOpenApi)
+
+import Web.Template.Servant (CbdAuth, UserId (..), Version, runServantServer)
+
+type API = Version "1" :>
+  ( Summary "ping route" :> Description "Returns pong" :> "ping" :> Get '[PlainText] Text
+  :<|> CbdAuth :>
+    ( Summary "hello route" :> Description "Returns hello + user id" :> "hello" :> Get '[PlainText] Text
+    :<|> "post" :> ReqBody '[JSON] Int :> Post '[JSON] Text
+    )
+  )
+
+pingH :: Handler Text
+pingH = return "pong!"
+
+helloH :: UserId -> Handler Text
+helloH (UserId userId) = return $ "Hello " <> userId
+
+postH :: UserId -> Int -> Handler Text
+postH _ _ = return "Foo"
+
+swagger :: OpenApi
+swagger = toOpenApi @API Proxy
+
+main :: IO ()
+main = do
+  print $ encode swagger
+
+  runServantServer @(OpenApiSchemaUI "swagger-ui" "swagger.json" :<|> API) 5000
+    $ openapiSchemaUIServer swagger :<|> (pingH :<|> (\userId -> helloH userId :<|> postH userId))

cabal.project

@@ -0,0 +1,24 @@
+packages: *.cabal
+
+package web-template
+    ghc-options: -Wall
+
+source-repository-package
+    type: git
+    location: https://github.com/maksbotan/servant-swagger-ui
+    tag: 0e3a6c3dcc54e081ca499e0ed0a73b9a12b538a8
+    subdir: servant-swagger-ui-core
+
+source-repository-package
+    type: git
+    location: https://github.com/maksbotan/servant-swagger-ui
+    tag: 0e3a6c3dcc54e081ca499e0ed0a73b9a12b538a8
+    subdir: servant-swagger-ui
+
+source-repository-package
+    type: git
+    location: https://github.com/maksbotan/servant-swagger-ui
+    tag: 0e3a6c3dcc54e081ca499e0ed0a73b9a12b538a8
+    subdir: servant-openapi-ui
+
+allow-newer: servant-blaze:servant

src/Web/Template.hs

@@ -5,6 +5,6 @@ module Web.Template
   , module Web.Template.Types
   ) where
 
-import           Web.Template.Except
-import           Web.Template.Server
-import           Web.Template.Types
+import Web.Template.Except
+import Web.Template.Server
+import Web.Template.Types

src/Web/Template/Except.hs

@@ -13,14 +13,11 @@ module Web.Template.Except
   , MonadWebError(..)
   ) where
 
-import           Data.Aeson                (FromJSON (..), ToJSON (..),
-                                            defaultOptions, genericToEncoding)
-import           Data.String               (fromString)
-import           GHC.Generics              (Generic)
-import           Network.HTTP.Types.Status (Status, status403, status404,
-                                            status500)
-import           Web.Scotty.Trans          (ActionT, ScottyError (..), json,
-                                            raise, status)
+import Data.Aeson                (FromJSON (..), ToJSON (..), defaultOptions, genericToEncoding)
+import Data.String               (fromString)
+import GHC.Generics              (Generic)
+import Network.HTTP.Types.Status (Status, status403, status404, status500)
+import Web.Scotty.Trans          (ActionT, ScottyError (..), json, raise, status)
 
 
 instance ScottyError Except where
@@ -36,7 +33,8 @@ data Except
 
 deriving instance Show Except
 
-newtype JsonWebError = JsonWebError { error :: String }
+newtype JsonWebError
+  = JsonWebError { error :: String }
   deriving (Generic)
 
 instance ToJSON JsonWebError where
@@ -73,6 +71,6 @@ class MonadWebError m where
   throwJson500 :: (Show e, ToJSON e) => e -> m a
   throwJson500 = throwJson status500
 
-instance Monad m => MonadWebError (ActionT Except m) where
+instance {-# OVERLAPPING #-} Monad m => MonadWebError (ActionT Except m) where
   {-# INLINE throwJson #-}
   throwJson s e = raise $ CustomJsonException s e

src/Web/Template/Servant.hs

@@ -0,0 +1,67 @@
+module Web.Template.Servant
+  ( runServantServer
+  , runServantServerWith
+  , runServantServerWithContext
+
+  , OpenApiSchemaUI
+  , openapiSchemaUIServer
+
+  , module Web.Template.Servant.Aeson
+  , module Web.Template.Servant.API
+  , module Web.Template.Servant.Auth
+  , module Web.Template.Servant.Error
+  ) where
+
+import Data.Proxy               (Proxy (..))
+import Network.Wai              (Application)
+import Network.Wai.Handler.Warp (Settings, runSettings)
+import Servant.OpenAPI.UI       (OpenApiSchemaUI, openapiSchemaUIServer)
+import Servant.Server           (Context, DefaultErrorFormatters, ErrorFormatters, HasContextEntry,
+                                 HasServer, Server, serveWithContext, type (.++), (.++))
+
+import Web.Template.Types (Port)
+import Web.Template.Wai   (defaultHandleLog, defaultHeaderCORS, warpSettings)
+
+import Web.Template.Servant.API
+import Web.Template.Servant.Aeson
+import Web.Template.Servant.Auth
+import Web.Template.Servant.Error
+
+runServantServer
+  :: forall api
+  .  (HasServer api '[ErrorFormatters])
+  => Port
+  -> Server api
+  -> IO ()
+runServantServer = runServantServerWith @api id (defaultHeaderCORS . defaultHandleLog)
+
+runServantServerWith
+  :: forall api
+  .  (HasServer api '[ErrorFormatters])
+  => (Settings -> Settings)
+  -> (Application -> Application)
+     -- ^ Middlewares
+  -> Port
+  -> Server api
+  -> IO ()
+runServantServerWith userSettings middlewares port server =
+  runSettings (warpSettings port userSettings)
+    $ middlewares
+    $ serveWithContext @api Proxy cbdContext
+    $ server
+
+runServantServerWithContext
+  :: forall api ctx
+  .  (HasServer api (ctx .++ '[ErrorFormatters]), HasContextEntry ((ctx .++ '[ErrorFormatters]) .++ DefaultErrorFormatters) ErrorFormatters)
+  => (Settings -> Settings)
+  -> (Application -> Application)
+     -- ^ Middlewares
+  -> Port
+  -> Context ctx
+  -> Server api
+  -> IO ()
+runServantServerWithContext userSettings middlewares port ctx server =
+  runSettings (warpSettings port userSettings)
+    $ middlewares
+    $ serveWithContext @api Proxy (ctx .++ cbdContext)
+    $ server

src/Web/Template/Servant/API.hs

@@ -0,0 +1,64 @@
+module Web.Template.Servant.API where
+
+import Control.Lens  ((?~))
+import Data.Function ((&))
+import Data.OpenApi  (applyTags, description)
+import Data.Proxy    (Proxy (..))
+import Data.String   (fromString)
+import Data.Text     (pack)
+import GHC.TypeLits  (AppendSymbol, KnownSymbol, Symbol, symbolVal)
+
+import Control.Monad.IO.Class       (MonadIO (..))
+import Control.Monad.Trans.Resource (runResourceT)
+import Network.Wai                  (Request, Response, ResponseReceived)
+import Servant                      (HasServer (..), Raw, (:>))
+import Servant.OpenApi              (HasOpenApi (..))
+import Servant.Server.Internal      (RouteResult (..), Router' (..), runDelayed, runHandler)
+
+-- | Prepend version to every sub-route.
+--
+-- > type API = Version "3" :> ("route1" :<|> "route2")
+type Version (v :: Symbol) = AppendSymbol "v" v
+
+-- | Mark sub-api with a Swagger tag with description.
+--
+-- > type API
+-- >   =    (Tag "foo" "Some Foo routes" :> ("foo1" :<|> "foo2"))
+-- >   :<|> (Tag "bar" "Some Bar routes" :> ("bar1" :<|> "bar2"))
+data Tag (tag :: Symbol) (descr :: Symbol)
+
+instance HasServer api context => HasServer (Tag tag descr :> api) context where
+  type ServerT (Tag tag descr :> api) m = ServerT api m
+
+  route _ = route @api Proxy
+  hoistServerWithContext _ = hoistServerWithContext @api Proxy
+
+instance (KnownSymbol tag, KnownSymbol descr, HasOpenApi api) => HasOpenApi (Tag tag descr :> api) where
+  toOpenApi _ = toOpenApi @api Proxy
+    & applyTags [fromString (symbolVal @tag Proxy) & description ?~ pack (symbolVal @descr Proxy)]
+
+-- | As 'Raw', but with access to the custom monad @m@.
+--
+-- See <https://github.com/haskell-servant/servant/pull/1349>.
+data RawM
+
+instance HasServer RawM ctx where
+  type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
+
+  hoistServerWithContext _ _ nt m = \request respond -> nt $ m request respond
+
+  route _ _ dApp = RawRouter $ \env request respond -> runResourceT $ do
+    r <- runDelayed dApp env request
+    liftIO $ case r of
+      Fail a -> respond $ Fail a
+      FailFatal e -> respond $ FailFatal e
+      Route appH -> do
+        r' <- runHandler $ appH request (respond . Route)
+        -- appH may return result with 'Right' _only_ by calling smth like @liftIO . respond@,
+        -- so in case of 'Left' we may suppose that 'respond' was never called.
+        case r' of
+          Left e  -> respond $ FailFatal e
+          Right x -> return x
+
+instance HasOpenApi RawM where
+  toOpenApi _ = toOpenApi @Raw Proxy

src/Web/Template/Servant/Aeson.hs

@@ -0,0 +1,71 @@
+module Web.Template.Servant.Aeson where
+
+import Control.Lens      ((?~))
+import Data.Aeson
+import Data.Aeson.Casing
+import Data.Functor      ((<&>))
+import Data.Proxy        (Proxy (..))
+import GHC.Generics
+
+import Data.OpenApi
+import Data.OpenApi.Internal.Schema
+
+-- | This wrapper is intended to be used with @DerivingVia@ to make
+-- consistent 'ToJSON', 'FromJSON' and 'ToSchema' for some data type.
+--
+-- Usage:
+--
+-- > data Foo
+-- >   = Foo
+-- >       { fFoo :: String
+-- >       , fBar :: String
+-- >       }
+-- >   deriving (Eq, Show, Generic)
+-- >   deriving (ToJSON, FromJSON, ToSchema) via CamelCaseAeson Foo
+--
+-- Instances are made with 'aesonPrefix' 'camelCase' and 'omitNothingFields' set to @True@.
+newtype CamelCaseAeson a
+  = CamelCaseAeson a
+
+prefixOptions :: Options
+prefixOptions = (aesonPrefix camelCase) { omitNothingFields = True }
+
+instance (Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CamelCaseAeson a) where
+  toJSON (CamelCaseAeson a) = genericToJSON prefixOptions a
+  toEncoding (CamelCaseAeson a) = genericToEncoding prefixOptions a
+
+instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CamelCaseAeson a) where
+  parseJSON = fmap CamelCaseAeson . genericParseJSON prefixOptions
+
+instance (Generic a, GToSchema (Rep a)) => ToSchema (CamelCaseAeson a) where
+    declareNamedSchema _ =
+      genericDeclareNamedSchema @a (fromAesonOptions prefixOptions) Proxy
+
+-- | This wrapper extends 'ToSchema' instance of the underlying type with
+-- an example obtained from 'WithExample' instance.
+--
+-- Usage:
+--
+-- > data Foo
+-- >   = ...
+-- >   deriving (Eq, Show, Generic)
+-- >   deriving (ToJSON, FromJSON) via CamelCaseAeson Foo
+-- >   deriving (ToSchema) via SwaggerWithExample (CamelCaseAeson Foo)
+--
+-- Last line reuses 'ToSchema' instances from 'CamelCaseAeson' to ensure that instances
+-- stay consistent.
+newtype SwaggerWithExample a
+  = SwaggerWithExample a
+
+-- | Provide an example for Swagger schema.
+--
+-- Swagger supports only one example per named schema.
+class ToJSON a => WithExample a where
+  mkExample :: a
+
+instance (WithExample a, ToSchema a) => ToSchema (SwaggerWithExample a) where
+  declareNamedSchema _ = declareNamedSchema @a Proxy
+    <&> schema . example ?~ toJSON (mkExample @a)
+
+instance (ToJSON (CamelCaseAeson a), WithExample a) => WithExample (CamelCaseAeson a) where
+  mkExample = CamelCaseAeson $ mkExample @a

src/Web/Template/Servant/Auth.hs

@@ -0,0 +1,66 @@
+module Web.Template.Servant.Auth
+  where
+
+-- after https://www.stackage.org/haddock/lts-15.15/servant-server-0.16.2/src/Servant.Server.Experimental.Auth.html
+
+import Control.Lens  (at, (.~), (?~))
+import Data.Function ((&))
+import Data.Functor  ((<&>))
+import Data.Proxy    (Proxy (..))
+import Data.Text     (Text)
+import GHC.Generics  (Generic)
+
+import Data.OpenApi.Internal     (ApiKeyLocation (..), ApiKeyParams (..), SecurityRequirement (..),
+                                  SecurityScheme (..), SecuritySchemeType (..))
+import Data.OpenApi.Lens         (components, description, security, securitySchemes)
+import Data.OpenApi.Operation    (allOperations, setResponse)
+import Network.HTTP.Types.Header (hContentType)
+import Network.Wai               (requestHeaders)
+import Servant.API               ((:>))
+import Servant.OpenApi           (HasOpenApi (..))
+import Servant.Server            (HasServer (..), ServerError (..), err401)
+import Servant.Server.Internal   (addAuthCheck, delayedFailFatal, withRequest)
+import Web.Cookie                (parseCookiesText)
+
+-- | Add authenthication via @id@ Cookie.
+--
+-- Usage:
+--
+-- > type API = CbdAuth :> (....)
+--
+-- Handlers will get an 'UserId' argument.
+data CbdAuth
+
+newtype UserId
+  = UserId { getUserId :: Text }
+  deriving (Eq, Show, Generic)
+
+instance HasServer api context => HasServer (CbdAuth :> api) context where
+  type ServerT (CbdAuth :> api) m = UserId -> ServerT api m
+
+  hoistServerWithContext _ pc nt s = hoistServerWithContext @api Proxy pc nt . s
+
+  route _ context sub =
+    route @api Proxy context
+      $ addAuthCheck sub
+      $ withRequest $ \req ->
+          maybe (delayedFailFatal err) return $
+            lookup "cookie" (requestHeaders req)
+              <&> parseCookiesText
+              >>= lookup "id"
+              <&> UserId
+    where
+      err = err401
+        { errBody = "{\"error\": \"Authorization failed\"}"
+        , errHeaders = [(hContentType, "application/json")]
+        }
+
+instance HasOpenApi api => HasOpenApi (CbdAuth :> api) where
+  toOpenApi _ = toOpenApi @api Proxy
+    & components . securitySchemes . at "cbdCookie" ?~ idCookie
+    & allOperations . security .~ [SecurityRequirement $ mempty & at "cbdCookie" ?~ []]
+    & setResponse 401 (return $ mempty & description .~ "Authorization failed")
+    where
+      idCookie = SecurityScheme
+        (SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie))
+        (Just "`id` cookie")