-Wall police
This commit is contained in:
parent
dacea018a7
commit
d461726b9a
5 changed files with 30 additions and 30 deletions
|
@ -106,7 +106,7 @@ instance (KnownSymbol sym, ToText a, HasClient sublayout)
|
||||||
|
|
||||||
clientWithRoute Proxy req paramlist =
|
clientWithRoute Proxy req paramlist =
|
||||||
clientWithRoute (Proxy :: Proxy sublayout) $
|
clientWithRoute (Proxy :: Proxy sublayout) $
|
||||||
foldl' (\ value req -> appendToQueryString pname req value) req paramlist'
|
foldl' (\ value req' -> appendToQueryString pname req' value) req paramlist'
|
||||||
|
|
||||||
where pname = cs pname'
|
where pname = cs pname'
|
||||||
pname' = symbolVal (Proxy :: Proxy sym)
|
pname' = symbolVal (Proxy :: Proxy sym)
|
||||||
|
|
|
@ -29,8 +29,8 @@ instance HasClient Raw where
|
||||||
type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
|
type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
|
||||||
|
|
||||||
clientWithRoute :: Proxy Raw -> Req -> Client Raw
|
clientWithRoute :: Proxy Raw -> Req -> Client Raw
|
||||||
clientWithRoute Proxy req method host =
|
clientWithRoute Proxy req httpMethod host =
|
||||||
performRequest method req (const True) host
|
performRequest httpMethod req (const True) host
|
||||||
|
|
||||||
|
|
||||||
instance HasDocs Raw where
|
instance HasDocs Raw where
|
||||||
|
|
|
@ -19,13 +19,13 @@ data BaseUrl = BaseUrl {
|
||||||
deriving (Show, Eq, Ord, Generic)
|
deriving (Show, Eq, Ord, Generic)
|
||||||
|
|
||||||
showBaseUrl :: BaseUrl -> String
|
showBaseUrl :: BaseUrl -> String
|
||||||
showBaseUrl (BaseUrl scheme host port) =
|
showBaseUrl (BaseUrl urlscheme host port) =
|
||||||
schemeString ++ "//" ++ host ++ portString
|
schemeString ++ "//" ++ host ++ portString
|
||||||
where
|
where
|
||||||
schemeString = case scheme of
|
schemeString = case urlscheme of
|
||||||
Http -> "http:"
|
Http -> "http:"
|
||||||
Https -> "https:"
|
Https -> "https:"
|
||||||
portString = case (scheme, port) of
|
portString = case (urlscheme, port) of
|
||||||
(Http, 80) -> ""
|
(Http, 80) -> ""
|
||||||
(Https, 443) -> ""
|
(Https, 443) -> ""
|
||||||
_ -> ":" ++ show port
|
_ -> ":" ++ show port
|
||||||
|
@ -46,6 +46,6 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of
|
||||||
then Left ("invalid base url: " ++ s)
|
then Left ("invalid base url: " ++ s)
|
||||||
else parseBaseUrl ("http://" ++ s)
|
else parseBaseUrl ("http://" ++ s)
|
||||||
where
|
where
|
||||||
removeTrailingSlash s = case lastMay s of
|
removeTrailingSlash str = case lastMay str of
|
||||||
Just '/' -> init s
|
Just '/' -> init str
|
||||||
_ -> s
|
_ -> str
|
||||||
|
|
|
@ -49,15 +49,15 @@ setRQBody :: ByteString -> Req -> Req
|
||||||
setRQBody b req = req { reqBody = b }
|
setRQBody b req = req { reqBody = b }
|
||||||
|
|
||||||
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
|
reqToRequest :: (Functor m, MonadThrow m) => Req -> BaseUrl -> m Request
|
||||||
reqToRequest req (BaseUrl scheme host port) = fmap (setrqb . setQS ) $ parseUrl url
|
reqToRequest req (BaseUrl reqScheme reqHost reqPort) = fmap (setrqb . setQS ) $ parseUrl url
|
||||||
|
|
||||||
where url = show $ nullURI { uriScheme = case scheme of
|
where url = show $ nullURI { uriScheme = case reqScheme of
|
||||||
Http -> "http:"
|
Http -> "http:"
|
||||||
Https -> "https:"
|
Https -> "https:"
|
||||||
, uriAuthority = Just $
|
, uriAuthority = Just $
|
||||||
URIAuth { uriUserInfo = ""
|
URIAuth { uriUserInfo = ""
|
||||||
, uriRegName = host
|
, uriRegName = reqHost
|
||||||
, uriPort = ":" ++ show port
|
, uriPort = ":" ++ show reqPort
|
||||||
}
|
}
|
||||||
, uriPath = reqPath req
|
, uriPath = reqPath req
|
||||||
}
|
}
|
||||||
|
@ -79,14 +79,14 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do
|
||||||
|
|
||||||
|
|
||||||
displayHttpRequest :: Method -> String
|
displayHttpRequest :: Method -> String
|
||||||
displayHttpRequest method = "HTTP " ++ cs method ++ " request"
|
displayHttpRequest httpmethod = "HTTP " ++ cs httpmethod ++ " request"
|
||||||
|
|
||||||
|
|
||||||
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)
|
performRequest :: Method -> Req -> (Int -> Bool) -> BaseUrl -> EitherT String IO (Int, ByteString)
|
||||||
performRequest method req isWantedStatus host = do
|
performRequest reqMethod req isWantedStatus reqHost = do
|
||||||
partialRequest <- liftIO $ reqToRequest req host
|
partialRequest <- liftIO $ reqToRequest req reqHost
|
||||||
|
|
||||||
let request = partialRequest { Client.method = method
|
let request = partialRequest { Client.method = reqMethod
|
||||||
, checkStatus = \ _status _headers _cookies -> Nothing
|
, checkStatus = \ _status _headers _cookies -> Nothing
|
||||||
}
|
}
|
||||||
|
|
||||||
|
@ -95,12 +95,12 @@ performRequest method req isWantedStatus host = do
|
||||||
Client.httpLbs request manager
|
Client.httpLbs request manager
|
||||||
case eResponse of
|
case eResponse of
|
||||||
Left status ->
|
Left status ->
|
||||||
left (displayHttpRequest method ++ " failed with status: " ++ showStatus status)
|
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
||||||
|
|
||||||
Right response -> do
|
Right response -> do
|
||||||
let status = Client.responseStatus response
|
let status = Client.responseStatus response
|
||||||
unless (isWantedStatus (statusCode status)) $
|
unless (isWantedStatus (statusCode status)) $
|
||||||
left (displayHttpRequest method ++ " failed with status: " ++ showStatus status)
|
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
||||||
return $ (statusCode status, Client.responseBody response)
|
return $ (statusCode status, Client.responseBody response)
|
||||||
where
|
where
|
||||||
showStatus (Status code message) =
|
showStatus (Status code message) =
|
||||||
|
@ -109,20 +109,20 @@ performRequest method req isWantedStatus host = do
|
||||||
|
|
||||||
performRequestJSON :: FromJSON result =>
|
performRequestJSON :: FromJSON result =>
|
||||||
Method -> Req -> Int -> BaseUrl -> EitherT String IO result
|
Method -> Req -> Int -> BaseUrl -> EitherT String IO result
|
||||||
performRequestJSON method req wantedStatus host = do
|
performRequestJSON reqMethod req wantedStatus reqHost = do
|
||||||
(_status, responseBody) <- performRequest method req (== wantedStatus) host
|
(_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost
|
||||||
either
|
either
|
||||||
(\ message -> left (displayHttpRequest method ++ " returned invalid json: " ++ message))
|
(\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))
|
||||||
return
|
return
|
||||||
(decodeLenient responseBody)
|
(decodeLenient respBody)
|
||||||
|
|
||||||
|
|
||||||
catchStatusCodeException :: IO a -> IO (Either Status a)
|
catchStatusCodeException :: IO a -> IO (Either Status a)
|
||||||
catchStatusCodeException action = catch (Right <$> action) $
|
catchStatusCodeException action =
|
||||||
\ e -> case e of
|
catch (Right <$> action) $ \e ->
|
||||||
Client.StatusCodeException status _ _ ->
|
case e of
|
||||||
return $ Left status
|
Client.StatusCodeException status _ _ -> return $ Left status
|
||||||
e -> throwIO e
|
exc -> throwIO exc
|
||||||
|
|
||||||
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
|
-- | Like 'Data.Aeson.decode' but allows all JSON values instead of just
|
||||||
-- objects and arrays.
|
-- objects and arrays.
|
||||||
|
|
|
@ -23,11 +23,11 @@ serveDocumentation proxy _request respond =
|
||||||
respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
|
respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
|
||||||
|
|
||||||
toHtml :: String -> String
|
toHtml :: String -> String
|
||||||
toHtml markdown =
|
toHtml md =
|
||||||
"<html>" ++
|
"<html>" ++
|
||||||
"<body>" ++
|
"<body>" ++
|
||||||
"<pre>" ++
|
"<pre>" ++
|
||||||
markdown ++
|
md ++
|
||||||
"</pre>" ++
|
"</pre>" ++
|
||||||
"</body>" ++
|
"</body>" ++
|
||||||
"</html>"
|
"</html>"
|
||||||
|
|
Loading…
Reference in a new issue