git.iko.soy/servant
on 85acead help sign in
servant/src/Servant/Client.hs
88 lines 2.6 kB history raw
1{-# LANGUAGE TypeFamilies #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE DeriveGeneric #-}
4module Servant.Client where
6import Control.Concurrent
7import Control.Monad.Catch
8import Data.ByteString.Lazy
9import Data.Proxy
10import Data.Text
11import GHC.Generics
12import Network.HTTP.Client hiding (Proxy)
13import Network.HTTP.Types
14import Network.URI
15import System.IO.Unsafe
17-- * Accessing APIs as a Client
19data Scheme = Http | Https
20 deriving (Show, Eq, Ord, Generic)
22data BaseUrl = BaseUrl {
23 baseUrlScheme :: Scheme,
24 baseUrlHost :: String,
25 baseUrlPort :: Int
26 }
27 deriving (Show, Eq, Ord, Generic)
29httpBaseUrl :: String -> BaseUrl
30httpBaseUrl host = BaseUrl Http host 80
32-- | 'client' allows you to produce operations to query an API from a client.
33client :: HasClient layout => Proxy layout -> Client layout
34client p = clientWithRoute p defReq
36class HasClient layout where
37 type Client layout :: *
38 clientWithRoute :: Proxy layout -> Req -> Client layout
40data Req = Req
41 { reqPath :: String
42 , qs :: QueryText
43 , reqBody :: ByteString
44 }
46defReq :: Req
47defReq = Req "" [] ""
49appendToPath :: String -> Req -> Req
50appendToPath p req =
51 req { reqPath = reqPath req ++ "/" ++ p }
53appendToQueryString :: Text -- ^ param name
54 -> Maybe Text -- ^ param value
55 -> Req
56 -> Req
57appendToQueryString pname pvalue req =
58 req { qs = qs req ++ [(pname, pvalue)]
59 }
61setRQBody :: ByteString -> Req -> Req
62setRQBody b req = req { reqBody = b }
64reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
65reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl url
67 where url = show $ nullURI { uriScheme = case scheme of
68 Http -> "http:"
69 Https -> "https:"
70 , uriAuthority = Just $
71 URIAuth { uriUserInfo = ""
72 , uriRegName = host
73 , uriPort = ":" ++ show port
74 }
75 , uriPath = reqPath req
76 }
78 setrqb r = r { requestBody = RequestBodyLBS (reqBody req) }
79 setQS = setQueryString $ queryTextToQuery (qs req)
81{-# NOINLINE __manager #-}
82__manager :: MVar Manager
83__manager = unsafePerformIO (newManager defaultManagerSettings >>= newMVar)
85__withGlobalManager :: (Manager -> IO a) -> IO a
86__withGlobalManager action = modifyMVar __manager $ \ manager -> do
87 result <- action manager
88 return (manager, result)