From 8c8bc15ea92061e2f0f201b60997431a29d66fa9 Mon Sep 17 00:00:00 2001
From: Alp Mestanogullari <alpmestan@gmail.com>
Date: Fri, 24 Oct 2014 13:36:19 +0200
Subject: [PATCH] get rid of a lot of useless proxies and implement POST
 requests support on server and client side

---
 servant.cabal |  1 +
 src/Soenke.hs | 55 ++++++++++++++++++++++++++++++++++++++++++++-------
 2 files changed, 49 insertions(+), 7 deletions(-)

diff --git a/servant.cabal b/servant.cabal
index d69f1dfe..2c361b32 100644
--- a/servant.cabal
+++ b/servant.cabal
@@ -20,6 +20,7 @@ library
       base >=4 && <5
     , either
     , aeson
+    , bytestring
     , string-conversions
     , http-client
     , http-types
diff --git a/src/Soenke.hs b/src/Soenke.hs
index eadda5f3..000e0e22 100644
--- a/src/Soenke.hs
+++ b/src/Soenke.hs
@@ -7,6 +7,7 @@ import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Either
 import           Data.Aeson
+import           Data.ByteString.Lazy (ByteString)
 import           Data.Proxy
 import           Data.String.Conversions
 import           GHC.TypeLits
@@ -32,6 +33,9 @@ import           System.IO.Unsafe           (unsafePerformIO)
 -- and serves the contained type as JSON.
 data Get a
 
+-- | Endpoint for POST requests.
+data Post a
+
 -- | The contained API (second argument) can be found under @("/" ++ path)@
 -- (path being the first argument).
 data (path :: k) :> a = Proxy path :> a
@@ -74,18 +78,33 @@ instance ToJSON result => HasServer (Get result) where
             responseLBS (mkStatus status (cs message)) [] (cs message)
     | otherwise = return Nothing
 
+instance ToJSON a => HasServer (Post a) where
+  type Server (Post a) = EitherT (Int, String) IO a
+
+  route Proxy action request
+    | null (pathInfo request) && requestMethod request == methodPost = do
+        e <- runEitherT action
+        return $ Just $ case e of
+          Right out ->
+            responseLBS status201 [("Content-Type", "application/json")] (encode out)
+          Left (status, message) ->
+            responseLBS (mkStatus status (cs message)) [] (cs message)
+    | otherwise = return Nothing
+
 instance (KnownSymbol path, HasServer sublayout) => HasServer (path :> sublayout) where
-  type Server (path :> sublayout) = path :> (Server sublayout)
-  route Proxy (path :> subserver) request = case pathInfo request of
+  type Server (path :> sublayout) = Server sublayout
+  route Proxy subserver request = case pathInfo request of
     (first : rest)
-      | first == cs (symbolVal path)
+      | first == cs (symbolVal proxyPath)
       -> route (Proxy :: Proxy sublayout) subserver request{
            pathInfo = rest
          }
     _ -> return Nothing
 
+    where proxyPath = Proxy :: Proxy path
+
 instance (HasServer a, HasServer b) => HasServer (a :<|> b) where
-  type Server (a :<|> b) = (Server a :<|> Server b)
+  type Server (a :<|> b) = Server a :<|> Server b
   route Proxy (a :<|> b) request = do
     m <- route (Proxy :: Proxy a) a request
     case m of
@@ -124,15 +143,37 @@ instance FromJSON result => HasClient (Get result) where
     maybe (left "HTTP GET request returned invalid json") return $
       decode' (Http.Client.responseBody innerResponse)
 
+instance FromJSON a => HasClient (Post a) where
+  type Client (Post a) = ByteString -> URI -> EitherT String IO a
+
+  clientWithRoute Proxy path rqbody 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 rqbody
+          }
+
+    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)
+
 instance (KnownSymbol path, HasClient sublayout) => HasClient (path :> sublayout) where
-  type Client (path :> sublayout) = path :> (Client sublayout)
+  type Client (path :> sublayout) = Client sublayout
   clientWithRoute Proxy path =
-    (Proxy :: Proxy path) :>
      clientWithRoute (Proxy :: Proxy sublayout)
        (path ++ "/" ++ (symbolVal (Proxy :: Proxy path)))
 
 instance (HasClient a, HasClient b) => HasClient (a :<|> b) where
-  type Client (a :<|> b) = (Client a :<|> Client b)
+  type Client (a :<|> b) = Client a :<|> Client b
   clientWithRoute Proxy path =
     clientWithRoute (Proxy :: Proxy a) path :<|>
     clientWithRoute (Proxy :: Proxy b) path