Added new cookbook recipe for using custom monad
This commit is contained in:
parent
68bc41b41d
commit
f1911f390d
5 changed files with 153 additions and 0 deletions
|
@ -7,6 +7,7 @@ packages: servant/
|
|||
doc/tutorial/
|
||||
doc/cookbook/basic-auth/
|
||||
doc/cookbook/db-postgres-pool/
|
||||
doc/cookbook/using-custom-monad/
|
||||
doc/cookbook/db-sqlite-simple/
|
||||
doc/cookbook/jwt-and-basic-auth/
|
||||
doc/cookbook/file-upload/
|
||||
|
|
|
@ -2,6 +2,11 @@ packages:
|
|||
basic-auth/
|
||||
db-sqlite-simple/
|
||||
db-postgres-pool/
|
||||
using-custom-monad/
|
||||
jwt-and-basic-auth/
|
||||
file-upload/
|
||||
structuring-apis/
|
||||
https/
|
||||
../../servant
|
||||
../../servant-server
|
||||
../../servant-client-core
|
||||
|
|
|
@ -21,6 +21,7 @@ you name it!
|
|||
https/Https.lhs
|
||||
db-sqlite-simple/DBConnection.lhs
|
||||
db-postgres-pool/PostgresPool.lhs
|
||||
using-custom-monad/UsingCustomMonad.lhs
|
||||
basic-auth/BasicAuth.lhs
|
||||
jwt-and-basic-auth/JWTAndBasicAuth.lhs
|
||||
file-upload/FileUpload.lhs
|
||||
|
|
117
doc/cookbook/using-custom-monad/UsingCustomMonad.lhs
Normal file
117
doc/cookbook/using-custom-monad/UsingCustomMonad.lhs
Normal file
|
@ -0,0 +1,117 @@
|
|||
# Using a custom monad
|
||||
|
||||
In this section we will create and API for a book shelf without any backing DB storage.
|
||||
We will keep state in memory and share it between requests using `Reader` monad and `STM`.
|
||||
|
||||
We start with a pretty standard set of imports and definition of the model:
|
||||
|
||||
``` haskell
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE DeriveGeneric #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
|
||||
import Control.Concurrent (forkIO, killThread)
|
||||
import Control.Concurrent.STM.TVar (TVar, newTVar, readTVar,
|
||||
writeTVar)
|
||||
import Control.Exception (bracket)
|
||||
import Control.Monad.IO.Class (liftIO)
|
||||
import Control.Monad.STM (atomically)
|
||||
import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT)
|
||||
import Data.Aeson (FromJSON, ToJSON)
|
||||
import GHC.Generics (Generic)
|
||||
import Network.HTTP.Client (defaultManagerSettings,
|
||||
newManager)
|
||||
import Network.Wai.Handler.Warp (run)
|
||||
|
||||
import Servant
|
||||
import Servant.Client
|
||||
|
||||
newtype Book = Book String deriving (Show, Generic)
|
||||
instance ToJSON Book
|
||||
instance FromJSON Book
|
||||
```
|
||||
|
||||
Now, let's define the API for book storage.
|
||||
For the sake of simplicity we'll only have methods for getting all books and adding a new one.
|
||||
|
||||
``` haskell
|
||||
type GetBooks = Get '[JSON] [Book]
|
||||
type AddBook = ReqBody '[JSON] Book :> PostCreated '[JSON] Book
|
||||
type BooksAPI = "books" :> (GetBooks :<|> AddBook)
|
||||
|
||||
api :: Proxy BooksAPI
|
||||
api = Proxy
|
||||
```
|
||||
|
||||
Next, we define the state and the monad to run our handlers
|
||||
|
||||
``` haskell
|
||||
data State = State
|
||||
{ books :: TVar [Book]
|
||||
}
|
||||
|
||||
type AppM = ReaderT State Handler
|
||||
```
|
||||
|
||||
Note that we can't use `State` monad here, because state will not be shared between requests.
|
||||
|
||||
We can now define handlers in terms of `AppM`...
|
||||
|
||||
```haskell
|
||||
server :: ServerT BooksAPI AppM
|
||||
server = getBooks :<|> addBook
|
||||
where getBooks :: AppM [Book]
|
||||
getBooks = do
|
||||
State{books = p} <- ask
|
||||
liftIO $ atomically $ readTVar p
|
||||
|
||||
addBook :: Book -> AppM Book
|
||||
addBook book = do
|
||||
State{books = p} <- ask
|
||||
liftIO $ atomically $ readTVar p >>= writeTVar p . (book :)
|
||||
return book
|
||||
|
||||
```
|
||||
|
||||
...and transform `AppM` to `Handler` by simply using `runReaderT`
|
||||
|
||||
``` haskell
|
||||
nt :: State -> AppM a -> Handler a
|
||||
nt s x = runReaderT x s
|
||||
|
||||
app :: State -> Application
|
||||
app s = serve api $ hoistServer api (nt s) server
|
||||
```
|
||||
|
||||
Finally, we end up with the following program
|
||||
|
||||
``` haskell
|
||||
main :: IO ()
|
||||
main = do
|
||||
let port = 8080
|
||||
mgr <- newManager defaultManagerSettings
|
||||
initialBooks <- atomically $ newTVar []
|
||||
let runApp = run port $ app $ State initialBooks
|
||||
bracket (forkIO runApp) killThread $ \_ -> do
|
||||
let getBooksClient :<|> addBookClient = client api
|
||||
let printBooks = getBooksClient >>= liftIO . print
|
||||
_ <- flip runClientM (ClientEnv mgr (BaseUrl Http "localhost" port "")) $ do
|
||||
_ <- printBooks
|
||||
_ <- addBookClient $ Book "Harry Potter and the Order of the Phoenix"
|
||||
_ <- printBooks
|
||||
_ <- addBookClient $ Book "To Kill a Mockingbird"
|
||||
_ <- printBooks
|
||||
_ <- addBookClient $ Book "The Picture of Dorian Gray"
|
||||
printBooks
|
||||
return ()
|
||||
```
|
||||
|
||||
When run, it outputs the following:
|
||||
|
||||
```
|
||||
Running cookbook-using-custom-monad...
|
||||
[]
|
||||
[Book "Harry Potter and the Order of the Phoenix"]
|
||||
[Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
|
||||
[Book "The Picture of Dorian Gray",Book "To Kill a Mockingbird",Book "Harry Potter and the Order of the Phoenix"]
|
||||
```
|
29
doc/cookbook/using-custom-monad/using-custom-monad.cabal
Normal file
29
doc/cookbook/using-custom-monad/using-custom-monad.cabal
Normal file
|
@ -0,0 +1,29 @@
|
|||
name: cookbook-using-custom-monad
|
||||
version: 0.1
|
||||
synopsis: Using custom monad to pass a state between handlers
|
||||
homepage: http://haskell-servant.readthedocs.org/
|
||||
license: BSD3
|
||||
license-file: ../../../servant/LICENSE
|
||||
author: Servant Contributors
|
||||
maintainer: haskell-servant-maintainers@googlegroups.com
|
||||
build-type: Simple
|
||||
cabal-version: >=1.10
|
||||
|
||||
executable cookbook-using-custom-monad
|
||||
if impl(ghc < 7.10.1)
|
||||
buildable: False
|
||||
main-is: UsingCustomMonad.lhs
|
||||
build-depends: base == 4.*
|
||||
, aeson >= 1.2
|
||||
, servant
|
||||
, servant-client
|
||||
, servant-server
|
||||
, warp >= 3.2
|
||||
, wai >= 3.2
|
||||
, http-client >= 0.5
|
||||
, markdown-unlit >= 0.4
|
||||
, stm >= 2.4
|
||||
, transformers >= 0.4
|
||||
default-language: Haskell2010
|
||||
ghc-options: -Wall -pgmL markdown-unlit
|
||||
build-tool-depends: markdown-unlit:markdown-unlit
|
Loading…
Reference in a new issue