Fix overlapping issues and improve tutorial.

doc/Main.hs

@@ -0,0 +1,4 @@
+import ServersEqual
+
+main :: IO ()
+main = main1

doc/ServersEqual.lhs

@@ -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
 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
 {-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveAnyClass #-}
+{-# LANGUAGE DeriveGeneric #-}
 {-# 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.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
     { title     :: String
     , completed :: Bool
     , url       :: String
     , order     :: Int
-    } deriving (Eq, Show, Read)
+    } deriving (Eq, Show, Read, Generic, ToJSON, FromJSON)
 
 type API = TodosAPI :<|> TodoAPI
 
@@ -125,30 +61,44 @@ type TodoAPI
   =    "todo" :> Capture "id " Int :>
            ( Get '[JSON] Todo
        :<|>  ReqBody '[JSON] Todo :> Patch '[JSON] ()
-       :<|> Delete '[JSON} ())
+       :<|> Delete '[JSON] ())
 
-serverTodos :: Server TodosAPI
+serverTodos :: DB -> Server TodosAPI
 serverTodos tvar = getTodos tvar
               :<|> postTodos tvar
               :<|> deleteAllTodos tvar
 
+{-
 serverTodo :: Server TodoAPI
 serverTodo id' = getTodo tvar id'
             :<|> patchTodo 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
 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
 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
+```
 

doc/doc.cabal

@@ -12,6 +12,28 @@ library
   other-extensions:    DataKinds, TypeOperators
   build-depends:       base >=4.8 && <4.9
                      , servant-server == 0.7.*
-
+                     , servant-quickcheck
+                     , servant-client
+                     , QuickCheck
+                     , stm
+                     , containers
+                     , transformers
+                     , warp
+                     , aeson
   ghc-options:         -Wall -Werror -pgmL markdown-unlit
   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

src/Servant/QuickCheck.hs

@@ -89,6 +89,11 @@ module Servant.QuickCheck
   , never500s
   , onlyJsonObjects
 
+  -- ** Re-exports
+  , BaseUrl(..)
+  , Scheme(..)
+
   ) where
 
 import Servant.QuickCheck.Internal
+import Servant.Client (BaseUrl(..), Scheme(..))

src/Servant/QuickCheck/Internal/Testable.hs

@@ -27,7 +27,8 @@ data ShouldMatch a = ShouldMatch
   , smBaseUrls :: (BaseUrl, BaseUrl)
   } 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
         let (burl1, burl2) = smBaseUrls sm
         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
                                ++ "\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
     property sm = forAllShrink arbitrary shrink go
       where go x = ($ x) <$> sm
@@ -63,7 +64,8 @@ data ShouldSatisfy filter expect a = ShouldSatisfy
   , ssBaseUrl :: BaseUrl
   } 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
     property ss = ioProperty $ do
         a' <- runExceptT $ ssVal ss (ssManager ss) (ssBaseUrl ss)
@@ -72,8 +74,9 @@ instance (Show a, Eq a, HasPredicate expect (Either ServantError a))
           Just (x', _) -> return $ Just (x', show a')
         return $ getPredicate (ssExpect ss) a'
 
-instance ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
+instance {-# OVERLAPPABLE #-}
-         , HasPredicate filter a)
+        ( Arbitrary a, Show a, Testable (ShouldSatisfy filter expect b)
+        , HasPredicate filter a)
       => Testable (ShouldSatisfy filter expect (a -> b)) where
     property ss = forAllShrink arbitrary shrink go
         where go x | getPredicate (ssFilter ss) x = ($ x) <$> ss