mirror of
https://github.com/ilyakooo0/servant-quickcheck.git
synced 2024-09-11 10:26:36 +03:00
Fix overlapping issues and improve tutorial.
This commit is contained in:
parent
0d455a9851
commit
bf4efbcb8c
4
doc/Main.hs
Normal file
4
doc/Main.hs
Normal file
@ -0,0 +1,4 @@
|
|||||||
|
import ServersEqual
|
||||||
|
|
||||||
|
main :: IO ()
|
||||||
|
main = main1
|
@ -20,98 +20,34 @@ don't need to know anything about Django or Python to follow along; indeed,
|
|||||||
part of the fun of it is using `serversEqual` to guide you through
|
part of the fun of it is using `serversEqual` to guide you through
|
||||||
re-implementing code you may not entirely understand.
|
re-implementing code you may not entirely understand.
|
||||||
|
|
||||||
Looking at the code, we can see the routes in `urls.py`:
|
Looking around the codebase (`urls.py`, `models.py` and `views.py` in
|
||||||
|
particular) may lead us to a first attempt at a rewrite:
|
||||||
``` python
|
|
||||||
urlpatterns = patterns('',
|
|
||||||
url(r'^$', RedirectView.as_view(url='/todos')),
|
|
||||||
url(r'^todos$', views.TodoList.as_view()),
|
|
||||||
url(r'^todo/(?P<pk>[0-9]+)$', views.Todo.as_view()),
|
|
||||||
)
|
|
||||||
```
|
|
||||||
|
|
||||||
And the handlers in `views.py`:
|
|
||||||
|
|
||||||
``` python
|
|
||||||
class TodoList(APIView):
|
|
||||||
def get(self, request, format=None):
|
|
||||||
todo_items = TodoItem.objects.all()
|
|
||||||
serializer = TodoItemSerializer(todo_items, many=True)
|
|
||||||
return JSONResponse(serializer.data, status=status.HTTP_200_OK)
|
|
||||||
|
|
||||||
def post(self, request, format=None):
|
|
||||||
serializer = TodoItemSerializer(data=request.DATA)
|
|
||||||
if serializer.is_valid():
|
|
||||||
saved_item = serializer.save()
|
|
||||||
saved_item.url = request.build_absolute_uri('/todo/' + str(saved_item.id))
|
|
||||||
saved_item.save()
|
|
||||||
serializer = TodoItemSerializer(instance=saved_item)
|
|
||||||
return JSONResponse(serializer.data, status=status.HTTP_201_CREATED)
|
|
||||||
return JSONResponse(serializer.errors, status=status.HTTP_400_BAD_REQUEST)
|
|
||||||
|
|
||||||
def delete(self, request, format=None):
|
|
||||||
TodoItem.objects.all().delete()
|
|
||||||
return JSONResponse(None, status=status.HTTP_204_NO_CONTENT)
|
|
||||||
|
|
||||||
class Todo(APIView):
|
|
||||||
def get(self, request, pk, format=None):
|
|
||||||
try:
|
|
||||||
todoItem = TodoItem.objects.get(pk=pk)
|
|
||||||
serializer = TodoItemSerializer(todoItem)
|
|
||||||
except TodoItem.DoesNotExist:
|
|
||||||
return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
|
|
||||||
return JSONResponse(serializer.data, status=status.HTTP_200_OK)
|
|
||||||
|
|
||||||
def delete(self, request, pk, format=None):
|
|
||||||
try:
|
|
||||||
todoItem = TodoItem.objects.get(pk=pk)
|
|
||||||
todoItem.delete()
|
|
||||||
except TodoItem.DoesNotExist:
|
|
||||||
return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
|
|
||||||
return JSONResponse(None, status=status.HTTP_204_NO_CONTENT)
|
|
||||||
|
|
||||||
def patch(self, request, pk, format=None):
|
|
||||||
try:
|
|
||||||
todoItem = TodoItem.objects.get(pk=pk)
|
|
||||||
except TodoItem.DoesNotExist:
|
|
||||||
return JSONResponse(None, status=status.HTTP_400_BAD_REQUEST)
|
|
||||||
serializer = TodoItemSerializer(data=request.DATA, instance=todoItem, partial=True)
|
|
||||||
if serializer.is_valid():
|
|
||||||
serializer.save()
|
|
||||||
return JSONResponse(serializer.data, status=status.HTTP_200_OK)
|
|
||||||
return JSONResponse(serializer.errors, status=status.HTTP_400_BAD_REQUEST)
|
|
||||||
```
|
|
||||||
|
|
||||||
And from `models.py`:
|
|
||||||
|
|
||||||
``` python
|
|
||||||
|
|
||||||
class TodoItem(models.Model):
|
|
||||||
title = models.CharField(max_length=256, null=True, blank=True)
|
|
||||||
completed = models.NullBooleanField(null=True, blank=True, default=False)
|
|
||||||
url = models.CharField(max_length=256, null=True, blank=True)
|
|
||||||
order = models.IntegerField(null=True, blank=True)
|
|
||||||
|
|
||||||
```
|
|
||||||
|
|
||||||
So as a first pass, let's try:
|
|
||||||
|
|
||||||
``` haskell
|
``` haskell
|
||||||
{-# LANGUAGE DataKinds #-}
|
{-# LANGUAGE DataKinds #-}
|
||||||
|
{-# LANGUAGE DeriveAnyClass #-}
|
||||||
|
{-# LANGUAGE DeriveGeneric #-}
|
||||||
{-# LANGUAGE TypeOperators #-}
|
{-# LANGUAGE TypeOperators #-}
|
||||||
|
|
||||||
|
module ServersEqual where
|
||||||
|
|
||||||
|
import Control.Concurrent (forkIO, killThread)
|
||||||
|
import Control.Concurrent.STM as STM
|
||||||
|
import Control.Monad.IO.Class
|
||||||
|
import Data.Aeson (ToJSON, FromJSON)
|
||||||
|
import Data.IntMap as M
|
||||||
|
import GHC.Generics (Generic)
|
||||||
|
import Network.Wai.Handler.Warp (run)
|
||||||
import Servant
|
import Servant
|
||||||
import Servant.QuickCheck
|
import Servant.QuickCheck (serversEqual, BaseUrl(..), Scheme(..))
|
||||||
import STMContainers.Map as M
|
import Test.QuickCheck (Arbitrary(..))
|
||||||
import GHC.Conc (atomically)
|
|
||||||
import Test.QuickCheck
|
|
||||||
|
|
||||||
data Todo = Todo
|
data Todo = Todo
|
||||||
{ title :: String
|
{ title :: String
|
||||||
, completed :: Bool
|
, completed :: Bool
|
||||||
, url :: String
|
, url :: String
|
||||||
, order :: Int
|
, order :: Int
|
||||||
} deriving (Eq, Show, Read)
|
} deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
|
||||||
|
|
||||||
type API = TodosAPI :<|> TodoAPI
|
type API = TodosAPI :<|> TodoAPI
|
||||||
|
|
||||||
@ -125,30 +61,44 @@ type TodoAPI
|
|||||||
= "todo" :> Capture "id " Int :>
|
= "todo" :> Capture "id " Int :>
|
||||||
( Get '[JSON] Todo
|
( Get '[JSON] Todo
|
||||||
:<|> ReqBody '[JSON] Todo :> Patch '[JSON] ()
|
:<|> ReqBody '[JSON] Todo :> Patch '[JSON] ()
|
||||||
:<|> Delete '[JSON} ())
|
:<|> Delete '[JSON] ())
|
||||||
|
|
||||||
serverTodos :: Server TodosAPI
|
serverTodos :: DB -> Server TodosAPI
|
||||||
serverTodos tvar = getTodos tvar
|
serverTodos tvar = getTodos tvar
|
||||||
:<|> postTodos tvar
|
:<|> postTodos tvar
|
||||||
:<|> deleteAllTodos tvar
|
:<|> deleteAllTodos tvar
|
||||||
|
|
||||||
|
{-
|
||||||
serverTodo :: Server TodoAPI
|
serverTodo :: Server TodoAPI
|
||||||
serverTodo id' = getTodo tvar id'
|
serverTodo id' = getTodo tvar id'
|
||||||
:<|> patchTodo tvar id'
|
:<|> patchTodo tvar id'
|
||||||
:<|> deleteTodo tvar id'
|
:<|> deleteTodo tvar id'
|
||||||
|
-}
|
||||||
|
|
||||||
getTodos :: Map Int Todo -> Handler [Todo]
|
type DB = TVar (M.IntMap Todo)
|
||||||
getTodos m = liftIO . atomically . toList $ S.stream m
|
|
||||||
|
|
||||||
postTodos :: Map Int Todo -> Todo -> Handler ()
|
getTodos :: DB -> Handler [Todo]
|
||||||
postTodos m t = liftIO . atomically $ S.insert m t
|
getTodos m = liftIO $ M.elems <$> STM.readTVarIO m
|
||||||
|
|
||||||
deleteTodos :: Map Int Todo -> Todo -> Handler ()
|
postTodos :: DB -> Todo -> Handler ()
|
||||||
deleteTodos m t = liftIO . atomically $ S.insert m t
|
postTodos m t = liftIO . STM.atomically $ STM.modifyTVar' m (M.insert (order t) t)
|
||||||
|
|
||||||
|
deleteAllTodos :: DB -> Handler ()
|
||||||
|
deleteAllTodos m = liftIO . STM.atomically $ STM.writeTVar m M.empty
|
||||||
|
|
||||||
|
main1 :: IO ()
|
||||||
|
main1 = do
|
||||||
|
db <- STM.newTVarIO M.empty
|
||||||
|
tId <- forkIO $ run 8000 $ serve (Proxy :: Proxy TodosAPI) $ serverTodos db
|
||||||
|
_ <- serversEqual (Proxy :: Proxy TodosAPI)
|
||||||
|
(BaseUrl Http "localhost" 8000 "")
|
||||||
|
(BaseUrl Http "localhost" 8001 "")
|
||||||
|
1000
|
||||||
|
killThread tId
|
||||||
```
|
```
|
||||||
|
|
||||||
(We're keeping the `Todo`s in memory for simplicity - if this were a production
|
(We're keeping the `Todo`s in an `MVar` for simplicity. If this were a
|
||||||
application, we'd likely want to use a database.)
|
production application, we'd likely want to use a database.)
|
||||||
|
|
||||||
Notice that we split up the API into two sub-APIs. Partly this makes things
|
Notice that we split up the API into two sub-APIs. Partly this makes things
|
||||||
cleaner and more readable, but there's also a more concrete benefit: we can
|
cleaner and more readable, but there's also a more concrete benefit: we can
|
||||||
@ -160,7 +110,16 @@ In order to check how we're doing, we need to add an `Arbitrary` instance for
|
|||||||
|
|
||||||
``` haskell
|
``` haskell
|
||||||
instance Arbitrary Todo where
|
instance Arbitrary Todo where
|
||||||
arbitrary = Todo <$> arbitrary <$> arbitrary <$> arbitrary <$> arbitrary
|
arbitrary = Todo <$> arbitrary <*> arbitrary <*> arbitrary <*> arbitrary
|
||||||
```
|
```
|
||||||
|
|
||||||
|
Let's try it out. First we need to get the old application running:
|
||||||
|
|
||||||
|
``` bash
|
||||||
|
git clone https://github.com/mihirk/todo-backend-django.git
|
||||||
|
cd todo-backend-django
|
||||||
|
virtualenv venv
|
||||||
|
. ./venv/bin/activate
|
||||||
|
python manage.py runserver localhost:8001
|
||||||
|
```
|
||||||
|
|
||||||
|
@ -12,6 +12,28 @@ library
|
|||||||
other-extensions: DataKinds, TypeOperators
|
other-extensions: DataKinds, TypeOperators
|
||||||
build-depends: base >=4.8 && <4.9
|
build-depends: base >=4.8 && <4.9
|
||||||
, servant-server == 0.7.*
|
, servant-server == 0.7.*
|
||||||
|
, servant-quickcheck
|
||||||
|
, servant-client
|
||||||
|
, QuickCheck
|
||||||
|
, stm
|
||||||
|
, containers
|
||||||
|
, transformers
|
||||||
|
, warp
|
||||||
|
, aeson
|
||||||
ghc-options: -Wall -Werror -pgmL markdown-unlit
|
ghc-options: -Wall -Werror -pgmL markdown-unlit
|
||||||
default-language: Haskell2010
|
default-language: Haskell2010
|
||||||
|
|
||||||
|
executable doc
|
||||||
|
main-is: Main.hs
|
||||||
|
build-depends: base >=4.8 && <4.9
|
||||||
|
, servant-server == 0.7.*
|
||||||
|
, servant-quickcheck
|
||||||
|
, servant-client
|
||||||
|
, QuickCheck
|
||||||
|
, stm
|
||||||
|
, containers
|
||||||
|
, transformers
|
||||||
|
, warp
|
||||||
|
, aeson
|
||||||
|
default-language: Haskell2010
|
||||||
|
ghc-options: -Wall -Werror -pgmL markdown-unlit
|
||||||
|
@ -89,6 +89,11 @@ module Servant.QuickCheck
|
|||||||
, never500s
|
, never500s
|
||||||
, onlyJsonObjects
|
, onlyJsonObjects
|
||||||
|
|
||||||
|
-- ** Re-exports
|
||||||
|
, BaseUrl(..)
|
||||||
|
, Scheme(..)
|
||||||
|
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import Servant.QuickCheck.Internal
|
import Servant.QuickCheck.Internal
|
||||||
|
import Servant.Client (BaseUrl(..), Scheme(..))
|
||||||
|
@ -27,7 +27,8 @@ data ShouldMatch a = ShouldMatch
|
|||||||
, smBaseUrls :: (BaseUrl, BaseUrl)
|
, smBaseUrls :: (BaseUrl, BaseUrl)
|
||||||
} deriving (Functor, Generic)
|
} deriving (Functor, Generic)
|
||||||
|
|
||||||
instance (Show a, Eq a) => Testable (ShouldMatch (FinalClient a)) where
|
instance {-# OVERLAPPING #-} (Show a, Eq a)
|
||||||
|
=> Testable (ShouldMatch (FinalClient a)) where
|
||||||
property sm = ioProperty $ do
|
property sm = ioProperty $ do
|
||||||
let (burl1, burl2) = smBaseUrls sm
|
let (burl1, burl2) = smBaseUrls sm
|
||||||
e1' <- runExceptT $ smClient sm (smManager sm) burl1
|
e1' <- runExceptT $ smClient sm (smManager sm) burl1
|
||||||
@ -44,7 +45,7 @@ instance (Show a, Eq a) => Testable (ShouldMatch (FinalClient a)) where
|
|||||||
++ "\nLHS:\n" ++ show err1
|
++ "\nLHS:\n" ++ show err1
|
||||||
++ "\nRHS:\n" ++ show err2
|
++ "\nRHS:\n" ++ show err2
|
||||||
|
|
||||||
instance (Arbitrary a, Show a, Testable (ShouldMatch b))
|
instance {-# OVERLAPPABLE #-} (Arbitrary a, Show a, Testable (ShouldMatch b))
|
||||||
=> Testable (ShouldMatch (a -> b)) where
|
=> Testable (ShouldMatch (a -> b)) where
|
||||||
property sm = forAllShrink arbitrary shrink go
|
property sm = forAllShrink arbitrary shrink go
|
||||||
where go x = ($ x) <$> sm
|
where go x = ($ x) <$> sm
|
||||||
@ -63,7 +64,8 @@ data ShouldSatisfy filter expect a = ShouldSatisfy
|
|||||||
, ssBaseUrl :: BaseUrl
|
, ssBaseUrl :: BaseUrl
|
||||||
} deriving (Functor)
|
} deriving (Functor)
|
||||||
|
|
||||||
instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
|
instance {-# OVERLAPPING #-}
|
||||||
|
(Show a, Eq a, HasPredicate expect (Either ServantError a))
|
||||||
=> Testable (ShouldSatisfy filter expect (FinalClient a)) where
|
=> Testable (ShouldSatisfy filter expect (FinalClient a)) where
|
||||||
property ss = ioProperty $ do
|
property ss = ioProperty $ do
|
||||||
a' <- runExceptT $ ssVal ss (ssManager ss) (ssBaseUrl ss)
|
a' <- runExceptT $ ssVal ss (ssManager ss) (ssBaseUrl ss)
|
||||||
@ -72,7 +74,8 @@ instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
|
|||||||
Just (x', _) -> return $ Just (x', show a')
|
Just (x', _) -> return $ Just (x', show a')
|
||||||
return $ getPredicate (ssExpect ss) a'
|
return $ getPredicate (ssExpect ss) a'
|
||||||
|
|
||||||
instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
|
instance {-# OVERLAPPABLE #-}
|
||||||
|
( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
|
||||||
, HasPredicate filter a)
|
, HasPredicate filter a)
|
||||||
=> Testable (ShouldSatisfy filter expect (a -> b)) where
|
=> Testable (ShouldSatisfy filter expect (a -> b)) where
|
||||||
property ss = forAllShrink arbitrary shrink go
|
property ss = forAllShrink arbitrary shrink go
|
||||||
|
Loading…
Reference in New Issue
Block a user