-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 :: Proxy sublayout) $
|
||||
foldl' (\ value req -> appendToQueryString pname req value) req paramlist'
|
||||
foldl' (\ value req' -> appendToQueryString pname req' value) req paramlist'
|
||||
|
||||
where pname = cs pname'
|
||||
pname' = symbolVal (Proxy :: Proxy sym)
|
||||
|
|
|
@ -29,8 +29,8 @@ instance HasClient Raw where
|
|||
type Client Raw = Method -> BaseUrl -> EitherT String IO (Int, ByteString)
|
||||
|
||||
clientWithRoute :: Proxy Raw -> Req -> Client Raw
|
||||
clientWithRoute Proxy req method host =
|
||||
performRequest method req (const True) host
|
||||
clientWithRoute Proxy req httpMethod host =
|
||||
performRequest httpMethod req (const True) host
|
||||
|
||||
|
||||
instance HasDocs Raw where
|
||||
|
|
|
@ -19,13 +19,13 @@ data BaseUrl = BaseUrl {
|
|||
deriving (Show, Eq, Ord, Generic)
|
||||
|
||||
showBaseUrl :: BaseUrl -> String
|
||||
showBaseUrl (BaseUrl scheme host port) =
|
||||
showBaseUrl (BaseUrl urlscheme host port) =
|
||||
schemeString ++ "//" ++ host ++ portString
|
||||
where
|
||||
schemeString = case scheme of
|
||||
schemeString = case urlscheme of
|
||||
Http -> "http:"
|
||||
Https -> "https:"
|
||||
portString = case (scheme, port) of
|
||||
portString = case (urlscheme, port) of
|
||||
(Http, 80) -> ""
|
||||
(Https, 443) -> ""
|
||||
_ -> ":" ++ show port
|
||||
|
@ -46,6 +46,6 @@ parseBaseUrl s = case parseURI (removeTrailingSlash s) of
|
|||
then Left ("invalid base url: " ++ s)
|
||||
else parseBaseUrl ("http://" ++ s)
|
||||
where
|
||||
removeTrailingSlash s = case lastMay s of
|
||||
Just '/' -> init s
|
||||
_ -> s
|
||||
removeTrailingSlash str = case lastMay str of
|
||||
Just '/' -> init str
|
||||
_ -> str
|
||||
|
|
|
@ -49,15 +49,15 @@ setRQBody :: ByteString -> Req -> Req
|
|||
setRQBody b req = req { reqBody = b }
|
||||
|
||||
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:"
|
||||
Https -> "https:"
|
||||
, uriAuthority = Just $
|
||||
URIAuth { uriUserInfo = ""
|
||||
, uriRegName = host
|
||||
, uriPort = ":" ++ show port
|
||||
, uriRegName = reqHost
|
||||
, uriPort = ":" ++ show reqPort
|
||||
}
|
||||
, uriPath = reqPath req
|
||||
}
|
||||
|
@ -79,14 +79,14 @@ __withGlobalManager action = modifyMVar __manager $ \ manager -> do
|
|||
|
||||
|
||||
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 isWantedStatus host = do
|
||||
partialRequest <- liftIO $ reqToRequest req host
|
||||
performRequest reqMethod req isWantedStatus reqHost = do
|
||||
partialRequest <- liftIO $ reqToRequest req reqHost
|
||||
|
||||
let request = partialRequest { Client.method = method
|
||||
let request = partialRequest { Client.method = reqMethod
|
||||
, checkStatus = \ _status _headers _cookies -> Nothing
|
||||
}
|
||||
|
||||
|
@ -95,12 +95,12 @@ performRequest method req isWantedStatus host = do
|
|||
Client.httpLbs request manager
|
||||
case eResponse of
|
||||
Left status ->
|
||||
left (displayHttpRequest method ++ " failed with status: " ++ showStatus status)
|
||||
left (displayHttpRequest reqMethod ++ " failed with status: " ++ showStatus status)
|
||||
|
||||
Right response -> do
|
||||
let status = Client.responseStatus response
|
||||
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)
|
||||
where
|
||||
showStatus (Status code message) =
|
||||
|
@ -109,20 +109,20 @@ performRequest method req isWantedStatus host = do
|
|||
|
||||
performRequestJSON :: FromJSON result =>
|
||||
Method -> Req -> Int -> BaseUrl -> EitherT String IO result
|
||||
performRequestJSON method req wantedStatus host = do
|
||||
(_status, responseBody) <- performRequest method req (== wantedStatus) host
|
||||
performRequestJSON reqMethod req wantedStatus reqHost = do
|
||||
(_status, respBody) <- performRequest reqMethod req (== wantedStatus) reqHost
|
||||
either
|
||||
(\ message -> left (displayHttpRequest method ++ " returned invalid json: " ++ message))
|
||||
(\ message -> left (displayHttpRequest reqMethod ++ " returned invalid json: " ++ message))
|
||||
return
|
||||
(decodeLenient responseBody)
|
||||
(decodeLenient respBody)
|
||||
|
||||
|
||||
catchStatusCodeException :: IO a -> IO (Either Status a)
|
||||
catchStatusCodeException action = catch (Right <$> action) $
|
||||
\ e -> case e of
|
||||
Client.StatusCodeException status _ _ ->
|
||||
return $ Left status
|
||||
e -> throwIO e
|
||||
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.
|
||||
|
|
|
@ -23,11 +23,11 @@ serveDocumentation proxy _request respond =
|
|||
respond $ responseLBS ok200 [] $ cs $ toHtml $ markdown $ docs proxy
|
||||
|
||||
toHtml :: String -> String
|
||||
toHtml markdown =
|
||||
toHtml md =
|
||||
"<html>" ++
|
||||
"<body>" ++
|
||||
"<pre>" ++
|
||||
markdown ++
|
||||
md ++
|
||||
"</pre>" ++
|
||||
"</body>" ++
|
||||
"</html>"
|
||||
|
|
Loading…
Reference in a new issue