diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/belka.cabal b/belka.cabal new file mode 100644 --- /dev/null +++ b/belka.cabal @@ -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 +maintainer: + Nikita Volkov +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 diff --git a/library/Belka/Attoparsec/ByteString.hs b/library/Belka/Attoparsec/ByteString.hs new file mode 100644 --- /dev/null +++ b/library/Belka/Attoparsec/ByteString.hs @@ -0,0 +1,60 @@ +{-| +See +. +-} +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 diff --git a/library/Belka/BytePredicates.hs b/library/Belka/BytePredicates.hs new file mode 100644 --- /dev/null +++ b/library/Belka/BytePredicates.hs @@ -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 diff --git a/library/Belka/IO.hs b/library/Belka/IO.hs new file mode 100644 --- /dev/null +++ b/library/Belka/IO.hs @@ -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_ diff --git a/library/Belka/Interact.hs b/library/Belka/Interact.hs new file mode 100644 --- /dev/null +++ b/library/Belka/Interact.hs @@ -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 diff --git a/library/Belka/MonadPlus.hs b/library/Belka/MonadPlus.hs new file mode 100644 --- /dev/null +++ b/library/Belka/MonadPlus.hs @@ -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 (<>) diff --git a/library/Belka/ParseBody.hs b/library/Belka/ParseBody.hs new file mode 100644 --- /dev/null +++ b/library/Belka/ParseBody.hs @@ -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) diff --git a/library/Belka/ParseHead.hs b/library/Belka/ParseHead.hs new file mode 100644 --- /dev/null +++ b/library/Belka/ParseHead.hs @@ -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) diff --git a/library/Belka/ParseHeaders.hs b/library/Belka/ParseHeaders.hs new file mode 100644 --- /dev/null +++ b/library/Belka/ParseHeaders.hs @@ -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) diff --git a/library/Belka/Potoki/Consume.hs b/library/Belka/Potoki/Consume.hs new file mode 100644 --- /dev/null +++ b/library/Belka/Potoki/Consume.hs @@ -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 diff --git a/library/Belka/Potoki/Transform.hs b/library/Belka/Potoki/Transform.hs new file mode 100644 --- /dev/null +++ b/library/Belka/Potoki/Transform.hs @@ -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) diff --git a/library/Belka/Prelude.hs b/library/Belka/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/Belka/Prelude.hs @@ -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 diff --git a/library/Belka/Ptr/Poking.hs b/library/Belka/Ptr/Poking.hs new file mode 100644 --- /dev/null +++ b/library/Belka/Ptr/Poking.hs @@ -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)) diff --git a/library/Belka/Request.hs b/library/Belka/Request.hs new file mode 100644 --- /dev/null +++ b/library/Belka/Request.hs @@ -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 diff --git a/library/Belka/TransportError.hs b/library/Belka/TransportError.hs new file mode 100644 --- /dev/null +++ b/library/Belka/TransportError.hs @@ -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 diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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)