@@ -3,95 +3,155 @@
33{-# LANGUAGE TypeFamilies #-}
44{-# LANGUAGE DeriveGeneric #-}
55{-# LANGUAGE TypeOperators #-}
6+{-# LANGUAGE FlexibleContexts #-}
67{-# LANGUAGE FlexibleInstances #-}
78{-# LANGUAGE OverloadedStrings #-}
89{-# LANGUAGE ScopedTypeVariables #-}
910module Servant where
1011
1112import Control.Applicative
13+import Control.Concurrent (forkIO, killThread)
14+import Control.Monad
15+import Control.Monad.IO.Class
16+import Control.Monad.Trans.Either
1217import Data.Aeson
18+import Data.ByteString.Lazy (ByteString)
1319import Data.Monoid
1420import Data.Proxy
1521import Data.Text
1622import GHC.Generics
1723import GHC.TypeLits
24+import Network.HTTP.Types
25+import Network.URI
1826import Network.Wai
1927import Network.Wai.Handler.Warp
2028import Soenke
2129
30+import qualified Network.HTTP.Client as Http.Client
31+
2232-- * Captures
2333data Capture sym a
2434
2535class FromText a where
2636 capture :: Text -> Maybe a
2737
38+class ToText a where
39+ toText :: a -> Text
40+
2841instance FromText Text where
2942 capture = Just
3043
44+instance ToText Text where
45+ toText = id
46+
3147captured :: FromText a => proxy (Capture sym a) -> Text -> Maybe a
3248captured _ = capture
3349
3450instance (KnownSymbol capture, FromText a, HasServer sublayout)
3551 => HasServer (Capture capture a :> sublayout) where
3652
37− -- this means that what follows the capture
38− -- must necessarily be a function that expects
39− -- the captured value. :-(
4053 type Server (Capture capture a :> sublayout) =
41− Capture capture a :> (a -> Server sublayout)
54+ a -> Server sublayout
4255
43− route Proxy (capture :> subserver) request = case pathInfo request of
56+ route Proxy subserver request = case pathInfo request of
4457 (first : rest)
45− -> case captured capture first of
58+ -> case captured captureProxy first of
4659 Nothing -> return Nothing
4760 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request{
4861 pathInfo = rest
4962 }
5063 _ -> return Nothing
5164
65+ where captureProxy = Proxy :: Proxy (Capture capture a)
66+
67+instance (KnownSymbol capture, ToText a, HasClient sublayout)
68+ => HasClient (Capture capture a :> sublayout) where
69+
70+ type Client (Capture capture a :> sublayout) =
71+ a -> Client sublayout
72+
73+ clientWithRoute Proxy path val =
74+ clientWithRoute (Proxy :: Proxy sublayout)
75+ (path ++ "/" ++ unpack (toText val))
76+
5277-- * Request Body support
5378data RQBody a
5479
5580instance (FromJSON a, HasServer sublayout)
5681 => HasServer (RQBody a :> sublayout) where
5782
58− -- same caveat as for the Captures...
5983 type Server (RQBody a :> sublayout) =
60− RQBody a :> (a -> Server sublayout)
84+ a -> Server sublayout
6185
62− route Proxy (rqbody :> subserver) request = do
86+ route Proxy subserver request = do
6387 mrqbody <- decode' <$> lazyRequestBody request
6488 case mrqbody of
6589 Nothing -> return Nothing
6690 Just v -> route (Proxy :: Proxy sublayout) (subserver v) request
6791
92+instance (ToJSON a, FromJSON b)
93+ => HasClient (RQBody a :> Post b) where
94+
95+ type Client (RQBody a :> Post b) =
96+ a -> URI -> EitherT String IO b
97+
98+ clientWithRoute Proxy path body uri = do
99+ partialRequest <- liftIO . Http.Client.parseUrl $
100+ show ( nullURI { uriPath = path }
101+ `relativeTo` uri
102+ )
103+
104+ let request = partialRequest
105+ { Http.Client.method = methodPost
106+ , Http.Client.requestBody = Http.Client.RequestBodyLBS (encode body)
107+ }
108+
109+ innerResponse <- liftIO . __withGlobalManager $ \ manager ->
110+ Http.Client.httpLbs request manager
111+
112+ when (Http.Client.responseStatus innerResponse /= status201) $
113+ left ("HTTP POST request failed with status: " ++ show (Http.Client.responseStatus innerResponse))
114+
115+ maybe (left "HTTP POST request returned invalid json") return $
116+ decode' (Http.Client.responseBody innerResponse)
117+
68118-- * Example
69119
70120type TestApi = "hello" :> Capture "name" Text :> Get Greet
121+ :<|> "greet" :> RQBody Greet :> Post Greet
71122
72123testApi :: Proxy TestApi
73124testApi = Proxy
74125
75126data Greet = Greet { msg :: Text }
76− deriving Generic
127+ deriving (Generic, Show)
77128
129+instance FromJSON Greet
78130instance ToJSON Greet
79131
80132server :: Server TestApi
81−server =
82− Proxy -- :: Proxy "hello"
83− :> Proxy -- :: Proxy (Capture "name" Text)
84− :> (return . func)
133+server = hello :<|> greet
134+
135+ where hello = return . Greet . ("Hello, " <>)
136+ greet = return
85137
86− where func name = Greet ("Hello, " <> name)
138+getGreet :: Text -> URI -> EitherT String IO Greet
139+postGreet :: Greet -> URI -> EitherT String IO Greet
140+
141+getGreet :<|> postGreet
142+ = client testApi
87143
88144test :: Application
89145test = serve testApi server
90146
91−runTest :: Port -> IO ()
92−runTest port = run port test
93−
94−-- load in ghci, call 'runTest 8000'
95−-- visit http://localhost:8000/hello/world
96−-- visit http://localhost:8000/hello/soenke
97−-- visit http://localhost:8000/hello/alp
147+runTestServer :: Port -> IO ()
148+runTestServer port = run port test
149+
150+runTest :: IO ()
151+runTest = do
152+ tid <- forkIO $ runTestServer 8001
153+ let Just uri = parseURI "http://localhost:8001/"
154+ print =<< runEitherT (getGreet "alp" uri)
155+ let g = Greet "yo"
156+ print =<< runEitherT (postGreet g uri)
157+ killThread tid