git.iko.soy/servant
on be5ea82 help sign in
servant/src/Servant/Client.hs
66 lines 1.9 kB history raw
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Servant.Client where
5import Control.Concurrent
6import Control.Monad.Catch
7import Data.ByteString.Lazy
8import Data.Proxy
9import Data.Text
10import Network.HTTP.Client hiding (Proxy)
11import Network.HTTP.Types
12import Network.URI
13import System.IO.Unsafe
15-- * Accessing APIs as a Client
17-- | 'client' allows you to produce operations to query an API from a client.
18client :: HasClient layout => Proxy layout -> Client layout
19client p = clientWithRoute p defReq
21class HasClient layout where
22 type Client layout :: *
23 clientWithRoute :: Proxy layout -> Req -> Client layout
25data Req = Req
26 { reqPath :: String
27 , qs :: QueryText
28 , reqBody :: ByteString
29 }
31defReq :: Req
32defReq = Req "" [] ""
34appendToPath :: String -> Req -> Req
35appendToPath p req =
36 req { reqPath = reqPath req ++ "/" ++ p }
38appendToQueryString :: Text -- ^ param name
39 -> Maybe Text -- ^ param value
40 -> Req
41 -> Req
42appendToQueryString pname pvalue req
43 | pvalue == Nothing = req
44 | otherwise = req { qs = qs req ++ [(pname, pvalue)]
45 }
47setRQBody :: ByteString -> Req -> Req
48setRQBody b req = req { reqBody = b }
50reqToRequest :: (Functor m, MonadThrow m) => Req -> URI -> m Request
51reqToRequest req uri = fmap (setrqb . setQS ) $ parseUrl url
53 where url = show $ nullURI { uriPath = reqPath req }
54 `relativeTo` uri
56 setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
57 setQS = setQueryString $ queryTextToQuery (qs req)
59{-# NOINLINE __manager #-}
60__manager :: MVar Manager
61__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
63__withGlobalManager :: (Manager -> IO a) -> IO a
64__withGlobalManager action = modifyMVar __manager $ \ manager -> do
65 result <- action manager
66 return (manager, result)