2014-11-27 18:28:01 +01:00
|
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
|
|
{-# LANGUAGE ScopedTypeVariables #-}
|
|
|
|
module Servant.Common.Req where
|
|
|
|
|
|
|
|
import Control.Applicative
|
|
|
|
import Control.Concurrent
|
|
|
|
import Control.Exception
|
|
|
|
import Control.Monad
|
|
|
|
import Control.Monad.Catch (MonadThrow)
|
|
|
|
import Control.Monad.IO.Class
|
|
|
|
import Control.Monad.Trans.Either
|
|
|
|
import Data.Aeson
|
|
|
|
import Data.Aeson.Parser
|
|
|
|
import Data.Aeson.Types
|
|
|
|
import Data.Attoparsec.ByteString
|
2015-02-17 01:56:15 +01:00
|
|
|
import Data.ByteString.Lazy hiding (pack, filter, map, null)
|
2014-12-08 12:52:30 +01:00
|
|
|
import Data.String
|
2014-11-27 18:28:01 +01:00
|
|
|
import Data.String.Conversions
|
2015-02-17 07:17:10 +01:00
|
|
|
import Data.Proxy
|
2015-02-17 01:51:59 +01:00
|
|
|
import Data.Text (Text)
|
2014-12-08 12:52:30 +01:00
|
|
|
import Data.Text.Encoding
|
2015-02-17 07:17:10 +01:00
|
|
|
import Network.HTTP.Client hiding (Proxy)
|
2015-01-22 23:18:13 +01:00
|
|
|
import Network.HTTP.Client.TLS
|
2015-02-17 00:05:39 +01:00
|
|
|
import Network.HTTP.Media
|
2014-11-27 18:28:01 +01:00
|
|
|
import Network.HTTP.Types
|
|
|
|
import Network.URI
|
|
|
|
import Servant.Common.BaseUrl
|
2014-12-08 12:52:30 +01:00
|
|
|
import Servant.Common.Text
|
2015-02-17 07:17:10 +01:00
|
|
|
import Servant.Server.ContentTypes
|
2014-11-27 18:28:01 +01:00
|
|
|
import System.IO.Unsafe
|
|
|
|
|
|
|
|
import qualified Network.HTTP.Client as Client
|
|
|
|
|
|
|
|
data Req = Req
|
2015-02-17 01:51:59 +01:00
|
|
|
{ reqPath :: String
|
|
|
|
, qs :: QueryText
|
|
|
|
, reqBody :: Maybe (ByteString, MediaType)
|
|
|
|
, reqAccept :: [MediaType]
|
|
|
|
, headers :: [(String, Text)]
|
2014-11-27 18:28:01 +01:00
|
|
|
}
|
|
|
|
|
|
|
|
defReq :: Req
|
2015-02-17 01:51:59 +01:00
|
|
|
defReq = Req "" [] Nothing [] []
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
appendToPath :: String -> Req -> Req
|
|
|
|
appendToPath p req =
|
|
|
|
req { reqPath = reqPath req ++ "/" ++ p }
|
|
|
|
|
2015-01-01 23:43:29 +01:00
|
|
|
appendToMatrixParams :: String
|
|
|
|
-> Maybe String
|
|
|
|
-> Req
|
|
|
|
-> Req
|
|
|
|
appendToMatrixParams pname pvalue req =
|
|
|
|
req { reqPath = reqPath req ++ ";" ++ pname ++ maybe "" ("=" ++) pvalue }
|
|
|
|
|
2014-11-27 18:28:01 +01:00
|
|
|
appendToQueryString :: Text -- ^ param name
|
|
|
|
-> Maybe Text -- ^ param value
|
|
|
|
-> Req
|
|
|
|
-> Req
|
|
|
|
appendToQueryString pname pvalue req =
|
|
|
|
req { qs = qs req ++ [(pname, pvalue)]
|
|
|
|
}
|
|
|
|
|
2014-12-08 12:52:30 +01:00
|
|
|
addHeader :: ToText a => String -> a -> Req -> Req
|
|
|
|
addHeader name val req = req { headers = headers req
|
|
|
|
++ [(name, toText val)]
|
|
|
|
}
|
|
|
|
|
2015-02-17 00:05:39 +01:00
|
|
|
setRQBody :: ByteString -> MediaType -> Req -> Req
|
|
|
|
setRQBody b t req = req { reqBody = Just (b, t) }
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
|
2014-12-08 12:52:30 +01:00
|
|
|
reqToRequest req (BaseUrl reqScheme reqHost reqPort) =
|
2015-02-17 01:51:59 +01:00
|
|
|
fmap (setheaders . setAccept . setrqb . setQS ) $ parseUrl url
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
where url = show $ nullURI { uriScheme = case reqScheme of
|
|
|
|
Http -> "http:"
|
|
|
|
Https -> "https:"
|
|
|
|
, uriAuthority = Just $
|
|
|
|
URIAuth { uriUserInfo = ""
|
|
|
|
, uriRegName = reqHost
|
|
|
|
, uriPort = ":" ++ show reqPort
|
|
|
|
}
|
|
|
|
, uriPath = reqPath req
|
|
|
|
}
|
|
|
|
|
2015-02-17 03:50:50 +01:00
|
|
|
setrqb r = case reqBody req of
|
2015-02-17 00:05:39 +01:00
|
|
|
Nothing -> r
|
|
|
|
Just (b,t) -> r { requestBody = RequestBodyLBS b
|
2015-02-17 01:51:59 +01:00
|
|
|
, requestHeaders = requestHeaders r
|
|
|
|
++ [(hContentType, cs . show $ t)] }
|
2014-11-27 18:28:01 +01:00
|
|
|
setQS = setQueryString $ queryTextToQuery (qs req)
|
2015-02-17 00:05:39 +01:00
|
|
|
setheaders r = r { requestHeaders = requestHeaders r
|
2015-02-17 03:50:50 +01:00
|
|
|
<> fmap toProperHeader (headers req) }
|
2015-02-17 01:51:59 +01:00
|
|
|
setAccept r = r { requestHeaders = filter ((/= "Accept") . fst) (requestHeaders r)
|
2015-02-17 03:50:50 +01:00
|
|
|
<> [("Accept", renderHeader $ reqAccept req)
|
2015-02-17 01:56:15 +01:00
|
|
|
| not . null . reqAccept $ req] }
|
2014-12-08 12:52:30 +01:00
|
|
|
toProperHeader (name, val) =
|
2015-02-06 09:34:59 +01:00
|
|
|
(fromString name, encodeUtf8 val)
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
|
|
|
|
-- * performing requests
|
|
|
|
|
|
|
|
{-# NOINLINE __manager #-}
|
|
|
|
__manager :: MVar Manager
|
2015-01-22 23:18:13 +01:00
|
|
|
__manager = unsafePerformIO (newManager tlsManagerSettings >>= newMVar)
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
__withGlobalManager :: (Manager -> IO a) -> IO a
|
|
|
|
__withGlobalManager action = modifyMVar __manager $ \ manager -> do
|
|
|
|
result <- action manager
|
|
|
|
return (manager, result)
|
|
|
|
|
|
|
|
|
|
|
|
displayHttpRequest :: Method -> String
|
|
|
|
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
|
|
|
|
|
|
|
|
|
2015-02-17 00:32:15 +01:00
|
|
|
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString, MediaType)
|
2014-11-27 18:28:01 +01:00
|
|
|
performRequest reqMethod req isWantedStatus reqHost = do
|
|
|
|
partialRequest <- liftIO $ reqToRequest req reqHost
|
|
|
|
|
|
|
|
let request = partialRequest { Client.method = reqMethod
|
|
|
|
, checkStatus = \ _status _headers _cookies -> Nothing
|
|
|
|
}
|
|
|
|
|
|
|
|
eResponse <- liftIO $ __withGlobalManager $ \ manager ->
|
|
|
|
catchStatusCodeException $
|
|
|
|
Client.httpLbs request manager
|
|
|
|
case eResponse of
|
|
|
|
Left status ->
|
|
|
|
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
|
|
|
|
|
|
|
Right response -> do
|
|
|
|
let status = Client.responseStatus response
|
|
|
|
unless (isWantedStatus (statusCode status)) $
|
|
|
|
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
2015-02-17 00:32:15 +01:00
|
|
|
ct <- case lookup "Content-Type" $ Client.responseHeaders response of
|
|
|
|
Nothing -> pure $ "application"//"octet-stream"
|
|
|
|
Just t -> case parseAccept t of
|
|
|
|
Nothing -> left $ "invalid Content-Type header: " <> cs t
|
|
|
|
Just t' -> pure t'
|
2015-02-17 03:50:50 +01:00
|
|
|
return (statusCode status, Client.responseBody response, ct)
|
2014-11-27 18:28:01 +01:00
|
|
|
where
|
|
|
|
showStatus (Status code message) =
|
|
|
|
show code ++ " - " ++ cs message
|
|
|
|
|
2015-02-17 07:17:10 +01:00
|
|
|
performRequestCT :: MimeUnrender ct result =>
|
|
|
|
Proxy ct -> Method -> Req -> Int -> BaseUrl -> EitherT String IO result
|
|
|
|
performRequestCT ct reqMethod req wantedStatus reqHost = do
|
|
|
|
let acceptCT = contentType ct
|
|
|
|
(_status, respBody, respCT) <-
|
|
|
|
performRequest reqMethod (req { reqAccept = [acceptCT] }) (== wantedStatus) reqHost
|
|
|
|
unless (matches respCT (acceptCT)) $
|
|
|
|
left $ "requested Content-Type " <> show acceptCT <> ", but got " <> show respCT
|
|
|
|
maybe
|
|
|
|
(left (displayHttpRequest reqMethod ++ " returned invalid response of type: " ++ show respCT))
|
2014-11-27 18:28:01 +01:00
|
|
|
return
|
2015-02-17 07:17:10 +01:00
|
|
|
(fromByteString ct respBody)
|
2014-11-27 18:28:01 +01:00
|
|
|
|
|
|
|
|
|
|
|
catchStatusCodeException :: IO a -> IO (Either Status a)
|
|
|
|
catchStatusCodeException action =
|
|
|
|
catch (Right <$> action) $ \e ->
|
|
|
|
case e of
|
|
|
|
Client.StatusCodeException status _ _ -> return $ Left status
|
|
|
|
exc -> throwIO exc
|
|
|
|
|
|
|
|
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
|
|
|
|
-- objects and arrays.
|
|
|
|
decodeLenient :: FromJSON a => ByteString -> Either String a
|
|
|
|
decodeLenient input = do
|
|
|
|
v :: Value <- parseOnly (Data.Aeson.Parser.value <* endOfInput) (cs input)
|
|
|
|
parseEither parseJSON v
|