Skip to content

Commit 249ff8a

Browse files
maksbotanmaksbotan
authored
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
1 parent 80a36d1 commit 249ff8a

File tree

15 files changed

+532
-89
lines changed

15 files changed

+532
-89
lines changed

‎CHANGELOG.md‎

Lines changed: 4 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,10 @@ and this project adheres to [Semantic Versioning](https://semver.org/spec/v2.0.0
66

77
## [Unreleased]
88

9+
## [0.1.3.0] - 2020-10-14
10+
### Added
11+
- `servant` support.
12+
913
## [0.1.2.3] - 2020-08-17
1014
### Added
1115
- `defaultHandleLog400` middleware to log response bodies of 4xx and 5xx responses.

‎app/ServantApp.hs‎

Lines changed: 42 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,42 @@
1+
{-# LANGUAGE DataKinds #-}
2+
{-# LANGUAGE OverloadedStrings #-}
3+
{-# LANGUAGE TypeApplications #-}
4+
{-# LANGUAGE TypeOperators #-}
5+
6+
import Data.Aeson (encode)
7+
import Data.OpenApi (OpenApi)
8+
import Data.Proxy (Proxy (..))
9+
import Data.Text (Text)
10+
import Servant (Description, Get, Handler, JSON, PlainText, Post, ReqBody, Summary,
11+
(:<|>) (..), (:>))
12+
import Servant.OpenAPI.UI (OpenApiSchemaUI, openapiSchemaUIServer)
13+
import Servant.OpenApi (toOpenApi)
14+
15+
import Web.Template.Servant (CbdAuth, UserId (..), Version, runServantServer)
16+
17+
type API = Version "1" :>
18+
( Summary "ping route" :> Description "Returns pong" :> "ping" :> Get '[PlainText] Text
19+
:<|> CbdAuth :>
20+
( Summary "hello route" :> Description "Returns hello + user id" :> "hello" :> Get '[PlainText] Text
21+
:<|> "post" :> ReqBody '[JSON] Int :> Post '[JSON] Text
22+
)
23+
)
24+
25+
pingH :: Handler Text
26+
pingH = return "pong!"
27+
28+
helloH :: UserId -> Handler Text
29+
helloH (UserId userId) = return $ "Hello " <> userId
30+
31+
postH :: UserId -> Int -> Handler Text
32+
postH _ _ = return "Foo"
33+
34+
swagger :: OpenApi
35+
swagger = toOpenApi @API Proxy
36+
37+
main :: IO ()
38+
main = do
39+
print $ encode swagger
40+
41+
runServantServer @(OpenApiSchemaUI "swagger-ui" "swagger.json" :<|> API) 5000
42+
$ openapiSchemaUIServer swagger :<|> (pingH :<|> (\userId -> helloH userId :<|> postH userId))

‎cabal.project‎

Lines changed: 24 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,24 @@
1+
packages: *.cabal
2+
3+
package web-template
4+
ghc-options: -Wall
5+
6+
source-repository-package
7+
type: git
8+
location: https://github.com/maksbotan/servant-swagger-ui
9+
tag: 0e3a6c3dcc54e081ca499e0ed0a73b9a12b538a8
10+
subdir: servant-swagger-ui-core
11+
12+
source-repository-package
13+
type: git
14+
location: https://github.com/maksbotan/servant-swagger-ui
15+
tag: 0e3a6c3dcc54e081ca499e0ed0a73b9a12b538a8
16+
subdir: servant-swagger-ui
17+
18+
source-repository-package
19+
type: git
20+
location: https://github.com/maksbotan/servant-swagger-ui
21+
tag: 0e3a6c3dcc54e081ca499e0ed0a73b9a12b538a8
22+
subdir: servant-openapi-ui
23+
24+
allow-newer: servant-blaze:servant

‎src/Web/Template.hs‎

Lines changed: 3 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -5,6 +5,6 @@ module Web.Template
55
, module Web.Template.Types
66
) where
77

8-
import Web.Template.Except
9-
import Web.Template.Server
10-
import Web.Template.Types
8+
import Web.Template.Except
9+
import Web.Template.Server
10+
import Web.Template.Types

‎src/Web/Template/Except.hs‎

Lines changed: 8 additions & 10 deletions
Original file line numberDiff line numberDiff line change
@@ -13,14 +13,11 @@ module Web.Template.Except
1313
, MonadWebError(..)
1414
) where
1515

16-
import Data.Aeson (FromJSON (..), ToJSON (..),
17-
defaultOptions, genericToEncoding)
18-
import Data.String (fromString)
19-
import GHC.Generics (Generic)
20-
import Network.HTTP.Types.Status (Status, status403, status404,
21-
status500)
22-
import Web.Scotty.Trans (ActionT, ScottyError (..), json,
23-
raise, status)
16+
import Data.Aeson (FromJSON (..), ToJSON (..), defaultOptions, genericToEncoding)
17+
import Data.String (fromString)
18+
import GHC.Generics (Generic)
19+
import Network.HTTP.Types.Status (Status, status403, status404, status500)
20+
import Web.Scotty.Trans (ActionT, ScottyError (..), json, raise, status)
2421

2522

2623
instance ScottyError Except where
@@ -36,7 +33,8 @@ data Except
3633

3734
deriving instance Show Except
3835

39-
newtype JsonWebError = JsonWebError { error :: String }
36+
newtype JsonWebError
37+
= JsonWebError { error :: String }
4038
deriving (Generic)
4139

4240
instance ToJSON JsonWebError where
@@ -73,6 +71,6 @@ class MonadWebError m where
7371
throwJson500 :: (Show e, ToJSON e) => e -> m a
7472
throwJson500 = throwJson status500
7573

76-
instance Monad m => MonadWebError (ActionT Except m) where
74+
instance {-# OVERLAPPING #-} Monad m => MonadWebError (ActionT Except m) where
7775
{-# INLINE throwJson #-}
7876
throwJson s e = raise $ CustomJsonException s e

‎src/Web/Template/Servant.hs‎

Lines changed: 67 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
module Web.Template.Servant
2+
( runServantServer
3+
, runServantServerWith
4+
, runServantServerWithContext
5+
6+
, OpenApiSchemaUI
7+
, openapiSchemaUIServer
8+
9+
, module Web.Template.Servant.Aeson
10+
, module Web.Template.Servant.API
11+
, module Web.Template.Servant.Auth
12+
, module Web.Template.Servant.Error
13+
) where
14+
15+
import Data.Proxy (Proxy (..))
16+
import Network.Wai (Application)
17+
import Network.Wai.Handler.Warp (Settings, runSettings)
18+
import Servant.OpenAPI.UI (OpenApiSchemaUI, openapiSchemaUIServer)
19+
import Servant.Server (Context, DefaultErrorFormatters, ErrorFormatters, HasContextEntry,
20+
HasServer, Server, serveWithContext, type (.++), (.++))
21+
22+
import Web.Template.Types (Port)
23+
import Web.Template.Wai (defaultHandleLog, defaultHeaderCORS, warpSettings)
24+
25+
import Web.Template.Servant.API
26+
import Web.Template.Servant.Aeson
27+
import Web.Template.Servant.Auth
28+
import Web.Template.Servant.Error
29+
30+
runServantServer
31+
:: forall api
32+
. (HasServer api '[ErrorFormatters])
33+
=> Port
34+
-> Server api
35+
-> IO ()
36+
runServantServer = runServantServerWith @api id (defaultHeaderCORS . defaultHandleLog)
37+
38+
runServantServerWith
39+
:: forall api
40+
. (HasServer api '[ErrorFormatters])
41+
=> (Settings -> Settings)
42+
-> (Application -> Application)
43+
-- ^ Middlewares
44+
-> Port
45+
-> Server api
46+
-> IO ()
47+
runServantServerWith userSettings middlewares port server =
48+
runSettings (warpSettings port userSettings)
49+
$ middlewares
50+
$ serveWithContext @api Proxy cbdContext
51+
$ server
52+
53+
runServantServerWithContext
54+
:: forall api ctx
55+
. (HasServer api (ctx .++ '[ErrorFormatters]), HasContextEntry ((ctx .++ '[ErrorFormatters]) .++ DefaultErrorFormatters) ErrorFormatters)
56+
=> (Settings -> Settings)
57+
-> (Application -> Application)
58+
-- ^ Middlewares
59+
-> Port
60+
-> Context ctx
61+
-> Server api
62+
-> IO ()
63+
runServantServerWithContext userSettings middlewares port ctx server =
64+
runSettings (warpSettings port userSettings)
65+
$ middlewares
66+
$ serveWithContext @api Proxy (ctx .++ cbdContext)
67+
$ server

‎src/Web/Template/Servant/API.hs‎

Lines changed: 64 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,64 @@
1+
module Web.Template.Servant.API where
2+
3+
import Control.Lens ((?~))
4+
import Data.Function ((&))
5+
import Data.OpenApi (applyTags, description)
6+
import Data.Proxy (Proxy (..))
7+
import Data.String (fromString)
8+
import Data.Text (pack)
9+
import GHC.TypeLits (AppendSymbol, KnownSymbol, Symbol, symbolVal)
10+
11+
import Control.Monad.IO.Class (MonadIO (..))
12+
import Control.Monad.Trans.Resource (runResourceT)
13+
import Network.Wai (Request, Response, ResponseReceived)
14+
import Servant (HasServer (..), Raw, (:>))
15+
import Servant.OpenApi (HasOpenApi (..))
16+
import Servant.Server.Internal (RouteResult (..), Router' (..), runDelayed, runHandler)
17+
18+
-- | Prepend version to every sub-route.
19+
--
20+
-- > type API = Version "3" :> ("route1" :<|> "route2")
21+
type Version (v :: Symbol) = AppendSymbol "v" v
22+
23+
-- | Mark sub-api with a Swagger tag with description.
24+
--
25+
-- > type API
26+
-- > = (Tag "foo" "Some Foo routes" :> ("foo1" :<|> "foo2"))
27+
-- > :<|> (Tag "bar" "Some Bar routes" :> ("bar1" :<|> "bar2"))
28+
data Tag (tag :: Symbol) (descr :: Symbol)
29+
30+
instance HasServer api context => HasServer (Tag tag descr :> api) context where
31+
type ServerT (Tag tag descr :> api) m = ServerT api m
32+
33+
route _ = route @api Proxy
34+
hoistServerWithContext _ = hoistServerWithContext @api Proxy
35+
36+
instance (KnownSymbol tag, KnownSymbol descr, HasOpenApi api) => HasOpenApi (Tag tag descr :> api) where
37+
toOpenApi _ = toOpenApi @api Proxy
38+
& applyTags [fromString (symbolVal @tag Proxy) & description ?~ pack (symbolVal @descr Proxy)]
39+
40+
-- | As 'Raw', but with access to the custom monad @m@.
41+
--
42+
-- See <https://github.com/haskell-servant/servant/pull/1349>.
43+
data RawM
44+
45+
instance HasServer RawM ctx where
46+
type ServerT RawM m = Request -> (Response -> IO ResponseReceived) -> m ResponseReceived
47+
48+
hoistServerWithContext _ _ nt m = \request respond -> nt $ m request respond
49+
50+
route _ _ dApp = RawRouter $ \env request respond -> runResourceT $ do
51+
r <- runDelayed dApp env request
52+
liftIO $ case r of
53+
Fail a -> respond $ Fail a
54+
FailFatal e -> respond $ FailFatal e
55+
Route appH -> do
56+
r' <- runHandler $ appH request (respond . Route)
57+
-- appH may return result with 'Right' _only_ by calling smth like @liftIO . respond@,
58+
-- so in case of 'Left' we may suppose that 'respond' was never called.
59+
case r' of
60+
Left e -> respond $ FailFatal e
61+
Right x -> return x
62+
63+
instance HasOpenApi RawM where
64+
toOpenApi _ = toOpenApi @Raw Proxy

‎src/Web/Template/Servant/Aeson.hs‎

Lines changed: 71 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,71 @@
1+
module Web.Template.Servant.Aeson where
2+
3+
import Control.Lens ((?~))
4+
import Data.Aeson
5+
import Data.Aeson.Casing
6+
import Data.Functor ((<&>))
7+
import Data.Proxy (Proxy (..))
8+
import GHC.Generics
9+
10+
import Data.OpenApi
11+
import Data.OpenApi.Internal.Schema
12+
13+
-- | This wrapper is intended to be used with @DerivingVia@ to make
14+
-- consistent 'ToJSON', 'FromJSON' and 'ToSchema' for some data type.
15+
--
16+
-- Usage:
17+
--
18+
-- > data Foo
19+
-- > = Foo
20+
-- > { fFoo :: String
21+
-- > , fBar :: String
22+
-- > }
23+
-- > deriving (Eq, Show, Generic)
24+
-- > deriving (ToJSON, FromJSON, ToSchema) via CamelCaseAeson Foo
25+
--
26+
-- Instances are made with 'aesonPrefix' 'camelCase' and 'omitNothingFields' set to @True@.
27+
newtype CamelCaseAeson a
28+
= CamelCaseAeson a
29+
30+
prefixOptions :: Options
31+
prefixOptions = (aesonPrefix camelCase) { omitNothingFields = True }
32+
33+
instance (Generic a, GToJSON Zero (Rep a), GToEncoding Zero (Rep a)) => ToJSON (CamelCaseAeson a) where
34+
toJSON (CamelCaseAeson a) = genericToJSON prefixOptions a
35+
toEncoding (CamelCaseAeson a) = genericToEncoding prefixOptions a
36+
37+
instance (Generic a, GFromJSON Zero (Rep a)) => FromJSON (CamelCaseAeson a) where
38+
parseJSON = fmap CamelCaseAeson . genericParseJSON prefixOptions
39+
40+
instance (Generic a, GToSchema (Rep a)) => ToSchema (CamelCaseAeson a) where
41+
declareNamedSchema _ =
42+
genericDeclareNamedSchema @a (fromAesonOptions prefixOptions) Proxy
43+
44+
-- | This wrapper extends 'ToSchema' instance of the underlying type with
45+
-- an example obtained from 'WithExample' instance.
46+
--
47+
-- Usage:
48+
--
49+
-- > data Foo
50+
-- > = ...
51+
-- > deriving (Eq, Show, Generic)
52+
-- > deriving (ToJSON, FromJSON) via CamelCaseAeson Foo
53+
-- > deriving (ToSchema) via SwaggerWithExample (CamelCaseAeson Foo)
54+
--
55+
-- Last line reuses 'ToSchema' instances from 'CamelCaseAeson' to ensure that instances
56+
-- stay consistent.
57+
newtype SwaggerWithExample a
58+
= SwaggerWithExample a
59+
60+
-- | Provide an example for Swagger schema.
61+
--
62+
-- Swagger supports only one example per named schema.
63+
class ToJSON a => WithExample a where
64+
mkExample :: a
65+
66+
instance (WithExample a, ToSchema a) => ToSchema (SwaggerWithExample a) where
67+
declareNamedSchema _ = declareNamedSchema @a Proxy
68+
<&> schema . example ?~ toJSON (mkExample @a)
69+
70+
instance (ToJSON (CamelCaseAeson a), WithExample a) => WithExample (CamelCaseAeson a) where
71+
mkExample = CamelCaseAeson $ mkExample @a

‎src/Web/Template/Servant/Auth.hs‎

Lines changed: 66 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,66 @@
1+
module Web.Template.Servant.Auth
2+
where
3+
4+
-- after https://www.stackage.org/haddock/lts-15.15/servant-server-0.16.2/src/Servant.Server.Experimental.Auth.html
5+
6+
import Control.Lens (at, (.~), (?~))
7+
import Data.Function ((&))
8+
import Data.Functor ((<&>))
9+
import Data.Proxy (Proxy (..))
10+
import Data.Text (Text)
11+
import GHC.Generics (Generic)
12+
13+
import Data.OpenApi.Internal (ApiKeyLocation (..), ApiKeyParams (..), SecurityRequirement (..),
14+
SecurityScheme (..), SecuritySchemeType (..))
15+
import Data.OpenApi.Lens (components, description, security, securitySchemes)
16+
import Data.OpenApi.Operation (allOperations, setResponse)
17+
import Network.HTTP.Types.Header (hContentType)
18+
import Network.Wai (requestHeaders)
19+
import Servant.API ((:>))
20+
import Servant.OpenApi (HasOpenApi (..))
21+
import Servant.Server (HasServer (..), ServerError (..), err401)
22+
import Servant.Server.Internal (addAuthCheck, delayedFailFatal, withRequest)
23+
import Web.Cookie (parseCookiesText)
24+
25+
-- | Add authenthication via @id@ Cookie.
26+
--
27+
-- Usage:
28+
--
29+
-- > type API = CbdAuth :> (....)
30+
--
31+
-- Handlers will get an 'UserId' argument.
32+
data CbdAuth
33+
34+
newtype UserId
35+
= UserId { getUserId :: Text }
36+
deriving (Eq, Show, Generic)
37+
38+
instance HasServer api context => HasServer (CbdAuth :> api) context where
39+
type ServerT (CbdAuth :> api) m = UserId -> ServerT api m
40+
41+
hoistServerWithContext _ pc nt s = hoistServerWithContext @api Proxy pc nt . s
42+
43+
route _ context sub =
44+
route @api Proxy context
45+
$ addAuthCheck sub
46+
$ withRequest $ \req ->
47+
maybe (delayedFailFatal err) return $
48+
lookup "cookie" (requestHeaders req)
49+
<&> parseCookiesText
50+
>>= lookup "id"
51+
<&> UserId
52+
where
53+
err = err401
54+
{ errBody = "{\"error\": \"Authorization failed\"}"
55+
, errHeaders = [(hContentType, "application/json")]
56+
}
57+
58+
instance HasOpenApi api => HasOpenApi (CbdAuth :> api) where
59+
toOpenApi _ = toOpenApi @api Proxy
60+
& components . securitySchemes . at "cbdCookie" ?~ idCookie
61+
& allOperations . security .~ [SecurityRequirement $ mempty & at "cbdCookie" ?~ []]
62+
& setResponse 401 (return $ mempty & description .~ "Authorization failed")
63+
where
64+
idCookie = SecurityScheme
65+
(SecuritySchemeApiKey (ApiKeyParams "id" ApiKeyCookie))
66+
(Just "`id` cookie")

0 commit comments

Comments
 (0)