Merge pull request #882 from ilya-murzinov/docs-another-monad

Added new cookbook recipe for using custom monad
This commit is contained in:
Alp Mestanogullari 2017-12-29 12:51:44 +01:00 committed by GitHub
commit 0147f4b5c7
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
5 changed files with 153 additions and 0 deletions

View file

@ -7,6 +7,7 @@ packages: servant/
doc/tutorial/ doc/tutorial/
doc/cookbook/basic-auth/ doc/cookbook/basic-auth/
doc/cookbook/db-postgres-pool/ doc/cookbook/db-postgres-pool/
doc/cookbook/using-custom-monad/
doc/cookbook/db-sqlite-simple/ doc/cookbook/db-sqlite-simple/
doc/cookbook/jwt-and-basic-auth/ doc/cookbook/jwt-and-basic-auth/
doc/cookbook/file-upload/ doc/cookbook/file-upload/

View file

@ -2,6 +2,11 @@ packages:
basic-auth/ basic-auth/
db-sqlite-simple/ db-sqlite-simple/
db-postgres-pool/ db-postgres-pool/
using-custom-monad/
jwt-and-basic-auth/
file-upload/
structuring-apis/
https/
../../servant ../../servant
../../servant-server ../../servant-server
../../servant-client-core ../../servant-client-core

View file

@ -21,6 +21,7 @@ you name it!
https/Https.lhs https/Https.lhs
db-sqlite-simple/DBConnection.lhs db-sqlite-simple/DBConnection.lhs
db-postgres-pool/PostgresPool.lhs db-postgres-pool/PostgresPool.lhs
using-custom-monad/UsingCustomMonad.lhs
basic-auth/BasicAuth.lhs basic-auth/BasicAuth.lhs
jwt-and-basic-auth/JWTAndBasicAuth.lhs jwt-and-basic-auth/JWTAndBasicAuth.lhs
file-upload/FileUpload.lhs file-upload/FileUpload.lhs

View 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"]
```

View 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