diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Li Meng Jun (c) 2017 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Li Meng Jun nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/src/Network/Wreq/Helper.hs b/src/Network/Wreq/Helper.hs new file mode 100644 --- /dev/null +++ b/src/Network/Wreq/Helper.hs @@ -0,0 +1,108 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +module Network.Wreq.Helper + ( responseValue + , responseMaybe + , responseEither + , responseEither' + , responseEitherJSON + , responseJSON + , responseOk + , responseOk_ + , responseList + , responseList_ + , tryResponse + , eitherToError + ) where + +import Control.Exception (try) +import Control.Lens ((^.), (^?)) +import Data.Aeson (FromJSON (..), decode) +import Data.Aeson.Result (Err, List, Ok, err, throwError, toList, + toOk) +import qualified Data.ByteString.Char8 as B (unpack) +import qualified Data.ByteString.Lazy as LB (ByteString, fromStrict) +import Data.Text (Text) +import Network.HTTP.Client (HttpException (..), + HttpExceptionContent (..)) +import Network.Wreq (Response, asJSON, responseBody) + +eitherToError :: IO (Either Err a) -> IO a +eitherToError io = do + r <- io + case r of + Left e -> throwError e + Right v -> pure v + +responseValue :: IO (Response a) -> IO a +responseValue req = do + r <- req + return $ r ^. responseBody + +responseMaybe :: IO (Response a) -> IO (Maybe a) +responseMaybe req = do + e <- try req + case e of + Left (_ :: HttpException) -> return Nothing + Right r -> return $ r ^? responseBody + +tryResponse :: IO (Response a) -> IO (Either Err (Response a)) +tryResponse req = do + e <- try req + case e of + Left (HttpExceptionRequest _ content) -> + case content of + (StatusCodeException _ body) -> + case decode . LB.fromStrict $ body of + Just er -> return $ Left er + Nothing -> return . Left . err . B.unpack $ body + ResponseTimeout -> return . Left . err $ "ResponseTimeout" + other -> return . Left . err $ show other + + Left (InvalidUrlException _ _) -> + return . Left . err $ "InvalidUrlException" + Right r -> return $ Right r + +responseEither :: IO (Response a) -> IO (Either Err a) +responseEither req = do + rsp <- tryResponse req + case rsp of + Left e -> return $ Left e + Right r -> return . Right $ r ^. responseBody + +responseEither' :: IO (Response LB.ByteString) -> IO (Either Err ()) +responseEither' req = do + rsp <- tryResponse req + case rsp of + Left e -> return $ Left e + Right _ -> return $ Right () + +responseEitherJSON :: FromJSON a => IO (Response LB.ByteString) -> IO (Either Err a) +responseEitherJSON req = responseEither $ asJSON =<< req + +responseJSON :: FromJSON a => IO (Response LB.ByteString) -> IO a +responseJSON = eitherToError . responseEitherJSON + +responseOk :: FromJSON a => Text -> IO (Response LB.ByteString) -> IO (Either Err (Ok a)) +responseOk okey req = do + rsp <- responseEitherJSON req + case rsp of + Left e -> return $ Left e + Right r -> case toOk okey r of + Just v -> return $ Right v + Nothing -> return . Left $ err "Invalid Result" + +responseOk_ :: FromJSON a => Text -> IO (Response LB.ByteString) -> IO (Ok a) +responseOk_ okey req = eitherToError (responseOk okey req) + +responseList :: FromJSON a => Text -> IO (Response LB.ByteString) -> IO (Either Err (List a)) +responseList okey req = do + rsp <- responseEitherJSON req + case rsp of + Left e -> return $ Left e + Right r -> case toList okey r of + Just v -> return $ Right v + Nothing -> return . Left $ err "Invalid Result" + +responseList_ :: FromJSON a => Text -> IO (Response LB.ByteString) -> IO (List a) +responseList_ okey req = eitherToError (responseList okey req) diff --git a/wreq-helper.cabal b/wreq-helper.cabal new file mode 100644 --- /dev/null +++ b/wreq-helper.cabal @@ -0,0 +1,31 @@ +name: wreq-helper +version: 0.1.0.0 +synopsis: Wreq response process +description: Wreq response process. +homepage: https://github.com/Lupino/yuntan-common/tree/master/wreq-helper#readme +license: BSD3 +license-file: LICENSE +author: Li Meng Jun +maintainer: lmjubuntu@gmail.com +copyright: MIT +category: value +build-type: Simple +-- extra-source-files: +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Network.Wreq.Helper + build-depends: base >= 4.7 && < 5 + , wreq + , http-client + , lens + , bytestring + , aeson + , text + , aeson-result + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/Lupino/yuntan-common