From 500aabc10a1448a31972021f81d4f92b412293cd Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 21 Feb 2022 08:25:47 +0100 Subject: [PATCH 1/5] .cabal: Reorganize constraints, allow base-4.16 in testsuite The constraints have been reorganized according to these principles: - mention dependency on top-level if mentioned in all branches of a conditional - do not repeat constraints in test-suite that are inherited from library - order each dependency group alphabetically (but `base` and parent go first) - format with leading comma (harder to make mistakes) - align at >= and && --- HTTP.cabal | 76 ++++++++++++++++++++++++++++++------------------------ 1 file changed, 43 insertions(+), 33 deletions(-) diff --git a/HTTP.cabal b/HTTP.cabal index d329695..e5438c5 100644 --- a/HTTP.cabal +++ b/HTTP.cabal @@ -1,7 +1,7 @@ +Cabal-Version: >= 1.10 Name: HTTP Version: 4000.3.16 x-revision: 1 -Cabal-Version: >= 1.10 Build-type: Simple License: BSD3 License-file: LICENSE @@ -57,7 +57,10 @@ Description: Extra-Source-Files: CHANGES -tested-with: GHC==9.0.1, GHC==8.10.4, GHC==8.8.3, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 +tested-with: + GHC==9.2.1, GHC==9.0.1, + GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 Source-Repository head type: git @@ -110,23 +113,30 @@ Library -- note the test harness constraints should be kept in sync with these -- where dependencies are shared - Build-depends: base >= 4.3.0.0 && < 4.17, parsec >= 2.0 && < 3.2 - Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.12 - Build-depends: time >= 1.1.2.3 && < 1.13 + build-depends: + base >= 4.3.0.0 && < 4.17 + , array >= 0.3.0.2 && < 0.6 + , bytestring >= 0.9.1.5 && < 0.12 + , parsec >= 2.0 && < 3.2 + , time >= 1.1.2.3 && < 1.13 + -- The following dependencies are refined by flags, but they should + -- still be mentioned here on the top-level. + , mtl >= 1.1.1.0 && < 2.3 + , network >= 2.4 && < 3.2 default-language: Haskell98 default-extensions: FlexibleInstances if flag(mtl1) - Build-depends: mtl >= 1.1.1.0 && < 1.2 + Build-depends: mtl < 1.2 CPP-Options: -DMTL1 else - Build-depends: mtl >= 2.0 && < 2.3 + Build-depends: mtl >= 2.0 if flag(network-uri) - Build-depends: network-uri == 2.6.*, network >= 2.6 && < 3.2 + Build-depends: network-uri == 2.6.*, network >= 2.6 else - Build-depends: network >= 2.4 && < 2.6 + Build-depends: network < 2.6 if flag(warn-as-error) ghc-options: -Werror @@ -147,37 +157,37 @@ Test-Suite test ghc-options: -Wall - -- note: version constraints for dependencies shared with the library - -- should be the same - build-depends: HTTP, - HUnit >= 1.2.0.1 && < 1.7, - httpd-shed >= 0.4 && < 0.5, - mtl >= 1.1.1.0 && < 2.3, - bytestring >= 0.9.1.5 && < 0.12, - deepseq >= 1.3.0.0 && < 1.5, - pureMD5 >= 0.2.4 && < 2.2, - base >= 4.3.0.0 && < 4.16, - split >= 0.1.3 && < 0.3, - test-framework >= 0.2.0 && < 0.9, - test-framework-hunit >= 0.3.0 && <0.4 + build-depends: + HTTP + -- constraints inherited from HTTP + , base + , bytestring + , mtl + , network + -- extra dependencies + , deepseq >= 1.3.0.0 && < 1.5 + , httpd-shed >= 0.4 && < 0.5 + , HUnit >= 1.2.0.1 && < 1.7 + , pureMD5 >= 0.2.4 && < 2.2 + , split >= 0.1.3 && < 0.3 + , test-framework >= 0.2.0 && < 0.9 + , test-framework-hunit >= 0.3.0 && < 0.4 if flag(network-uri) - Build-depends: network-uri == 2.6.*, network >= 2.6 && < 3.2 + Build-depends: network-uri == 2.6.*, network >= 2.6 else - Build-depends: network >= 2.3 && < 2.6 + Build-depends: network < 2.6 if flag(warp-tests) CPP-Options: -DWARP_TESTS build-depends: - case-insensitive >= 0.4.0.1 && < 1.3, - http-types >= 0.8.0 && < 1.0, - wai >= 2.1.0 && < 3.3, - warp >= 2.1.0 && < 3.4 + case-insensitive >= 0.4.0.1 && < 1.3 + , conduit >= 1.0.8 && < 1.4 + , http-types >= 0.8.0 && < 1.0 + , wai >= 2.1.0 && < 3.3 + , warp >= 2.1.0 && < 3.4 if flag(conduit10) - build-depends: - conduit >= 1.0.8 && < 1.1 + build-depends: conduit < 1.1 else - build-depends: - conduit >= 1.1 && < 1.4, - conduit-extra >= 1.1 && < 1.4 + build-depends: conduit >= 1.1, conduit-extra >= 1.1 && < 1.4 From dfd942bfe5b2173a4c2b363c6c50eda8520e8430 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 21 Feb 2022 08:31:33 +0100 Subject: [PATCH 2/5] Haskell-CI for GHC 7.0 - 9.2 --- .github/workflows/haskell-ci.yml | 267 +++++++++++++++++++++++++++++++ 1 file changed, 267 insertions(+) create mode 100644 .github/workflows/haskell-ci.yml diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml new file mode 100644 index 0000000..23b044a --- /dev/null +++ b/.github/workflows/haskell-ci.yml @@ -0,0 +1,267 @@ +# This GitHub workflow config has been generated by a script via +# +# haskell-ci 'github' 'HTTP.cabal' +# +# To regenerate the script (for example after adjusting tested-with) run +# +# haskell-ci regenerate +# +# For more information, see https://github.com/haskell-CI/haskell-ci +# +# version: 0.14.1 +# +# REGENDATA ("0.14.1",["github","HTTP.cabal"]) +# +name: Haskell-CI +on: + - push + - pull_request +jobs: + linux: + name: Haskell-CI - Linux - ${{ matrix.compiler }} + runs-on: ubuntu-18.04 + timeout-minutes: + 60 + container: + image: buildpack-deps:bionic + continue-on-error: ${{ matrix.allow-failure }} + strategy: + matrix: + include: + - compiler: ghc-9.2.1 + compilerKind: ghc + compilerVersion: 9.2.1 + setup-method: ghcup + allow-failure: false + - compiler: ghc-9.0.1 + compilerKind: ghc + compilerVersion: 9.0.1 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-8.10.7 + compilerKind: ghc + compilerVersion: 8.10.7 + setup-method: ghcup + allow-failure: false + - compiler: ghc-8.8.4 + compilerKind: ghc + compilerVersion: 8.8.4 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-8.6.5 + compilerKind: ghc + compilerVersion: 8.6.5 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-8.4.4 + compilerKind: ghc + compilerVersion: 8.4.4 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-8.2.2 + compilerKind: ghc + compilerVersion: 8.2.2 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-8.0.2 + compilerKind: ghc + compilerVersion: 8.0.2 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-7.10.3 + compilerKind: ghc + compilerVersion: 7.10.3 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-7.8.4 + compilerKind: ghc + compilerVersion: 7.8.4 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-7.6.3 + compilerKind: ghc + compilerVersion: 7.6.3 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-7.4.2 + compilerKind: ghc + compilerVersion: 7.4.2 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-7.2.2 + compilerKind: ghc + compilerVersion: 7.2.2 + setup-method: hvr-ppa + allow-failure: false + - compiler: ghc-7.0.4 + compilerKind: ghc + compilerVersion: 7.0.4 + setup-method: hvr-ppa + allow-failure: false + fail-fast: false + steps: + - name: apt + run: | + apt-get update + apt-get install -y --no-install-recommends gnupg ca-certificates dirmngr curl git software-properties-common libtinfo5 + if [ "${{ matrix.setup-method }}" = ghcup ]; then + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install ghc "$HCVER" + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 + else + apt-add-repository -y 'ppa:hvr/ghc' + apt-get update + apt-get install -y "$HCNAME" + mkdir -p "$HOME/.ghcup/bin" + curl -sL https://downloads.haskell.org/ghcup/0.1.17.3/x86_64-linux-ghcup-0.1.17.3 > "$HOME/.ghcup/bin/ghcup" + chmod a+x "$HOME/.ghcup/bin/ghcup" + "$HOME/.ghcup/bin/ghcup" install cabal 3.6.2.0 + fi + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: Set PATH and environment variables + run: | + echo "$HOME/.cabal/bin" >> $GITHUB_PATH + echo "LANG=C.UTF-8" >> "$GITHUB_ENV" + echo "CABAL_DIR=$HOME/.cabal" >> "$GITHUB_ENV" + echo "CABAL_CONFIG=$HOME/.cabal/config" >> "$GITHUB_ENV" + HCDIR=/opt/$HCKIND/$HCVER + if [ "${{ matrix.setup-method }}" = ghcup ]; then + HC=$HOME/.ghcup/bin/$HCKIND-$HCVER + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HOME/.ghcup/bin/$HCKIND-pkg-$HCVER" >> "$GITHUB_ENV" + echo "HADDOCK=$HOME/.ghcup/bin/haddock-$HCVER" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + else + HC=$HCDIR/bin/$HCKIND + echo "HC=$HC" >> "$GITHUB_ENV" + echo "HCPKG=$HCDIR/bin/$HCKIND-pkg" >> "$GITHUB_ENV" + echo "HADDOCK=$HCDIR/bin/haddock" >> "$GITHUB_ENV" + echo "CABAL=$HOME/.ghcup/bin/cabal-3.6.2.0 -vnormal+nowrap" >> "$GITHUB_ENV" + fi + + HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\d+)\.(\d+)\.(\d+)(\.(\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))') + echo "HCNUMVER=$HCNUMVER" >> "$GITHUB_ENV" + echo "ARG_TESTS=--enable-tests" >> "$GITHUB_ENV" + echo "ARG_BENCH=--enable-benchmarks" >> "$GITHUB_ENV" + echo "HEADHACKAGE=false" >> "$GITHUB_ENV" + echo "ARG_COMPILER=--$HCKIND --with-compiler=$HC" >> "$GITHUB_ENV" + echo "GHCJSARITH=0" >> "$GITHUB_ENV" + env: + HCKIND: ${{ matrix.compilerKind }} + HCNAME: ${{ matrix.compiler }} + HCVER: ${{ matrix.compilerVersion }} + - name: env + run: | + env + - name: write cabal config + run: | + mkdir -p $CABAL_DIR + cat >> $CABAL_CONFIG <> $CABAL_CONFIG < cabal-plan.xz + echo 'de73600b1836d3f55e32d80385acc055fd97f60eaa0ab68a755302685f5d81bc cabal-plan.xz' | sha256sum -c - + xz -d < cabal-plan.xz > $HOME/.cabal/bin/cabal-plan + rm -f cabal-plan.xz + chmod a+x $HOME/.cabal/bin/cabal-plan + cabal-plan --version + - name: checkout + uses: actions/checkout@v2 + with: + path: source + - name: initial cabal.project for sdist + run: | + touch cabal.project + echo "packages: $GITHUB_WORKSPACE/source/." >> cabal.project + cat cabal.project + - name: sdist + run: | + mkdir -p sdist + $CABAL sdist all --output-dir $GITHUB_WORKSPACE/sdist + - name: unpack + run: | + mkdir -p unpacked + find sdist -maxdepth 1 -type f -name '*.tar.gz' -exec tar -C $GITHUB_WORKSPACE/unpacked -xzvf {} \; + - name: generate cabal.project + run: | + PKGDIR_HTTP="$(find "$GITHUB_WORKSPACE/unpacked" -maxdepth 1 -type d -regex '.*/HTTP-[0-9.]*')" + echo "PKGDIR_HTTP=${PKGDIR_HTTP}" >> "$GITHUB_ENV" + rm -f cabal.project cabal.project.local + touch cabal.project + touch cabal.project.local + echo "packages: ${PKGDIR_HTTP}" >> cabal.project + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo "package HTTP" >> cabal.project ; fi + if [ $((HCNUMVER >= 80200)) -ne 0 ] ; then echo " ghc-options: -Werror=missing-methods" >> cabal.project ; fi + cat >> cabal.project <> cabal.project.local + cat cabal.project + cat cabal.project.local + - name: dump install plan + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dry-run all + cabal-plan + - name: cache + uses: actions/cache@v2 + with: + key: ${{ runner.os }}-${{ matrix.compiler }}-${{ github.sha }} + path: ~/.cabal/store + restore-keys: ${{ runner.os }}-${{ matrix.compiler }}- + - name: install dependencies + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --dependencies-only -j2 all + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH --dependencies-only -j2 all + - name: build w/o tests + run: | + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all + - name: build + run: | + $CABAL v2-build $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --write-ghc-environment-files=always + - name: tests + run: | + $CABAL v2-test $ARG_COMPILER $ARG_TESTS $ARG_BENCH all --test-show-details=direct + - name: cabal check + run: | + cd ${PKGDIR_HTTP} || false + ${CABAL} -vnormal check + - name: haddock + run: | + $CABAL v2-haddock $ARG_COMPILER --with-haddock $HADDOCK $ARG_TESTS $ARG_BENCH all + - name: unconstrained build + run: | + rm -f cabal.project.local + $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all From 05256a4329db61200960943607df243aa37e10d8 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 21 Feb 2022 08:55:07 +0100 Subject: [PATCH 3/5] Fix whitespace violations in Haskell sources find . -name "*hs" | xargs fix-whitespace --- Network/Browser.hs | 153 +++++++++++++++++------------------ Network/BufferType.hs | 28 +++---- Network/HTTP.hs | 56 ++++++------- Network/HTTP/Auth.hs | 24 +++--- Network/HTTP/Base.hs | 138 +++++++++++++++---------------- Network/HTTP/Base64.hs | 24 +++--- Network/HTTP/Cookie.hs | 28 +++---- Network/HTTP/HandleStream.hs | 24 +++--- Network/HTTP/Headers.hs | 36 ++++----- Network/HTTP/MD5Aux.hs | 4 +- Network/HTTP/Proxy.hs | 12 +-- Network/HTTP/Stream.hs | 30 +++---- Network/HTTP/UserAgent.hs | 20 ++--- Network/HTTP/Utils.hs | 16 ++-- Network/Stream.hs | 10 +-- Network/StreamDebugger.hs | 14 ++-- Network/StreamSocket.hs | 6 +- Network/TCP.hs | 38 ++++----- test/get.hs | 22 ++--- test/getb.hs | 42 +++++----- test/httpTests.hs | 6 +- 21 files changed, 365 insertions(+), 366 deletions(-) diff --git a/Network/Browser.hs b/Network/Browser.hs index a2a1774..e23222b 100644 --- a/Network/Browser.hs +++ b/Network/Browser.hs @@ -4,15 +4,15 @@ Module : Network.Browser Copyright : See LICENSE file License : BSD - + Maintainer : Ganesh Sittampalam Stability : experimental Portability : non-portable (not tested) Session-level interactions over HTTP. - -The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in -providing support for more involved, and real, request/response interactions over + +The "Network.Browser" goes beyond the basic "Network.HTTP" functionality in +providing support for more involved, and real, request/response interactions over HTTP. Additional features supported are: * HTTP Authentication handling @@ -33,25 +33,25 @@ Example use: > setAllowRedirects True -- handle HTTP redirects > request $ getRequest "http://www.haskell.org/" > return (take 100 (rspBody rsp)) - + -} -module Network.Browser +module Network.Browser ( BrowserState , BrowserAction -- browser monad, effectively a state monad. , Proxy(..) - + , browse -- :: BrowserAction a -> IO a , request -- :: Request -> BrowserAction Response - + , getBrowserState -- :: BrowserAction t (BrowserState t) , withBrowserState -- :: BrowserState t -> BrowserAction t a -> BrowserAction t a - + , setAllowRedirects -- :: Bool -> BrowserAction t () , getAllowRedirects -- :: BrowserAction t Bool , setMaxRedirects -- :: Int -> BrowserAction t () , getMaxRedirects -- :: BrowserAction t (Maybe Int) - + , Authority(..) , getAuthorities , setAuthorities @@ -59,12 +59,12 @@ module Network.Browser , Challenge(..) , Qop(..) , Algorithm(..) - + , getAuthorityGen , setAuthorityGen , setAllowBasicAuth , getAllowBasicAuth - + , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) @@ -78,21 +78,21 @@ module Network.Browser , getCookieFilter -- :: BrowserAction t (URI -> Cookie -> IO Bool) , defaultCookieFilter -- :: URI -> Cookie -> IO Bool , userCookieFilter -- :: URI -> Cookie -> IO Bool - + , Cookie(..) , getCookies -- :: BrowserAction t [Cookie] , setCookies -- :: [Cookie] -> BrowserAction t () , addCookie -- :: Cookie -> BrowserAction t () - + , setErrHandler -- :: (String -> IO ()) -> BrowserAction t () , setOutHandler -- :: (String -> IO ()) -> BrowserAction t () - + , setEventHandler -- :: (BrowserEvent -> BrowserAction t ()) -> BrowserAction t () - + , BrowserEvent(..) , BrowserEventType(..) , RequestID - + , setProxy -- :: Proxy -> BrowserAction t () , getProxy -- :: BrowserAction t Proxy @@ -100,20 +100,20 @@ module Network.Browser , getCheckForProxy -- :: BrowserAction t Bool , setDebugLog -- :: Maybe String -> BrowserAction t () - + , getUserAgent -- :: BrowserAction t String , setUserAgent -- :: String -> BrowserAction t () - + , out -- :: String -> BrowserAction t () , err -- :: String -> BrowserAction t () , ioAction -- :: IO a -> BrowserAction a , defaultGETRequest , defaultGETRequest_ - + , formToRequest , uriDefaultTo - + -- old and half-baked; don't use: , Form(..) , FormVar @@ -209,7 +209,7 @@ getCookiesFor dom path = where cookiematch :: Cookie -> Bool cookiematch = cookieMatch (dom,path) - + -- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () @@ -253,7 +253,7 @@ is added to a rejected request this predictive annotation is suppressed. Notes: - - digest authentication so far ignores qop, so fails to authenticate + - digest authentication so far ignores qop, so fails to authenticate properly with qop=auth-int challenges - calculates a1 more than necessary - doesn't reverse authenticate @@ -273,7 +273,7 @@ getAuthFor dom pth = getAuthorities >>= return . (filter match) matchURI :: URI -> Bool matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) - + -- | @getAuthorities@ return the current set of @Authority@s known -- to the browser. @@ -308,7 +308,7 @@ getAllowBasicAuth = gets bsAllowBasicAuth -- | @setMaxAuthAttempts mbMax@ sets the maximum number of authentication attempts -- to do. If @Nothing@, rever to default max. setMaxAuthAttempts :: Maybe Int -> BrowserAction t () -setMaxAuthAttempts mb +setMaxAuthAttempts mb | fromMaybe 0 mb < 0 = return () | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb}) @@ -359,7 +359,7 @@ challengeToAuthority uri ch answerable chall = (chAlgorithm chall) == Just AlgMD5 buildAuth :: Challenge -> String -> String -> Authority - buildAuth (ChalBasic r) u p = + buildAuth (ChalBasic r) u p = AuthBasic { auSite=uri , auRealm=r , auUsername=u @@ -410,7 +410,7 @@ data BrowserState connection } instance Show (BrowserState t) where - show bs = "BrowserState { " + show bs = "BrowserState { " ++ shows (bsCookies bs) ("\n" {- ++ show (bsAuthorities bs) ++ "\n"-} ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") @@ -441,7 +441,7 @@ runBA bs = flip evalStateT bs . unBA browse :: BrowserAction conn a -> IO a browse = runBA defaultBrowserState --- | The default browser state has the settings +-- | The default browser state has the settings defaultBrowserState :: BrowserState t defaultBrowserState = res where @@ -463,7 +463,7 @@ defaultBrowserState = res , bsConnectionPool = [] , bsCheckProxy = defaultAutoProxyDetect , bsProxy = noProxy - , bsDebug = Nothing + , bsDebug = Nothing , bsEvent = Nothing , bsRequestID = 0 , bsUserAgent = Nothing @@ -484,8 +484,8 @@ withBrowserState bs = BA . withStateT (const bs) . unBA -- before doing so. nextRequest :: BrowserAction t a -> BrowserAction t a nextRequest act = do - let updReqID st = - let + let updReqID st = + let rid = succ (bsRequestID st) in rid `seq` st{bsRequestID=rid} @@ -528,7 +528,7 @@ getAllowRedirects = gets bsAllowRedirects -- redirects count does /not/ enable following of redirects itself; use -- 'setAllowRedirects' to do so. setMaxRedirects :: Maybe Int -> BrowserAction t () -setMaxRedirects c +setMaxRedirects c | fromMaybe 0 c < 0 = return () | otherwise = modify (\b -> b{bsMaxRedirects=c}) @@ -550,7 +550,7 @@ getMaxPoolSize = gets bsMaxPoolSize -- | @setProxy p@ will disable proxy usage if @p@ is @NoProxy@. -- If @p@ is @Proxy proxyURL mbAuth@, then @proxyURL@ is interpreted --- as the URL of the proxy to use, possibly authenticating via +-- as the URL of the proxy to use, possibly authenticating via -- 'Authority' information in @mbAuth@. setProxy :: Proxy -> BrowserAction t () setProxy p = @@ -560,7 +560,7 @@ setProxy p = -- | @getProxy@ returns the current proxy settings. If -- the auto-proxy flag is set to @True@, @getProxy@ will --- perform the necessary +-- perform the necessary getProxy :: BrowserAction t Proxy getProxy = do p <- gets bsProxy @@ -571,7 +571,7 @@ getProxy = do NoProxy{} -> do flg <- gets bsCheckProxy if not flg - then return p + then return p else do np <- liftIO $ fetchProxy True{-issue warning on stderr if ill-formed...-} -- note: this resets the check-proxy flag; a one-off affair. @@ -619,10 +619,10 @@ getUserAgent = do n <- gets bsUserAgent return (maybe defaultUserAgent id n) --- | @RequestState@ is an internal tallying type keeping track of various --- per-connection counters, like the number of authorization attempts and +-- | @RequestState@ is an internal tallying type keeping track of various +-- per-connection counters, like the number of authorization attempts and -- forwards we've gone through. -data RequestState +data RequestState = RequestState { reqDenies :: Int -- ^ number of 401 responses so far , reqRedirects :: Int -- ^ number of redirects so far @@ -665,7 +665,7 @@ data BrowserEventType | AuthChallenge | AuthResponse -} - + -- | @setEventHandler onBrowserEvent@ configures event handling. -- If @onBrowserEvent@ is @Nothing@, event handling is turned off; -- setting it to @Just onEv@ causes the @onEv@ IO action to be @@ -677,7 +677,7 @@ setEventHandler mbH = modify (\b -> b { bsEvent=mbH}) buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent buildBrowserEvent bt uri reqID = do ct <- getCurrentTime - return BrowserEvent + return BrowserEvent { browserTimestamp = ct , browserRequestID = reqID , browserRequestURI = uri @@ -693,7 +693,7 @@ reportEvent bt uri = do evt <- liftIO $ buildBrowserEvent bt uri (bsRequestID st) evH evt -- if it fails, we fail. --- | The default number of hops we are willing not to go beyond for +-- | The default number of hops we are willing not to go beyond for -- request forwardings. defaultMaxRetries :: Int defaultMaxRetries = 4 @@ -733,7 +733,7 @@ request req = nextRequest $ do initialState = nullRequestState nullVal = buf_empty bufferOps --- | Internal helper function, explicitly carrying along per-request +-- | Internal helper function, explicitly carrying along per-request -- counts. request' :: HStream ty => ty @@ -743,7 +743,7 @@ request' :: HStream ty request' nullVal rqState rq = do let uri = rqURI rq failHTTPS uri - let uria = reqURIAuth rq + let uria = reqURIAuth rq -- add cookies to request cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) {- Not for now: @@ -752,20 +752,20 @@ request' nullVal rqState rq = do xs -> case chopAtDelim ':' xs of (_,[]) -> id - (usr,pwd) -> withAuth - AuthBasic{ auUserName = usr + (usr,pwd) -> withAuth + AuthBasic{ auUserName = usr , auPassword = pwd - , auRealm = "/" - , auSite = uri - }) $ do + , auRealm = "/" + , auSite = uri + }) $ do -} - when (not $ null cookies) + when (not $ null cookies) (out $ "Adding cookies to request. Cookie names: " ++ unwords (map ckName cookies)) -- add credentials to request - rq' <- - if not (reqStopOnDeny rqState) - then return rq - else do + rq' <- + if not (reqStopOnDeny rqState) + then return rq + else do auth <- anticipateChallenge rq case auth of Nothing -> return rq @@ -774,7 +774,7 @@ request' nullVal rqState rq = do p <- getProxy def_ua <- gets bsUserAgent let defaultOpts = - case p of + case p of NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} Proxy _ ath -> defaultNormalizeRequestOptions @@ -787,11 +787,11 @@ request' nullVal rqState rq = do } let final_req = normalizeRequest defaultOpts rq'' out ("Sending:\n" ++ show final_req) - e_rsp <- + e_rsp <- case p of NoProxy -> dorequest (reqURIAuth rq'') final_req Proxy str _ath -> do - let notURI + let notURI | null pt || null hst = URIAuth{ uriUserInfo = "" , uriRegName = str @@ -815,18 +815,18 @@ request' nullVal rqState rq = do dorequest proxyURIAuth final_req mbMx <- getMaxErrorRetries case e_rsp of - Left v - | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && + Left v + | (reqRetries rqState < fromMaybe defaultMaxErrorRetries mbMx) && (v == ErrorReset || v == ErrorClosed) -> do --empty connnection pool in case connection has become invalid - modify (\b -> b { bsConnectionPool=[] }) + modify (\b -> b { bsConnectionPool=[] }) request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq - | otherwise -> + | otherwise -> return (Left v) - Right rsp -> do + Right rsp -> do out ("Received:\n" ++ show rsp) -- add new cookies to browser state - handleCookies uri (uriAuthToString $ reqURIAuth rq) + handleCookies uri (uriAuthToString $ reqURIAuth rq) (retrieveHeaders HdrSetCookie rsp) -- Deal with "Connection: close" in response. handleConnectionClose (reqURIAuth rq) (retrieveHeaders HdrConnection rsp) @@ -894,10 +894,10 @@ request' nullVal rqState rq = do False -> return (Right (uri,rsp)) _ -> do case retrieveHeaders HdrLocation rsp of - [] -> do + [] -> do err "No Location: header in redirect response" return (Right (uri,rsp)) - (Header _ u:_) -> + (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location: header in a redirect response failed: " ++ u) @@ -908,14 +908,14 @@ request' nullVal rqState rq = do return (Right (uri, rsp)) | otherwise -> do out ("Redirecting to " ++ show newURI_abs ++ " ...") - + -- Redirect using GET request method, depending on -- response code. let toGet = x `elem` [2,3] method = if toGet then GET else rqMethod rq rq1 = rq { rqMethod=method, rqURI=newURI_abs } rq2 = if toGet then (replaceHeader HdrContentLength "0") (rq1 {rqBody = nullVal}) else rq1 - + request' nullVal rqState{ reqDenies = 0 , reqRedirects = succ(reqRedirects rqState) @@ -927,10 +927,10 @@ request' nullVal rqState rq = do (3,0,5) -> case retrieveHeaders HdrLocation rsp of - [] -> do + [] -> do err "No Location header in proxy redirect response." return (Right (uri,rsp)) - (Header _ u:_) -> + (Header _ u:_) -> case parseURIReference u of Nothing -> do err ("Parse of Location header in a proxy redirect response failed: " ++ u) @@ -956,9 +956,9 @@ dorequest hst rqst = do pool <- gets bsConnectionPool let uPort = uriAuthPort Nothing{-ToDo: feed in complete URL-} hst conn <- liftIO $ filterM (\c -> c `isTCPConnectedTo` EndPoint (uriRegName hst) uPort) pool - rsp <- + rsp <- case conn of - [] -> do + [] -> do out ("Creating new connection to " ++ uriAuthToString hst) reportEvent OpenConnection (show (rqURI rqst)) c <- liftIO $ openStream (uriRegName hst) uPort @@ -968,15 +968,15 @@ dorequest hst rqst = do out ("Recovering connection to " ++ uriAuthToString hst) reportEvent ReuseConnection (show (rqURI rqst)) dorequest2 c rqst - case rsp of - Right (Response a b c _) -> + case rsp of + Right (Response a b c _) -> reportEvent (ResponseEnd (a,b,c)) (show (rqURI rqst)) ; _ -> return () return rsp where dorequest2 c r = do dbg <- gets bsDebug st <- get - let + let onSendComplete = maybe (return ()) (\evh -> do @@ -984,7 +984,7 @@ dorequest hst rqst = do runBA st (evh x) return ()) (bsEvent st) - liftIO $ + liftIO $ maybe (sendHTTP_notify c r onSendComplete) (\ f -> do c' <- debugByteStream (f++'-': uriAuthToString hst) c @@ -1000,12 +1000,12 @@ updateConnectionPool c = do maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize when (len_pool > maxPoolSize) (liftIO $ close (last pool)) - let pool' + let pool' | len_pool > maxPoolSize = init pool | otherwise = pool when (maxPoolSize > 0) $ modify (\b -> b { bsConnectionPool=c:pool' }) return () - + -- | Default maximum number of open connections we are willing to have active. defaultMaxPoolSize :: Int defaultMaxPoolSize = 5 @@ -1096,4 +1096,3 @@ formToRequest (Form m u vs) = } _ -> error ("unexpected request: " ++ show m) - diff --git a/Network/BufferType.hs b/Network/BufferType.hs index a78dc27..659c515 100644 --- a/Network/BufferType.hs +++ b/Network/BufferType.hs @@ -18,10 +18,10 @@ -- -- This module provides definitions for the standard buffer types that the -- package supports, i.e., for @String@ and @ByteString@ (strict and lazy.) --- +-- ----------------------------------------------------------------------------- module Network.BufferType - ( + ( BufferType(..) , BufferOp(..) @@ -44,7 +44,7 @@ import Network.HTTP.Utils ( crlf, lf ) -- that the library requires to operate over data embedded in HTTP -- requests and responses. That is, we use explicit dictionaries -- for the operations, but overload the name of the dicts themselves. --- +-- class BufferType bufType where bufferOps :: BufferOp bufType @@ -57,7 +57,7 @@ instance BufferType Strict.ByteString where instance BufferType String where bufferOps = stringBufferOp --- | @BufferOp@ encodes the I/O operations of the underlying buffer over +-- | @BufferOp@ encodes the I/O operations of the underlying buffer over -- a Handle in an (explicit) dictionary type. May not be needed, but gives -- us flexibility in explicit overriding and wrapping up of these methods. -- @@ -67,7 +67,7 @@ instance BufferType String where -- -- We supply three default @BufferOp@ values, for @String@ along with the -- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ --- definitions for +-- definitions for data BufferOp a = BufferOp { buf_hGet :: Handle -> Int -> IO a @@ -92,8 +92,8 @@ instance Eq (BufferOp a) where -- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-lazy kind. strictBufferOp :: BufferOp Strict.ByteString -strictBufferOp = - BufferOp +strictBufferOp = + BufferOp { buf_hGet = Strict.hGet , buf_hGetContents = Strict.hGetContents , buf_hPut = Strict.hPut @@ -108,7 +108,7 @@ strictBufferOp = , buf_empty = Strict.empty , buf_isLineTerm = \ b -> Strict.length b == 2 && p_crlf == b || Strict.length b == 1 && p_lf == b - , buf_isEmpty = Strict.null + , buf_isEmpty = Strict.null } where p_crlf = Strict.pack crlf @@ -117,8 +117,8 @@ strictBufferOp = -- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, -- the non-strict kind. lazyBufferOp :: BufferOp Lazy.ByteString -lazyBufferOp = - BufferOp +lazyBufferOp = + BufferOp { buf_hGet = Lazy.hGet , buf_hGetContents = Lazy.hGetContents , buf_hPut = Lazy.hPut @@ -133,7 +133,7 @@ lazyBufferOp = , buf_empty = Lazy.empty , buf_isLineTerm = \ b -> Lazy.length b == 2 && p_crlf == b || Lazy.length b == 1 && p_lf == b - , buf_isEmpty = Lazy.null + , buf_isEmpty = Lazy.null } where p_crlf = Lazy.pack crlf @@ -143,7 +143,7 @@ lazyBufferOp = -- It is defined in terms of @strictBufferOp@ operations, -- unpacking/converting to @String@ when needed. stringBufferOp :: BufferOp String -stringBufferOp =BufferOp +stringBufferOp =BufferOp { buf_hGet = \ h n -> buf_hGet strictBufferOp h n >>= return . Strict.unpack , buf_hGetContents = \ h -> buf_hGetContents strictBufferOp h >>= return . Strict.unpack , buf_hPut = \ h s -> buf_hPut strictBufferOp h (Strict.pack s) @@ -154,11 +154,11 @@ stringBufferOp =BufferOp , buf_toStr = id , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] , buf_splitAt = splitAt - , buf_span = \ p a -> + , buf_span = \ p a -> case Strict.span p (Strict.pack a) of (x,y) -> (Strict.unpack x, Strict.unpack y) , buf_empty = [] , buf_isLineTerm = \ b -> b == crlf || b == lf - , buf_isEmpty = null + , buf_isEmpty = null } diff --git a/Network/HTTP.hs b/Network/HTTP.hs index ef0d623..d385ed4 100644 --- a/Network/HTTP.hs +++ b/Network/HTTP.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) @@ -27,31 +27,31 @@ -- namespace, letting you either use the default implementation here -- by importing @Network.HTTP@ or, for more specific uses, selectively -- import the modules in @Network.HTTP.*@. To wit, more than one kind of --- representation of the bulk data that flows across a HTTP connection is +-- representation of the bulk data that flows across a HTTP connection is -- supported. (see "Network.HTTP.HandleStream".) --- +-- -- /NOTE:/ The 'Request' send actions will normalize the @Request@ prior to transmission. -- Normalization such as having the request path be in the expected form and, possibly, -- introduce a default @Host:@ header if one isn't already present. -- Normalization also takes the @"user:pass\@"@ portion out of the the URI, -- if it was supplied, and converts it into @Authorization: Basic$ header. --- If you do not +-- If you do not -- want the requests tampered with, but sent as-is, please import and use the -- the "Network.HTTP.HandleStream" or "Network.HTTP.Stream" modules instead. They --- export the same functions, but leaves construction and any normalization of +-- export the same functions, but leaves construction and any normalization of -- @Request@s to the user. -- -- /NOTE:/ This package only supports HTTP; it does not support HTTPS. -- Attempts to use HTTPS result in an error. ----------------------------------------------------------------------------- -module Network.HTTP +module Network.HTTP ( module Network.HTTP.Base , module Network.HTTP.Headers - {- the functionality that the implementation modules, - Network.HTTP.HandleStream and Network.HTTP.Stream, - exposes: - -} + {- the functionality that the implementation modules, + Network.HTTP.HandleStream and Network.HTTP.Stream, + exposes: + -} , simpleHTTP -- :: Request -> IO (Result Response) , simpleHTTP_ -- :: Stream s => s -> Request -> IO (Result Response) , sendHTTP -- :: Stream s => s -> Request -> IO (Result Response) @@ -60,12 +60,12 @@ module Network.HTTP , respondHTTP -- :: Stream s => s -> Response -> IO () , module Network.TCP - + , getRequest -- :: String -> Request_String , headRequest -- :: String -> Request_String , postRequest -- :: String -> Request_String , postRequestWithBody -- :: String -> String -> String -> Request_String - + , getResponseBody -- :: Result (Request ty) -> IO ty , getResponseCode -- :: Result (Request ty) -> IO ResponseCode ) where @@ -109,10 +109,10 @@ simpleHTTP r = do c <- openStream (host auth) (fromMaybe 80 (port auth)) let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r simpleHTTP_ c norm_r - + -- | Identical to 'simpleHTTP', but acting on an already opened stream. simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) -simpleHTTP_ s r = do +simpleHTTP_ s r = do let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r S.sendHTTP s norm_r @@ -121,7 +121,7 @@ simpleHTTP_ s r = do -- closed upon receiving the response. sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) sendHTTP conn rq = do - let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP conn norm_r -- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but @@ -134,7 +134,7 @@ sendHTTP_notify :: HStream ty -> IO () -> IO (Result (Response ty)) sendHTTP_notify conn rq onSendComplete = do - let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq S.sendHTTP_notify conn norm_r onSendComplete -- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ @@ -154,7 +154,7 @@ respondHTTP conn rsp = S.respondHTTP conn rsp getRequest :: String -- ^URL to fetch -> Request_String -- ^The constructed request -getRequest urlString = +getRequest urlString = case parseURI urlString of Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest GET u @@ -165,7 +165,7 @@ getRequest urlString = headRequest :: String -- ^URL to fetch -> Request_String -- ^The constructed request -headRequest urlString = +headRequest urlString = case parseURI urlString of Nothing -> error ("headRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest HEAD u @@ -176,7 +176,7 @@ headRequest urlString = postRequest :: String -- ^URL to POST to -> Request_String -- ^The constructed request -postRequest urlString = +postRequest urlString = case parseURI urlString of Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) Just u -> mkRequest POST u @@ -193,7 +193,7 @@ postRequestWithBody -> String -- ^Content-Type of body -> String -- ^The body of the request -> Request_String -- ^The constructed request -postRequestWithBody urlString typ body = +postRequestWithBody urlString typ body = case parseURI urlString of Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString) Just u -> setRequestBody (mkRequest POST u) (typ, body) @@ -222,21 +222,21 @@ getResponseCode (Right r) = return (rspCode r) -- - comm timeouts -- - MIME & entity stuff (happening in separate module) -- - support \"*\" uri-request-string for OPTIONS request method --- --- +-- +-- -- * Header notes: -- -- [@Host@] -- Required by HTTP\/1.1, if not supplied as part -- of a request a default Host value is extracted -- from the request-uri. --- --- [@Connection@] +-- +-- [@Connection@] -- If this header is present in any request or -- response, and it's value is "close", then --- the current request\/response is the last +-- the current request\/response is the last -- to be allowed on that connection. --- +-- -- [@Expect@] -- Should a request contain a body, an Expect -- header will be added to the request. The added @@ -244,7 +244,7 @@ getResponseCode (Right r) = return (rspCode r) -- a 417 \"Expectation Failed\" response the request -- is attempted again without this added Expect -- header. --- +-- -- [@TransferEncoding,ContentLength,...@] -- if request is inconsistent with any of these -- header values then you may not receive any response @@ -257,7 +257,7 @@ getResponseCode (Right r) = return (rspCode r) -- [@1xx@] \"100 Continue\" will cause any unsent request body to be sent. -- \"101 Upgrade\" will be returned. -- Other 1xx responses are ignored. --- +-- -- [@417@] The reason for this code is \"Expectation failed\", indicating -- that the server did not like the Expect \"100-continue\" header -- added to a request. Receipt of 417 will induce another diff --git a/Network/HTTP/Auth.hs b/Network/HTTP/Auth.hs index 81df3e7..8619655 100644 --- a/Network/HTTP/Auth.hs +++ b/Network/HTTP/Auth.hs @@ -4,14 +4,14 @@ -- Module : Network.HTTP.Auth -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Representing HTTP Auth values in Haskell. -- Right now, it contains mostly functionality needed by 'Network.Browser'. --- +-- ----------------------------------------------------------------------------- module Network.HTTP.Auth ( Authority(..) @@ -38,7 +38,7 @@ import Data.Word ( Word8 ) -- | @Authority@ specifies the HTTP Authentication method to use for -- a given domain/realm; @Basic@ or @Digest@. -data Authority +data Authority = AuthBasic { auRealm :: String , auUsername :: String , auPassword :: String @@ -55,7 +55,7 @@ data Authority } -data Challenge +data Challenge = ChalBasic { chRealm :: String } | ChalDigest { chRealm :: String , chDomain :: [URI] @@ -74,13 +74,13 @@ instance Show Algorithm where show AlgMD5 = "md5" show AlgMD5sess = "md5-sess" --- | +-- | data Qop = QopAuth | QopAuthInt deriving(Eq,Show) -- | @withAuthority auth req@ generates a credentials value from the @auth@ 'Authority', -- in the context of the given request. --- +-- -- If a client nonce was to be used then this function might need to be of type ... -> BrowserAction String withAuthority :: Authority -> Request ty -> String withAuthority a rq = case a of @@ -104,7 +104,7 @@ withAuthority a rq = case a of a1, a2 :: String a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a - + {- If the "qop" directive's value is "auth" or is unspecified, then A2 is: @@ -135,7 +135,7 @@ kd a b = md5 (a ++ ":" ++ b) --- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header +-- | @headerToChallenge base www_auth@ tries to convert the @WWW-Authenticate@ header -- @www_auth@ into a 'Challenge' value. headerToChallenge :: URI -> Header -> Maybe Challenge headerToChallenge baseURI (Header _ str) = @@ -173,12 +173,12 @@ headerToChallenge baseURI (Header _ str) = -- with Maybe monad do { r <- lookup "realm" params ; n <- lookup "nonce" params - ; return $ + ; return $ ChalDigest { chRealm = r - , chDomain = (annotateURIs + , chDomain = (annotateURIs $ map parseURI - $ words - $ fromMaybe [] + $ words + $ fromMaybe [] $ lookup "domain" params) , chNonce = n , chOpaque = lookup "opaque" params diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs index deaf8b2..6901792 100644 --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -4,7 +4,7 @@ -- Module : Network.HTTP.Base -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) @@ -27,12 +27,12 @@ module Network.HTTP.Base , Request(..) , Response(..) , RequestMethod(..) - + , Request_String , Response_String , HTTPRequest , HTTPResponse - + -- ** URL Encoding , urlEncode , urlDecode @@ -41,7 +41,7 @@ module Network.HTTP.Base -- ** URI authority parsing , URIAuthority(..) , parseURIAuthority - + -- internal , uriToAuthorityString -- :: URI -> String , uriAuthToString -- :: URIAuth -> String @@ -56,8 +56,8 @@ module Network.HTTP.Base , ResponseData , ResponseCode , RequestData - - , NormalizeRequestOptions(..) + + , NormalizeRequestOptions(..) , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty , RequestNormalizer @@ -77,7 +77,7 @@ module Network.HTTP.Base , uglyDeathTransfer , readTillEmpty1 , readTillEmpty2 - + , defaultGETRequest , defaultGETRequest_ , mkRequest @@ -86,18 +86,18 @@ module Network.HTTP.Base , defaultUserAgent , httpPackageVersion , libUA {- backwards compatibility, will disappear..soon -} - + , catchIO , catchIO_ , responseParseError - + , getRequestVersion , getResponseVersion , setRequestVersion , setResponseVersion , failHTTPS - + ) where import Network.URI @@ -186,20 +186,20 @@ uriToAuthorityString :: URI -> String uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) uriAuthToString :: URIAuth -> String -uriAuthToString ua = - concat [ uriUserInfo ua +uriAuthToString ua = + concat [ uriUserInfo ua , uriRegName ua , uriPort ua ] uriAuthPort :: Maybe URI -> URIAuth -> Int -uriAuthPort mbURI u = +uriAuthPort mbURI u = case uriPort u of (':':s) -> readsOne id (default_port mbURI) s _ -> default_port mbURI where default_port Nothing = default_http - default_port (Just url) = + default_port (Just url) = case map toLower $ uriScheme url of "http:" -> default_http "https:" -> default_https @@ -222,7 +222,7 @@ failHTTPS uri -- the information may either be in the request's URI or inside -- the Host: header. reqURIAuth :: Request ty -> URIAuth -reqURIAuth req = +reqURIAuth req = case uriAuthority (rqURI req) of Just ua -> ua _ -> case lookupHeader HdrHost (rqHeaders req) of @@ -255,7 +255,7 @@ data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNEC deriving(Eq) instance Show RequestMethod where - show x = + show x = case x of HEAD -> "HEAD" PUT -> "PUT" @@ -277,10 +277,10 @@ rqMethodMap = [("HEAD", HEAD), ("TRACE", TRACE), ("CONNECT", CONNECT)] --- +-- -- for backwards-ish compatibility; suggest -- migrating to new Req/Resp by adding type param. --- +-- type Request_String = Request String type Response_String = Response String @@ -314,8 +314,8 @@ instance Show (Request a) where ++ foldr (++) [] (map show (dropHttpVersion h)) ++ crlf where ver = fromMaybe httpVersion (getRequestVersion req) - alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' - then u { uriPath = '/' : uriPath u } + alt_uri = show $ if null (uriPath u) || head (uriPath u) /= '/' + then u { uriPath = '/' : uriPath u } else u instance HasHeaders (Request a) where @@ -346,8 +346,8 @@ data Response a = , rspHeaders :: [Header] , rspBody :: a } - --- This is an invalid representation of a received response, + +-- This is an invalid representation of a received response, -- since we have made the assumption that all responses are HTTP/1.1 instance Show (Response a) where show rsp@(Response (a,b,c) reason headers _) = @@ -388,17 +388,17 @@ defaultGETRequest :: URI -> Request_String defaultGETRequest uri = defaultGETRequest_ uri defaultGETRequest_ :: BufferType a => URI -> Request a -defaultGETRequest_ uri = mkRequest GET uri +defaultGETRequest_ uri = mkRequest GET uri -- | 'mkRequest method uri' constructs a well formed -- request for the given HTTP method and URI. It does not --- normalize the URI for the request _nor_ add the required +-- normalize the URI for the request _nor_ add the required -- Host: header. That is done either explicitly by the user -- or when requests are normalized prior to transmission. mkRequest :: BufferType ty => RequestMethod -> URI -> Request ty mkRequest meth uri = req where - req = + req = Request { rqURI = uri , rqBody = empty , rqHeaders = [ Header HdrContentLength "0" @@ -421,12 +421,12 @@ setRequestBody req (typ, body) = req' { rqBody=body } -- stub out the user info. updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) - withHost = + withHost = case uriToAuthorityString uri{uriAuthority=updAuth} of "" -> id h -> ((Header HdrHost h):) - uri_req + uri_req | forProxy = uri | otherwise = snd (splitRequestURI uri) -} @@ -472,12 +472,12 @@ parseResponseHead (sts:hdrs) = do where responseStatus _l _yes@(version:code:reason) = return (version,match code,concatMap (++" ") reason) - responseStatus l _no + responseStatus l _no | null l = failWith ErrorClosed -- an assumption | otherwise = parse_err l - parse_err l = - responseParseError + parse_err l = + responseParseError "parseResponseHead" ("Response status line parse failure: " ++ l) @@ -495,7 +495,7 @@ parseResponseHead (sts:hdrs) = do -- the version info explicitly in their record types. You have to use -- {get,set}{Request,Response}Version for that. withVersion :: String -> [Header] -> [Header] -withVersion v hs +withVersion v hs | v == httpVersion = hs -- don't bother adding it if the default. | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs @@ -511,7 +511,7 @@ setRequestVersion s r = setHttpVersion r s -- | @getResponseVersion rsp@ returns the HTTP protocol version of --- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be -- assumed. getResponseVersion :: Response a -> Maybe String getResponseVersion r = getHttpVersion r @@ -526,7 +526,7 @@ setResponseVersion s r = setHttpVersion r s -- version info is represented internally. getHttpVersion :: HasHeaders a => a -> Maybe String -getHttpVersion r = +getHttpVersion r = fmap toVersion $ find isHttpVersion $ getHeaders r @@ -534,7 +534,7 @@ getHttpVersion r = toVersion (Header _ x) = x setHttpVersion :: HasHeaders a => a -> String -> a -setHttpVersion r v = +setHttpVersion r v = setHeaders r $ withVersion v $ dropHttpVersion $ @@ -545,7 +545,7 @@ dropHttpVersion hs = filter (not.isHttpVersion) hs isHttpVersion :: Header -> Bool isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True -isHttpVersion _ = False +isHttpVersion _ = False @@ -579,9 +579,9 @@ matchResponse rqst rsp = where ans | rqst == HEAD = Done | otherwise = ExpectEntity - - + + ----------------------------------------------------------------- ------------------ A little friendly funtionality --------------- ----------------------------------------------------------------- @@ -684,7 +684,7 @@ urlDecode = go [] urlEncode :: String -> String urlEncode [] = [] -urlEncode (ch:t) +urlEncode (ch:t) | (isAscii ch && isAlphaNum ch) || ch `elem` "-_.~" = ch : urlEncode t | not (isAscii ch) = foldr escape (urlEncode t) (encodeChar ch) | otherwise = escape (fromIntegral (fromEnum ch)) (urlEncode t) @@ -722,18 +722,18 @@ getAuth :: MonadFail m => Request ty -> m URIAuthority #else getAuth :: Monad m => Request ty -> m URIAuthority #endif -getAuth r = +getAuth r = -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) case parseURIAuthority auth of - Just x -> return x + Just x -> return x Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" - where + where auth = maybe (uriToAuthorityString uri) id (findHeader HdrHost r) uri = rqURI r {-# DEPRECATED normalizeRequestURI "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeRequestURI :: Bool{-do close-} -> {-URI-}String -> Request ty -> Request ty -normalizeRequestURI doClose h r = +normalizeRequestURI doClose h r = (if doClose then replaceHeader HdrConnection "close" else id) $ insertHeaderIfMissing HdrHost h $ r { rqURI = (rqURI r){ uriScheme = "" @@ -771,31 +771,31 @@ normalizeRequest :: NormalizeRequestOptions ty normalizeRequest opts req = foldr (\ f -> f opts) req normalizers where --normalizers :: [RequestNormalizer ty] - normalizers = + normalizers = ( normalizeHostURI : normalizeBasicAuth : normalizeConnectionClose - : normalizeUserAgent + : normalizeUserAgent : normCustoms opts ) --- | @normalizeUserAgent ua x req@ augments the request @req@ with --- a @User-Agent: ua@ header if @req@ doesn't already have a +-- | @normalizeUserAgent ua x req@ augments the request @req@ with +-- a @User-Agent: ua@ header if @req@ doesn't already have a -- a @User-Agent:@ set. normalizeUserAgent :: RequestNormalizer ty -normalizeUserAgent opts req = +normalizeUserAgent opts req = case normUserAgent opts of Nothing -> req - Just ua -> + Just ua -> case findHeader HdrUserAgent req of Just u | u /= defaultUserAgent -> req _ -> replaceHeader HdrUserAgent ua req --- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ +-- | @normalizeConnectionClose opts req@ sets the header @Connection: close@ -- to indicate one-shot behavior iff @normDoClose@ is @True@. i.e., it then -- _replaces_ any an existing @Connection:@ header in @req@. normalizeConnectionClose :: RequestNormalizer ty -normalizeConnectionClose opts req +normalizeConnectionClose opts req | normDoClose opts = replaceHeader HdrConnection "close" req | otherwise = req @@ -818,18 +818,18 @@ normalizeBasicAuth _ req = -- | @normalizeHostURI forProxy req@ rewrites your request to have it -- follow the expected formats by the receiving party (proxy or server.) --- +-- normalizeHostURI :: RequestNormalizer ty -normalizeHostURI opts req = +normalizeHostURI opts req = case splitRequestURI uri of ("",_uri_abs) - | forProxy -> + | forProxy -> case findHeader HdrHost req of Nothing -> req -- no host/authority in sight..not much we can do. Just h -> req{rqURI=uri{ uriAuthority=Just URIAuth{uriUserInfo="", uriRegName=hst, uriPort=pNum} , uriScheme=if (null (uriScheme uri)) then "http" else uriScheme uri }} - where + where hst = case span (/='@') user_hst of (as,'@':bs) -> case span (/=':') as of @@ -841,16 +841,16 @@ normalizeHostURI opts req = case span isDigit (reverse h) of (ds,':':bs) -> (reverse bs, ':':reverse ds) _ -> (h,"") - | otherwise -> + | otherwise -> case findHeader HdrHost req of Nothing -> req -- no host/authority in sight..not much we can do...complain? Just{} -> req - (h,uri_abs) - | forProxy -> insertHeaderIfMissing HdrHost h req + (h,uri_abs) + | forProxy -> insertHeaderIfMissing HdrHost h req | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass where - uri0 = rqURI req - -- stub out the user:pass + uri0 = rqURI req + -- stub out the user:pass uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} forProxy = normForProxy opts @@ -861,7 +861,7 @@ normalizeHostURI opts req = resource on an origin server or gateway. In this case the absolute path of the URI MUST be transmitted (see section 3.2.1, abs_path) as the Request-URI, and the network location of the URI (authority) MUST - be transmitted in a Host header field." + be transmitted in a Host header field." We assume that this is the case, so we take the host name from the Host header if there is one, otherwise from the request-URI. Then we make the request-URI an abs_path and make sure that there @@ -874,11 +874,11 @@ splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority= -- Adds a Host header if one is NOT ALREADY PRESENT.. {-# DEPRECATED normalizeHostHeader "Please use Network.HTTP.Base.normalizeRequest instead" #-} normalizeHostHeader :: Request ty -> Request ty -normalizeHostHeader rq = +normalizeHostHeader rq = insertHeaderIfMissing HdrHost (uriToAuthorityString $ rqURI rq) rq - + -- Looks for a "Connection" header with the value "close". -- Returns True when this is found. findConnClose :: [Header] -> Bool @@ -899,8 +899,8 @@ hopefulTransfer :: BufferOp a -> IO (Result a) -> [a] -> IO (Result ([Header],a)) -hopefulTransfer bufOps readL strs - = readL >>= +hopefulTransfer bufOps readL strs + = readL >>= either (\v -> return $ Left v) (\more -> if (buf_isEmpty bufOps more) then return (Right ([], buf_concat bufOps $ reverse strs)) @@ -925,8 +925,8 @@ chunkedTransferC bufOps readL readBlk acc n = do v <- readL case v of Left e -> return (Left e) - Right line - | size == 0 -> + Right line + | size == 0 -> -- last chunk read; look for trailing headers.. fmapE (\ strs -> do ftrs <- parseHeaders (map (buf_toStr bufOps) strs) @@ -944,9 +944,9 @@ chunkedTransferC bufOps readL readBlk acc n = do _ <- readL -- CRLF is mandated after the chunk block; ToDo: check that the line is empty.? chunkedTransferC bufOps readL readBlk (cdata:acc) (n+size) where - size + size | buf_isEmpty bufOps line = 0 - | otherwise = + | otherwise = case readHex (buf_toStr bufOps line) of (hx,_):_ -> hx _ -> 0 @@ -964,7 +964,7 @@ readTillEmpty1 :: BufferOp a readTillEmpty1 bufOps readL = readL >>= either (return . Left) - (\ s -> + (\ s -> if buf_isLineTerm bufOps s then readTillEmpty1 bufOps readL else readTillEmpty2 bufOps readL [s]) diff --git a/Network/HTTP/Base64.hs b/Network/HTTP/Base64.hs index bd1c28b..3f24117 100644 --- a/Network/HTTP/Base64.hs +++ b/Network/HTTP/Base64.hs @@ -8,8 +8,8 @@ -- Stability : experimental -- Portability : portable -- --- Base64 encoding and decoding functions provided by Warwick Gray. --- See +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See -- and . -- ----------------------------------------------------------------------------- @@ -148,8 +148,8 @@ the second variation corresponds better with the RFC above, but outside of MIME applications might be undesireable. -But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only - 8 significant bits, which is more than enough for US-ASCII. +But: The Haskell98 Char type is at least 16bits (and often 32), these implementations assume only + 8 significant bits, which is more than enough for US-ASCII. -} @@ -161,9 +161,9 @@ import Data.Word (Word8) type Octet = Word8 encodeArray :: Array Int Char -encodeArray = array (0,64) - [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') - , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') +encodeArray = array (0,64) + [ (0,'A'), (1,'B'), (2,'C'), (3,'D'), (4,'E'), (5,'F') + , (6,'G'), (7,'H'), (8,'I'), (9,'J'), (10,'K'), (11,'L') , (12,'M'), (13,'N'), (14,'O'), (15,'P'), (16,'Q'), (17,'R') , (18,'S'), (19,'T'), (20,'U'), (21,'V'), (22,'W'), (23,'X') , (24,'Y'), (25,'Z'), (26,'a'), (27,'b'), (28,'c'), (29,'d') @@ -177,11 +177,11 @@ encodeArray = array (0,64) -- Convert between 4 base64 (6bits ea) integers and 1 ordinary integer (32 bits) -- clearly the upmost/leftmost 8 bits of the answer are 0. --- Hack Alert: In the last entry of the answer, the upper 8 bits encode +-- Hack Alert: In the last entry of the answer, the upper 8 bits encode -- the integer number of 6bit groups encoded in that integer, ie 1, 2, 3. -- 0 represents a 4 :( int4_char3 :: [Int] -> [Char] -int4_char3 (a:b:c:d:t) = +int4_char3 (a:b:c:d:t) = let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) in (chr (n `shiftR` 16 .&. 0xff)) : (chr (n `shiftR` 8 .&. 0xff)) @@ -192,7 +192,7 @@ int4_char3 [a,b,c] = in [ (chr (n `shiftR` 16 .&. 0xff)) , (chr (n `shiftR` 8 .&. 0xff)) ] -int4_char3 [a,b] = +int4_char3 [a,b] = let n = (a `shiftL` 18 .|. b `shiftL` 12) in [ (chr (n `shiftR` 16 .&. 0xff)) ] @@ -209,7 +209,7 @@ int4_char3 [] = [] -- a trailing 2 character group gives 3 integers, -- while a trailing single character gives 2 integers. char3_int4 :: [Char] -> [Int] -char3_int4 (a:b:c:t) +char3_int4 (a:b:c:t) = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8 .|. ord c) in (n `shiftR` 18 .&. 0x3f) : (n `shiftR` 12 .&. 0x3f) : (n `shiftR` 6 .&. 0x3f) : (n .&. 0x3f) : char3_int4 t @@ -218,7 +218,7 @@ char3_int4 [a,b] in [ (n `shiftR` 18 .&. 0x3f) , (n `shiftR` 12 .&. 0x3f) , (n `shiftR` 6 .&. 0x3f) ] - + char3_int4 [a] = let n = (ord a `shiftL` 16) in [(n `shiftR` 18 .&. 0x3f),(n `shiftR` 12 .&. 0x3f)] diff --git a/Network/HTTP/Cookie.hs b/Network/HTTP/Cookie.hs index 1b5175d..7f15bc0 100644 --- a/Network/HTTP/Cookie.hs +++ b/Network/HTTP/Cookie.hs @@ -3,14 +3,14 @@ -- Module : Network.HTTP.Cookie -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- This module provides the data types and functions for working with HTTP cookies. -- Right now, it contains mostly functionality needed by 'Network.Browser'. --- +-- ----------------------------------------------------------------------------- module Network.HTTP.Cookie ( Cookie(..) @@ -38,8 +38,8 @@ import Text.ParserCombinators.Parsec -- | @Cookie@ is the Haskell representation of HTTP cookie values. -- See its relevant specs for authoritative details. -data Cookie - = MkCookie +data Cookie + = MkCookie { ckDomain :: String , ckName :: String , ckValue :: String @@ -50,8 +50,8 @@ data Cookie deriving(Show,Read) instance Eq Cookie where - a == b = ckDomain a == ckDomain b - && ckName a == ckName b + a == b = ckDomain a == ckDomain b + && ckName a == ckName b && ckPath a == ckPath b -- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header. @@ -66,7 +66,7 @@ mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1 mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c -- | @cookieMatch (domain,path) ck@ performs the standard cookie --- match wrt the given domain and path. +-- match wrt the given domain and path. cookieMatch :: (String, String) -> Cookie -> Bool cookieMatch (dom,path) ck = ckDomain ck `isSuffixOf` dom && @@ -75,13 +75,13 @@ cookieMatch (dom,path) ck = Just p -> p `isPrefixOf` path --- | @processCookieHeaders dom hdrs@ +-- | @processCookieHeaders dom hdrs@ processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs --- | @headerToCookies dom hdr acc@ +-- | @headerToCookies dom hdr acc@ headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) -headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = case parse cookies "" val of Left{} -> (val:accErr, accCookie) Right x -> (accErr, x ++ accCookie) @@ -100,11 +100,11 @@ headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = return $ mkCookie name val1 args cvalue :: Parser String - + spaces_l = many (satisfy isSpace) cvalue = quotedstring <|> many1 (satisfy $ not . (==';')) <|> return "" - + -- all keys in the result list MUST be in lower case cdetail :: Parser [(String,String)] cdetail = many $ @@ -118,7 +118,7 @@ headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = ) mkCookie :: String -> String -> [(String,String)] -> Cookie - mkCookie nm cval more = + mkCookie nm cval more = MkCookie { ckName = nm , ckValue = cval , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) @@ -128,7 +128,7 @@ headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = } headerToCookies _ _ acc = acc - + word, quotedstring :: Parser String diff --git a/Network/HTTP/HandleStream.hs b/Network/HTTP/HandleStream.hs index 29ef82a..5c75ba7 100644 --- a/Network/HTTP/HandleStream.hs +++ b/Network/HTTP/HandleStream.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP.HandleStream -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) @@ -15,16 +15,16 @@ -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead. --- +-- ----------------------------------------------------------------------------- -module Network.HTTP.HandleStream +module Network.HTTP.HandleStream ( simpleHTTP -- :: Request ty -> IO (Result (Response ty)) , simpleHTTP_ -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP -- :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) , sendHTTP_notify -- :: HStream ty => HandleStream ty -> Request ty -> IO () -> IO (Result (Response ty)) , receiveHTTP -- :: HStream ty => HandleStream ty -> IO (Result (Request ty)) , respondHTTP -- :: HStream ty => HandleStream ty -> Response ty -> IO () - + , simpleHTTP_debug -- :: FilePath -> Request DebugString -> IO (Response DebugString) ) where @@ -52,7 +52,7 @@ import Control.Monad (when) -- | @simpleHTTP@ transmits a resource across a non-persistent connection. simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) -simpleHTTP r = do +simpleHTTP r = do auth <- getAuth r failHTTPS (rqURI r) c <- openStream (host auth) (fromMaybe 80 (port auth)) @@ -61,7 +61,7 @@ simpleHTTP r = do -- | @simpleHTTP_debug debugFile req@ behaves like 'simpleHTTP', but logs -- the HTTP operation via the debug file @debugFile@. simpleHTTP_debug :: HStream ty => FilePath -> Request ty -> IO (Result (Response ty)) -simpleHTTP_debug httpLogFile r = do +simpleHTTP_debug httpLogFile r = do auth <- getAuth r failHTTPS (rqURI r) c0 <- openStream (host auth) (fromMaybe 80 (port auth)) @@ -138,7 +138,7 @@ switchResponse _ _ _ (Left e) _ = return (Left e) -- if we attempt to use the same socket then there is an excellent -- chance that the socket is not in a completely closed state. -switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = +switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = case matchResponse (rqMethod rqst) cd of Continue | not bdy_sent -> do {- Time to send the body -} @@ -159,7 +159,7 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = (rqBody rqst)) rsp <- getResponseHead conn switchResponse conn False bdy_sent rsp rqst - + Done -> do when (findConnClose hdrs) (closeOnEnd conn True) @@ -192,10 +192,10 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = tc = lookupHeader HdrTransferEncoding hdrs cl = lookupHeader HdrContentLength hdrs bo = bufferOps - + -- reads and parses headers getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData) -getResponseHead conn = +getResponseHead conn = fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) (readTillEmpty1 bufferOps (readLine conn)) @@ -231,7 +231,7 @@ receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest -- the 'HandleStream' @hStream@. It could be used to implement simple web -- server interactions, performing the dual role to 'sendHTTP'. respondHTTP :: HStream ty => HandleStream ty -> Response ty -> IO () -respondHTTP conn rsp = do +respondHTTP conn rsp = do -- TODO: review throwing away of result _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) -- write body immediately, don't wait for 100 CONTINUE @@ -245,7 +245,7 @@ headerName :: String -> String headerName x = map toLower (trim x) ifChunked :: a -> a -> String -> a -ifChunked a b s = +ifChunked a b s = case headerName s of "chunked" -> a _ -> b diff --git a/Network/HTTP/Headers.hs b/Network/HTTP/Headers.hs index 4b98c79..5f36cbd 100644 --- a/Network/HTTP/Headers.hs +++ b/Network/HTTP/Headers.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP.Headers -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) @@ -13,7 +13,7 @@ -- header values in 'Request's and 'Response's. To avoid having to provide -- separate set of operations for doing so, we introduce a type class 'HasHeaders' -- to facilitate writing such processing using overloading instead. --- +-- ----------------------------------------------------------------------------- module Network.HTTP.Headers ( HasHeaders(..) -- type class @@ -35,9 +35,9 @@ module Network.HTTP.Headers , parseHeader -- :: parseHeader :: String -> Result Header , parseHeaders -- :: [String] -> Result [Header] - + , headerMap -- :: [(String, HeaderName)] - + , HeaderSetter ) where @@ -70,15 +70,15 @@ instance Show Header where -- Encoding HTTP header names differently, as Strings perhaps, is an -- equally fine choice..no decidedly clear winner, but let's stick -- with data constructors here. --- -data HeaderName +-- +data HeaderName -- Generic Headers -- = HdrCacheControl | HdrConnection | HdrDate | HdrPragma - | HdrTransferEncoding - | HdrUpgrade + | HdrTransferEncoding + | HdrUpgrade | HdrVia -- Request Headers -- | HdrAccept @@ -287,7 +287,7 @@ instance Eq HeaderName where HdrContentTransferEncoding == _ = False _ == HdrContentTransferEncoding = False --- | @headerMap@ is a straight assoc list for translating between header names +-- | @headerMap@ is a straight assoc list for translating between header names -- and values. headerMap :: [ (String,HeaderName) ] headerMap = @@ -382,12 +382,12 @@ insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) newHeaders [] = [Header name value] -- | @replaceHeader hdr val o@ replaces the header @hdr@ with the --- value @val@, dropping any existing +-- value @val@, dropping any existing replaceHeader :: HasHeaders a => HeaderSetter a replaceHeader name value h = setHeaders h newHeaders where newHeaders = Header name value : [ x | x@(Header n _) <- getHeaders h, name /= n ] - + -- | @insertHeaders hdrs x@ appends multiple headers to @x@'s existing -- set. insertHeaders :: HasHeaders a => [Header] -> a -> a @@ -397,7 +397,7 @@ insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] retrieveHeaders name x = filter matchname (getHeaders x) where - matchname (Header n _) = n == name + matchname (Header n _) = n == name -- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first -- header that matches, if any. @@ -408,7 +408,7 @@ findHeader n x = lookupHeader n (getHeaders x) -- list @hdrs@. lookupHeader :: HeaderName -> [Header] -> Maybe String lookupHeader _ [] = Nothing -lookupHeader v (Header n s:t) +lookupHeader v (Header n s:t) | v == n = Just s | otherwise = lookupHeader v t @@ -426,14 +426,14 @@ parseHeader str = match :: String -> String -> Bool match s1 s2 = map toLower s1 == map toLower s2 - + -- | @parseHeaders hdrs@ takes a sequence of strings holding header -- information and parses them into a set of headers (preserving their -- order in the input argument.) Handles header values split up over -- multiple lines. parseHeaders :: [String] -> Result [Header] -parseHeaders = catRslts [] . - map (parseHeader . clean) . +parseHeaders = catRslts [] . + map (parseHeader . clean) . joinExtended "" where -- Joins consecutive lines where the second line @@ -454,8 +454,8 @@ parseHeaders = catRslts [] . -- errors here be reported or ignored? -- currently ignored. catRslts :: [a] -> [Result a] -> Result [a] - catRslts list (h:t) = + catRslts list (h:t) = case h of Left _ -> catRslts list t Right v -> catRslts (v:list) t - catRslts list [] = Right $ reverse list + catRslts list [] = Right $ reverse list diff --git a/Network/HTTP/MD5Aux.hs b/Network/HTTP/MD5Aux.hs index 60d1c2b..3ccfce0 100644 --- a/Network/HTTP/MD5Aux.hs +++ b/Network/HTTP/MD5Aux.hs @@ -1,6 +1,6 @@ -module Network.HTTP.MD5Aux +module Network.HTTP.MD5Aux (md5, md5s, md5i, - MD5(..), ABCD(..), + MD5(..), ABCD(..), Zord64, Str(..), BoolList(..), WordList(..)) where import Data.Char (ord, chr) diff --git a/Network/HTTP/Proxy.hs b/Network/HTTP/Proxy.hs index e7a5f6a..e1e3e3c 100644 --- a/Network/HTTP/Proxy.hs +++ b/Network/HTTP/Proxy.hs @@ -4,13 +4,13 @@ -- Module : Network.HTTP.Proxy -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) -- -- Handling proxy server settings and their resolution. --- +-- ----------------------------------------------------------------------------- module Network.HTTP.Proxy ( Proxy(..) @@ -60,7 +60,7 @@ import System.Win32.Registry( regQueryValue ) -- | HTTP proxies (or not) are represented via 'Proxy', specifying if a -- proxy should be used for the request (see 'Network.Browser.setProxy') -data Proxy +data Proxy = NoProxy -- ^ Don't use a proxy. | Proxy String (Maybe Authority) -- ^ Use the proxy given. Should be of the @@ -94,7 +94,7 @@ windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString registryProxyLoc :: (HKEY,String) registryProxyLoc = (hive, path) where - -- some sources say proxy settings should be at + -- some sources say proxy settings should be at -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows -- \CurrentVersion\Internet Settings\ProxyServer -- but if the user sets them with IE connection panel they seem to @@ -103,7 +103,7 @@ registryProxyLoc = (hive, path) path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings" -- read proxy settings from the windows registry; this is just a best --- effort and may not work on all setups. +-- effort and may not work on all setups. registryProxyString :: IO (Maybe String) registryProxyString = catchIO (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do @@ -198,7 +198,7 @@ fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri } where f a@URIAuth{uriUserInfo=s} = a{uriUserInfo=dropWhileTail (=='@') s} --- +-- uri2proxy :: URI -> Maybe Proxy uri2proxy uri@URI{ uriScheme = "http:" , uriAuthority = Just (URIAuth auth' hst prt) diff --git a/Network/HTTP/Stream.hs b/Network/HTTP/Stream.hs index 112b719..484ac9c 100644 --- a/Network/HTTP/Stream.hs +++ b/Network/HTTP/Stream.hs @@ -3,7 +3,7 @@ -- Module : Network.HTTP.Stream -- Copyright : See LICENSE file -- License : BSD --- +-- -- Maintainer : Ganesh Sittampalam -- Stability : experimental -- Portability : non-portable (not tested) @@ -20,9 +20,9 @@ -- not perform any kind of normalization prior to transmission (or receipt); you are -- responsible for doing any such yourself, or, if you prefer, just switch to using -- "Network.HTTP" function instead. --- +-- ----------------------------------------------------------------------------- -module Network.HTTP.Stream +module Network.HTTP.Stream ( module Network.Stream , simpleHTTP -- :: Request_String -> IO (Result Response_String) @@ -31,7 +31,7 @@ module Network.HTTP.Stream , sendHTTP_notify -- :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) , receiveHTTP -- :: Stream s => s -> IO (Result Request_String) , respondHTTP -- :: Stream s => s -> Response_String -> IO () - + ) where ----------------------------------------------------------------- @@ -68,7 +68,7 @@ httpLogFile = "http-debug.log" -- | Simple way to transmit a resource across a non-persistent connection. simpleHTTP :: Request_String -> IO (Result Response_String) -simpleHTTP r = do +simpleHTTP r = do auth <- getAuth r c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) simpleHTTP_ c r @@ -103,7 +103,7 @@ sendHTTP_notify conn rq onSendComplete = do -- -- Since we would wait forever, I have disabled use of 100-continue for now. sendMain :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) -sendMain conn rqst onSendComplete = do +sendMain conn rqst onSendComplete = do --let str = if null (rqBody rqst) -- then show rqst -- else show (insertHeader HdrExpect "100-continue" rqst) @@ -115,7 +115,7 @@ sendMain conn rqst onSendComplete = do onSendComplete rsp <- getResponseHead conn switchResponse conn True False rsp rqst - + -- reads and parses headers getResponseHead :: Stream s => s -> IO (Result ResponseData) getResponseHead conn = do @@ -150,7 +150,7 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = } | otherwise -> {- keep waiting -} do { rsp <- getResponseHead conn - ; switchResponse conn allow_retry bdy_sent rsp rqst + ; switchResponse conn allow_retry bdy_sent rsp rqst } Retry -> {- Request with "Expect" header failed. @@ -160,8 +160,8 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = _ <- writeBlock conn (show rqst ++ rqBody rqst) ; rsp <- getResponseHead conn ; switchResponse conn False bdy_sent rsp rqst - } - + } + Done -> do when (findConnClose hdrs) (closeOnEnd conn True) @@ -176,11 +176,11 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = cl = lookupHeader HdrContentLength hdrs in do { rslt <- case tc of - Nothing -> + Nothing -> case cl of Just x -> linearTransfer (readBlock conn) (read x :: Int) Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] - Just x -> + Just x -> case map toLower (trim x) of "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn) @@ -193,7 +193,7 @@ switchResponse conn allow_retry bdy_sent (Right (cd,rn,hdrs)) rqst = return (Right (Response cd rn (hdrs++ftrs) bdy)) } --- | Receive and parse a HTTP request from the given Stream. Should be used +-- | Receive and parse a HTTP request from the given Stream. Should be used -- for server side interactions. receiveHTTP :: Stream s => s -> IO (Result Request_String) receiveHTTP conn = getRequestHead >>= processRequest @@ -220,12 +220,12 @@ receiveHTTP conn = getRequestHead >>= processRequest "chunked" -> chunkedTransfer stringBufferOp (readLine conn) (readBlock conn) _ -> uglyDeathTransfer "receiveHTTP" - + return $ do (ftrs,bdy) <- rslt return (Request uri rm (hdrs++ftrs) bdy) --- | Very simple function, send a HTTP response over the given stream. This +-- | Very simple function, send a HTTP response over the given stream. This -- could be improved on to use different transfer types. respondHTTP :: Stream s => s -> Response_String -> IO () respondHTTP conn rsp = do -- TODO review throwing away of result diff --git a/Network/HTTP/UserAgent.hs b/Network/HTTP/UserAgent.hs index 42cd32e..827c680 100644 --- a/Network/HTTP/UserAgent.hs +++ b/Network/HTTP/UserAgent.hs @@ -18,39 +18,39 @@ defaultRequest = Request { rqURI = undefined , rqBody = BS.empty } uri :: (MonadError e m, Monad m, HTTPError e) => String -> Request -> m Request -uri str r = do u <- parseURI' str; return $ r { rqURI = u } +uri str r = do u <- parseURI' str; return $ r { rqURI = u } headerAdderM :: Monad m => m Header -> Request -> m Request -headerAdderM hm r@(Request{rqHeaders = hs}) = +headerAdderM hm r@(Request{rqHeaders = hs}) = do h <- hm; return $ r { rqHeaders = h:hs } headerAdder :: Monad m => Header -> Request -> m Request headerAdder h r@(Request{rqHeaders = hs}) = return $ r { rqHeaders = h:hs } - + hExpires :: Monad m => Int -> Request -> m Request hExpires n = headerAdder (Header HdrExpires (show n)) - + hReferer :: (MonadError e m, HTTPError e, Monad m) => String -> Request -> m Request -hReferer str = headerAdderM $ +hReferer str = headerAdderM $ do uri <- parseURI' str return $ Header HdrReferer (show uri) - + exampleRequest :: (MonadError e m, Monad m, HTTPError e) => m Request exampleRequest = mkRequest [uri "http://www.google.com", hExpires 4] - -mkRequest :: (MonadError e m, Monad m, HTTPError e) => + +mkRequest :: (MonadError e m, Monad m, HTTPError e) => [Request -> m Request] -> m Request mkRequest mods = f mods defaultRequest where f [] x = return x f (m:ms) x = m x >>= f ms parseURI' :: (MonadError e m, HTTPError e) => String -> m URI -parseURI' str = maybe (throwHTTPError URIErr) return $ parseURI str +parseURI' str = maybe (throwHTTPError URIErr) return $ parseURI str -- | Perform HTTP request after parsing the URI string. -get :: (MonadError e m, MonadIO m, HTTPError e) => String -> m Response +get :: (MonadError e m, MonadIO m, HTTPError e) => String -> m Response get uriString = mkRequest [uri uriString] >>= simpleHTTP -- | Directly get the content of the given String which is parsed as a URI. diff --git a/Network/HTTP/Utils.hs b/Network/HTTP/Utils.hs index 7a5dcce..7809dd7 100644 --- a/Network/HTTP/Utils.hs +++ b/Network/HTTP/Utils.hs @@ -14,23 +14,23 @@ module Network.HTTP.Utils ( trim -- :: String -> String , trimL -- :: String -> String , trimR -- :: String -> String - + , crlf -- :: String , lf -- :: String , sp -- :: String , split -- :: Eq a => a -> [a] -> Maybe ([a],[a]) , splitBy -- :: Eq a => a -> [a] -> [[a]] - + , readsOne -- :: Read a => (a -> b) -> b -> String -> b , dropWhileTail -- :: (a -> Bool) -> [a] -> [a] , chopAtDelim -- :: Eq a => a -> [a] -> ([a],[a]) - + , toUTF8BS , fromUTF8BS ) where - + import Data.Bits import Data.Char import Data.List ( elemIndex ) @@ -62,7 +62,7 @@ split delim list = case delim `elemIndex` list of -- | @trim str@ removes leading and trailing whitespace from @str@. trim :: String -> String trim xs = trimR (trimL xs) - + -- | @trimL str@ removes leading whitespace (as defined by 'Data.Char.isSpace') -- from @str@. trimL :: String -> String @@ -74,14 +74,14 @@ trimR :: String -> String trimR str = fromMaybe "" $ foldr trimIt Nothing str where trimIt x (Just xs) = Just (x:xs) - trimIt x Nothing + trimIt x Nothing | isSpace x = Nothing | otherwise = Just [x] -- | @splitMany delim ls@ removes the delimiter @delim@ from @ls@. splitBy :: Eq a => a -> [a] -> [[a]] splitBy _ [] = [] -splitBy c xs = +splitBy c xs = case break (==c) xs of (_,[]) -> [xs] (as,_:bs) -> as : splitBy c bs @@ -90,7 +90,7 @@ splitBy c xs = -- the first result and passing it to @f@. If the 'read' -- doesn't succeed, return @def@. readsOne :: Read a => (a -> b) -> b -> String -> b -readsOne f n str = +readsOne f n str = case reads str of ((v,_):_) -> f v _ -> n diff --git a/Network/Stream.hs b/Network/Stream.hs index 43caa61..66609f9 100644 --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -34,8 +34,8 @@ module Network.Stream import Control.Monad.Error -data ConnError - = ErrorReset +data ConnError + = ErrorReset | ErrorClosed | ErrorParse String | ErrorMisc String @@ -66,8 +66,8 @@ fmapE f a = do x <- a case x of Left e -> return (Left e) - Right r -> return (f r) - + Right r -> return (f r) + -- | This is the type returned by many exported network functions. type Result a = Either ConnError {- error -} a {- result -} @@ -81,7 +81,7 @@ type Result a = Either ConnError {- error -} -- the input in any way, e.g. leave LF on line -- endings etc. Unless that is exactly the behaviour -- you want from your twisted instances ;) -class Stream x where +class Stream x where readLine :: x -> IO (Result String) readBlock :: x -> Int -> IO (Result String) writeBlock :: x -> String -> IO (Result ()) diff --git a/Network/StreamDebugger.hs b/Network/StreamDebugger.hs index 04b5f0a..561cd1f 100644 --- a/Network/StreamDebugger.hs +++ b/Network/StreamDebugger.hs @@ -13,7 +13,7 @@ -- -- * Changes by Robin Bate Boerop : -- - Created. Made minor formatting changes. --- +-- ----------------------------------------------------------------------------- module Network.StreamDebugger ( StreamDebugger @@ -26,7 +26,7 @@ import System.IO ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, hSetBuffering, BufferMode(NoBuffering) ) -import Network.TCP ( HandleStream, HStream, +import Network.TCP ( HandleStream, HStream, StreamHooks(..), setStreamHooks, getStreamHooks ) -- | Allows stream logging. Refer to 'debugStream' below. @@ -57,22 +57,22 @@ instance (Stream x) => Stream (StreamDebugger x) where hClose h closeOnEnd (Dbg h x) f = do hPutStrLn h ("--close-on-end.." ++ show f) - hFlush h + hFlush h closeOnEnd x f -- | Wraps a stream with logging I\/O. -- The first argument is a filename which is opened in @AppendMode@. debugStream :: (Stream a) => FilePath -> a -> IO (StreamDebugger a) -debugStream file stream = +debugStream file stream = do h <- openFile file AppendMode hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") return (Dbg h stream) debugByteStream :: HStream ty => FilePath -> HandleStream ty -> IO (HandleStream ty) debugByteStream file stream = do - sh <- getStreamHooks stream + sh <- getStreamHooks stream case sh of - Just h + Just h | hook_name h == file -> return stream -- reuse the stream hooks. _ -> do h <- openFile file AppendMode @@ -82,7 +82,7 @@ debugByteStream file stream = do return stream debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty -debugStreamHooks h nm = +debugStreamHooks h nm = StreamHooks { hook_readBlock = \ toStr n val -> do let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} diff --git a/Network/StreamSocket.hs b/Network/StreamSocket.hs index 42bdaf5..398c0cb 100644 --- a/Network/StreamSocket.hs +++ b/Network/StreamSocket.hs @@ -18,7 +18,7 @@ -- -- * Changes by Simon Foster: -- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --- +-- ----------------------------------------------------------------------------- module Network.StreamSocket ( handleSocketError @@ -77,7 +77,7 @@ readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) } -- Use of the following function is discouraged. --- The function reads in one character at a time, +-- The function reads in one character at a time, -- which causes many calls to the kernel recv() -- hence causes many context switches. readLineSocket :: Socket -> IO (Result String) @@ -88,7 +88,7 @@ readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk) if null c || c == "\n" then return (reverse str++c) else fn (head c:str) - + writeBlockSocket :: Socket -> String -> IO (Result ()) writeBlockSocket sk str = (liftM Right $ fn str) `catchIO` (handleSocketError sk) where diff --git a/Network/TCP.hs b/Network/TCP.hs index 1df858c..b9ac308 100644 --- a/Network/TCP.hs +++ b/Network/TCP.hs @@ -23,10 +23,10 @@ module Network.TCP , openTCPConnection , socketConnection , isTCPConnectedTo - + , HandleStream , HStream(..) - + , StreamHooks(..) , nullHooks , setStreamHooks @@ -89,7 +89,7 @@ instance Eq EndPoint where EndPoint host1 port1 == EndPoint host2 port2 = map toLower host1 == map toLower host2 && port1 == port2 -data Conn a +data Conn a = MkConn { connSock :: !Socket , connHandle :: Handle , connBuffer :: BufferOp a @@ -122,7 +122,7 @@ instance Eq ty => Eq (StreamHooks ty) where (==) _ _ = True nullHooks :: StreamHooks ty -nullHooks = StreamHooks +nullHooks = StreamHooks { hook_readLine = \ _ _ -> return () , hook_readBlock = \ _ _ _ -> return () , hook_writeBlock = \ _ _ _ -> return () @@ -144,7 +144,7 @@ getStreamHooks h = readMVar (getRef h) >>= return.connHooks -- The library comes with instances for @ByteString@s and @String@, but -- should you want to plug in your own payload representation, defining -- your own @HStream@ instance _should_ be all that it takes. --- +-- class BufferType bufType => HStream bufType where openStream :: String -> Int -> IO (HandleStream bufType) openSocketStream :: String -> Int -> Socket -> IO (HandleStream bufType) @@ -154,7 +154,7 @@ class BufferType bufType => HStream bufType where close :: HandleStream bufType -> IO () closeQuick :: HandleStream bufType -> IO () closeOnEnd :: HandleStream bufType -> Bool -> IO () - + instance HStream Strict.ByteString where openStream = openTCPConnection openSocketStream = socketConnection @@ -178,10 +178,10 @@ instance HStream Lazy.ByteString where instance Stream.Stream Connection where readBlock (Connection c) = Network.TCP.readBlock c readLine (Connection c) = Network.TCP.readLine c - writeBlock (Connection c) = Network.TCP.writeBlock c + writeBlock (Connection c) = Network.TCP.writeBlock c close (Connection c) = Network.TCP.close c closeOnEnd (Connection c) f = Network.TCP.closeEOF c f - + instance HStream String where openStream = openTCPConnection openSocketStream = socketConnection @@ -190,7 +190,7 @@ instance HStream String where -- This function uses a buffer, at this time the buffer is just 1000 characters. -- (however many bytes this is is left to the user to decypher) readLine ref = readLineBS ref - -- The 'Connection' object allows no outward buffering, + -- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) @@ -199,14 +199,14 @@ instance HStream String where -- at any time before a call to this function. This function is idempotent. -- (I think the behaviour here is TCP specific) close c = closeIt c null True - + -- Closes a Connection without munching the rest of the stream. closeQuick c = closeIt c null False closeOnEnd c f = closeEOF c f - + -- | @openTCPPort uri port@ establishes a connection to a remote --- host, using 'getHostByName' which possibly queries the DNS system, hence +-- host, using 'getHostByName' which possibly queries the DNS system, hence -- may trigger a network connection. openTCPPort :: String -> Int -> IO Connection openTCPPort uri port = openTCPConnection uri port >>= return.Connection @@ -288,7 +288,7 @@ socketConnection_ :: BufferType ty socketConnection_ hst port sock stashInput = do h <- socketToHandle sock ReadWriteMode mb <- case stashInput of { True -> liftM Just $ buf_hGetContents bufferOps h; _ -> return Nothing } - let conn = MkConn + let conn = MkConn { connSock = sock , connHandle = h , connBuffer = bufferOps @@ -338,7 +338,7 @@ isTCPConnectedTo conn endPoint = do v <- readMVar (getRef conn) case v of ConnClosed -> return False - _ + _ | connEndPoint v == endPoint -> catchIO (getPeerName (connSock v) >> return True) (const $ return False) | otherwise -> return False @@ -361,7 +361,7 @@ readLineBS ref = onNonClosedDo ref $ \ conn -> do (connHooks' conn) return x --- The 'Connection' object allows no outward buffering, +-- The 'Connection' object allows no outward buffering, -- since in general messages are serialised in their entirety. writeBlockBS :: HandleStream a -> a -> IO (Result ()) writeBlockBS ref b = onNonClosedDo ref $ \ conn -> do @@ -401,7 +401,7 @@ bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do else return (failMisc (show e))) bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) -bufferPutBlock ops h b = +bufferPutBlock ops h b = catchIO (buf_hPut ops h b >> hFlush h >> return (return ())) (\ e -> return (failMisc (show e))) @@ -414,7 +414,7 @@ bufferReadLine ref = onNonClosedDo ref $ \ conn -> do modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) return (return (buf_append (connBuffer conn) a newl)) _ -> catchIO - (buf_hGetLine (connBuffer conn) (connHandle conn) >>= + (buf_hGetLine (connBuffer conn) (connHandle conn) >>= return . return . appendNL (connBuffer conn)) (\ e -> if isEOFError e @@ -426,7 +426,7 @@ bufferReadLine ref = onNonClosedDo ref $ \ conn -> do -- yes, this s**ks.. _may_ have to be addressed if perf -- suggests worthiness. appendNL ops b = buf_snoc ops b nl - + nl :: Word8 nl = fromIntegral (fromEnum '\n') @@ -436,4 +436,4 @@ onNonClosedDo h act = do case x of ConnClosed{} -> return (failWith ErrorClosed) _ -> act x - + diff --git a/test/get.hs b/test/get.hs index c1058d3..0961965 100644 --- a/test/get.hs +++ b/test/get.hs @@ -13,21 +13,21 @@ import System.Environment (getArgs) import System.Exit (exitFailure) import System.IO (hPutStrLn, stderr) -main = +main = do args <- getArgs - case args of - [addr] -> case parseURI addr of - Nothing -> err "Could not parse URI" - Just uri -> do - cont <- get uri - putStr cont - _ -> err "Usage: get " + case args of + [addr] -> case parseURI addr of + Nothing -> err "Could not parse URI" + Just uri -> do + cont <- get uri + putStr cont + _ -> err "Usage: get " err :: String -> IO a -err msg = do - hPutStrLn stderr msg - exitFailure +err msg = do + hPutStrLn stderr msg + exitFailure get :: URI -> IO String get uri = diff --git a/test/getb.hs b/test/getb.hs index f353948..59259e6 100644 --- a/test/getb.hs +++ b/test/getb.hs @@ -16,29 +16,29 @@ import Network.Stream import qualified Data.ByteString as Strict import qualified Data.ByteString.Lazy as Lazy -main = +main = do args <- getArgs - case args of - [addr0] -> - let (isLazy, isString, addr) = - case addr0 of - '+':xs -> (True,False,xs) - '-':xs -> (False,True,xs) - _ -> (False,False,addr0) + case args of + [addr0] -> + let (isLazy, isString, addr) = + case addr0 of + '+':xs -> (True,False,xs) + '-':xs -> (False,True,xs) + _ -> (False,False,addr0) in - case parseURI addr of - Nothing -> err "Could not parse URI" - Just uri - | isLazy -> get uri >>= putStr . show . Lazy.length - | isString -> get uri >>= \ x -> putStr $ show (length (x::String)) - | otherwise -> get uri >>= putStr . show . Strict.length - _ -> err "Usage: get " + case parseURI addr of + Nothing -> err "Could not parse URI" + Just uri + | isLazy -> get uri >>= putStr . show . Lazy.length + | isString -> get uri >>= \ x -> putStr $ show (length (x::String)) + | otherwise -> get uri >>= putStr . show . Strict.length + _ -> err "Usage: get " err :: String -> IO a -err msg = do - hPutStrLn stderr msg - exitFailure +err msg = do + hPutStrLn stderr msg + exitFailure get :: HStream ty => URI -> IO ty get uri = do @@ -56,9 +56,9 @@ request uri = req where req = Request{ rqURI = uri , rqMethod = GET - , rqHeaders = [] - , rqBody = nullVal - } + , rqHeaders = [] + , rqBody = nullVal + } nullVal = buf_empty bufferOps diff --git a/test/httpTests.hs b/test/httpTests.hs index c843218..fdc4a0c 100644 --- a/test/httpTests.hs +++ b/test/httpTests.hs @@ -139,7 +139,7 @@ browserExample = do result <- -- sample code from Network.Browser haddock, with URL changed -- Note there's also a copy of the example in the .cabal file - do + do (_, rsp) <- Network.Browser.browse $ do setAllowRedirects True -- handle HTTP redirects @@ -453,7 +453,7 @@ processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Httpd.Request -> IO Httpd.Response processRequest req = do - case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of + case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "It works." ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "It works (2)." ("GET", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." @@ -520,7 +520,7 @@ processRequest req = do altProcessRequest :: Httpd.Request -> IO Httpd.Response altProcessRequest req = do - case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of + case (Httpd.reqMethod req, Network.URI.uriPath (Httpd.reqURI req)) of ("GET", "/basic/get") -> return $ Httpd.mkResponse 200 [] "This is the alternate server." ("GET", "/basic/get2") -> return $ Httpd.mkResponse 200 [] "This is the alternate server (2)." _ -> return $ Httpd.mkResponse 500 [] "Unknown request" From d3da6b36feecee9f9446fcc3022471c730e4b1b5 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 21 Feb 2022 09:12:41 +0100 Subject: [PATCH 4/5] Remove deprecated instance Error (mtl) --- Network/HTTP/Base.hs | 2 +- Network/HTTP/UserAgent.hs | 2 -- Network/Stream.hs | 8 +------- 3 files changed, 2 insertions(+), 10 deletions(-) diff --git a/Network/HTTP/Base.hs b/Network/HTTP/Base.hs index 6901792..de1ac67 100644 --- a/Network/HTTP/Base.hs +++ b/Network/HTTP/Base.hs @@ -107,7 +107,7 @@ import Network.URI ) import Control.Monad ( guard ) -import Control.Monad.Error.Class () + import Data.Bits ( (.&.), (.|.), shiftL, shiftR ) import Data.Word ( Word8 ) import Data.Char ( digitToInt, intToDigit, toLower, isDigit, diff --git a/Network/HTTP/UserAgent.hs b/Network/HTTP/UserAgent.hs index 827c680..e9d81bc 100644 --- a/Network/HTTP/UserAgent.hs +++ b/Network/HTTP/UserAgent.hs @@ -1,7 +1,5 @@ module Network.HTTP.UserAgent where -import Control.Monad.Error - import Data.ByteString.Lazy.Char8 ( ByteString ) import qualified Data.ByteString.Lazy.Char8 as BS diff --git a/Network/Stream.hs b/Network/Stream.hs index 66609f9..be535b0 100644 --- a/Network/Stream.hs +++ b/Network/Stream.hs @@ -32,8 +32,6 @@ module Network.Stream , failMisc -- :: String -> Result a ) where -import Control.Monad.Error - data ConnError = ErrorReset | ErrorClosed @@ -41,15 +39,11 @@ data ConnError | ErrorMisc String deriving(Show,Eq) -instance Error ConnError where - noMsg = strMsg "unknown error" - strMsg x = ErrorMisc x - -- in GHC 7.0 the Monad instance for Error no longer -- uses fail x = Left (strMsg x). failMisc is therefore -- used instead. failMisc :: String -> Result a -failMisc x = failWith (strMsg x) +failMisc x = failWith (ErrorMisc x) failParse :: String -> Result a failParse x = failWith (ErrorParse x) From 57694dab8201c39d77570f11369d100449fbb506 Mon Sep 17 00:00:00 2001 From: Andreas Abel Date: Mon, 21 Feb 2022 11:00:25 +0100 Subject: [PATCH 5/5] Restrict to GHC >= 7.6 (base >= 4.6) instance Monad (Either e) isn't found when compiling with base <= 4.5 --- .github/workflows/haskell-ci.yml | 15 --------------- HTTP.cabal | 4 ++-- 2 files changed, 2 insertions(+), 17 deletions(-) diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index 23b044a..53fa14a 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -83,21 +83,6 @@ jobs: compilerVersion: 7.6.3 setup-method: hvr-ppa allow-failure: false - - compiler: ghc-7.4.2 - compilerKind: ghc - compilerVersion: 7.4.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.2.2 - compilerKind: ghc - compilerVersion: 7.2.2 - setup-method: hvr-ppa - allow-failure: false - - compiler: ghc-7.0.4 - compilerKind: ghc - compilerVersion: 7.0.4 - setup-method: hvr-ppa - allow-failure: false fail-fast: false steps: - name: apt diff --git a/HTTP.cabal b/HTTP.cabal index e5438c5..f29bcd0 100644 --- a/HTTP.cabal +++ b/HTTP.cabal @@ -60,7 +60,7 @@ Extra-Source-Files: CHANGES tested-with: GHC==9.2.1, GHC==9.0.1, GHC==8.10.7, GHC==8.8.4, GHC==8.6.5, GHC==8.4.4, GHC==8.2.2, GHC==8.0.2, - GHC==7.10.3, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2, GHC==7.0.4 + GHC==7.10.3, GHC==7.8.4, GHC==7.6.3 Source-Repository head type: git @@ -114,7 +114,7 @@ Library -- note the test harness constraints should be kept in sync with these -- where dependencies are shared build-depends: - base >= 4.3.0.0 && < 4.17 + base >= 4.6.0.0 && < 4.17 , array >= 0.3.0.2 && < 0.6 , bytestring >= 0.9.1.5 && < 0.12 , parsec >= 2.0 && < 3.2