From 35c9078fcb487d9d1dfbb96c36896bbfd1b8f206 Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Fri, 24 Oct 2014 13:37:37 +0200
Subject: [PATCH] get rid of some more proxies, client-side capture support,
 client and server side request body support

---
 src/Servant.hs | 102 +++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 81 insertions(+), 21 deletions(-)

diff --git a/src/Servant.hs b/src/Servant.hs
index 1fa733f1..5c5dea76 100644
--- a/src/Servant.hs
+++ b/src/Servant.hs
@@ -3,95 +3,155 @@
 {-# LANGUAGE TypeFamilies #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 module Servant where
 
 import Control.Applicative
+import Control.Concurrent (forkIO, killThread)
+import Control.Monad
+import Control.Monad.IO.Class
+import Control.Monad.Trans.Either
 import Data.Aeson
+import Data.ByteString.Lazy (ByteString)
 import Data.Monoid
 import Data.Proxy
 import Data.Text
 import GHC.Generics
 import GHC.TypeLits
+import Network.HTTP.Types
+import Network.URI
 import Network.Wai
 import Network.Wai.Handler.Warp
 import Soenke
 
+import qualified Network.HTTP.Client as Http.Client
+
 -- * Captures
 data Capture sym a
 
 class FromText a where
   capture :: Text -> Maybe a
 
+class ToText a where
+  toText :: a -> Text
+
 instance FromText Text where
   capture = Just
 
+instance ToText Text where
+  toText = id
+
 captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
 captured _ = capture
 
 instance (KnownSymbol capture, FromText a, HasServer sublayout)
       => HasServer (Capture capture a :> sublayout) where
 
-  -- this means that what follows the capture
-  -- must necessarily be a function that expects
-  -- the captured value. :-(
   type Server (Capture capture a :> sublayout) =
-    Capture capture a :> (a -> Server sublayout)
+     a -> Server sublayout
 
-  route Proxy (capture :> subserver) request = case pathInfo request of
+  route Proxy subserver request = case pathInfo request of
     (first : rest)
-      -> case captured capture first of
+      -> case captured captureProxy first of
            Nothing  -> return Nothing
            Just v   -> route (Proxy :: Proxy sublayout) (subserver v) request{
                          pathInfo = rest
                        }
     _ -> return Nothing
 
+    where captureProxy = Proxy :: Proxy (Capture capture a)
+
+instance (KnownSymbol capture, ToText a, HasClient sublayout)
+      => HasClient (Capture capture a :> sublayout) where
+
+  type Client (Capture capture a :> sublayout) =
+    a -> Client sublayout
+
+  clientWithRoute Proxy path val =
+      clientWithRoute (Proxy :: Proxy sublayout)
+                      (path ++ "/" ++ unpack (toText val))
+
 -- * Request Body support
 data RQBody a
 
 instance (FromJSON a, HasServer sublayout)
       => HasServer (RQBody a :> sublayout) where
 
-  -- same caveat as for the Captures...
   type Server (RQBody a :> sublayout) =
-    RQBody a :> (a -> Server sublayout)
+    a -> Server sublayout
 
-  route Proxy (rqbody :> subserver) request = do
+  route Proxy subserver request = do
     mrqbody <- decode' <$> lazyRequestBody request
     case mrqbody of
       Nothing -> return Nothing
       Just v  -> route (Proxy :: Proxy sublayout) (subserver v) request
 
+instance (ToJSON a, FromJSON b)
+      => HasClient (RQBody a :> Post b) where
+
+  type Client (RQBody a :> Post b) =
+    a -> URI -> EitherT String IO b
+
+  clientWithRoute Proxy path body uri = do
+    partialRequest <- liftIO . Http.Client.parseUrl $
+      show ( nullURI { uriPath = path }
+             `relativeTo` uri
+           )
+
+    let request = partialRequest
+          { Http.Client.method = methodPost
+          , Http.Client.requestBody = Http.Client.RequestBodyLBS (encode body)
+          }
+
+    innerResponse <- liftIO . __withGlobalManager $ \ manager ->
+      Http.Client.httpLbs request manager
+
+    when (Http.Client.responseStatus innerResponse /= status201) $
+      left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
+
+    maybe (left "HTTP POST request returned invalid json") return $
+      decode' (Http.Client.responseBody innerResponse)
+
 -- * Example
 
 type TestApi = "hello" :> Capture "name" Text :> Get Greet
+          :<|> "greet" :> RQBody Greet :> Post Greet
 
 testApi :: Proxy TestApi
 testApi = Proxy
 
 data Greet = Greet { msg :: Text }
-  deriving Generic
+  deriving (Generic, Show)
 
+instance FromJSON Greet
 instance ToJSON Greet
 
 server :: Server TestApi
-server =
-     Proxy -- :: Proxy "hello"
-  :> Proxy -- :: Proxy (Capture "name" Text)
-  :> (return . func)
+server = hello :<|> greet
 
-  where func name = Greet ("Hello, " <> name)
+  where hello = return . Greet . ("Hello, " <>)
+        greet = return
+
+getGreet :: Text -> URI -> EitherT String IO Greet
+postGreet :: Greet -> URI -> EitherT String IO Greet
+
+getGreet :<|> postGreet
+  = client testApi
 
 test :: Application
 test = serve testApi server
 
-runTest :: Port -> IO ()
-runTest port = run port test
+runTestServer :: Port -> IO ()
+runTestServer port = run port test
 
--- load in ghci, call 'runTest 8000'
--- visit http://localhost:8000/hello/world
--- visit http://localhost:8000/hello/soenke
--- visit http://localhost:8000/hello/alp
+runTest :: IO ()
+runTest = do
+  tid <- forkIO $ runTestServer 8001
+  let Just uri = parseURI "http://localhost:8001/"
+  print =<< runEitherT (getGreet "alp" uri)
+  let g = Greet "yo"
+  print =<< runEitherT (postGreet g uri)
+  killThread tid