-Wall police

This commit is contained in:
Alp Mestanogullari 2014-11-22 14:35:03 +01:00
parent dacea018a7
commit d461726b9a
5 changed files with 30 additions and 30 deletions

View file

@ -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)

View file

@ -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

View file

@ -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

View file

@ -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.

View file

@ -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>"