packages feed

belka (empty) → 0.8

raw patch · 18 files changed

+999/−0 lines, 18 filesdep +QuickCheckdep +aesondep +aeson-value-parsersetup-changed

Dependencies added: QuickCheck, aeson, aeson-value-parser, attoparsec, base, base-prelude, base64-bytestring, belka, bug, bytestring, case-insensitive, hashable, http-client, http-client-tls, http-media, http-types, iri, json-bytes-builder, mtl, potoki, potoki-core, ptr, quickcheck-instances, rerebase, semigroups, tasty, tasty-hunit, tasty-quickcheck, text, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,22 @@+Copyright (c) 2016, Nikita Volkov++Permission is hereby granted, free of charge, to any person+obtaining a copy of this software and associated documentation+files (the "Software"), to deal in the Software without+restriction, including without limitation the rights to use,+copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the+Software is furnished to do so, subject to the following+conditions:++The above copyright notice and this permission notice shall be+included in all copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,+EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES+OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND+NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT+HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,+WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING+FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR+OTHER DEALINGS IN THE SOFTWARE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ belka.cabal view
@@ -0,0 +1,112 @@+name:+  belka+version:+  0.8+synopsis:+  HTTP client DSL+homepage:+  https://github.com/nikita-volkov/belka+bug-reports:+  https://github.com/nikita-volkov/belka/issues+author:+  Nikita Volkov <nikita.y.volkov@mail.ru>+maintainer:+  Nikita Volkov <nikita.y.volkov@mail.ru>+copyright:+  (c) 2016, Nikita Volkov+license:+  MIT+license-file:+  LICENSE+build-type:+  Simple+cabal-version:+  >=1.10++source-repository head+  type:+    git+  location:+    git://github.com/nikita-volkov/belka.git++library+  hs-source-dirs:+    library+  exposed-modules:+    Belka.Request+    Belka.ParseHead+    Belka.ParseBody+    Belka.ParseHeaders+    Belka.Interact+    Belka.IO+    Belka.Potoki.Transform+  other-modules:+    Belka.Potoki.Consume+    Belka.Ptr.Poking+    Belka.Attoparsec.ByteString+    Belka.TransportError+    Belka.BytePredicates+    Belka.MonadPlus+    Belka.Prelude+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    -- codecs:+    base64-bytestring ==1.*,+    json-bytes-builder >=0.5 && <0.6,+    -- streaming:+    potoki >=0.6.1 && <0.7,+    potoki-core >=1.2 && <1.3,+    -- parsing:+    aeson-value-parser >=0.12.2 && <0.13,+    attoparsec >=0.13 && <0.14,+    http-media >=0.6.4 && <0.8,+    -- +    http-client ==0.5.*,+    http-client-tls >=0.3.4 && <0.4,+    http-types ==0.9.*,+    -- +    vector >=0.12 && <0.13,+    iri >=0.2 && <0.3,+    aeson >=1.2 && <2,+    bytestring >=0.10 && <0.11,+    text >=1 && <2,+    unordered-containers >=0.2 && <0.3,+    hashable ==1.*,+    case-insensitive ==1.*,+    -- +    ptr >=0.16.2 && <0.17,+    semigroups >=0.18 && <0.19,+    mtl ==2.*,+    transformers >=0.4 && <0.6,+    bug >=1 && <2,+    base-prelude <2,+    base <5++test-suite tests+  type:+    exitcode-stdio-1.0+  hs-source-dirs:+    tests+  main-is:+    Main.hs+  default-extensions:+    Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples+  default-language:+    Haskell2010+  build-depends:+    -- +    belka,+    iri,+    potoki,+    -- testing:+    tasty >=0.12 && <0.13,+    tasty-quickcheck >=0.9 && <0.10,+    tasty-hunit >=0.9 && <0.10,+    quickcheck-instances >=0.3.11 && <0.4,+    QuickCheck >=2.8.1 && <3,+    --+    bug ==1.0.*,+    rerebase >=1.1 && <2
+ library/Belka/Attoparsec/ByteString.hs view
@@ -0,0 +1,60 @@+{-|+See+<https://tools.ietf.org/html/rfc2046 MIME RFC>.+-}+module Belka.Attoparsec.ByteString+where++import Belka.Prelude hiding (fail)+import Data.Attoparsec.ByteString+import qualified Belka.BytePredicates as A+import qualified Belka.MonadPlus as B+import qualified Data.HashMap.Strict as C+import qualified Ptr.Poking as D+import qualified Ptr.ByteString as E+++contentTypeHeader :: Parser (ByteString, HashMap ByteString ByteString)+contentTypeHeader =+  do+    mimeType <- takeWhile1 A.mimeType+    parameters <- B.foldl (\ table (k, v) -> C.insert k v table) mempty parameter+    return (mimeType, parameters)+  where+    parameter =+      do+        skipWhile A.space+        semicolon+        skipWhile A.space+        attribute <- token+        equality+        value <- token <|> quotedToken+        return (attribute, value)++quotedToken :: Parser ByteString+quotedToken =+  quote *> (lowerCaseBytesInIso8859_1 . E.poking <$> B.foldl mappend mempty segment) <* quote+  where+    segment =+      (D.bytes <$> takeWhile1 A.quotedTokenUnescaped) <|>+      (D.word8 34 <$ (backslash *> quote))++token :: Parser ByteString+token =+  lowerCaseBytesInIso8859_1 <$> takeWhile1 A.token++backslash :: Parser Word8+backslash =+  word8 92++quote :: Parser Word8+quote =+  word8 34++equality :: Parser Word8+equality =+  word8 61++semicolon :: Parser Word8+semicolon =+  word8 59
+ library/Belka/BytePredicates.hs view
@@ -0,0 +1,84 @@+module Belka.BytePredicates+where++import Belka.Prelude hiding ((|||), (&&&), inRange, Predicate)+import qualified Data.Vector as A+import qualified Data.Char as B+++type Predicate =+  Word8 -> Bool++{-# NOINLINE cached #-}+cached :: Predicate -> Predicate+cached predicate =+  case A.generate 256 (predicate . fromIntegral) of+    vector -> A.unsafeIndex vector . fromIntegral++{-# NOINLINE cachedAscii #-}+cachedAscii :: Predicate -> Predicate+cachedAscii predicate =+  case A.generate 128 (predicate . fromIntegral) of+    vector -> A.unsafeIndex vector . fromIntegral++oneOfChars :: [Char] -> Predicate+oneOfChars string i =+  elem i (fmap (fromIntegral . ord) string)++infixr 2 |||+(|||) :: Predicate -> Predicate -> Predicate+(|||) left right i =+  left i || right i++infixr 3 &&&+(&&&) :: Predicate -> Predicate -> Predicate+(&&&) left right i =+  left i && right i++inRange :: Word8 -> Word8 -> Predicate+inRange min max i =+  i >= min && i <= max++inCharRange :: Char -> Char -> Predicate+inCharRange min max =+  inRange (fromIntegral (ord min)) (fromIntegral (ord max))++charPredicate :: (Char -> Bool) -> Predicate+charPredicate p =+  p . chr . fromIntegral++{-| 7-bit -}+septimal :: Predicate+septimal i =+  i < 0x80++nonSeptimal :: Predicate+nonSeptimal i =+  i >= 0x80++asciiAlphanumeric :: Predicate+asciiAlphanumeric =+  inCharRange 'a' 'z' |||+  inCharRange 'A' 'Z' |||+  inCharRange '0' '9'++mimeType :: Predicate+mimeType =+  cachedAscii $+  asciiAlphanumeric ||| oneOfChars "-/+*"++space :: Predicate+space =+  charPredicate B.isSpace++semicolon :: Predicate+semicolon =+  charPredicate (== ';')++token :: Predicate+token =+  mimeType++quotedTokenUnescaped :: Predicate+quotedTokenUnescaped =+  mimeType
+ library/Belka/IO.hs view
@@ -0,0 +1,32 @@+module Belka.IO+(+  C.TransportError(..),+  interact,+  interactUsingNewManager,+  interactUsingGlobalManager,+)+where++import Belka.Prelude hiding (interact)+import qualified Network.HTTP.Client as A+import qualified Network.HTTP.Client.TLS as B+import qualified Belka.TransportError as C+import qualified Belka.Interact as D+import qualified Potoki.IO as E+++interact :: A.Manager -> D.Interact a -> IO (Either Text (Either C.TransportError a))+interact manager (D.Interact interactIO) =+  runReaderT (runExceptT (runExceptT interactIO)) manager++interactUsingNewManager :: D.Interact a -> IO (Either Text (Either C.TransportError a))+interactUsingNewManager interact_ =+  do+    manager <- B.newTlsManager+    interact manager interact_++interactUsingGlobalManager :: D.Interact a -> IO (Either Text (Either C.TransportError a))+interactUsingGlobalManager interact_ =+  do+    manager <- B.getGlobalManager+    interact manager interact_
+ library/Belka/Interact.hs view
@@ -0,0 +1,39 @@+module Belka.Interact+where++import Belka.Prelude+import qualified Network.HTTP.Client as A+import qualified Belka.Request as B+import qualified Belka.ParseHead as C+import qualified Belka.ParseBody as D+import qualified Potoki.IO as E+import qualified Data.ByteString as F+import qualified Belka.TransportError as G+++newtype Interact a =+  Interact (ExceptT G.TransportError (ExceptT Text (ReaderT A.Manager IO)) a)+  deriving (Functor, Applicative, Monad, MonadIO)++request :: B.Request -> C.ParseHead (D.ParseBody response) -> Interact response+request (B.Request requestIO) (C.ParseHead (ExceptT (ReaderT parseResponseHeadIO))) =+  Interact $ ExceptT $ ExceptT $ ReaderT $ \ manager ->+  handle (return . Right . Left . G.httpException) $+  do+    (hcRequest, requestCleanUp) <- requestIO A.defaultRequest+    result <-+      A.withResponse hcRequest manager $ \ response -> do+        parsedHead <- parseResponseHeadIO response+        case parsedHead of+          Left parsingError -> return (Left parsingError)+          Right (D.ParseBody (Compose consumeBody)) ->+            E.consume+              (let fetchChunk = A.responseBody response+                in \ end element -> do+                  chunk <- fetchChunk+                  return $ if F.null chunk+                    then end+                    else element chunk)+              (fmap (either (Left . mappend "Body parsing: ") (Right . Right)) consumeBody)+    requestCleanUp+    return result
+ library/Belka/MonadPlus.hs view
@@ -0,0 +1,34 @@+module Belka.MonadPlus+where++import Belka.Prelude hiding (foldl, foldl1, concat)+++{-# INLINE foldl #-}+foldl :: MonadPlus m => (a -> b -> a) -> a -> m b -> m a+foldl step start fetch =+  loop start+  where+    loop !state =+      mplus+        (do+          !element <- fetch+          loop (step state element))+        (return state)++{-# INLINE foldl1 #-}+foldl1 :: MonadPlus m => (a -> a -> a) -> m a -> m a+foldl1 step fetch =+  do+    !start <- fetch+    foldl step start fetch++{-# INLINE concat #-}+concat :: (MonadPlus m, Monoid a) => m a -> m a+concat =+  foldl mappend mempty++{-# INLINE concat1 #-}+concat1 :: (MonadPlus m, Semigroup a) => m a -> m a+concat1 =+  foldl1 (<>)
+ library/Belka/ParseBody.hs view
@@ -0,0 +1,31 @@+module Belka.ParseBody+where++import Belka.Prelude+import qualified Belka.ParseHeaders as E+import qualified Belka.Potoki.Consume as H+import qualified Potoki.Consume as F+import qualified Aeson.ValueParser as G+import qualified Data.Aeson as I+++newtype ParseBody a =+  ParseBody (Compose (F.Consume ByteString) (Either Text) a)+  deriving (Functor, Applicative)++consume :: F.Consume ByteString (Either Text body) -> ParseBody body+consume consume =+  ParseBody (Compose consume)++json :: ParseBody I.Value+json =+  consume (H.json)++parseJson :: G.Value json -> ParseBody json+parseJson jsonParser =+  consume (H.parseJson jsonParser)++{-| Useful for debugging -}+print :: ParseBody ()+print =+  consume (fmap Right F.printBytes)
+ library/Belka/ParseHead.hs view
@@ -0,0 +1,37 @@+module Belka.ParseHead+where++import Belka.Prelude+import qualified Data.CaseInsensitive as B+import qualified Data.HashMap.Strict as D+import qualified Network.HTTP.Client as A+import qualified Network.HTTP.Types as C+import qualified Belka.ParseHeaders as E+import qualified Belka.Potoki.Consume as H+import qualified Potoki.Consume as F+import qualified Aeson.ValueParser as G+++newtype ParseHead a =+  ParseHead (ExceptT Text (ReaderT (A.Response A.BodyReader) IO) a)+  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadIO, MonadError Text)++liftIOFn :: (A.Response A.BodyReader -> IO (Either Text a)) -> ParseHead a+liftIOFn fn =+  ParseHead (ExceptT (ReaderT fn))++liftPureFn :: (A.Response A.BodyReader -> Either Text a) -> ParseHead a+liftPureFn fn =+  liftIOFn (pure . fn)++liftTotalFn :: (A.Response A.BodyReader -> a) -> ParseHead a+liftTotalFn fn =+  liftPureFn (Right . fn)++getStatus :: ParseHead Int+getStatus =+  liftTotalFn (C.statusCode . A.responseStatus)++parseHeaders :: E.ParseHeaders headers -> ParseHead headers+parseHeaders (E.ParseHeaders (ReaderT hashMapFn)) =+  liftPureFn (runExcept . hashMapFn . D.fromList . map (first B.foldedCase) . A.responseHeaders)
+ library/Belka/ParseHeaders.hs view
@@ -0,0 +1,34 @@+module Belka.ParseHeaders+where++import Belka.Prelude+import qualified Data.CaseInsensitive as B+import qualified Data.HashMap.Strict as D+import qualified Network.HTTP.Client as A+import qualified Network.HTTP.Types as C+import qualified Belka.Attoparsec.ByteString as E+import qualified Data.Attoparsec.ByteString as G+import qualified Ptr.ByteString as F+++newtype ParseHeaders a =+  ParseHeaders (ReaderT (HashMap ByteString ByteString) (Except Text) a)+  deriving (Functor, Applicative, Alternative, Monad, MonadPlus, MonadError Text)++header :: ByteString -> ParseHeaders ByteString+header name =+  ParseHeaders (ReaderT (except . maybe (Left ("Header not found: " <> showText name)) Right . D.lookup name))++contentType :: ParseHeaders (ByteString, HashMap ByteString ByteString)+contentType =+  do+    value <- header "content-type"+    case G.parseOnly (E.contentTypeHeader <* G.endOfInput) value of+      Right result -> return result+      Left message -> throwError (fromString (showString "Content-type parsing: " (showString message (showString ". Input: " (show value)))))++charset :: ParseHeaders ByteString+charset =+  do+    (_, detailsTable) <- contentType+    maybe (throwError "No Charset specified in the Content-Type header") return (D.lookup "charset" detailsTable)
+ library/Belka/Potoki/Consume.hs view
@@ -0,0 +1,21 @@+module Belka.Potoki.Consume+where++import Belka.Prelude+import Potoki.Consume+import qualified Aeson.ValueParser as A+import qualified Data.Aeson.Parser as B+import qualified Data.Aeson as C+++json :: Consume ByteString (Either Text C.Value)+json =+  parseBytes B.json'++lazyJson :: Consume ByteString (Either Text C.Value)+lazyJson =+  parseBytes B.json++parseJson :: A.Value parsed -> Consume ByteString (Either Text parsed)+parseJson parser =+  fmap (>>= A.run parser) lazyJson
+ library/Belka/Potoki/Transform.hs view
@@ -0,0 +1,53 @@+module Belka.Potoki.Transform+where++import Belka.Prelude+import Potoki.Transform+import qualified Network.HTTP.Client as A+import qualified Network.HTTP.Client.TLS as A+import qualified Belka.Request as B+import qualified Belka.ParseHead as C+import qualified Belka.ParseBody as D+import qualified Belka.TransportError as G+import qualified Belka.IO as H+import qualified Belka.Interact as I+++{-|+Given a specification of how to parse the response,+execute the requests, producing the parsed responses.+-}+request :: C.ParseHead (D.ParseBody response) -> Transform B.Request (Either Text (Either G.TransportError response))+request parse =+  arr (\ request -> A.newTlsManager >>= \ manager -> H.interact manager (I.request request parse) <* A.closeManager manager) >>>+  executeIO++{-|+Given an HTTP manager, a specification of how to parse the response,+execute the requests, producing the parsed responses.+-}+requestUsingManager :: A.Manager -> C.ParseHead (D.ParseBody response) -> Transform B.Request (Either Text (Either G.TransportError response))+requestUsingManager manager parse =+  arr (\ request -> H.interact manager (I.request request parse)) >>>+  executeIO++{-|+Perform 'requestUsingManager' using a new manager.+-}+requestUsingNewManager :: C.ParseHead (D.ParseBody response) -> Transform B.Request (Either Text (Either G.TransportError response))+requestUsingNewManager parse =+  ioTransform $ do+    manager <- A.newTlsManagerWith settings+    return (requestUsingManager manager parse)+  where+    settings =+      A.tlsManagerSettings++{-|+Perform 'requestUsingManager' using a global manager.+-}+requestUsingGlobalManager :: C.ParseHead (D.ParseBody response) -> Transform B.Request (Either Text (Either G.TransportError response))+requestUsingGlobalManager parse =+  ioTransform $ do+    manager <- A.getGlobalManager+    return (requestUsingManager manager parse)
+ library/Belka/Prelude.hs view
@@ -0,0 +1,95 @@+module Belka.Prelude+( +  module Exports,+  lowerCaseBytesInIso8859_1,+  tryError,+  textString,+  showText,+)+where+++-- base-prelude+-------------------------+import BasePrelude as Exports hiding (First(..), Last(..), (<>))++-- transformers+-------------------------+import Control.Monad.IO.Class as Exports+import Control.Monad.Trans.Class as Exports+import Control.Monad.Trans.Cont as Exports hiding (shift, callCC)+import Control.Monad.Trans.Except as Exports (ExceptT(ExceptT), Except, except, runExcept, runExceptT, mapExcept, mapExceptT, withExcept, withExceptT)+import Control.Monad.Trans.Maybe as Exports+import Control.Monad.Trans.Reader as Exports (Reader, runReader, mapReader, withReader, ReaderT(ReaderT), runReaderT, mapReaderT, withReaderT)+import Control.Monad.Trans.State.Strict as Exports (State, runState, evalState, execState, mapState, withState, StateT(StateT), runStateT, evalStateT, execStateT, mapStateT, withStateT)+import Control.Monad.Trans.Writer.Strict as Exports (Writer, runWriter, execWriter, mapWriter, WriterT(..), execWriterT, mapWriterT)+import Data.Functor.Compose as Exports++-- mtl+-------------------------+import Control.Monad.Cont.Class as Exports+import Control.Monad.Error.Class as Exports hiding (Error(..))+import Control.Monad.Reader.Class as Exports+import Control.Monad.State.Class as Exports+import Control.Monad.Writer.Class as Exports++-- semigroups+-------------------------+import Data.Semigroup as Exports++-- unordered-containers+-------------------------+import Data.HashMap.Strict as Exports (HashMap)++-- bytestring+-------------------------+import Data.ByteString as Exports (ByteString)++-- text+-------------------------+import Data.Text as Exports (Text)++-- hashable+-------------------------+import Data.Hashable as Exports++-- iri+-------------------------+import Iri.Data as Exports (Iri)++-- bug+-------------------------+import Bug as Exports++-- Utils+-------------------------+import qualified Data.Text as A+import qualified Data.ByteString as B++-- |+-- Lowercase according to ISO-8859-1.+lowerCaseBytesInIso8859_1 :: ByteString -> ByteString+lowerCaseBytesInIso8859_1 =+  B.map byteTransformation+  where+    byteTransformation w =+      if transformable+        then w + 32+        else w+      where+        transformable =+          65 <= w && w <=  90 ||+          192 <= w && w <= 214 ||+          216 <= w && w <= 222++tryError :: MonadError e m => m a -> m (Either e a)+tryError m =+  catchError (liftM Right m) (return . Left)++textString :: Text -> String+textString =+  A.unpack++showText :: Show a => a -> Text+showText =+  fromString . show
+ library/Belka/Ptr/Poking.hs view
@@ -0,0 +1,32 @@+module Belka.Ptr.Poking+where++import Belka.Prelude+import Ptr.Poking+import qualified Iri.Data as J+import qualified Iri.Rendering.Ptr.Poking as K+import qualified Ptr.ByteString as O+import qualified Data.ByteString.Base64 as A+import qualified Data.Text.Encoding as B+++host :: J.Host -> Poking+host =+  K.host++path :: J.Path -> Poking+path path =+  asciiChar '/' <> K.path path++queryString :: J.Query -> Poking+queryString query =+  asciiChar '?' <> K.query query++basicAuth :: Text -> Text -> Poking+basicAuth user password =+  bytes "Basic " <> bytes (A.encode bodyBytes)+  where+    bodyBytes =+      if password == ""+        then B.encodeUtf8 user+        else O.poking (bytes (B.encodeUtf8 user) <> asciiChar ':' <> bytes (B.encodeUtf8 password))
+ library/Belka/Request.hs view
@@ -0,0 +1,158 @@+module Belka.Request+where++import Belka.Prelude+import qualified Network.HTTP.Client as A+import qualified Data.CaseInsensitive as B+import qualified Potoki.Produce as C+import qualified Potoki.Core.Produce as C+import qualified Potoki.Core.Fetch as I+import qualified Potoki.IO as D+import qualified JSONBytesBuilder.Builder as E+import qualified JSONBytesBuilder.ByteString.Builder as G+import qualified Data.ByteString as L+import qualified Data.ByteString.Builder as F+import qualified Data.Text as H+import qualified Iri.Data as J+import qualified Iri.Rendering.Ptr.Poking as K+import qualified Ptr.Poking as M+import qualified Ptr.ByteString as O+import qualified Belka.Ptr.Poking as P+++{-| Composable settings of an HTTP request -}+newtype Request =+  Request (A.Request -> IO (A.Request, IO ()))++instance Semigroup Request where+  (<>) (Request leftIO) (Request rightIO) =+    Request $ \ !hcRequest ->+    do+      (leftRequest, leftCleanUp) <- leftIO hcRequest+      (rightRequest, rightCleanUp) <- rightIO leftRequest+      return (rightRequest, leftCleanUp >> rightCleanUp)++instance Monoid Request where+  mempty =+    Request (\ hcRequest -> return (hcRequest, return ()))+  mappend =+    (<>)++endo :: (A.Request -> A.Request) -> Request+endo endo =+  Request $ \ hcRequest -> return (endo hcRequest, return ())++{-| Set timeout in millis -}+setTimeout :: Int -> Request+setTimeout timeout =+  endo (\ x -> x {A.responseTimeout = A.responseTimeoutMicro (timeout * 1000)})++setHeader :: ByteString -> ByteString -> Request+setHeader name value =+  endo (\ x -> x {A.requestHeaders = newHeaders (A.requestHeaders x)})+  where+    newHeaders oldHeaders =+      (B.mk name, value) : oldHeaders++setAcceptHeader :: ByteString -> Request+setAcceptHeader value =+  setHeader "accept" value++setAcceptLanguageHeader :: ByteString -> Request+setAcceptLanguageHeader =+  setHeader "accept-language"++setContentTypeHeader :: ByteString -> Request+setContentTypeHeader value =+  setHeader "content-type" value++setBasicAuthHeader :: Text -> Text -> Request+setBasicAuthHeader user password =+  setHeader "authorization" (O.poking (P.basicAuth user password))++setAcceptHeaderToJson :: Request+setAcceptHeaderToJson =+  setAcceptHeader "application/json"++setAcceptHeaderToHtml :: Request+setAcceptHeaderToHtml =+  setAcceptHeader "text/html"++setContentTypeHeaderToJson :: Request+setContentTypeHeaderToJson =+  setContentTypeHeader "application/json"++setUserAgentHeader :: ByteString -> Request+setUserAgentHeader =+  setHeader "user-agent"++setIri :: J.HttpIri -> Request+setIri (J.HttpIri (J.Security secure) host port path query fragment) =+  endo $ \ request ->+    request {+      A.secure = secure,+      A.host = preparedHost,+      A.port = preparedPort,+      A.path = preparedPath,+      A.queryString = preparedQuery+    }+  where+    preparedHost =+      O.poking (K.host host)+    preparedPort =+      case port of+        J.PresentPort value -> fromIntegral value+        J.MissingPort -> if secure then 443 else 80+    preparedPath =+      O.poking (M.asciiChar '/' <> K.path path)+    preparedQuery =+      O.poking $+      case K.query query of+        query -> if M.null query then mempty else M.asciiChar '?' <> query++setMethod :: ByteString -> Request+setMethod method =+  endo (\ x -> x {A.method = method})++setMethodToGet :: Request+setMethodToGet =+  setMethod "get"++setMethodToPost :: Request+setMethodToPost =+  setMethod "post"++setMethodToDelete :: Request+setMethodToDelete =+  setMethod "delete"++setMethodToHead :: Request+setMethodToHead =+  setMethod "head"++setBody :: ByteString -> Request+setBody bytes =+  endo $ \ request ->+  request { A.requestBody = A.RequestBodyBS bytes }++produceBody :: C.Produce ByteString -> Request+produceBody (C.Produce produceIO) =+  Request $ \ hcRequest ->+  do+    (fetch, cleanUp) <- produceIO+    return+      ((,)+        (hcRequest { A.requestBody = A.RequestBodyStreamChunked (givesPopper fetch) })+        cleanUp)+  where+    givesPopper (I.Fetch fetchIO) takesPopper =+      takesPopper (fetchIO mempty id)++buildBody :: F.Builder -> Request+buildBody builder =+  endo $ \ request ->+  request { A.requestBody = A.RequestBodyLBS (F.toLazyByteString builder) }++buildJsonBody :: E.Literal -> Request+buildJsonBody builder =+  buildBody (G.jsonLiteral builder) <> setContentTypeHeaderToJson
+ library/Belka/TransportError.hs view
@@ -0,0 +1,36 @@+module Belka.TransportError+where++import Belka.Prelude+import qualified Network.HTTP.Client as A+++data TransportError =+  TimeoutTransportError |+  ConnectionTransportError IOErrorType |+  UnclassifiedTransportError A.HttpException+  deriving (Show)++someException :: TransportError -> SomeException -> TransportError+someException alternative someException =+  case fromException someException of+    Just ioException -> ConnectionTransportError (ioeGetErrorType ioException)+    Nothing -> alternative++httpException :: A.HttpException -> TransportError+httpException httpException =+  case httpException of+    A.HttpExceptionRequest _ content ->+      case content of+        A.ResponseTimeout ->+          TimeoutTransportError+        A.ConnectionTimeout ->+          TimeoutTransportError+        A.ConnectionFailure x ->+          someException (UnclassifiedTransportError httpException) x+        A.InternalException x ->+          someException (UnclassifiedTransportError httpException) x+        _ ->+          UnclassifiedTransportError httpException+    _ ->+      UnclassifiedTransportError httpException
+ tests/Main.hs view
@@ -0,0 +1,117 @@+module Main+where++import Prelude hiding (assert, choose, (.&.), Success, Failure, Fixed)+import Bug+import Test.Tasty+import Test.Tasty.Runners+import Test.Tasty.HUnit+import Test.Tasty.QuickCheck+import Test.QuickCheck.Instances+import qualified Belka.IO as A+import qualified Belka.Interact as B+import qualified Belka.Request as C+import qualified Belka.ParseBody as D+import qualified Belka.ParseHead as J+import qualified Belka.ParseHeaders as K+import qualified Belka.Potoki.Transform as I+import qualified Iri.QuasiQuoter as E+import qualified Iri.Parsing.Text as M+import qualified Potoki.Produce as F+import qualified Potoki.IO as G+import qualified Potoki.Consume as H+import qualified Potoki.Transform as N+import qualified Data.Text as L+++main =+  defaultMain $+  testGroup "All tests" $+  [+    bombingWithRequests+    ,+    scrape+    ,+    erroneusResponse+    ,+    charset+  ]++erroneusResponse =+  testCase "Erroneous response" $ do+    result <-+      fmap+        (either Left (either (Left . fromString . show) Right))+        (A.interactUsingGlobalManager+          (B.request+            (C.setIri [E.httpUri|http://localhost:993|])+            (pure (fmap (const ()) D.json))))+    assertBool "" (isLeft result)++scrape =+  testCase "Scrape" $ do+    result <- G.produceAndConsume produce consume+    let (Right (Right bodies)) = fmap sequence (sequence result)+    assertBool "" ((not . null) bodies)+  where+    produce =+      F.list [request]+      where+        request =+          C.setIri [E.httpUri|https://best-trailer.ru/player/html5/zrollnotgpmd.php|] <>+          C.setAcceptHeaderToHtml <>+          C.setUserAgentHeader "Mozilla/5.0 (Windows NT 6.2; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/60.0.3112.113 YaBrowser/17.9.1.785 (beta) Yowser/2.5 Safari/537.36" <>+          C.setAcceptLanguageHeader ""+    consume =+      H.transform transform H.list+      where+        transform =+          I.requestUsingNewManager (pure (D.consume consume))+          where+            consume =+              fmap Right H.concat++charset =+  testCase "Charset" $ do+    result <- G.produceAndConsume produce consume+    let (Right (Right bodies)) = fmap sequence (sequence result)+    assertEqual "" ["utf-8"] bodies+  where+    produce =+      F.list [request]+      where+        request =+          C.setIri [E.httpUri|http://google.com|] <>+          C.setAcceptHeaderToHtml <>+          C.setUserAgentHeader "Mozilla/5.0 (Windows NT 6.2; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/60.0.3112.113 YaBrowser/17.9.1.785 (beta) Yowser/2.5 Safari/537.36" <>+          C.setAcceptLanguageHeader ""+    consume =+      H.transform transform H.list+      where+        transform =+          I.requestUsingNewManager (J.parseHeaders K.charset >>= return . pure)++bombingWithRequests =+  testCase "Bombing with requests" $ do+    results <- run+    assertBool (show results) (isRight results)+  where+    getIris =+      do+        result <- traverse M.httpIri . L.split (== '\n') <$> L.readFile "samples/iris"+        either (fail . show) return result+    getRequests =+      do+        iris <- getIris+        return $ do+          iri <- iris+          return $ C.setIri iri+    run =+      do+        requests <- getRequests+        results <- G.produceAndConsume (F.list requests) (H.transform transform H.list)+        either (fail . showString "Parsing error: " . show) (return . sequence) (sequence results)+      where+        transform =+          N.concurrently 30 $+          I.requestUsingNewManager (J.parseHeaders K.contentType >>= return . pure)