diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/debian/changelog cabal-install-head-2.1+git20171213.0.b8c95ea/debian/changelog --- cabal-install-head-2.1+git20171204.0.2b835e6/debian/changelog 2017-12-04 09:03:54.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/debian/changelog 2017-12-13 10:28:09.000000000 +0000 @@ -1,5 +1,5 @@ -cabal-install-head (2.1+git20171204.0.2b835e6-5~14.04) trusty; urgency=medium +cabal-install-head (2.1+git20171213.0.b8c95ea-5~14.04) trusty; urgency=medium * Initial release - -- Herbert Valerio Riedel Mon, 04 Dec 2017 10:03:54 +0100 + -- Herbert Valerio Riedel Wed, 13 Dec 2017 11:28:09 +0100 diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/buildplan.lst cabal-install-head-2.1+git20171213.0.b8c95ea/src/buildplan.lst --- cabal-install-head-2.1+git20171204.0.2b835e6/src/buildplan.lst 2017-12-04 09:03:25.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/buildplan.lst 2017-12-13 10:27:43.000000000 +0000 @@ -17,6 +17,6 @@ hashable-1.2.6.1 network-uri-2.6.1.0 Cabal-2.1.0.0 -HTTP-4000.3.8 +HTTP-4000.3.9 hackage-security-0.5.2.2 cabal-install-2.1.0.0 diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Cabal.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Cabal.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Cabal.cabal 2017-12-04 09:03:10.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Cabal.cabal 2017-12-13 10:27:29.000000000 +0000 @@ -32,15 +32,33 @@ -- Generated with 'misc/gen-extra-source-files.sh' -- Do NOT edit this section manually; instead, run the script. -- BEGIN gen-extra-source-files + tests/ParserTests/errors/common1.cabal + tests/ParserTests/errors/common1.errors + tests/ParserTests/errors/common2.cabal + tests/ParserTests/errors/common2.errors + tests/ParserTests/errors/common3.cabal + tests/ParserTests/errors/common3.errors tests/ParserTests/regressions/Octree-0.5.cabal + tests/ParserTests/regressions/Octree-0.5.format + tests/ParserTests/regressions/common.cabal + tests/ParserTests/regressions/common.format + tests/ParserTests/regressions/common2.cabal + tests/ParserTests/regressions/common2.format tests/ParserTests/regressions/elif.cabal + tests/ParserTests/regressions/elif.format tests/ParserTests/regressions/elif2.cabal + tests/ParserTests/regressions/elif2.format tests/ParserTests/regressions/encoding-0.8.cabal + tests/ParserTests/regressions/encoding-0.8.format tests/ParserTests/regressions/generics-sop.cabal + tests/ParserTests/regressions/generics-sop.format tests/ParserTests/regressions/haddock-api-2.18.1-check.cabal tests/ParserTests/regressions/issue-774.cabal + tests/ParserTests/regressions/issue-774.format tests/ParserTests/regressions/nothing-unicode.cabal + tests/ParserTests/regressions/nothing-unicode.format tests/ParserTests/regressions/shake.cabal + tests/ParserTests/regressions/shake.format tests/ParserTests/warnings/bom.cabal tests/ParserTests/warnings/bool.cabal tests/ParserTests/warnings/deprecatedfield.cabal diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/changelog cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/changelog --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/changelog 2017-12-04 09:03:10.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/changelog 2017-12-13 10:27:29.000000000 +0000 @@ -27,11 +27,17 @@ * Support for GHC's numeric -g debug levels (#4673). * Added elif-conditionals to .cabal syntax (#4750). * Support for building with Win32 version 2.6 (#4835). - * Compilation with section splitting is now supported via the '--enable-split-sections' flag (#4819) + * Compilation with section splitting is now supported via the + '--enable-split-sections' flag (#4819) + * Support for common stanzas (#4751) * TODO +2.0.1.1 Mikhail Glushenkov December 2017 + * Don't pass `other-modules` to stub executable for detailed-0.9 + (#4918). + * Hpc: Use relative .mix search paths (#4917). -2.0.1.0 Mikhail Glushenkov October 2017 +2.0.1.0 Mikhail Glushenkov November 2017 * Support for GHC's numeric -g debug levels (#4673). * Added a new 'Distribution.Verbosity.modifyVerbosity' combinator (#4724). @@ -43,7 +49,7 @@ 2.0.0.2 Mikhail Glushenkov July 2017 * See http://coldwa.st/e/blog/2017-09-09-Cabal-2-0.html - for more detailed release notes. + for more detailed release notes. * The 2.0 migration guide gives advice on adapting Custom setup scripts to backwards-incompatible changes in this release: https://github.com/haskell/cabal/wiki/2.0-migration-guide diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/Check.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/Check.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/Check.hs 2017-12-04 09:03:08.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/Check.hs 2017-12-13 10:27:27.000000000 +0000 @@ -1364,7 +1364,7 @@ , usesWildcardSyntax vr ] depsUsingMajorBoundSyntax = [ dep | dep@(Dependency _ vr) <- buildDepends pkg - , usesMajorBoundSyntax vr ] + , usesMajorBoundSyntax vr ] usesBackpackIncludes = any (not . null . mixins) (allBuildInfo pkg) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/FieldGrammar.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/FieldGrammar.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/FieldGrammar.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/FieldGrammar.hs 2017-12-13 10:27:29.000000000 +0000 @@ -175,6 +175,9 @@ , _testStanzaBuildInfo :: BuildInfo } +instance L.HasBuildInfo TestSuiteStanza where + buildInfo = testStanzaBuildInfo + testStanzaTestType :: Lens' TestSuiteStanza (Maybe TestType) testStanzaTestType f s = fmap (\x -> s { _testStanzaTestType = x }) (f (_testStanzaTestType s)) {-# INLINE testStanzaTestType #-} @@ -274,6 +277,9 @@ , _benchmarkStanzaBuildInfo :: BuildInfo } +instance L.HasBuildInfo BenchmarkStanza where + buildInfo = benchmarkStanzaBuildInfo + benchmarkStanzaBenchmarkType :: Lens' BenchmarkStanza (Maybe BenchmarkType) benchmarkStanzaBenchmarkType f s = fmap (\x -> s { _benchmarkStanzaBenchmarkType = x }) (f (_benchmarkStanzaBenchmarkType s)) {-# INLINE benchmarkStanzaBenchmarkType #-} diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/Parsec.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/Parsec.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/Parsec.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/Parsec.hs 2017-12-13 10:27:29.000000000 +0000 @@ -42,7 +42,7 @@ import Distribution.PackageDescription import Distribution.PackageDescription.FieldGrammar import Distribution.PackageDescription.Quirks (patchQuirks) -import Distribution.Parsec.Class (parsec) +import Distribution.Parsec.Class (parsecCommaList, parsec, parsecToken) import Distribution.Parsec.Common import Distribution.Parsec.ConfVar (parseConditionConfVar) import Distribution.Parsec.Field (FieldName, getName) @@ -52,6 +52,7 @@ import Distribution.Simple.Utils (die', fromUTF8BS, warn) import Distribution.Text (display) import Distribution.Types.CondTree +import Distribution.Types.Dependency (Dependency) import Distribution.Types.ForeignLib import Distribution.Types.UnqualComponentName (UnqualComponentName, mkUnqualComponentName) @@ -62,6 +63,7 @@ import System.Directory (doesFileExist) import Distribution.Compat.Lens +import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L import qualified Distribution.Types.PackageDescription.Lens as L @@ -124,7 +126,21 @@ fieldlinesToBS = BS.intercalate "\n" . map (\(FieldLine _ bs) -> bs) -- Monad in which sections are parsed -type SectionParser = StateT GenericPackageDescription ParseResult +type SectionParser = StateT SectionS ParseResult + +-- | State of section parser +data SectionS = SectionS + { _stateGpd :: !GenericPackageDescription + , _stateCommonStanzas :: !(Map String CondTreeBuildInfo) + } + +stateGpd :: Lens' SectionS GenericPackageDescription +stateGpd f (SectionS gpd cs) = (\x -> SectionS x cs) <$> f gpd +{-# INLINE stateGpd #-} + +stateCommonStanzas :: Lens' SectionS (Map String CondTreeBuildInfo) +stateCommonStanzas f (SectionS gpd cs) = SectionS gpd <$> f cs +{-# INLINE stateCommonStanzas #-} -- Note [Accumulating parser] -- @@ -147,9 +163,10 @@ -- Sections let gpd = emptyGpd & L.packageDescription .~ pd - -- elif conditional is accepted if spec version is >= 2.1 - let hasElif = if specVersion pd >= mkVersion [2,1] then HasElif else NoElif - execStateT (goSections hasElif sectionFields) gpd + -- parse sections + view stateGpd <$> execStateT + (goSections (specVersion pd) sectionFields) + (SectionS gpd Map.empty) where emptyGpd :: GenericPackageDescription emptyGpd = GenericPackageDescription emptyPackageDescription [] Nothing [] [] [] [] [] @@ -180,9 +197,14 @@ maybeWarnCabalVersion _ _ = return () -- Sections -goSections :: HasElif -> [Field Position] -> SectionParser () -goSections hasElif = traverse_ process +goSections :: Version -> [Field Position] -> SectionParser () +goSections sv = traverse_ process where + hasElif = if sv >= mkVersion [2,1] then HasElif else NoElif + + -- Common stanzas are avaiable since cabal-version: 2.1 + hasCommonStanzas = sv >= mkVersion [2,1] + process (Field (Name pos name) _) = lift $ parseWarning pos PWTTrailingFields $ "Ignoring trailing fields after sections: " ++ show name @@ -193,55 +215,75 @@ parseSection :: Name Position -> [SectionArg Position] -> [Field Position] -> SectionParser () parseSection (Name pos name) args fields + | not hasCommonStanzas, name == "common" = lift $ do + parseWarning pos PWTUnknownSection $ "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." + + | name == "common" = do + commonStanzas <- use stateCommonStanzas + name' <- lift $ parseCommonName pos args + biTree <- lift $ parseCondTreeWithCommonStanzas hasElif hasCommonStanzas buildInfoFieldGrammar commonStanzas fields + + case Map.lookup name' commonStanzas of + Nothing -> stateCommonStanzas .= Map.insert name' biTree commonStanzas + Just _ -> lift $ parseFailure pos $ + "Duplicate common stanza: " ++ name' + | name == "library" && null args = do - lib <- lift $ parseCondTree hasElif (libraryFieldGrammar Nothing) (targetBuildDepends . libBuildInfo) fields + commonStanzas <- use stateCommonStanzas + lib <- lift $ parseCondTreeWithCommonStanzas hasElif hasCommonStanzas (libraryFieldGrammar Nothing) commonStanzas fields -- TODO: check that library is defined once - L.condLibrary ?= lib + stateGpd . L.condLibrary ?= lib -- Sublibraries + -- TODO: check cabal-version | name == "library" = do - -- TODO: check cabal-version + commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - lib <- lift $ parseCondTree hasElif (libraryFieldGrammar $ Just name') (targetBuildDepends . libBuildInfo) fields + lib <- lift $ parseCondTreeWithCommonStanzas hasElif hasCommonStanzas (libraryFieldGrammar $ Just name') commonStanzas fields -- TODO check duplicate name here? - L.condSubLibraries %= snoc (name', lib) + stateGpd . L.condSubLibraries %= snoc (name', lib) + -- TODO: check cabal-version | name == "foreign-library" = do + commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - flib <- lift $ parseCondTree hasElif (foreignLibFieldGrammar name') (targetBuildDepends . foreignLibBuildInfo) fields + flib <- lift $ parseCondTreeWithCommonStanzas hasElif hasCommonStanzas (foreignLibFieldGrammar name') commonStanzas fields -- TODO check duplicate name here? - L.condForeignLibs %= snoc (name', flib) + stateGpd . L.condForeignLibs %= snoc (name', flib) | name == "executable" = do + commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - exe <- lift $ parseCondTree hasElif (executableFieldGrammar name') (targetBuildDepends . buildInfo) fields + exe <- lift $ parseCondTreeWithCommonStanzas hasElif hasCommonStanzas (executableFieldGrammar name') commonStanzas fields -- TODO check duplicate name here? - L.condExecutables %= snoc (name', exe) + stateGpd . L.condExecutables %= snoc (name', exe) | name == "test-suite" = do + commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - testStanza <- lift $ parseCondTree hasElif testSuiteFieldGrammar (targetBuildDepends . _testStanzaBuildInfo) fields + testStanza <- lift $ parseCondTreeWithCommonStanzas hasElif hasCommonStanzas testSuiteFieldGrammar commonStanzas fields testSuite <- lift $ traverse (validateTestSuite pos) testStanza -- TODO check duplicate name here? - L.condTestSuites %= snoc (name', testSuite) + stateGpd . L.condTestSuites %= snoc (name', testSuite) | name == "benchmark" = do + commonStanzas <- use stateCommonStanzas name' <- parseUnqualComponentName pos args - benchStanza <- lift $ parseCondTree hasElif benchmarkFieldGrammar (targetBuildDepends . _benchmarkStanzaBuildInfo) fields + benchStanza <- lift $ parseCondTreeWithCommonStanzas hasElif hasCommonStanzas benchmarkFieldGrammar commonStanzas fields bench <- lift $ traverse (validateBenchmark pos) benchStanza -- TODO check duplicate name here? - L.condBenchmarks %= snoc (name', bench) + stateGpd . L.condBenchmarks %= snoc (name', bench) | name == "flag" = do name' <- parseName pos args name'' <- lift $ runFieldParser' pos parsec name' `recoverWith` mkFlagName "" flag <- lift $ parseFields fields (flagFieldGrammar name'') -- Check default flag - L.genPackageFlags %= snoc flag + stateGpd . L.genPackageFlags %= snoc flag | name == "custom-setup" && null args = do sbi <- lift $ parseFields fields (setupBInfoFieldGrammar False) - L.packageDescription . L.setupBuildInfo ?= sbi + stateGpd . L.packageDescription . L.setupBuildInfo ?= sbi | name == "source-repository" = do kind <- lift $ case args of @@ -255,12 +297,13 @@ pure RepoHead sr <- lift $ parseFields fields (sourceRepoFieldGrammar kind) - L.packageDescription . L.sourceRepos %= snoc sr + stateGpd . L.packageDescription . L.sourceRepos %= snoc sr | otherwise = lift $ parseWarning pos PWTUnknownSection $ "Ignoring section: " ++ show name parseName :: Position -> [SectionArg Position] -> SectionParser String +-- TODO: use strict parser parseName pos args = case args of [SecArgName _pos secName] -> pure $ fromUTF8BS secName @@ -274,6 +317,20 @@ lift $ parseFailure pos $ "Invalid name " ++ show args pure "" +parseCommonName :: Position -> [SectionArg Position] -> ParseResult String +parseCommonName pos args = case args of + [SecArgName _pos secName] -> + pure $ fromUTF8BS secName + [SecArgStr _pos secName] -> + pure $ fromUTF8BS secName + [] -> do + parseFailure pos $ "name required" + pure "" + _ -> do + -- TODO: pretty print args + parseFailure pos $ "Invalid name " ++ show args + pure "" + parseUnqualComponentName :: Position -> [SectionArg Position] -> SectionParser UnqualComponentName parseUnqualComponentName pos args = mkUnqualComponentName <$> parseName pos args @@ -291,7 +348,6 @@ warnInvalidSubsection (MkSection (Name pos name) _ _) = void (parseFailure pos $ "invalid subsection " ++ show name) - data HasElif = HasElif | NoElif deriving (Eq, Show) @@ -333,6 +389,8 @@ sections' <- parseIfs sections return (Just elseFields, sections') + + parseElseIfs (MkSection (Name _ name) test fields : sections) | hasElif == HasElif, name == "elif" = do -- TODO: check cabal-version test' <- parseConditionConfVar test @@ -342,6 +400,10 @@ a <- parseFieldGrammar mempty grammar return (Just $ CondNode a (cond a) [CondBranch test' fields' elseFields], sections') + parseElseIfs (MkSection (Name pos name) _ _ : sections) | name == "elif" = do + parseWarning pos PWTInvalidSubsection $ "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." + (,) Nothing <$> parseIfs sections + parseElseIfs sections = (,) Nothing <$> parseIfs sections {- Note [Accumulating parser] @@ -367,6 +429,111 @@ -} ------------------------------------------------------------------------------- +-- Common stanzas +------------------------------------------------------------------------------- + +-- $commonStanzas +-- +-- [Note: Common stanzas] +-- +-- In Cabal 2.2 we support simple common stanzas: +-- +-- * Commons stanzas define 'BuildInfo' +-- +-- * import "fields" can only occur at top of other stanzas (think: imports) +-- +-- In particular __there aren't__ +-- +-- * implicit stanzas +-- +-- * More specific common stanzas (executable, test-suite). +-- +-- +-- The approach uses the fact that 'BuildInfo' is a 'Monoid': +-- +-- @ +-- mergeCommonStanza' :: HasBuildInfo comp => BuildInfo -> comp -> comp +-- mergeCommonStanza' bi = over L.BuildInfo (bi <>) +-- @ +-- +-- Real 'mergeCommonStanza' is more complicated as we have to deal with +-- conditional trees. +-- +-- The approach is simple, and have good properties: +-- +-- * Common stanzas are parsed exactly once, even if not-used. Thus we report errors in them. +-- +type CondTreeBuildInfo = CondTree ConfVar [Dependency] BuildInfo + +-- | Create @a@ from 'BuildInfo'. +-- +-- Law: @view buildInfo . fromBuildInfo = id@ +class L.HasBuildInfo a => FromBuildInfo a where + fromBuildInfo :: BuildInfo -> a + +instance FromBuildInfo BuildInfo where fromBuildInfo = id +instance FromBuildInfo Library where fromBuildInfo bi = set L.buildInfo bi emptyLibrary +instance FromBuildInfo ForeignLib where fromBuildInfo bi = set L.buildInfo bi emptyForeignLib +instance FromBuildInfo Executable where fromBuildInfo bi = set L.buildInfo bi emptyExecutable + +instance FromBuildInfo TestSuiteStanza where + fromBuildInfo = TestSuiteStanza Nothing Nothing Nothing + +instance FromBuildInfo BenchmarkStanza where + fromBuildInfo = BenchmarkStanza Nothing Nothing Nothing + +parseCondTreeWithCommonStanzas + :: forall a. FromBuildInfo a + => HasElif -- ^ accept @elif@ + -> Bool -- ^ accept @import@ + -> ParsecFieldGrammar' a -- ^ grammar + -> Map String CondTreeBuildInfo -- ^ common stanzas + -> [Field Position] + -> ParseResult (CondTree ConfVar [Dependency] a) +parseCondTreeWithCommonStanzas hasElif hasCommonStanzas grammar commonStanzas = goImports [] + where + -- parse leading imports + -- not supported: + goImports acc (Field (Name pos name) _ : fields) | name == "import", not hasCommonStanzas = do + parseWarning pos PWTUnknownField "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" + goImports acc fields + -- supported: + goImports acc (Field (Name pos name) fls : fields) | name == "import" = do + names <- runFieldParser pos (parsecCommaList parsecToken) fls + names' <- for names $ \commonName -> + case Map.lookup commonName commonStanzas of + Nothing -> do + parseFailure pos $ "Undefined common stanza imported: " ++ commonName + pure Nothing + Just commonTree -> + pure (Just commonTree) + + goImports (acc ++ catMaybes names') fields + + -- Go to parsing condTree after first non-import 'Field'. + goImports acc fields = go acc fields + + -- parse actual CondTree + go :: [CondTreeBuildInfo] -> [Field Position] -> ParseResult (CondTree ConfVar [Dependency] a) + go bis fields = do + x <- parseCondTree hasElif grammar (view L.targetBuildDepends) fields + pure $ foldr mergeCommonStanza x bis + +mergeCommonStanza + :: forall a. FromBuildInfo a + => CondTree ConfVar [Dependency] BuildInfo + -> CondTree ConfVar [Dependency] a + -> CondTree ConfVar [Dependency] a +mergeCommonStanza (CondNode bi _ bis) (CondNode x _ cs) = + CondNode x' (x' ^. L.targetBuildDepends) cs' + where + -- new value is old value with buildInfo field _prepended_. + x' = x & L.buildInfo %~ (bi <>) + + -- tree components are appended together. + cs' = map (fmap fromBuildInfo) bis ++ cs + +------------------------------------------------------------------------------- -- Old syntax ------------------------------------------------------------------------------- diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/PrettyPrint.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/PrettyPrint.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/PackageDescription/PrettyPrint.hs 2017-12-04 09:03:08.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/PackageDescription/PrettyPrint.hs 2017-12-13 10:27:27.000000000 +0000 @@ -147,7 +147,7 @@ ppCondForeignLibs :: [(UnqualComponentName, CondTree ConfVar [Dependency] ForeignLib)] -> Doc ppCondForeignLibs flibs = vcat - [ emptyLine $ (text "library" <+> disp n) $+$ + [ emptyLine $ (text "foreign-library" <+> disp n) $+$ nest indentWith (ppCondTree2 (foreignLibFieldGrammar n) condTree) | (n, condTree) <- flibs ] diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Parsec/Newtypes.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Parsec/Newtypes.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Parsec/Newtypes.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Parsec/Newtypes.hs 2017-12-13 10:27:29.000000000 +0000 @@ -63,8 +63,9 @@ class Sep sep where prettySep :: P sep -> [Doc] -> Doc parseSep - :: P sep -> P.Stream s Identity Char - => P.Parsec s [PWarning] a + :: P.Stream s Identity Char + => P sep + -> P.Parsec s [PWarning] a -> P.Parsec s [PWarning] [a] instance Sep CommaVCat where diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Parsec/Parser.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Parsec/Parser.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Parsec/Parser.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Parsec/Parser.hs 2017-12-13 10:27:29.000000000 +0000 @@ -221,7 +221,7 @@ -- An individual element, ie a field or a section. These can either use -- layout style or braces style. For layout style then it must start on --- a line on it's own (so that we know its indentation level). +-- a line on its own (so that we know its indentation level). -- -- element ::= '\n' name elementInLayoutContext -- | name elementInNonLayoutContext diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/Compiler.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/Compiler.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/Compiler.hs 2017-12-04 09:03:08.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/Compiler.hs 2017-12-13 10:27:28.000000000 +0000 @@ -11,7 +11,7 @@ -- Portability : portable -- -- This should be a much more sophisticated abstraction than it is. Currently --- it's just a bit of data about the compiler, like it's flavour and name and +-- it's just a bit of data about the compiler, like its flavour and name and -- version. The reason it's just data is because currently it has to be in -- 'Read' and 'Show' so it can be saved along with the 'LocalBuildInfo'. The -- only interesting bit of info it contains is a mapping between language diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/GHC/Internal.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/GHC/Internal.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/GHC/Internal.hs 2017-12-04 09:03:10.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/GHC/Internal.hs 2017-12-13 10:27:29.000000000 +0000 @@ -499,7 +499,7 @@ -- ----------------------------------------------------------------------------- -- GHC platform and version strings --- | GHC's rendering of it's host or target 'Arch' as used in its platform +-- | GHC's rendering of its host or target 'Arch' as used in its platform -- strings and certain file locations (such as user package db location). -- ghcArchString :: Arch -> String @@ -507,7 +507,7 @@ ghcArchString PPC64 = "powerpc64" ghcArchString other = display other --- | GHC's rendering of it's host or target 'OS' as used in its platform +-- | GHC's rendering of its host or target 'OS' as used in its platform -- strings and certain file locations (such as user package db location). -- ghcOsString :: OS -> String @@ -516,7 +516,7 @@ ghcOsString Solaris = "solaris2" ghcOsString other = display other --- | GHC's rendering of it's platform and compiler version string as used in +-- | GHC's rendering of its platform and compiler version string as used in -- certain file locations (such as user package db location). -- For example @x86_64-linux-7.10.4@ -- diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/PreProcess.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/PreProcess.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/PreProcess.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/PreProcess.hs 2017-12-13 10:27:28.000000000 +0000 @@ -466,7 +466,7 @@ _ -> id -- We don't link in the actual Haskell libraries of our dependencies, so -- the -u flags in the ldOptions of the rts package mean linking fails on - -- OS X (it's ld is a tad stricter than gnu ld). Thus we remove the + -- OS X (its ld is a tad stricter than gnu ld). Thus we remove the -- ldOptions for GHC's rts package: hackRtsPackage index = case PackageIndex.lookupPackageName index (mkPackageName "rts") of diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/Program/GHC.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/Program/GHC.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Simple/Program/GHC.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Simple/Program/GHC.hs 2017-12-13 10:27:28.000000000 +0000 @@ -70,7 +70,7 @@ ghcOptOutputDynFile :: Flag FilePath, -- | Start with an empty search path for Haskell source files; - -- the @ghc -i@ flag (@-i@ on it's own with no path argument). + -- the @ghc -i@ flag (@-i@ on its own with no path argument). ghcOptSourcePathClear :: Flag Bool, -- | Search path for Haskell source files; the @ghc -i@ flag. diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Text.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Text.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Text.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Text.hs 2017-12-13 10:27:28.000000000 +0000 @@ -8,7 +8,7 @@ -- Portability : portable -- -- This defines a 'Text' class which is a bit like the 'Read' and 'Show' --- classes. The difference is that is uses a modern pretty printer and parser +-- classes. The difference is that it uses a modern pretty printer and parser -- system and the format is not expected to be Haskell concrete syntax but -- rather the external human readable representation used by Cabal. -- @@ -33,7 +33,7 @@ import Data.Version (Version(Version)) -- | /Note:/ this class will soon be deprecated. --- It's not yet, so we are @-Wall@ clean. +-- It's not yet, so that we are @-Wall@ clean. class Text a where disp :: a -> Disp.Doc default disp :: Pretty a => a -> Disp.Doc diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Verbosity.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Verbosity.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/Distribution/Verbosity.hs 2017-12-04 09:03:09.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/Distribution/Verbosity.hs 2017-12-13 10:27:29.000000000 +0000 @@ -129,15 +129,17 @@ Normal -> v { vLevel = Silent } Silent -> v --- | Combinator for transforming verbosity level while retaining the original hidden state. +-- | Combinator for transforming verbosity level while retaining the +-- original hidden state. -- -- For instance, the following property holds -- -- prop> isVerboseNoWrap (modifyVerbosity (max verbose) v) == isVerboseNoWrap v -- --- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite @v1@'s flags with @v0@'s flags. +-- __Note__: you can use @modifyVerbosity (const v1) v0@ to overwrite +-- @v1@'s flags with @v0@'s flags. -- --- @since 2.0.1 +-- @since 2.0.1.0 modifyVerbosity :: (Verbosity -> Verbosity) -> Verbosity -> Verbosity modifyVerbosity f v = v { vLevel = vLevel (f v) } diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/doc/developing-packages.rst cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/doc/developing-packages.rst --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/doc/developing-packages.rst 2017-12-04 09:03:10.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/doc/developing-packages.rst 2017-12-13 10:27:29.000000000 +0000 @@ -999,7 +999,7 @@ :synopsis: Library build information. Build information for libraries. There can be only one library in a - package, and it's name is the same as package name set by global + package, and its name is the same as package name set by global :pkg-field:`name` field. The library section should contain the following fields: @@ -1251,7 +1251,7 @@ ^^^^^^^^^^^ .. pkg-section:: executable name - :synopsis: Exectuable build info section. + :synopsis: Executable build info section. Executable sections (if present) describe executable programs contained in the package and must have an argument after the section label, which @@ -1729,9 +1729,8 @@ than ``1.0``. This is not an issue with the caret-operator ``^>=`` described below. - Starting with Cabal 2.0, there's a new syntactic sugar to express - PVP_-style - major upper bounds conveniently, and is inspired by similar + Starting with Cabal 2.0, there's a new version operator to express + PVP_-style major upper bounds conveniently, and is inspired by similar syntactic sugar found in other language ecosystems where it's often called the "Caret" operator: @@ -1741,15 +1740,46 @@ foo ^>= 1.2.3.4, bar ^>= 1 - This allows to express the intent that this packages requires - versions of ``foo`` and ``bar`` which are semantically compatible - to ``foo-1.2.3.4`` and ``bar-1`` respectively. This subtle but important - difference in signaling allows tooling to treat *"hard"* ``<``-style - and *"weak"* ``^>=``-style upper bounds differently. For instance, - :option:`--allow-newer`'s ``^``-modifier allows to relax only *"weak"* - ``^>=``-style bounds while leaving ``<``-bounds unaffected. + This allows to assert the positive knowledge that this package is + *known* to be semantically compatible with the releases + ``foo-1.2.3.4`` and ``bar-1`` respectively. The information + encoded via such ``^>=``-assertions is used by the cabal solver to + infer version constraints describing semantically compatible + version ranges according to the PVP_ contract (see below). + + Another way to say this is that ``foo < 1.3`` expresses *negative* + information, i.e. "``foo-1.3`` or ``foo-1.4.2`` will *not* be + compatible"; whereas ``foo ^>= 1.2.3.4`` asserts the *positive* + information that "``foo-1.2.3.4`` is *known* to be compatible" and (in + the absence of additional information) according to the PVP_ + contract we can (positively) infer right away that all versions + satisfying ``foo >= 1.2.3.4 && < 1.3`` will be compatible as well. - Ignoring the signaling intent, the equivalences are + .. Note:: + + More generally, the PVP_ contract implies that we can safely + relax the lower bound to ``>= 1.2``, because if we know that + ``foo-1.2.3.4`` is semantically compatible, then so is + ``foo-1.2`` (if it typechecks). But we'd need to perform + additional static analysis (i.e. perform typechecking) in order + to know if our package in the role of an API consumer will + successfully typecheck against the dependency ``foo-1.2``. But + since we cannot do this analysis during constraint solving and + to keep things simple, we pragmatically use ``foo >= 1.2.3.4`` + as the initially inferred approximation for the lower bound + resulting from the assertion ``foo ^>= 1.2.3.4``. If further + evidence becomes available that e.g. ``foo-1.2`` typechecks, + one can simply revise the dependency specification to include + the assertion ``foo ^>= 1.2``. + + The subtle but important difference in signaling allows tooling to + treat explicitly expressed ``<``-style constraints and inferred + (``^>=``-style) upper bounds differently. For instance, + :option:`--allow-newer`'s ``^``-modifier allows to relax only + ``^>=``-style bounds while leaving explicitly stated + ``<``-constraints unaffected. + + Ignoring the signaling intent, the default syntactic desugaring rules are - ``^>= x`` == ``>= x && < x.1`` - ``^>= x.y`` == ``>= x.y && < x.(y+1)`` @@ -1757,6 +1787,17 @@ - ``^>= x.y.z.u`` == ``>= x.y.z.u && < x.(y+1)`` - etc. + .. Note:: + + One might expected the desugaring to truncate all version + components below (and including) the patch-level, i.e. + ``^>= x.y.z.u`` == ``>= x.y.z && < x.(y+1)``, + as the major and minor version components alone are supposed to + uniquely identify the API according to the PVP_. However, by + designing ``^>=`` to be closer to the ``>=`` operator, we avoid + the potentially confusing effect of ``^>=`` being more liberal + than ``>=`` in the presence of patch-level versions. + Consequently, the example declaration above is equivalent to :: @@ -2479,6 +2520,45 @@ else Main-is: Main.hs +Common stanzas +^^^^^^^^^^^^^^ + +.. pkg-section:: common name + :synopsis: Common build info section + +Starting with Cabal-2.2 it's possible to use common build info stanzas. + +:: + + common deps + build-depends: base ^>= 4.11 + ghc-options: -Wall + + common test-deps + build-depends: tasty + + library + import: deps + exposed-modules: Foo + + test-suite tests + import: deps, test-deps + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: foo + +- You can use `build information`_ fields in common stanzas. + +- Common stanzas must be defined before use. + +- Common stanzas can import other common stanzas. + +- You can import multiple stanzas at once. Stanza names must be separated by commas. + +.. Note:: + + The name `import` was chosen, because there is ``includes`` field. + Source Repositories ^^^^^^^^^^^^^^^^^^^ diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserHackageTests.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserHackageTests.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserHackageTests.hs 2017-12-04 09:03:10.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserHackageTests.hs 2017-12-13 10:27:29.000000000 +0000 @@ -35,6 +35,7 @@ import Distribution.Compat.Lens import qualified Distribution.Types.BuildInfo.Lens as L import qualified Distribution.Types.Executable.Lens as L +import qualified Distribution.Types.ForeignLib.Lens as L import qualified Distribution.Types.GenericPackageDescription.Lens as L import qualified Distribution.Types.Library.Lens as L import qualified Distribution.Types.PackageDescription.Lens as L @@ -123,9 +124,10 @@ & L.packageDescription . L.description .~ "" & L.packageDescription . L.synopsis .~ "" & L.packageDescription . L.maintainer .~ "" - -- ReadP doesn't (always) parse sublibrary or executable names + -- ReadP doesn't (always) parse sublibrary or executable or other component names & L.condSubLibraries . traverse . _2 . traverse . L.libName .~ Nothing & L.condExecutables . traverse . _2 . traverse . L.exeName .~ fromString "" + & L.condForeignLibs . traverse . _2 . traverse . L.foreignLibName .~ fromString "" -- custom fields: no order. TODO: see if we can preserve it. & L.buildInfos . L.customFieldsBI %~ sort diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.cabal 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.cabal 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,29 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple +cabal-version: >=2.1 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common windows + if os(windows) + build-depends: Win32 + +-- Non-existing common stanza +common deps + import: windo + build-depends: + base >=4.10 && <4.11, + containers + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.errors cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.errors --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.errors 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common1.errors 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1 @@ +PError (Position 17 3) "Undefined common stanza imported: windo" diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.cabal 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.cabal 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,29 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple +cabal-version: >=2.1 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +-- Used before use +common deps + import: windows + build-depends: + base >=4.10 && <4.11, + containers + +common windows + if os(windows) + build-depends: Win32 + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.errors cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.errors --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.errors 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common2.errors 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1 @@ +PError (Position 13 3) "Undefined common stanza imported: windows" diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.cabal 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.cabal 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,31 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple +cabal-version: >=2.1 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common windows + if os(windows) + build-depends: Win32 + +common deps + import: windows + build-depends: + base >=4.10 && <4.11, + containers + +-- Duplicate +common deps + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.errors cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.errors --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.errors 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/errors/common3.errors 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1 @@ +PError (Position 22 1) "Duplicate common stanza: deps" diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.cabal 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.cabal 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,37 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple +cabal-version: >=2.1 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common win-dows + if os(windows) + build-depends: Win32 + +common deps + import: win-dows + build-depends: + base >=4.10 && <4.11, + containers + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim + +test-suite tests + import: deps, win-dows + + type: exitcode-stdio-1.0 + main-is: Tests.hs + + build-depends: + HUnit diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common2.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,38 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +cabal-version: >=2.1 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: + ElseIf + default-language: Haskell2010 + build-depends: + base >=4.10 && <4.11, + containers -any, + ghc-prim -any + + if os(windows) + build-depends: + Win32 -any + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: + base >=4.10 && <4.11, + containers -any, + HUnit -any + + if os(windows) + build-depends: + Win32 -any + + if os(windows) + build-depends: + Win32 -any \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.cabal 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.cabal 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,32 @@ +name: common +version: 0 +synopsis: Common-stanza demo demo +build-type: Simple +cabal-version: >=1.10 + +source-repository head + Type: git + Location: https://github.com/hvr/-.git + +common deps + build-depends: + base >=4.10 && <4.11, + containers + +library + import: deps + + default-language: Haskell2010 + exposed-modules: ElseIf + + build-depends: + ghc-prim + +test-suite tests + import: deps + + type: exitcode-stdio-1.0 + main-is: Tests.hs + + build-depends: + HUnit diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/common.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,25 @@ +PWarning PWTUnknownField (Position 26 3) "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" +PWarning PWTUnknownField (Position 17 3) "Unknown field: import. You should set cabal-version: 2.2 or larger to use common stanzas" +PWarning PWTUnknownSection (Position 11 1) "Ignoring section: common. You should set cabal-version: 2.2 or larger to use common stanzas." +name: common +version: 0 +synopsis: Common-stanza demo demo +cabal-version: >=1.10 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: + ElseIf + default-language: Haskell2010 + build-depends: + ghc-prim -any + +test-suite tests + type: exitcode-stdio-1.0 + main-is: Tests.hs + build-depends: + HUnit -any \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif2.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif2.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif2.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif2.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,25 @@ +name: elif +version: 0 +synopsis: The elif demo +cabal-version: >=2.1 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: + ElseIf + default-language: Haskell2010 + + if os(linux) + build-depends: + unix -any + else + + if os(windows) + build-depends: + Win32 -any + else + buildable: False \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/elif.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,20 @@ +PWarning PWTInvalidSubsection (Position 19 3) "invalid subsection \"else\"" +PWarning PWTInvalidSubsection (Position 17 3) "invalid subsection \"elif\". You should set cabal-version: 2.2 or larger to use elif-conditionals." +name: elif +version: 0 +synopsis: The elif demo +cabal-version: >=1.10 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +library + exposed-modules: + ElseIf + default-language: Haskell2010 + + if os(linux) + build-depends: + unix -any \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.cabal 2017-12-04 09:03:10.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.cabal 2017-12-13 10:27:29.000000000 +0000 @@ -1,10 +1,11 @@ Name: encoding Version: 0.8 +cabal-version: >=1.12 custom-setup -  setup-depends: + setup-depends: base < 5, -    ghc-prim + ghc-prim Library -- version range round trip is better diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/encoding-0.8.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,14 @@ +name: encoding +version: 0.8 +cabal-version: >=1.12 + +custom-setup + setup-depends: base <5, + ghc-prim -any + +library + exposed-modules: + Data.Encoding + ghc-options: -Wall -O2 -threaded -rtsopts "-with-rtsopts=-N1 -A64m" + build-depends: + base (>4.4 || ==4.4) \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/generics-sop.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/generics-sop.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/generics-sop.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/generics-sop.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,121 @@ +name: generics-sop +version: 0.3.1.0 +license: BSD3 +license-file: LICENSE +maintainer: andres@well-typed.com +author: Edsko de Vries , Andres Löh +tested-with: ghc ==7.8.4 ghc ==7.10.3 ghc ==8.0.1 ghc ==8.0.2 + ghc ==8.2.1 ghc ==8.3.* +synopsis: Generic Programming using True Sums of Products +description: + A library to support the definition of generic functions. + Datatypes are viewed in a uniform, structured way: + the choice between constructors is represented using an n-ary + sum, and the arguments of each constructor are represented using + an n-ary product. + . + The module "Generics.SOP" is the main module of this library and contains + more detailed documentation. + . + Examples of using this library are provided by the following + packages: + . + * @@ basic examples, + . + * @@ generic pretty printing, + . + * @@ generically computed lenses, + . + * @@ generic JSON conversions. + . + A detailed description of the ideas behind this library is provided by + the paper: + . + * Edsko de Vries and Andres Löh. + . + Workshop on Generic Programming (WGP) 2014. + . +category: Generics +cabal-version: >=1.10 +build-type: Custom +extra-source-files: + CHANGELOG.md + +source-repository head + type: git + location: https://github.com/well-typed/generics-sop + +custom-setup + setup-depends: base -any, + Cabal -any, + cabal-doctest >=1.0.2 && <1.1 + +library + exposed-modules: + Generics.SOP + Generics.SOP.GGP + Generics.SOP.TH + Generics.SOP.Dict + Generics.SOP.Type.Metadata + Generics.SOP.BasicFunctors + Generics.SOP.Classes + Generics.SOP.Constraint + Generics.SOP.Instances + Generics.SOP.Metadata + Generics.SOP.NP + Generics.SOP.NS + Generics.SOP.Universe + Generics.SOP.Sing + hs-source-dirs: src + default-language: Haskell2010 + default-extensions: CPP ScopedTypeVariables TypeFamilies RankNTypes + TypeOperators GADTs ConstraintKinds MultiParamTypeClasses + TypeSynonymInstances FlexibleInstances FlexibleContexts + DeriveFunctor DeriveFoldable DeriveTraversable DefaultSignatures + KindSignatures DataKinds FunctionalDependencies + other-extensions: OverloadedStrings PolyKinds UndecidableInstances + TemplateHaskell DeriveGeneric StandaloneDeriving + ghc-options: -Wall + build-depends: + base >=4.7 && <5, + template-haskell >=2.8 && <2.13, + ghc-prim >=0.3 && <0.6, + deepseq >=1.3 && <1.5 + + if !impl(ghc >=7.8) + build-depends: + tagged >=0.7 && <0.9 + + if !impl(ghc >=8.0) + build-depends: + transformers-compat >=0.3 && <0.6, + transformers >=0.3 && <0.6 + + if impl(ghc >=7.8) + default-extensions: AutoDeriveTypeable + + if impl(ghc <7.10) + other-extensions: OverlappingInstances + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: test + default-language: Haskell2010 + ghc-options: -Wall -threaded + x-doctest-options: --preserve-it + build-depends: + base -any, + doctest >=0.13 && <0.14 + +test-suite generics-sop-examples + type: exitcode-stdio-1.0 + main-is: Example.hs + hs-source-dirs: test + other-modules: + HTransExample + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base >=4.6 && <5, + generics-sop -any \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/issue-774.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/issue-774.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/issue-774.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/issue-774.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,19 @@ +name: issue +version: 744 +synopsis: Package description parser interprets curly braces in the description field +description: + Here is some C code: + . + > for(i = 0; i < 100; i++) { + > printf("%d\n",i); + > } + . + What does it look like? +cabal-version: >=1.10 +build-type: Simple + +library + exposed-modules: + Issue + default-language: Haskell2010 + ghc-options: -Wall -threaded "-with-rtsopts=-N -s -M1G -c" -rtsopts \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/nothing-unicode.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/nothing-unicode.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/nothing-unicode.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/nothing-unicode.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,22 @@ +name: 無 +version: 0 +synopsis: The canonical non-package 無 +x-無: 無 +cabal-version: >=1.10 +build-type: Simple + +source-repository head + type: git + location: https://github.com/hvr/-.git + +flag 無 + description: + 無 + +library + exposed-modules: + Ω + default-language: Haskell2010 + + if !flag(無) + buildable: False \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/Octree-0.5.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/Octree-0.5.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/Octree-0.5.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/Octree-0.5.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,54 @@ +PWarning PWTLexNBSP (Position 43 3) "Non-breaking space found" +PWarning PWTLexNBSP (Position 41 3) "Non-breaking space found" +PWarning PWTLexNBSP (Position 39 3) "Non-breaking space found" +name: Octree +version: 0.5 +license: BSD3 +license-file: LICENSE +copyright: Copyright by Michal J. Gajda '2012 +maintainer: mjgajda@googlemail.com +author: Michal J. Gajda +stability: beta +tested-with: ghc ==7.0.4 ghc ==7.4.1 ghc ==7.4.2 ghc ==7.6.0 +homepage: https://github.com/mgajda/octree +package-url: http://hackage.haskell.org/package/octree +bug-reports: mailto:mjgajda@googlemail.com +synopsis: Simple unbalanced Octree for storing data about 3D points +description: + Octree data structure is relatively shallow data structure for space partitioning. +category: Data +cabal-version: >=1.8 +build-type: Simple + +source-repository head + type: git + location: git@github.com:mgajda/octree.git + +library + exposed-modules: + Data.Octree + other-modules: + Data.Octree.Internal + extensions: ScopedTypeVariables + build-depends: + base >=4.0 && <4.7, + AC-Vector >=2.3.0, + QuickCheck >=2.4.0 + +test-suite test_Octree + type: exitcode-stdio-1.0 + main-is: tests/test_Octree.hs + build-depends: + base >=4.0 && <4.7, + AC-Vector >=2.3.0, + QuickCheck >=2.4.0 + +test-suite readme + type: exitcode-stdio-1.0 + main-is: README.lhs + ghc-options: -pgmL markdown-unlit + build-depends: + base >=4.0 && <4.7, + AC-Vector >=2.3.0, + QuickCheck >=2.4.0, + markdown-unlit -any \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/shake.format cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/shake.format --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests/regressions/shake.format 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests/regressions/shake.format 2017-12-13 10:27:29.000000000 +0000 @@ -0,0 +1,418 @@ +name: shake +version: 0.15.11 +license: BSD3 +license-file: LICENSE +copyright: Neil Mitchell 2011-2017 +maintainer: Neil Mitchell +author: Neil Mitchell +tested-with: ghc ==8.0.1 ghc ==7.10.3 ghc ==7.8.4 ghc ==7.6.3 + ghc ==7.4.2 +homepage: http://shakebuild.com +bug-reports: https://github.com/ndmitchell/shake/issues +synopsis: Build system library, like Make, but more accurate dependencies. +description: + Shake is a Haskell library for writing build systems - designed as a + replacement for @make@. See "Development.Shake" for an introduction, + including an example. Further examples are included in the Cabal tarball, + under the @Examples@ directory. The homepage contains links to a user + manual, an academic paper and further information: + + . + To use Shake the user writes a Haskell program + that imports "Development.Shake", defines some build rules, and calls + the 'Development.Shake.shakeArgs' function. Thanks to do notation and infix + operators, a simple Shake build system + is not too dissimilar from a simple Makefile. However, as build systems + get more complex, Shake is able to take advantage of the excellent + abstraction facilities offered by Haskell and easily support much larger + projects. The Shake library provides all the standard features available in other + build systems, including automatic parallelism and minimal rebuilds. + Shake also provides more accurate dependency tracking, including seamless + support for generated files, and dependencies on system information + (e.g. compiler version). +category: Development, Shake +cabal-version: >=1.18 +build-type: Simple +data-files: + html/viz.js + html/profile.html + html/progress.html + html/shake.js + docs/manual/build.bat + docs/manual/Build.hs + docs/manual/build.sh + docs/manual/constants.c + docs/manual/constants.h + docs/manual/main.c +extra-source-files: + src/Test/C/constants.c + src/Test/C/constants.h + src/Test/C/main.c + src/Test/MakeTutor/Makefile + src/Test/MakeTutor/hellofunc.c + src/Test/MakeTutor/hellomake.c + src/Test/MakeTutor/hellomake.h + src/Test/Tar/list.txt + src/Test/Ninja/*.ninja + src/Test/Ninja/subdir/*.ninja + src/Test/Ninja/*.output + src/Test/Progress/*.prog + src/Test/Tup/hello.c + src/Test/Tup/root.cfg + src/Test/Tup/newmath/root.cfg + src/Test/Tup/newmath/square.c + src/Test/Tup/newmath/square.h + src/Paths.hs + docs/Manual.md + docs/shake-progress.png +extra-doc-files: CHANGES.txt + README.md + +source-repository head + type: git + location: https://github.com/ndmitchell/shake.git + +flag portable + description: + Obtain FileTime using portable functions + default: False + manual: True + +library + exposed-modules: + Development.Shake + Development.Shake.Classes + Development.Shake.Command + Development.Shake.Config + Development.Shake.FilePath + Development.Shake.Forward + Development.Shake.Rule + Development.Shake.Util + hs-source-dirs: src + other-modules: + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Core + Development.Shake.CmdOption + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePattern + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + default-language: Haskell2010 + build-depends: + base >=4.5, + directory -any, + hashable >=1.1.2.3, + binary -any, + filepath -any, + process >=1.1, + unordered-containers >=0.2.1, + bytestring -any, + utf8-string >=0.3, + time -any, + random -any, + js-jquery -any, + js-flot -any, + transformers >=0.2, + extra >=1.4.8, + deepseq >=1.1 + + if flag(portable) + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + build-depends: + old-time -any + else + + if !os(windows) + build-depends: + unix >=2.5.1 + + if !os(windows) + build-depends: + unix -any + +executable shake + main-is: Run.hs + scope: unknown + hs-source-dirs: src + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + default-language: Haskell2010 + ghc-options: -main-is Run.main -rtsopts + build-depends: + base ==4.*, + directory -any, + hashable >=1.1.2.3, + binary -any, + filepath -any, + process >=1.1, + unordered-containers >=0.2.1, + bytestring -any, + utf8-string >=0.3, + time -any, + random -any, + js-jquery -any, + js-flot -any, + transformers >=0.2, + extra >=1.4.8, + deepseq >=1.1, + primitive -any + + if impl(ghc >=7.8) + scope: unknown + ghc-options: -threaded "-with-rtsopts=-I0 -qg -qb" + + if flag(portable) + scope: unknown + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + scope: unknown + build-depends: + old-time -any + else + scope: unknown + + if !os(windows) + scope: unknown + build-depends: + unix >=2.5.1 + + if !os(windows) + scope: unknown + build-depends: + unix -any + +test-suite shake-test + type: exitcode-stdio-1.0 + main-is: Test.hs + hs-source-dirs: src + other-modules: + Development.Make.All + Development.Make.Env + Development.Make.Parse + Development.Make.Rules + Development.Make.Type + Development.Ninja.All + Development.Ninja.Env + Development.Ninja.Lexer + Development.Ninja.Parse + Development.Ninja.Type + Development.Shake + Development.Shake.Args + Development.Shake.ByteString + Development.Shake.Classes + Development.Shake.CmdOption + Development.Shake.Command + Development.Shake.Config + Development.Shake.Core + Development.Shake.Database + Development.Shake.Demo + Development.Shake.Derived + Development.Shake.Errors + Development.Shake.FileInfo + Development.Shake.FilePath + Development.Shake.FilePattern + Development.Shake.Forward + Development.Shake.Monad + Development.Shake.Pool + Development.Shake.Profile + Development.Shake.Progress + Development.Shake.Resource + Development.Shake.Rule + Development.Shake.Rules.Directory + Development.Shake.Rules.File + Development.Shake.Rules.Files + Development.Shake.Rules.Oracle + Development.Shake.Rules.OrderOnly + Development.Shake.Rules.Rerun + Development.Shake.Shake + Development.Shake.Special + Development.Shake.Storage + Development.Shake.Types + Development.Shake.Util + Development.Shake.Value + General.Bilist + General.Binary + General.Cleanup + General.Concurrent + General.Extra + General.FileLock + General.Intern + General.Process + General.String + General.Template + General.Timing + Paths_shake + Run + Test.Assume + Test.Basic + Test.Benchmark + Test.C + Test.Cache + Test.Command + Test.Config + Test.Digest + Test.Directory + Test.Docs + Test.Errors + Test.FileLock + Test.FilePath + Test.FilePattern + Test.Files + Test.Forward + Test.Journal + Test.Lint + Test.Live + Test.Makefile + Test.Manual + Test.Match + Test.Monad + Test.Ninja + Test.Oracle + Test.OrderOnly + Test.Parallel + Test.Pool + Test.Progress + Test.Random + Test.Resources + Test.Self + Test.Tar + Test.Tup + Test.Type + Test.Unicode + Test.Util + Test.Verbosity + Test.Version + default-language: Haskell2010 + ghc-options: -main-is Test.main -rtsopts + build-depends: + base ==4.*, + directory -any, + hashable >=1.1.2.3, + binary -any, + filepath -any, + process >=1.1, + unordered-containers >=0.2.1, + bytestring -any, + utf8-string >=0.3, + time -any, + random -any, + js-jquery -any, + js-flot -any, + transformers >=0.2, + deepseq >=1.1, + extra >=1.4.8, + QuickCheck >=2.0 + + if impl(ghc >=7.6) + ghc-options: -with-rtsopts=-K1K + + if impl(ghc >=7.8) + ghc-options: -threaded + + if flag(portable) + cpp-options: -DPORTABLE + + if impl(ghc <7.6) + build-depends: + old-time -any + else + + if !os(windows) + build-depends: + unix >=2.5.1 + + if !os(windows) + build-depends: + unix -any \ No newline at end of file diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/Cabal-2.1.0.0/tests/ParserTests.hs 2017-12-04 09:03:10.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/Cabal-2.1.0.0/tests/ParserTests.hs 2017-12-13 10:27:29.000000000 +0000 @@ -27,8 +27,9 @@ tests :: TestTree tests = testGroup "parsec tests" - [ warningTests - , regressionTests + [ regressionTests + , warningTests + , errorTests ] ------------------------------------------------------------------------------- @@ -70,6 +71,33 @@ _ -> assertFailure $ "got multiple warnings: " ++ show warns ------------------------------------------------------------------------------- +-- Errors +------------------------------------------------------------------------------- + +errorTests :: TestTree +errorTests = testGroup "errors" + [ errorTest "common1.cabal" + , errorTest "common2.cabal" + , errorTest "common3.cabal" + ] + +errorTest :: FilePath -> TestTree +errorTest fp = cabalGoldenTest "errors" correct $ do + contents <- BS.readFile input + let res = parseGenericPackageDescription contents + let (_, errs, x) = runParseResult res + + return $ toUTF8BS $ case x of + Just gpd | null errs -> + "UNXPECTED SUCCESS\n" ++ + showGenericPackageDescription gpd + _ -> + unlines $ map show errs + where + input = "tests" "ParserTests" "errors" fp + correct = replaceExtension input "errors" + +------------------------------------------------------------------------------- -- Regressions ------------------------------------------------------------------------------- @@ -83,6 +111,8 @@ , regressionTest "elif.cabal" , regressionTest "elif2.cabal" , regressionTest "shake.cabal" + , regressionTest "common.cabal" + , regressionTest "common2.cabal" ] regressionTest :: FilePath -> TestTree @@ -95,11 +125,12 @@ formatGoldenTest fp = cabalGoldenTest "format" correct $ do contents <- BS.readFile input let res = parseGenericPackageDescription contents - let (_, errs, x) = runParseResult res + let (warns, errs, x) = runParseResult res return $ toUTF8BS $ case x of Just gpd | null errs -> - showGenericPackageDescription gpd + unlines (map show warns) + ++ showGenericPackageDescription gpd _ -> unlines $ "ERROR" : map show errs where diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/bootstrap.sh cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/bootstrap.sh --- cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/bootstrap.sh 2017-12-04 09:03:18.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/bootstrap.sh 2017-12-13 10:27:35.000000000 +0000 @@ -227,29 +227,29 @@ esac -TEXT_VER="1.2.2.1"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" +TEXT_VER="1.2.2.2"; TEXT_VER_REGEXP="((1\.[012]\.)|(0\.([2-9]|(1[0-1]))\.))" # >= 0.2 && < 1.3 -NETWORK_VER="2.6.3.1"; NETWORK_VER_REGEXP="2\.[0-6]\." +NETWORK_VER="2.6.3.2"; NETWORK_VER_REGEXP="2\.[0-6]\." # >= 2.0 && < 2.7 NETWORK_URI_VER="2.6.1.0"; NETWORK_URI_VER_REGEXP="2\.6\." # >= 2.6 && < 2.7 -CABAL_VER="2.1.0.0"; CABAL_VER_REGEXP="2\.1\.[0-9]" +CABAL_VER="2.1.0.0"; CABAL_VER_REGEXP="2\.1\.[0-9]" # >= 2.1 && < 2.2 -TRANS_VER="0.5.2.0"; TRANS_VER_REGEXP="0\.[45]\." +TRANS_VER="0.5.5.0"; TRANS_VER_REGEXP="0\.[45]\." # >= 0.2.* && < 0.6 MTL_VER="2.2.1"; MTL_VER_REGEXP="[2]\." # >= 2.0 && < 3 -HTTP_VER="4000.3.3"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" +HTTP_VER="4000.3.8"; HTTP_VER_REGEXP="4000\.(2\.([5-9]|1[0-9]|2[0-9])|3\.?)" # >= 4000.2.5 < 4000.4 ZLIB_VER="0.6.1.2"; ZLIB_VER_REGEXP="(0\.5\.([3-9]|1[0-9])|0\.6)" # >= 0.5.3 && <= 0.7 -TIME_VER="1.7" TIME_VER_REGEXP="1\.[1-7]\.?" - # >= 1.1 && < 1.8 +TIME_VER="1.8.0.3" TIME_VER_REGEXP="1\.[1-8]\.?" + # >= 1.1 && < 1.9 RANDOM_VER="1.1" RANDOM_VER_REGEXP="1\.[01]\.?" # >= 1 && < 1.2 STM_VER="2.4.4.1"; STM_VER_REGEXP="2\." # == 2.* -ASYNC_VER="2.1.0"; ASYNC_VER_REGEXP="2\." +ASYNC_VER="2.1.1.1"; ASYNC_VER_REGEXP="2\." # 2.* OLD_TIME_VER="1.1.0.3"; OLD_TIME_VER_REGEXP="1\.[01]\.?" # >=1.0.0.0 && <1.2 @@ -259,11 +259,11 @@ # 0.1.* BASE64_BYTESTRING_VER="1.0.0.1"; BASE64_BYTESTRING_VER_REGEXP="1\." # >=1.0 -CRYPTOHASH_SHA256_VER="0.11.100.1"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" +CRYPTOHASH_SHA256_VER="0.11.101.0"; CRYPTOHASH_SHA256_VER_REGEXP="0\.11\.?" # 0.11.* -RESOLV_VER="0.1.1.0"; RESOLV_VER_REGEXP="0\.1\.[1-9]" +RESOLV_VER="0.1.1.1"; RESOLV_VER_REGEXP="0\.1\.[1-9]" # >= 0.1.1 && < 0.2 -MINTTY_VER="0.1"; MINTTY_VER_REGEXP="0\.1\.?" +MINTTY_VER="0.1.1"; MINTTY_VER_REGEXP="0\.1\.?" # 0.1.* ECHO_VER="0.1.3"; ECHO_VER_REGEXP="0\.1\.[3-9]" # >= 0.1.3 && < 0.2 @@ -276,7 +276,7 @@ BYTESTRING_BUILDER_VER="0.10.8.1.0"; BYTESTRING_BUILDER_VER_REGEXP="0\.10\.?" TAR_VER="0.5.0.3"; TAR_VER_REGEXP="0\.5\.([1-9]|1[0-9]|0\.[3-9]|0\.1[0-9])\.?" # >= 0.5.0.3 && < 0.6 -HASHABLE_VER="1.2.4.0"; HASHABLE_VER_REGEXP="1\." +HASHABLE_VER="1.2.6.1"; HASHABLE_VER_REGEXP="1\." # 1.* HACKAGE_URL="https://hackage.haskell.org/package" diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/changelog cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/changelog --- cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/changelog 2017-12-04 09:03:18.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/changelog 2017-12-13 10:27:35.000000000 +0000 @@ -39,7 +39,7 @@ build-tools and build-tool-depends dependencies in the solver (#4884). -2.0.0.1 Mikhail Glushenkov October 2017 +2.0.0.1 Mikhail Glushenkov December 2017 * Support for GHC's numeric -g debug levels (#4673). * Demoted 'scope' field version check to a warning (#4714). * Fixed verbosity flags getting removed before being passed to diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/DistDirLayout.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/DistDirLayout.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/DistDirLayout.hs 2017-12-04 09:03:17.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/DistDirLayout.hs 2017-12-13 10:27:34.000000000 +0000 @@ -2,7 +2,7 @@ -- | -- --- The layout of the .\/dist\/ directory where cabal keeps all of it's state +-- The layout of the .\/dist\/ directory where cabal keeps all of its state -- and build artifacts. -- module Distribution.Client.DistDirLayout ( diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/PackageHash.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/PackageHash.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/PackageHash.hs 2017-12-04 09:03:17.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/PackageHash.hs 2017-12-13 10:27:34.000000000 +0000 @@ -136,7 +136,7 @@ -- | On macOS we shorten the name very aggressively. The mach-o linker on -- macOS has a limited load command size, to which the name of the lirbary --- as well as it's relative path (\@rpath) entry count. To circumvent this, +-- as well as its relative path (\@rpath) entry count. To circumvent this, -- on macOS the libraries are not stored as -- @store//libHS.dylib@ -- where libraryname contains the librarys name, version and abi hash, but in diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/Types.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/Types.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/Types.hs 2017-12-04 09:03:17.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/Types.hs 2017-12-13 10:27:34.000000000 +0000 @@ -147,11 +147,11 @@ -- | A ConfiguredId is a package ID for a configured package. -- --- Once we configure a source package we know it's UnitId. It is still +-- Once we configure a source package we know its UnitId. It is still -- however useful in lots of places to also know the source ID for the package. -- We therefore bundle the two. -- --- An already installed package of course is also "configured" (all it's +-- An already installed package of course is also "configured" (all its -- configuration parameters and dependencies have been specified). data ConfiguredId = ConfiguredId { confSrcId :: PackageId diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/Win32SelfUpgrade.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/Win32SelfUpgrade.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/cabal-install-2.1.0.0/Distribution/Client/Win32SelfUpgrade.hs 2017-12-04 09:03:17.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/cabal-install-2.1.0.0/Distribution/Client/Win32SelfUpgrade.hs 2017-12-13 10:27:34.000000000 +0000 @@ -17,7 +17,7 @@ -- | Windows inherited a design choice from DOS that while initially innocuous -- has rather unfortunate consequences. It maintains the invariant that every -- open file has a corresponding name on disk. One positive consequence of this --- is that an executable can always find it's own executable file. The downside +-- is that an executable can always find its own executable file. The downside -- is that a program cannot be deleted or upgraded while it is running without -- hideous workarounds. This module implements one such hideous workaround. -- diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/CHANGES cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/CHANGES --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/CHANGES 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/CHANGES 1970-01-01 00:00:00.000000000 +0000 @@ -1,119 +0,0 @@ - * If the URI contains "user:pass@" part, use it for Basic Authorization - * Add a test harness. - * Don't leak a socket when getHostAddr throws an exception. - * Send cookies in request format, not response format. - * Moved BrowserAction to be a StateT IO, with instances for - Applicative, MonadIO, MonadState. - * Add method to control size of connection pool. - * Consider both host and port when reusing connections. - * Handle response code 304 "not modified" properly. - * Fix digest authentication by fixing md5 output string rep. - * Make the default user agent string follow the package version. - * Document lack of HTTPS support and fail when clients try - to use it instead of silently falling back to HTTP. - * Add helper to set the request type and body. - -Version 4000.1.2: release 2011-08-11 - * Turn off buffering for the debug log. - * Update installation instructions. - * Bump base dependency to support GHC 7.2. - -Version 4000.1.1: release 2010-11-28 - * Be tolerant of LF (instead of CRLF which is the spec) in responses. - -Version 4000.1.0: release 2010-11-09 - * Retroactively fixed CHANGES to refer to 4000.x.x instead of - 4004.x.x. - * Fix problem with close looping on certain URLs due to trying - to munch the rest of the stream even on EOF. Modified from - a fix by Daniel Wagner. - * This involves a new class member for HStream and is thus an - API change, but one that will only affect clients that - define their own payload type to replace String/ByteString. - * Applied patch by Antoine Latter to fix problem with 301 and 307 - redirects. - -Version 4000.0.10: release 2010-10-29 - * Bump base dependency to support GHC 7.0. - * Stop using 'fail' from the Either monad and instead build Left - values explicitly; the behaviour of fail is changing in GHC 7.0 - and this avoids being sensitive to the change. - -Version 4000.0.9: release 2009-12-20 - - * Export headerMap from Network.HTTP.Headers - (suggested by David Leuschner.) - * Fix Network.TCP.{isTCPConnectedTo,isConnectedTo} to be useful. - * Always delay closing non-persistent connections until we reach EOF. - Delaying it until then is vital when reading the response out as a - lazy ByteString; all of the I/O may not have happened by the time we - were returning the HTTP response. Bug manifested itself occasionally - with larger responses. Courtesy of Valery Vorotyntsev; both untiring bug - hunt and fix. - * drop unused type argument from Network.Browser.BrowserEvent; needlessly general. - (patch provided by Daniel Wagner.) - -Version 4000.0.8: release 2009-08-05 - - * Incorporated proxy setting lookup and parsing contribution - by Eric Kow; provided in Network.HTTP.Proxy - * Factor out HTTP Cookies and Auth handling into separate - modules Network.HTTP.Cookie, Network.HTTP.Auth - * new Network.Browser functionality for hooking up the - proxy detection code in Network.HTTP.Proxy: - - setCheckForProxy :: Bool -> BrowserAction t () - getCheckForProxy :: BrowserAction t Bool - - If you do 'setCheckForProxy True' within a browser - session, the proxy-checking code will be called upon. - Use 'getCheckForProxy' to get the current setting for - this flag. - - * Network.Browser: if HTTP Basic Auth is allowed and - server doesn't 401-challenge with an WWW-Authenticate: - header, simply assume / realm and proceed. Preferable - than failing, even if server is the wrong. - -Version 4000.0.7: release 2009-05-22 - - * Minor release. - * Added - Network.TCP.openSocketStream :: (BufferType t) - => String {-host-} - -> Socket - -> IO (HandleStream t) - - for interfacing to pre-existing @Socket@s. Contributed and - suggested by . - -Version 4000.0.6: release 2009-04-21; changes from 4000.0.5 - - * Network.Browser: use HTTP.HandleStream.sendHTTP_notify, not HTTP.sendHTTP_notify - when issuing requests. The latter runs the risk of undoing request normalization. - * Network.HTTP.Base.normalizeRequest: when normalizing proxy-bound requests, - insert a Host: header if none present. Set it to the destination server authority, - not the proxy. - * Network.Browser: don't fail on seeing invalid cookie values, but report them - as errors and continue. - -Version 4000.0.5: release 2009-03-30; changes from 4000.0.4 - - * Get serious about comments and Haddock documentation. - * Cleaned up normalization of requests, fixing bugs and bringing together - previous disparate attempts at handling this. - * RequestMethod now supports custom verbs; use the (Custom String) constructor - * Beef up Network.HTTP.Base's support for normalizing requests and URIs: - - * added splitRequestURI which divides a URI into two; the Authority portion - (as a String) and the input URI sans the authority portion. Useful when - wanting to split up a request's URI into its Host: and abs_path pieces. - * added normalizeRequest :: Bool -> Request ty -> Request ty, which - fixes up a requests URI path and Host: info depending on whether it is - destined for a proxy or not (controlled by the Bool.) - * moved defaultRequest, defaultRequest_, libUA from Network.Browser - to Network.HTTP.Base - * added mkRequest :: RequestMethod -> URI -> Bool -> Request ty - for constructing normalized&sane Request bases on top of which - you can add custom headers, body payload etc. - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/HTTP.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/HTTP.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/HTTP.cabal 2017-12-04 09:03:40.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/HTTP.cabal 1970-01-01 00:00:00.000000000 +0000 @@ -1,182 +0,0 @@ -Name: HTTP -Version: 4000.3.8 -Cabal-Version: >= 1.8 -Build-type: Simple -License: BSD3 -License-file: LICENSE -Author: Warrick Gray -Maintainer: Ganesh Sittampalam -Homepage: https://github.com/haskell/HTTP -Category: Network -Synopsis: A library for client-side HTTP -Description: - - The HTTP package supports client-side web programming in Haskell. It lets you set up - HTTP connections, transmitting requests and processing the responses coming back, all - from within the comforts of Haskell. It's dependent on the network package to operate, - but other than that, the implementation is all written in Haskell. - . - A basic API for issuing single HTTP requests + receiving responses is provided. On top - of that, a session-level abstraction is also on offer (the @BrowserAction@ monad); - it taking care of handling the management of persistent connections, proxies, - state (cookies) and authentication credentials required to handle multi-step - interactions with a web server. - . - The representation of the bytes flowing across is extensible via the use of a type class, - letting you pick the representation of requests and responses that best fits your use. - Some pre-packaged, common instances are provided for you (@ByteString@, @String@). - . - Here's an example use: - . - > - > do - > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/") - > -- fetch document and return it (as a 'String'.) - > fmap (take 100) (getResponseBody rsp) - > - > do - > (_, rsp) - > <- Network.Browser.browse $ do - > setAllowRedirects True -- handle HTTP redirects - > request $ getRequest "http://www.haskell.org/" - > return (take 100 (rspBody rsp)) - . - __Note:__ This package does not support HTTPS connections. - If you need HTTPS, take a look at the following packages: - . - * - . - * (in combination with - ) - . - * - . - * - . - -Extra-Source-Files: CHANGES - -Source-Repository head - type: git - location: https://github.com/haskell/HTTP.git - -Flag mtl1 - description: Use the old mtl version 1. - default: False - -Flag warn-as-error - default: False - description: Build with warnings-as-errors - manual: True - -Flag network23 - description: Use version 2.3.x or below of the network package - default: False - -Flag conduit10 - description: Use version 1.0.x or below of the conduit package (for the test suite) - default: False - -Flag warp-tests - description: Test against warp - default: True - manual: True - -flag network-uri - description: Get Network.URI from the network-uri package - default: True - -Library - Exposed-modules: - Network.BufferType, - Network.Stream, - Network.StreamDebugger, - Network.StreamSocket, - Network.TCP, - Network.HTTP, - Network.HTTP.Headers, - Network.HTTP.Base, - Network.HTTP.Stream, - Network.HTTP.Auth, - Network.HTTP.Cookie, - Network.HTTP.Proxy, - Network.HTTP.HandleStream, - Network.Browser - Other-modules: - Network.HTTP.Base64, - Network.HTTP.MD5Aux, - Network.HTTP.Utils - Paths_HTTP - GHC-options: -fwarn-missing-signatures -Wall - - -- note the test harness constraints should be kept in sync with these - -- where dependencies are shared - Build-depends: base >= 4.3.0.0 && < 4.11, parsec >= 2.0 && < 3.2 - Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.11 - Build-depends: time >= 1.1.2.3 && < 1.9 - - Extensions: FlexibleInstances - - if flag(mtl1) - Build-depends: mtl >= 1.1.1.0 && < 1.2 - CPP-Options: -DMTL1 - else - Build-depends: mtl >= 2.0 && < 2.3 - - if flag(network-uri) - Build-depends: network-uri == 2.6.*, network == 2.6.* - else - Build-depends: network >= 2.2.1.8 && < 2.6 - - if flag(warn-as-error) - ghc-options: -Werror - - if os(windows) - Build-depends: Win32 >= 2.2.0.0 && < 2.6 - -Test-Suite test - type: exitcode-stdio-1.0 - - hs-source-dirs: test - main-is: httpTests.hs - - other-modules: - Httpd - UnitTests - - -- 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.11, - deepseq >= 1.3.0.0 && < 1.5, - pureMD5 >= 0.2.4 && < 2.2, - base >= 4.3.0.0 && < 4.11, - 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.* - else - Build-depends: network >= 2.2.1.5 && < 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.3 - - if flag(conduit10) - build-depends: - conduit >= 1.0.8 && < 1.1 - else - build-depends: - conduit >= 1.1 && < 1.3, - conduit-extra >= 1.1 && < 1.2 - - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/LICENSE cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/LICENSE --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/LICENSE 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/LICENSE 1970-01-01 00:00:00.000000000 +0000 @@ -1,46 +0,0 @@ -Copyright (c) 2002, Warrick Gray -Copyright (c) 2002-2005, Ian Lynagh -Copyright (c) 2003-2006, Bjorn Bringert -Copyright (c) 2004, Andre Furtado -Copyright (c) 2004-2005, Dominic Steinitz -Copyright (c) 2007, Robin Bate Boerop -Copyright (c) 2008-2010, Sigbjorn Finne -Copyright (c) 2009, Eric Kow -Copyright (c) 2010, Antoine Latter -Copyright (c) 2004, 2010-2011, Ganesh Sittampalam -Copyright (c) 2011, Duncan Coutts -Copyright (c) 2011, Matthew Gruen -Copyright (c) 2011, Jeremy Yallop -Copyright (c) 2011, Eric Hesselink -Copyright (c) 2011, Yi Huang -Copyright (c) 2011, Tom Lokhorst - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * The names of contributors may not be used to endorse or promote - products derived from this software without specific prior - written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/Browser.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/Browser.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/Browser.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/Browser.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,1091 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} -{- | - -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 -HTTP. Additional features supported are: - -* HTTP Authentication handling - -* Transparent handling of redirects - -* Cookie stores + transmission. - -* Transaction logging - -* Proxy-mediated connections. - -Example use: - -> do -> (_, rsp) -> <- Network.Browser.browse $ do -> setAllowRedirects True -- handle HTTP redirects -> request $ getRequest "http://www.haskell.org/" -> return (take 100 (rspBody rsp)) - --} -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 - , addAuthority - , Challenge(..) - , Qop(..) - , Algorithm(..) - - , getAuthorityGen - , setAuthorityGen - , setAllowBasicAuth - , getAllowBasicAuth - - , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () - , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) - - , setMaxPoolSize -- :: Int -> BrowserAction t () - , getMaxPoolSize -- :: BrowserAction t (Maybe Int) - - , setMaxAuthAttempts -- :: Maybe Int -> BrowserAction t () - , getMaxAuthAttempts -- :: BrowserAction t (Maybe Int) - - , setCookieFilter -- :: (URI -> Cookie -> IO Bool) -> BrowserAction t () - , 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 - - , setCheckForProxy -- :: Bool -> BrowserAction t () - , 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 - ) where - -import Network.URI - ( URI(..) - , URIAuth(..) - , parseURI, parseURIReference, relativeTo - ) -import Network.StreamDebugger (debugByteStream) -import Network.HTTP hiding ( sendHTTP_notify ) -import Network.HTTP.HandleStream ( sendHTTP_notify ) -import Network.HTTP.Auth -import Network.HTTP.Cookie -import Network.HTTP.Proxy - -import Network.Stream ( ConnError(..), Result ) -import Network.BufferType - -import Data.Char (toLower) -import Data.List (isPrefixOf) -import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) -import Control.Applicative (Applicative (..), (<$>)) -#ifdef MTL1 -import Control.Monad (filterM, forM_, when, ap) -#else -import Control.Monad (filterM, forM_, when) -#endif -import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..)) - -import qualified System.IO - ( hSetBuffering, hPutStr, stdout, stdin, hGetChar - , BufferMode(NoBuffering, LineBuffering) - ) -import Data.Time.Clock ( UTCTime, getCurrentTime ) - - ------------------------------------------------------------------- ------------------------ Cookie Stuff ----------------------------- ------------------------------------------------------------------- - --- | @defaultCookieFilter@ is the initial cookie acceptance filter. --- It welcomes them all into the store @:-)@ -defaultCookieFilter :: URI -> Cookie -> IO Bool -defaultCookieFilter _url _cky = return True - --- | @userCookieFilter@ is a handy acceptance filter, asking the --- user if he/she is willing to accept an incoming cookie before --- adding it to the store. -userCookieFilter :: URI -> Cookie -> IO Bool -userCookieFilter url cky = do - do putStrLn ("Set-Cookie received when requesting: " ++ show url) - case ckComment cky of - Nothing -> return () - Just x -> putStrLn ("Cookie Comment:\n" ++ x) - let pth = maybe "" ('/':) (ckPath cky) - putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth) - putStrLn (ckName cky ++ '=' : ckValue cky) - System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering - System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering - System.IO.hPutStr System.IO.stdout "Accept [y/n]? " - x <- System.IO.hGetChar System.IO.stdin - System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering - System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering - return (toLower x == 'y') - --- | @addCookie c@ adds a cookie to the browser state, removing duplicates. -addCookie :: Cookie -> BrowserAction t () -addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) }) - --- | @setCookies cookies@ replaces the set of cookies known to --- the browser to @cookies@. Useful when wanting to restore cookies --- used across 'browse' invocations. -setCookies :: [Cookie] -> BrowserAction t () -setCookies cs = modify (\b -> b { bsCookies=cs }) - --- | @getCookies@ returns the current set of cookies known to --- the browser. -getCookies :: BrowserAction t [Cookie] -getCookies = gets bsCookies - --- ...get domain specific cookies... --- ... this needs changing for consistency with rfc2109... --- ... currently too broad. -getCookiesFor :: String -> String -> BrowserAction t [Cookie] -getCookiesFor dom path = - do cks <- getCookies - return (filter cookiematch cks) - where - cookiematch :: Cookie -> Bool - cookiematch = cookieMatch (dom,path) - - --- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. -setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () -setCookieFilter f = modify (\b -> b { bsCookieFilter=f }) - --- | @getCookieFilter@ returns the current cookie acceptance filter. -getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) -getCookieFilter = gets bsCookieFilter - ------------------------------------------------------------------- ------------------------ Authorisation Stuff ---------------------- ------------------------------------------------------------------- - -{- - -The browser handles 401 responses in the following manner: - 1) extract all WWW-Authenticate headers from a 401 response - 2) rewrite each as a Challenge object, using "headerToChallenge" - 3) pick a challenge to respond to, usually the strongest - challenge understood by the client, using "pickChallenge" - 4) generate a username/password combination using the browsers - "bsAuthorityGen" function (the default behaviour is to ask - the user) - 5) build an Authority object based upon the challenge and user - data, store this new Authority in the browser state - 6) convert the Authority to a request header and add this - to a request using "withAuthority" - 7) send the amended request - -Note that by default requests are annotated with authority headers -before the first sending, based upon previously generated Authority -objects (which contain domain information). Once a specific authority -is added to a rejected request this predictive annotation is suppressed. - -407 responses are handled in a similar manner, except - a) Authorities are not collected, only a single proxy authority - is kept by the browser - b) If the proxy used by the browser (type Proxy) is NoProxy, then - a 407 response will generate output on the "err" stream and - the response will be returned. - - -Notes: - - 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 - - doesn't properly receive AuthenticationInfo headers, so fails - to use next-nonce etc - --} - --- | Return authorities for a given domain and path. --- Assumes "dom" is lower case -getAuthFor :: String -> String -> BrowserAction t [Authority] -getAuthFor dom pth = getAuthorities >>= return . (filter match) - where - match :: Authority -> Bool - match au@AuthBasic{} = matchURI (auSite au) - match au@AuthDigest{} = or (map matchURI (auDomain au)) - - matchURI :: URI -> Bool - matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) - - --- | @getAuthorities@ return the current set of @Authority@s known --- to the browser. -getAuthorities :: BrowserAction t [Authority] -getAuthorities = gets bsAuthorities - --- @setAuthorities as@ replaces the Browser's known set --- of 'Authority's to @as@. -setAuthorities :: [Authority] -> BrowserAction t () -setAuthorities as = modify (\b -> b { bsAuthorities=as }) - --- @addAuthority a@ adds 'Authority' @a@ to the Browser's --- set of known authorities. -addAuthority :: Authority -> BrowserAction t () -addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b }) - --- | @getAuthorityGen@ returns the current authority generator -getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) -getAuthorityGen = gets bsAuthorityGen - --- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. -setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () -setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f }) - --- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. -setAllowBasicAuth :: Bool -> BrowserAction t () -setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba }) - -getAllowBasicAuth :: BrowserAction t Bool -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 - | fromMaybe 0 mb < 0 = return () - | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb}) - --- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@, --- the browser's default is used. -getMaxAuthAttempts :: BrowserAction t (Maybe Int) -getMaxAuthAttempts = gets bsMaxAuthAttempts - --- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at --- transmitting a request. If @Nothing@, rever to default max. -setMaxErrorRetries :: Maybe Int -> BrowserAction t () -setMaxErrorRetries mb - | fromMaybe 0 mb < 0 = return () - | otherwise = modify (\ b -> b{bsMaxErrorRetries=mb}) - --- | @getMaxErrorRetries@ returns the current max number of error retries. -getMaxErrorRetries :: BrowserAction t (Maybe Int) -getMaxErrorRetries = gets bsMaxErrorRetries - --- TO BE CHANGED!!! -pickChallenge :: Bool -> [Challenge] -> Maybe Challenge -pickChallenge allowBasic [] - | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust. -pickChallenge _ ls = listToMaybe ls - --- | Retrieve a likely looking authority for a Request. -anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) -anticipateChallenge rq = - let uri = rqURI rq in - do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) - ; return (listToMaybe authlist) - } - --- | Asking the user to respond to a challenge -challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) -challengeToAuthority uri ch - | not (answerable ch) = return Nothing - | otherwise = do - -- prompt user for authority - prompt <- getAuthorityGen - userdetails <- liftIO $ prompt uri (chRealm ch) - case userdetails of - Nothing -> return Nothing - Just (u,p) -> return (Just $ buildAuth ch u p) - where - answerable :: Challenge -> Bool - answerable ChalBasic{} = True - answerable chall = (chAlgorithm chall) == Just AlgMD5 - - buildAuth :: Challenge -> String -> String -> Authority - buildAuth (ChalBasic r) u p = - AuthBasic { auSite=uri - , auRealm=r - , auUsername=u - , auPassword=p - } - - -- note to self: this is a pretty stupid operation - -- to perform isn't it? ChalX and AuthX are so very - -- similar. - buildAuth (ChalDigest r d n o _stale a q) u p = - AuthDigest { auRealm=r - , auUsername=u - , auPassword=p - , auDomain=d - , auNonce=n - , auOpaque=o - , auAlgorithm=a - , auQop=q - } - - ------------------------------------------------------------------- ------------------- Browser State Actions ------------------------- ------------------------------------------------------------------- - - --- | @BrowserState@ is the (large) record type tracking the current --- settings of the browser. -data BrowserState connection - = BS { bsErr, bsOut :: String -> IO () - , bsCookies :: [Cookie] - , bsCookieFilter :: URI -> Cookie -> IO Bool - , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) - , bsAuthorities :: [Authority] - , bsAllowRedirects :: Bool - , bsAllowBasicAuth :: Bool - , bsMaxRedirects :: Maybe Int - , bsMaxErrorRetries :: Maybe Int - , bsMaxAuthAttempts :: Maybe Int - , bsMaxPoolSize :: Maybe Int - , bsConnectionPool :: [connection] - , bsCheckProxy :: Bool - , bsProxy :: Proxy - , bsDebug :: Maybe String - , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ()) - , bsRequestID :: RequestID - , bsUserAgent :: Maybe String - } - -instance Show (BrowserState t) where - show bs = "BrowserState { " - ++ shows (bsCookies bs) ("\n" - {- ++ show (bsAuthorities bs) ++ "\n"-} - ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") - --- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'. -newtype BrowserAction conn a - = BA { unBA :: StateT (BrowserState conn) IO a } -#ifdef MTL1 - deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn)) - -instance Applicative (BrowserAction conn) where - pure = return - (<*>) = ap -#else - deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)) -#endif - -runBA :: BrowserState conn -> BrowserAction conn a -> IO a -runBA bs = flip evalStateT bs . unBA - --- | @browse act@ is the toplevel action to perform a 'BrowserAction'. --- Example use: @browse (request (getRequest yourURL))@. -browse :: BrowserAction conn a -> IO a -browse = runBA defaultBrowserState - --- | The default browser state has the settings -defaultBrowserState :: BrowserState t -defaultBrowserState = res - where - res = BS - { bsErr = putStrLn - , bsOut = putStrLn - , bsCookies = [] - , bsCookieFilter = defaultCookieFilter - , bsAuthorityGen = \ _uri _realm -> do - bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing" - return Nothing - , bsAuthorities = [] - , bsAllowRedirects = True - , bsAllowBasicAuth = False - , bsMaxRedirects = Nothing - , bsMaxErrorRetries = Nothing - , bsMaxAuthAttempts = Nothing - , bsMaxPoolSize = Nothing - , bsConnectionPool = [] - , bsCheckProxy = defaultAutoProxyDetect - , bsProxy = noProxy - , bsDebug = Nothing - , bsEvent = Nothing - , bsRequestID = 0 - , bsUserAgent = Nothing - } - -{-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-} --- | @getBrowserState@ returns the current browser config. Useful --- for restoring state across 'BrowserAction's. -getBrowserState :: BrowserAction t (BrowserState t) -getBrowserState = get - --- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. -withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a -withBrowserState bs = BA . withStateT (const bs) . unBA - --- | @nextRequest act@ performs the browser action @act@ as --- the next request, i.e., setting up a new request context --- before doing so. -nextRequest :: BrowserAction t a -> BrowserAction t a -nextRequest act = do - let updReqID st = - let - rid = succ (bsRequestID st) - in - rid `seq` st{bsRequestID=rid} - modify updReqID - act - --- | Lifts an IO action into the 'BrowserAction' monad. -{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-} -ioAction :: IO a -> BrowserAction t a -ioAction = liftIO - --- | @setErrHandler@ sets the IO action to call when --- the browser reports running errors. To disable any --- such, set it to @const (return ())@. -setErrHandler :: (String -> IO ()) -> BrowserAction t () -setErrHandler h = modify (\b -> b { bsErr=h }) - --- | @setOutHandler@ sets the IO action to call when --- the browser chatters info on its running. To disable any --- such, set it to @const (return ())@. -setOutHandler :: (String -> IO ()) -> BrowserAction t () -setOutHandler h = modify (\b -> b { bsOut=h }) - -out, err :: String -> BrowserAction t () -out s = do { f <- gets bsOut ; liftIO $ f s } -err s = do { f <- gets bsErr ; liftIO $ f s } - --- | @setAllowRedirects onOff@ toggles the willingness to --- follow redirects (HTTP responses with 3xx status codes). -setAllowRedirects :: Bool -> BrowserAction t () -setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl}) - --- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. -getAllowRedirects :: BrowserAction t Bool -getAllowRedirects = gets bsAllowRedirects - --- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops --- we are willing to jump through. A no-op if the count is negative; if zero, --- the max is set to whatever default applies. Notice that setting the max --- redirects count does /not/ enable following of redirects itself; use --- 'setAllowRedirects' to do so. -setMaxRedirects :: Maybe Int -> BrowserAction t () -setMaxRedirects c - | fromMaybe 0 c < 0 = return () - | otherwise = modify (\b -> b{bsMaxRedirects=c}) - --- | @getMaxRedirects@ returns the current setting for the max-redirect count. --- If @Nothing@, the "Network.Browser"'s default is used. -getMaxRedirects :: BrowserAction t (Maybe Int) -getMaxRedirects = gets bsMaxRedirects - --- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool --- that is used to cache connections between requests -setMaxPoolSize :: Maybe Int -> BrowserAction t () -setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c}) - --- | @getMaxPoolSize@ gets the maximum size of the connection pool --- that is used to cache connections between requests. --- If @Nothing@, the "Network.Browser"'s default is used. -getMaxPoolSize :: BrowserAction t (Maybe Int) -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 --- 'Authority' information in @mbAuth@. -setProxy :: Proxy -> BrowserAction t () -setProxy p = - -- Note: if user _explicitly_ sets the proxy, we turn - -- off any auto-detection of proxies. - modify (\b -> b {bsProxy = p, bsCheckProxy=False}) - --- | @getProxy@ returns the current proxy settings. If --- the auto-proxy flag is set to @True@, @getProxy@ will --- perform the necessary -getProxy :: BrowserAction t Proxy -getProxy = do - p <- gets bsProxy - case p of - -- Note: if there is a proxy, no need to perform any auto-detect. - -- Presumably this is the user's explicit and preferred proxy server. - Proxy{} -> return p - NoProxy{} -> do - flg <- gets bsCheckProxy - if not flg - 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. - setProxy np - return np - --- | @setCheckForProxy flg@ sets the one-time check for proxy --- flag to @flg@. If @True@, the session will try to determine --- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' --- for details of how this done. -setCheckForProxy :: Bool -> BrowserAction t () -setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg}) - --- | @getCheckForProxy@ returns the current check-proxy setting. --- Notice that this may not be equal to @True@ if the session has --- set it to that via 'setCheckForProxy' and subsequently performed --- some HTTP protocol interactions. i.e., the flag return represents --- whether a proxy will be checked for again before any future protocol --- interactions. -getCheckForProxy :: BrowserAction t Bool -getCheckForProxy = gets bsCheckProxy - --- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ --- is @Nothing@. If set to @Just fStem@, logs of browser activity --- is appended to files of the form @fStem-url-authority@, i.e., --- @fStem@ is just the prefix for a set of log files, one per host/authority. -setDebugLog :: Maybe String -> BrowserAction t () -setDebugLog v = modify (\b -> b {bsDebug=v}) - --- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It --- will be used if no explicit user agent header is found in subsequent requests. --- --- A common form of user agent string is @\"name\/version (details)\"@. For --- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version --- of this HTTP package can be helpful if you ever need to track down HTTP --- compatability quirks. This version is available via 'httpPackageVersion'. --- For more info see . --- -setUserAgent :: String -> BrowserAction t () -setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua}) - --- | @getUserAgent@ returns the current @User-Agent:@ default string. -getUserAgent :: BrowserAction t String -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 --- forwards we've gone through. -data RequestState - = RequestState - { reqDenies :: Int -- ^ number of 401 responses so far - , reqRedirects :: Int -- ^ number of redirects so far - , reqRetries :: Int -- ^ number of retries so far - , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response - } - -type RequestID = Int -- yeah, it will wrap around. - -nullRequestState :: RequestState -nullRequestState = RequestState - { reqDenies = 0 - , reqRedirects = 0 - , reqRetries = 0 - , reqStopOnDeny = True - } - --- | @BrowserEvent@ is the event record type that a user-defined handler, set --- via 'setEventHandler', will be passed. It indicates various state changes --- encountered in the processing of a given 'RequestID', along with timestamps --- at which they occurred. -data BrowserEvent - = BrowserEvent - { browserTimestamp :: UTCTime - , browserRequestID :: RequestID - , browserRequestURI :: {-URI-}String - , browserEventType :: BrowserEventType - } - --- | 'BrowserEventType' is the enumerated list of events that the browser --- internals will report to a user-defined event handler. -data BrowserEventType - = OpenConnection - | ReuseConnection - | RequestSent - | ResponseEnd ResponseData - | ResponseFinish -{- not yet, you will have to determine these via the ResponseEnd event. - | Redirect - | 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 --- notified of browser events during the processing of a request --- by the Browser pipeline. -setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty () -setEventHandler mbH = modify (\b -> b { bsEvent=mbH}) - -buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent -buildBrowserEvent bt uri reqID = do - ct <- getCurrentTime - return BrowserEvent - { browserTimestamp = ct - , browserRequestID = reqID - , browserRequestURI = uri - , browserEventType = bt - } - -reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () -reportEvent bt uri = do - st <- get - case bsEvent st of - Nothing -> return () - Just evH -> 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 --- request forwardings. -defaultMaxRetries :: Int -defaultMaxRetries = 4 - --- | The default number of error retries we are willing to perform. -defaultMaxErrorRetries :: Int -defaultMaxErrorRetries = 4 - --- | The default maximum HTTP Authentication attempts we will make for --- a single request. -defaultMaxAuthAttempts :: Int -defaultMaxAuthAttempts = 2 - --- | The default setting for auto-proxy detection. --- You may change this within a session via 'setAutoProxyDetect'. --- To avoid initial backwards compatibility issues, leave this as @False@. -defaultAutoProxyDetect :: Bool -defaultAutoProxyDetect = False - --- | @request httpRequest@ tries to submit the 'Request' @httpRequest@ --- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.) --- Upon successful delivery, the URL where the response was fetched from --- is returned along with the 'Response' itself. -request :: HStream ty - => Request ty - -> BrowserAction (HandleStream ty) (URI,Response ty) -request req = nextRequest $ do - res <- request' nullVal initialState req - reportEvent ResponseFinish (show (rqURI req)) - case res of - Right r -> return r - Left e -> do - let errStr = ("Network.Browser.request: Error raised " ++ show e) - err errStr - fail errStr - where - initialState = nullRequestState - nullVal = buf_empty bufferOps - --- | Internal helper function, explicitly carrying along per-request --- counts. -request' :: HStream ty - => ty - -> RequestState - -> Request ty - -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) -request' nullVal rqState rq = do - let uri = rqURI rq - failHTTPS uri - let uria = reqURIAuth rq - -- add cookies to request - cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) -{- Not for now: - (case uriUserInfo uria of - "" -> id - xs -> - case chopAtDelim ':' xs of - (_,[]) -> id - (usr,pwd) -> withAuth - AuthBasic{ auUserName = usr - , auPassword = pwd - , auRealm = "/" - , auSite = uri - }) $ do --} - 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 - auth <- anticipateChallenge rq - case auth of - Nothing -> return rq - Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) - let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' - p <- getProxy - def_ua <- gets bsUserAgent - let defaultOpts = - case p of - NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} - Proxy _ ath -> - defaultNormalizeRequestOptions - { normForProxy = True - , normUserAgent = def_ua - , normCustoms = - maybe [] - (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) - ath - } - let final_req = normalizeRequest defaultOpts rq'' - out ("Sending:\n" ++ show final_req) - e_rsp <- - case p of - NoProxy -> dorequest (reqURIAuth rq'') final_req - Proxy str _ath -> do - let notURI - | null pt || null hst = - URIAuth{ uriUserInfo = "" - , uriRegName = str - , uriPort = "" - } - | otherwise = - URIAuth{ uriUserInfo = "" - , uriRegName = hst - , uriPort = pt - } - -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! - where (hst, pt) = span (':'/=) str - -- Proxy can take multiple forms - look for http://host:port first, - -- then host:port. Fall back to just the string given (probably a host name). - let proxyURIAuth = - maybe notURI - (\parsed -> maybe notURI id (uriAuthority parsed)) - (parseURI str) - - out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth - dorequest proxyURIAuth final_req - mbMx <- getMaxErrorRetries - case e_rsp of - 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=[] }) - request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq - | otherwise -> - return (Left v) - Right rsp -> do - out ("Received:\n" ++ show rsp) - -- add new cookies to browser state - handleCookies uri (uriAuthToString $ reqURIAuth rq) - (retrieveHeaders HdrSetCookie rsp) - -- Deal with "Connection: close" in response. - handleConnectionClose (reqURIAuth rq) (retrieveHeaders HdrConnection rsp) - mbMxAuths <- getMaxAuthAttempts - case rspCode rsp of - (4,0,1) -- Credentials not sent or refused. - | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do - out "401 - credentials again refused; exceeded retry count (2)" - return (Right (uri,rsp)) - | otherwise -> do - out "401 - credentials not supplied or refused; retrying.." - let hdrs = retrieveHeaders HdrWWWAuthenticate rsp - flg <- getAllowBasicAuth - case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of - Nothing -> do - out "no challenge" - return (Right (uri,rsp)) {- do nothing -} - Just x -> do - au <- challengeToAuthority uri x - case au of - Nothing -> do - out "no auth" - return (Right (uri,rsp)) {- do nothing -} - Just au' -> do - out "Retrying request with new credentials" - request' nullVal - rqState{ reqDenies = succ(reqDenies rqState) - , reqStopOnDeny = False - } - (insertHeader HdrAuthorization (withAuthority au' rq) rq) - - (4,0,7) -- Proxy Authentication required - | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do - out "407 - proxy authentication required; max deny count exceeeded (2)" - return (Right (uri,rsp)) - | otherwise -> do - out "407 - proxy authentication required" - let hdrs = retrieveHeaders HdrProxyAuthenticate rsp - flg <- getAllowBasicAuth - case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of - Nothing -> return (Right (uri,rsp)) {- do nothing -} - Just x -> do - au <- challengeToAuthority uri x - case au of - Nothing -> return (Right (uri,rsp)) {- do nothing -} - Just au' -> do - pxy <- gets bsProxy - case pxy of - NoProxy -> do - err "Proxy authentication required without proxy!" - return (Right (uri,rsp)) - Proxy px _ -> do - out "Retrying with proxy authentication" - setProxy (Proxy px (Just au')) - request' nullVal - rqState{ reqDenies = succ(reqDenies rqState) - , reqStopOnDeny = False - } - rq - - (3,0,x) | x `elem` [2,3,1,7] -> do - out ("30" ++ show x ++ " - redirect") - allow_redirs <- allowRedirect rqState - case allow_redirs of - False -> return (Right (uri,rsp)) - _ -> do - case retrieveHeaders HdrLocation rsp of - [] -> do - err "No Location: header in redirect response" - return (Right (uri,rsp)) - (Header _ u:_) -> - case parseURIReference u of - Nothing -> do - err ("Parse of Location: header in a redirect response failed: " ++ u) - return (Right (uri,rsp)) - Just newURI - | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do - err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs) - 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) - , reqStopOnDeny = True - } - rq2 - where - newURI_abs = uriDefaultTo newURI uri - - (3,0,5) -> - case retrieveHeaders HdrLocation rsp of - [] -> do - err "No Location header in proxy redirect response." - return (Right (uri,rsp)) - (Header _ u:_) -> - case parseURIReference u of - Nothing -> do - err ("Parse of Location header in a proxy redirect response failed: " ++ u) - return (Right (uri,rsp)) - Just newuri -> do - out ("Retrying with proxy " ++ show newuri ++ "...") - setProxy (Proxy (uriToAuthorityString newuri) Nothing) - request' nullVal rqState{ reqDenies = 0 - , reqRedirects = 0 - , reqRetries = succ (reqRetries rqState) - , reqStopOnDeny = True - } - rq - _ -> return (Right (uri,rsp)) - --- | The internal request handling state machine. -dorequest :: (HStream ty) - => URIAuth - -> Request ty - -> BrowserAction (HandleStream ty) - (Result (Response ty)) -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 <- - case conn of - [] -> do - out ("Creating new connection to " ++ uriAuthToString hst) - reportEvent OpenConnection (show (rqURI rqst)) - c <- liftIO $ openStream (uriRegName hst) uPort - updateConnectionPool c - dorequest2 c rqst - (c:_) -> do - out ("Recovering connection to " ++ uriAuthToString hst) - reportEvent ReuseConnection (show (rqURI rqst)) - dorequest2 c rqst - 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 - onSendComplete = - maybe (return ()) - (\evh -> do - x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) - runBA st (evh x) - return ()) - (bsEvent st) - liftIO $ - maybe (sendHTTP_notify c r onSendComplete) - (\ f -> do - c' <- debugByteStream (f++'-': uriAuthToString hst) c - sendHTTP_notify c' r onSendComplete) - dbg - -updateConnectionPool :: HStream hTy - => HandleStream hTy - -> BrowserAction (HandleStream hTy) () -updateConnectionPool c = do - pool <- gets bsConnectionPool - let len_pool = length pool - maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize - when (len_pool > maxPoolSize) - (liftIO $ close (last 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 - -cleanConnectionPool :: HStream hTy - => URIAuth -> BrowserAction (HandleStream hTy) () -cleanConnectionPool uri = do - let ep = EndPoint (uriRegName uri) (uriAuthPort Nothing uri) - pool <- gets bsConnectionPool - bad <- liftIO $ mapM (\c -> c `isTCPConnectedTo` ep) pool - let tmp = zip bad pool - newpool = map snd $ filter (not . fst) tmp - toclose = map snd $ filter fst tmp - liftIO $ forM_ toclose close - modify (\b -> b { bsConnectionPool = newpool }) - -handleCookies :: URI -> String -> [Header] -> BrowserAction t () -handleCookies _ _ [] = return () -- cut short the silliness. -handleCookies uri dom cookieHeaders = do - when (not $ null errs) - (err $ unlines ("Errors parsing these cookie values: ":errs)) - when (not $ null newCookies) - (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies) - filterfn <- getCookieFilter - newCookies' <- liftIO (filterM (filterfn uri) newCookies) - when (not $ null newCookies') - (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies')) - mapM_ addCookie newCookies' - where - (errs, newCookies) = processCookieHeaders dom cookieHeaders - -handleConnectionClose :: HStream hTy - => URIAuth -> [Header] - -> BrowserAction (HandleStream hTy) () -handleConnectionClose _ [] = return () -handleConnectionClose uri headers = do - let doClose = any (== "close") $ map headerToConnType headers - when doClose $ cleanConnectionPool uri - where headerToConnType (Header _ t) = map toLower t - ------------------------------------------------------------------- ------------------------ Miscellaneous ---------------------------- ------------------------------------------------------------------- - -allowRedirect :: RequestState -> BrowserAction t Bool -allowRedirect rqState = do - rd <- getAllowRedirects - mbMxRetries <- getMaxRedirects - return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries)) - --- | Return @True@ iff the package is able to handle requests and responses --- over it. -supportedScheme :: URI -> Bool -supportedScheme u = uriScheme u == "http:" - --- | @uriDefaultTo a b@ returns a URI that is consistent with the first --- argument URI @a@ when read in the context of the second URI @b@. --- If the second argument is not sufficient context for determining --- a full URI then anarchy reins. -uriDefaultTo :: URI -> URI -> URI -#if MIN_VERSION_network(2,4,0) -uriDefaultTo a b = a `relativeTo` b -#else -uriDefaultTo a b = maybe a id (a `relativeTo` b) -#endif - - --- This form junk is completely untested... - -type FormVar = (String,String) - -data Form = Form RequestMethod URI [FormVar] - -formToRequest :: Form -> Request_String -formToRequest (Form m u vs) = - let enc = urlEncodeVars vs - in case m of - GET -> Request { rqMethod=GET - , rqHeaders=[ Header HdrContentLength "0" ] - , rqBody="" - , rqURI=u { uriQuery= '?' : enc } -- What about old query? - } - POST -> Request { rqMethod=POST - , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded", - Header HdrContentLength (show $ length enc) ] - , rqBody=enc - , rqURI=u - } - _ -> error ("unexpected request: " ++ show m) - - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/BufferType.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/BufferType.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/BufferType.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/BufferType.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,164 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Network.BufferType --- Description : Abstract representation of request and response buffer types. --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- In order to give the user freedom in how request and response content --- is represented, a sufficiently abstract representation is needed of --- these internally. The "Network.BufferType" module provides this, defining --- the 'BufferType' class and its ad-hoc representation of buffer operations --- via the 'BufferOp' record. --- --- 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(..) - , strictBufferOp - , lazyBufferOp - , stringBufferOp - ) where - - -import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) -import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) -import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) -import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) -import System.IO ( Handle ) -import Data.Word ( Word8 ) - -import Network.HTTP.Utils ( crlf, lf ) - --- | The @BufferType@ class encodes, in a mixed-mode way, the interface --- 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 - -instance BufferType Lazy.ByteString where - bufferOps = lazyBufferOp - -instance BufferType Strict.ByteString where - bufferOps = strictBufferOp - -instance BufferType String where - bufferOps = stringBufferOp - --- | @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. --- --- Along with IO operations is an ad-hoc collection of functions for working --- with these abstract buffers, as needed by the internals of the code --- that processes requests and responses. --- --- We supply three default @BufferOp@ values, for @String@ along with the --- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ --- definitions for -data BufferOp a - = BufferOp - { buf_hGet :: Handle -> Int -> IO a - , buf_hGetContents :: Handle -> IO a - , buf_hPut :: Handle -> a -> IO () - , buf_hGetLine :: Handle -> IO a - , buf_empty :: a - , buf_append :: a -> a -> a - , buf_concat :: [a] -> a - , buf_fromStr :: String -> a - , buf_toStr :: a -> String - , buf_snoc :: a -> Word8 -> a - , buf_splitAt :: Int -> a -> (a,a) - , buf_span :: (Char -> Bool) -> a -> (a,a) - , buf_isLineTerm :: a -> Bool - , buf_isEmpty :: a -> Bool - } - -instance Eq (BufferOp a) where - _ == _ = False - --- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, --- the non-lazy kind. -strictBufferOp :: BufferOp Strict.ByteString -strictBufferOp = - BufferOp - { buf_hGet = Strict.hGet - , buf_hGetContents = Strict.hGetContents - , buf_hPut = Strict.hPut - , buf_hGetLine = Strict.hGetLine - , buf_append = Strict.append - , buf_concat = Strict.concat - , buf_fromStr = Strict.pack - , buf_toStr = Strict.unpack - , buf_snoc = Strict.snoc - , buf_splitAt = Strict.splitAt - , buf_span = Strict.span - , 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 - } - where - p_crlf = Strict.pack crlf - p_lf = Strict.pack lf - --- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, --- the non-strict kind. -lazyBufferOp :: BufferOp Lazy.ByteString -lazyBufferOp = - BufferOp - { buf_hGet = Lazy.hGet - , buf_hGetContents = Lazy.hGetContents - , buf_hPut = Lazy.hPut - , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) - , buf_append = Lazy.append - , buf_concat = Lazy.concat - , buf_fromStr = Lazy.pack - , buf_toStr = Lazy.unpack - , buf_snoc = Lazy.snoc - , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x - , buf_span = Lazy.span - , 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 - } - where - p_crlf = Lazy.pack crlf - p_lf = Lazy.pack lf - --- | @stringBufferOp@ is the 'BufferOp' definition over @String@s. --- It is defined in terms of @strictBufferOp@ operations, --- unpacking/converting to @String@ when needed. -stringBufferOp :: BufferOp String -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) - , buf_hGetLine = \ h -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack - , buf_append = (++) - , buf_concat = concat - , buf_fromStr = id - , buf_toStr = id - , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] - , buf_splitAt = splitAt - , 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 - } - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Auth.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Auth.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Auth.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Auth.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,221 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- 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(..) - , Algorithm(..) - , Challenge(..) - , Qop(..) - - , headerToChallenge -- :: URI -> Header -> Maybe Challenge - , withAuthority -- :: Authority -> Request ty -> String - ) where - -import Network.URI -import Network.HTTP.Base -import Network.HTTP.Utils -import Network.HTTP.Headers ( Header(..) ) -import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str)) -import qualified Network.HTTP.Base64 as Base64 (encode) -import Text.ParserCombinators.Parsec - ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 ) - -import Data.Char -import Data.Maybe -import Data.Word ( Word8 ) - --- | @Authority@ specifies the HTTP Authentication method to use for --- a given domain/realm; @Basic@ or @Digest@. -data Authority - = AuthBasic { auRealm :: String - , auUsername :: String - , auPassword :: String - , auSite :: URI - } - | AuthDigest{ auRealm :: String - , auUsername :: String - , auPassword :: String - , auNonce :: String - , auAlgorithm :: Maybe Algorithm - , auDomain :: [URI] - , auOpaque :: Maybe String - , auQop :: [Qop] - } - - -data Challenge - = ChalBasic { chRealm :: String } - | ChalDigest { chRealm :: String - , chDomain :: [URI] - , chNonce :: String - , chOpaque :: Maybe String - , chStale :: Bool - , chAlgorithm ::Maybe Algorithm - , chQop :: [Qop] - } - --- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. -data Algorithm = AlgMD5 | AlgMD5sess - deriving(Eq) - -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 - AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) - AuthDigest{} -> - "Digest " ++ - concat [ "username=" ++ quo (auUsername a) - , ",realm=" ++ quo (auRealm a) - , ",nonce=" ++ quo (auNonce a) - , ",uri=" ++ quo digesturi - , ",response=" ++ quo rspdigest - -- plus optional stuff: - , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) - , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) - , if null (auQop a) then "" else ",qop=auth" - ] - where - quo s = '"':s ++ "\"" - - rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) - - a1, a2 :: String - a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a - - {- - If the "qop" directive's value is "auth" or is unspecified, then A2 - is: - A2 = Method ":" digest-uri-value - If the "qop" value is "auth-int", then A2 is: - A2 = Method ":" digest-uri-value ":" H(entity-body) - -} - a2 = show (rqMethod rq) ++ ":" ++ digesturi - - digesturi = show (rqURI rq) - noncevalue = auNonce a - -type Octet = Word8 - --- FIXME: these probably only work right for latin-1 strings -stringToOctets :: String -> [Octet] -stringToOctets = map (fromIntegral . fromEnum) - -base64encode :: String -> String -base64encode = Base64.encode . stringToOctets - -md5 :: String -> String -md5 = MD5.md5s . MD5.Str - -kd :: String -> String -> String -kd a b = md5 (a ++ ":" ++ b) - - - - --- | @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) = - case parse challenge "" str of - Left{} -> Nothing - Right (name,props) -> case name of - "basic" -> mkBasic props - "digest" -> mkDigest props - _ -> Nothing - where - challenge :: Parser (String,[(String,String)]) - challenge = - do { nme <- word - ; spaces - ; pps <- cprops - ; return (map toLower nme,pps) - } - - cprops = sepBy1 cprop comma - - comma = do { spaces ; _ <- char ',' ; spaces } - - cprop = - do { nm <- word - ; _ <- char '=' - ; val <- quotedstring - ; return (map toLower nm,val) - } - - mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge - - mkBasic params = fmap ChalBasic (lookup "realm" params) - - mkDigest params = - -- with Maybe monad - do { r <- lookup "realm" params - ; n <- lookup "nonce" params - ; return $ - ChalDigest { chRealm = r - , chDomain = (annotateURIs - $ map parseURI - $ words - $ fromMaybe [] - $ lookup "domain" params) - , chNonce = n - , chOpaque = lookup "opaque" params - , chStale = "true" == (map toLower - $ fromMaybe "" (lookup "stale" params)) - , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) - , chQop = readQop (fromMaybe "" $ lookup "qop" params) - } - } - - annotateURIs :: [Maybe URI] -> [URI] -#if MIN_VERSION_network(2,4,0) - annotateURIs = map (`relativeTo` baseURI) . catMaybes -#else - annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes -#endif - - -- Change These: - readQop :: String -> [Qop] - readQop = catMaybes . (map strToQop) . (splitBy ',') - - strToQop qs = case map toLower (trim qs) of - "auth" -> Just QopAuth - "auth-int" -> Just QopAuthInt - _ -> Nothing - - readAlgorithm astr = case map toLower (trim astr) of - "md5" -> Just AlgMD5 - "md5-sess" -> Just AlgMD5sess - _ -> Nothing - -word, quotedstring :: Parser String -quotedstring = - do { _ <- char '"' -- " - ; str <- many (satisfy $ not . (=='"')) - ; _ <- char '"' - ; return str - } - -word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Base64.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Base64.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Base64.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Base64.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,282 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Codec.Binary.Base64 --- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002 --- License : BSD-style (see the file ReadMe.tex) --- --- Maintainer : dominic.steinitz@blueyonder.co.uk --- Stability : experimental --- Portability : portable --- --- Base64 encoding and decoding functions provided by Warwick Gray. --- See --- and . --- ------------------------------------------------------------------------------ - -module Network.HTTP.Base64 - ( encode - , decode - , chop72 - , Octet - ) where - -{------------------------------------------------------------------------ -This is what RFC2045 had to say: - -6.8. Base64 Content-Transfer-Encoding - - The Base64 Content-Transfer-Encoding is designed to represent - arbitrary sequences of octets in a form that need not be humanly - readable. The encoding and decoding algorithms are simple, but the - encoded data are consistently only about 33 percent larger than the - unencoded data. This encoding is virtually identical to the one used - in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421. - - A 65-character subset of US-ASCII is used, enabling 6 bits to be - represented per printable character. (The extra 65th character, "=", - is used to signify a special processing function.) - - NOTE: This subset has the important property that it is represented - identically in all versions of ISO 646, including US-ASCII, and all - characters in the subset are also represented identically in all - versions of EBCDIC. Other popular encodings, such as the encoding - used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and - the base85 encoding specified as part of Level 2 PostScript, do not - share these properties, and thus do not fulfill the portability - requirements a binary transport encoding for mail must meet. - - The encoding process represents 24-bit groups of input bits as output - strings of 4 encoded characters. Proceeding from left to right, a - 24-bit input group is formed by concatenating 3 8bit input groups. - These 24 bits are then treated as 4 concatenated 6-bit groups, each - of which is translated into a single digit in the base64 alphabet. - When encoding a bit stream via the base64 encoding, the bit stream - must be presumed to be ordered with the most-significant-bit first. - That is, the first bit in the stream will be the high-order bit in - the first 8bit byte, and the eighth bit will be the low-order bit in - the first 8bit byte, and so on. - - Each 6-bit group is used as an index into an array of 64 printable - characters. The character referenced by the index is placed in the - output string. These characters, identified in Table 1, below, are - selected so as to be universally representable, and the set excludes - characters with particular significance to SMTP (e.g., ".", CR, LF) - and to the multipart boundary delimiters defined in RFC 2046 (e.g., - "-"). - - - - Table 1: The Base64 Alphabet - - Value Encoding Value Encoding Value Encoding Value Encoding - 0 A 17 R 34 i 51 z - 1 B 18 S 35 j 52 0 - 2 C 19 T 36 k 53 1 - 3 D 20 U 37 l 54 2 - 4 E 21 V 38 m 55 3 - 5 F 22 W 39 n 56 4 - 6 G 23 X 40 o 57 5 - 7 H 24 Y 41 p 58 6 - 8 I 25 Z 42 q 59 7 - 9 J 26 a 43 r 60 8 - 10 K 27 b 44 s 61 9 - 11 L 28 c 45 t 62 + - 12 M 29 d 46 u 63 / - 13 N 30 e 47 v - 14 O 31 f 48 w (pad) = - 15 P 32 g 49 x - 16 Q 33 h 50 y - - The encoded output stream must be represented in lines of no more - than 76 characters each. All line breaks or other characters not - found in Table 1 must be ignored by decoding software. In base64 - data, characters other than those in Table 1, line breaks, and other - white space probably indicate a transmission error, about which a - warning message or even a message rejection might be appropriate - under some circumstances. - - Special processing is performed if fewer than 24 bits are available - at the end of the data being encoded. A full encoding quantum is - always completed at the end of a body. When fewer than 24 input bits - are available in an input group, zero bits are added (on the right) - to form an integral number of 6-bit groups. Padding at the end of - the data is performed using the "=" character. Since all base64 - input is an integral number of octets, only the following cases can - arise: (1) the final quantum of encoding input is an integral - multiple of 24 bits; here, the final unit of encoded output will be - an integral multiple of 4 characters with no "=" padding, (2) the - final quantum of encoding input is exactly 8 bits; here, the final - unit of encoded output will be two characters followed by two "=" - padding characters, or (3) the final quantum of encoding input is - exactly 16 bits; here, the final unit of encoded output will be three - characters followed by one "=" padding character. - - Because it is used only for padding at the end of the data, the - occurrence of any "=" characters may be taken as evidence that the - end of the data has been reached (without truncation in transit). No - such assurance is possible, however, when the number of octets - transmitted was a multiple of three and no "=" characters are - present. - - Any characters outside of the base64 alphabet are to be ignored in - base64-encoded data. - - Care must be taken to use the proper octets for line breaks if base64 - encoding is applied directly to text material that has not been - converted to canonical form. In particular, text line breaks must be - converted into CRLF sequences prior to base64 encoding. The - important thing to note is that this may be done directly by the - encoder rather than in a prior canonicalization step in some - implementations. - - NOTE: There is no need to worry about quoting potential boundary - delimiters within base64-encoded bodies within multipart entities - because no hyphen characters are used in the base64 encoding. - -----------------------------------------------------------------------------} - -{- - -The following properties should hold: - - decode . encode = id - decode . chop72 . encode = id - -I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, -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. --} - - -import Data.Array (Array, array, (!)) -import Data.Bits (shiftL, shiftR, (.&.), (.|.)) -import Data.Char (chr, ord) -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') - , (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') - , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') - , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') - , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') - , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') - , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') - , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] - - --- 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 --- 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) = - let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) - in (chr (n `shiftR` 16 .&. 0xff)) - : (chr (n `shiftR` 8 .&. 0xff)) - : (chr (n .&. 0xff)) : int4_char3 t - -int4_char3 [a,b,c] = - let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) - in [ (chr (n `shiftR` 16 .&. 0xff)) - , (chr (n `shiftR` 8 .&. 0xff)) ] - -int4_char3 [a,b] = - let n = (a `shiftL` 18 .|. b `shiftL` 12) - in [ (chr (n `shiftR` 16 .&. 0xff)) ] - -int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints." - -int4_char3 [] = [] - - - - --- Convert triplets of characters to --- 4 base64 integers. The last entries --- in the list may not produce 4 integers, --- 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) - = 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 - -char3_int4 [a,b] - = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) - 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)] - -char3_int4 [] = [] - - --- Retrieve base64 char, given an array index integer in the range [0..63] -enc1 :: Int -> Char -enc1 ch = encodeArray!ch - - --- | Cut up a string into 72 char lines, each line terminated by CRLF. - -chop72 :: String -> String -chop72 str = let (bgn,end) = splitAt 70 str - in if null end then bgn else "\r\n" ++ chop72 end - - --- Pads a base64 code to a multiple of 4 characters, using the special --- '=' character. -quadruplets :: [Char] -> [Char] -quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t -quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit -quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit -quadruplets [_] = error "Network.HTTP.Base64.quadruplets: impossible number of characters." -quadruplets [] = [] -- 24bit tail unit - - -enc :: [Int] -> [Char] -enc = quadruplets . map enc1 - - -dcd :: String -> [Int] -dcd [] = [] -dcd (h:t) - | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t - | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t - | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t - | h == '+' = 62 : dcd t - | h == '/' = 63 : dcd t - | h == '=' = [] -- terminate data stream - | otherwise = dcd t - - --- Principal encoding and decoding functions. - -encode :: [Octet] -> String -encode = enc . char3_int4 . (map (chr .fromIntegral)) - -{- -prop_base64 os = - os == (f . g . h) os - where types = (os :: [Word8]) - f = map (fromIntegral. ord) - g = decode . encode - h = map (chr . fromIntegral) --} - -decode :: String -> [Octet] -decode = (map (fromIntegral . ord)) . int4_char3 . dcd diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Base.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Base.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Base.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Base.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,994 +0,0 @@ -{-# LANGUAGE ScopedTypeVariables #-} ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP.Base --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- Definitions of @Request@ and @Response@ types along with functions --- for normalizing them. It is assumed to be an internal module; user --- code should, if possible, import @Network.HTTP@ to access the functionality --- that this module provides. --- --- Additionally, the module exports internal functions for working with URLs, --- and for handling the processing of requests and responses coming back. --- ------------------------------------------------------------------------------ -module Network.HTTP.Base - ( - -- ** Constants - httpVersion -- :: String - - -- ** HTTP - , Request(..) - , Response(..) - , RequestMethod(..) - - , Request_String - , Response_String - , HTTPRequest - , HTTPResponse - - -- ** URL Encoding - , urlEncode - , urlDecode - , urlEncodeVars - - -- ** URI authority parsing - , URIAuthority(..) - , parseURIAuthority - - -- internal - , uriToAuthorityString -- :: URI -> String - , uriAuthToString -- :: URIAuth -> String - , uriAuthPort -- :: Maybe URI -> URIAuth -> Int - , reqURIAuth -- :: Request ty -> URIAuth - - , parseResponseHead -- :: [String] -> Result ResponseData - , parseRequestHead -- :: [String] -> Result RequestData - - , ResponseNextStep(..) - , matchResponse - , ResponseData - , ResponseCode - , RequestData - - , NormalizeRequestOptions(..) - , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty - , RequestNormalizer - - , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty - - , splitRequestURI - - , getAuth - , normalizeRequestURI - , normalizeHostHeader - , findConnClose - - -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) - , linearTransfer - , hopefulTransfer - , chunkedTransfer - , uglyDeathTransfer - , readTillEmpty1 - , readTillEmpty2 - - , defaultGETRequest - , defaultGETRequest_ - , mkRequest - , setRequestBody - - , defaultUserAgent - , httpPackageVersion - , libUA {- backwards compatibility, will disappear..soon -} - - , catchIO - , catchIO_ - , responseParseError - - , getRequestVersion - , getResponseVersion - , setRequestVersion - , setResponseVersion - - , failHTTPS - - ) where - -import Network.URI - ( URI(uriAuthority, uriPath, uriScheme) - , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort) - , parseURIReference - ) - -import Control.Monad ( guard ) -import Control.Monad.Error () -import Data.Bits ( (.&.), (.|.), shiftL, shiftR ) -import Data.Word ( Word8 ) -import Data.Char ( digitToInt, intToDigit, toLower, isDigit, - isAscii, isAlphaNum, ord, chr ) -import Data.List ( partition, find ) -import Data.Maybe ( listToMaybe, fromMaybe ) -import Numeric ( readHex ) - -import Network.Stream -import Network.BufferType ( BufferOp(..), BufferType(..) ) -import Network.HTTP.Headers -import Network.HTTP.Utils ( trim, crlf, sp, readsOne ) -import qualified Network.HTTP.Base64 as Base64 (encode) - -import Text.Read.Lex (readDecP) -import Text.ParserCombinators.ReadP - ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) - -import Control.Exception as Exception (catch, IOException) - -import qualified Paths_HTTP as Self (version) -import Data.Version (showVersion) - ------------------------------------------------------------------ ------------------- URI Authority parsing ------------------------ ------------------------------------------------------------------ - -data URIAuthority = URIAuthority { user :: Maybe String, - password :: Maybe String, - host :: String, - port :: Maybe Int - } deriving (Eq,Show) - --- | Parse the authority part of a URL. --- --- > RFC 1732, section 3.1: --- > --- > //:@:/ --- > Some or all of the parts ":@", ":", --- > ":", and "/" may be excluded. -parseURIAuthority :: String -> Maybe URIAuthority -parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) - - -pURIAuthority :: ReadP URIAuthority -pURIAuthority = do - (u,pw) <- (pUserInfo `before` char '@') - <++ return (Nothing, Nothing) - h <- rfc2732host <++ munch (/=':') - p <- orNothing (char ':' >> readDecP) - look >>= guard . null - return URIAuthority{ user=u, password=pw, host=h, port=p } - --- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL -rfc2732host :: ReadP String -rfc2732host = do - _ <- char '[' - res <- munch1 (/=']') - _ <- char ']' - return res - -pUserInfo :: ReadP (Maybe String, Maybe String) -pUserInfo = do - u <- orNothing (munch (`notElem` ":@")) - p <- orNothing (char ':' >> munch (/='@')) - return (u,p) - -before :: Monad m => m a -> m b -> m a -before a b = a >>= \x -> b >> return x - -orNothing :: ReadP a -> ReadP (Maybe a) -orNothing p = fmap Just p <++ return Nothing - --- This function duplicates old Network.URI.authority behaviour. -uriToAuthorityString :: URI -> String -uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) - -uriAuthToString :: URIAuth -> String -uriAuthToString ua = - concat [ uriUserInfo ua - , uriRegName ua - , uriPort ua - ] - -uriAuthPort :: Maybe URI -> URIAuth -> Int -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) = - case map toLower $ uriScheme url of - "http:" -> default_http - "https:" -> default_https - -- todo: refine - _ -> default_http - - default_http = 80 - default_https = 443 - -failHTTPS :: Monad m => URI -> m () -failHTTPS uri - | map toLower (uriScheme uri) == "https:" = fail "https not supported" - | otherwise = return () - --- Fish out the authority from a possibly normalized Request, i.e., --- the information may either be in the request's URI or inside --- the Host: header. -reqURIAuth :: Request ty -> URIAuth -reqURIAuth req = - case uriAuthority (rqURI req) of - Just ua -> ua - _ -> case lookupHeader HdrHost (rqHeaders req) of - Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req) - Just h -> - case toHostPort h of - (ht,p) -> URIAuth { uriUserInfo = "" - , uriRegName = ht - , uriPort = p - } - where - -- Note: just in case you're wondering..the convention is to include the ':' - -- in the port part.. - toHostPort h = break (==':') h - ------------------------------------------------------------------ ------------------- HTTP Messages -------------------------------- ------------------------------------------------------------------ - - --- Protocol version -httpVersion :: String -httpVersion = "HTTP/1.1" - - --- | The HTTP request method, to be used in the 'Request' object. --- We are missing a few of the stranger methods, but these are --- not really necessary until we add full TLS. -data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String - deriving(Eq) - -instance Show RequestMethod where - show x = - case x of - HEAD -> "HEAD" - PUT -> "PUT" - GET -> "GET" - POST -> "POST" - DELETE -> "DELETE" - OPTIONS -> "OPTIONS" - TRACE -> "TRACE" - CONNECT -> "CONNECT" - Custom c -> c - -rqMethodMap :: [(String, RequestMethod)] -rqMethodMap = [("HEAD", HEAD), - ("PUT", PUT), - ("GET", GET), - ("POST", POST), - ("DELETE", DELETE), - ("OPTIONS", OPTIONS), - ("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 - --- Hmm..I really want to use these for the record --- type, but it will upset codebases wanting to --- migrate (and live with using pre-HTTPbis versions.) -type HTTPRequest a = Request a -type HTTPResponse a = Response a - --- | An HTTP Request. --- The 'Show' instance of this type is used for message serialisation, --- which means no body data is output. -data Request a = - Request { rqURI :: URI -- ^ might need changing in future - -- 1) to support '*' uri in OPTIONS request - -- 2) transparent support for both relative - -- & absolute uris, although this should - -- already work (leave scheme & host parts empty). - , rqMethod :: RequestMethod - , rqHeaders :: [Header] - , rqBody :: a - } - --- Notice that request body is not included, --- this show function is used to serialise --- a request for the transport link, we send --- the body separately where possible. -instance Show (Request a) where - show req@(Request u m h _) = - show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf - ++ 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 } - else u - -instance HasHeaders (Request a) where - getHeaders = rqHeaders - setHeaders rq hdrs = rq { rqHeaders=hdrs } - --- | For easy pattern matching, HTTP response codes @xyz@ are --- represented as @(x,y,z)@. -type ResponseCode = (Int,Int,Int) - --- | @ResponseData@ contains the head of a response payload; --- HTTP response code, accompanying text description + header --- fields. -type ResponseData = (ResponseCode,String,[Header]) - --- | @RequestData@ contains the head of a HTTP request; method, --- its URL along with the auxillary/supporting header data. -type RequestData = (RequestMethod,URI,[Header]) - --- | An HTTP Response. --- The 'Show' instance of this type is used for message serialisation, --- which means no body data is output, additionally the output will --- show an HTTP version of 1.1 instead of the actual version returned --- by a server. -data Response a = - Response { rspCode :: ResponseCode - , rspReason :: String - , rspHeaders :: [Header] - , rspBody :: a - } - --- 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 _) = - ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf - ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf - where - ver = fromMaybe httpVersion (getResponseVersion rsp) - -instance HasHeaders (Response a) where - getHeaders = rspHeaders - setHeaders rsp hdrs = rsp { rspHeaders=hdrs } - - ------------------------------------------------------------------- ------------------- Request Building ------------------------------ ------------------------------------------------------------------- - --- | Deprecated. Use 'defaultUserAgent' -libUA :: String -libUA = "hs-HTTP-4000.0.9" -{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-} - --- | A default user agent string. The string is @\"haskell-HTTP/$version\"@ --- where @$version@ is the version of this HTTP package. --- -defaultUserAgent :: String -defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion - --- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This --- may be useful to include in a user agent string so that you can determine --- from server logs what version of this package HTTP clients are using. --- This can be useful for tracking down HTTP compatibility quirks. --- -httpPackageVersion :: String -httpPackageVersion = showVersion Self.version - -defaultGETRequest :: URI -> Request_String -defaultGETRequest uri = defaultGETRequest_ uri - -defaultGETRequest_ :: BufferType a => URI -> Request a -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 --- 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 = - Request { rqURI = uri - , rqBody = empty - , rqHeaders = [ Header HdrContentLength "0" - , Header HdrUserAgent defaultUserAgent - ] - , rqMethod = meth - } - - empty = buf_empty (toBufOps req) - --- set rqBody, Content-Type and Content-Length headers. -setRequestBody :: Request_String -> (String, String) -> Request_String -setRequestBody req (typ, body) = req' { rqBody=body } - where - req' = replaceHeader HdrContentType typ . - replaceHeader HdrContentLength (show $ length body) $ - req - -{- - -- stub out the user info. - updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) - - withHost = - case uriToAuthorityString uri{uriAuthority=updAuth} of - "" -> id - h -> ((Header HdrHost h):) - - uri_req - | forProxy = uri - | otherwise = snd (splitRequestURI uri) --} - - -toBufOps :: BufferType a => Request a -> BufferOp a -toBufOps _ = bufferOps - ------------------------------------------------------------------ ------------------- Parsing -------------------------------------- ------------------------------------------------------------------ - --- Parsing a request -parseRequestHead :: [String] -> Result RequestData -parseRequestHead [] = Left ErrorClosed -parseRequestHead (com:hdrs) = do - (version,rqm,uri) <- requestCommand com (words com) - hdrs' <- parseHeaders hdrs - return (rqm,uri,withVer version hdrs') - where - withVer [] hs = hs - withVer (h:_) hs = withVersion h hs - - requestCommand l _yes@(rqm:uri:version) = - case (parseURIReference uri, lookup rqm rqMethodMap) of - (Just u, Just r) -> return (version,r,u) - (Just u, Nothing) -> return (version,Custom rqm,u) - _ -> parse_err l - requestCommand l _ - | null l = failWith ErrorClosed - | otherwise = parse_err l - - parse_err l = responseParseError "parseRequestHead" - ("Request command line parse failure: " ++ l) - --- Parsing a response -parseResponseHead :: [String] -> Result ResponseData -parseResponseHead [] = failWith ErrorClosed -parseResponseHead (sts:hdrs) = do - (version,code,reason) <- responseStatus sts (words sts) - hdrs' <- parseHeaders hdrs - return (code,reason, withVersion version hdrs') - where - responseStatus _l _yes@(version:code:reason) = - return (version,match code,concatMap (++" ") reason) - responseStatus l _no - | null l = failWith ErrorClosed -- an assumption - | otherwise = parse_err l - - parse_err l = - responseParseError - "parseResponseHead" - ("Response status line parse failure: " ++ l) - - match [a,b,c] = (digitToInt a, - digitToInt b, - digitToInt c) - match _ = (-1,-1,-1) -- will create appropriate behaviour - --- To avoid changing the @RequestData@ and @ResponseData@ types --- just for this (and the upstream backwards compat. woes that --- will result in), encode version info as a custom header. --- Used by 'parseResponseData' and 'parseRequestData'. --- --- Note: the Request and Response types do not currently represent --- 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 - | v == httpVersion = hs -- don't bother adding it if the default. - | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs - --- | @getRequestVersion req@ returns the HTTP protocol version of --- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed. -getRequestVersion :: Request a -> Maybe String -getRequestVersion r = getHttpVersion r - --- | @setRequestVersion v req@ returns a new request, identical to --- @req@, but with its HTTP version set to @v@. -setRequestVersion :: String -> Request a -> Request a -setRequestVersion s r = setHttpVersion r s - - --- | @getResponseVersion rsp@ returns the HTTP protocol version of --- the response @rsp@. If @Nothing@, the default 'httpVersion' can be --- assumed. -getResponseVersion :: Response a -> Maybe String -getResponseVersion r = getHttpVersion r - --- | @setResponseVersion v rsp@ returns a new response, identical to --- @rsp@, but with its HTTP version set to @v@. -setResponseVersion :: String -> Response a -> Response a -setResponseVersion s r = setHttpVersion r s - --- internal functions for accessing HTTP-version info in --- requests and responses. Not exported as it exposes ho --- version info is represented internally. - -getHttpVersion :: HasHeaders a => a -> Maybe String -getHttpVersion r = - fmap toVersion $ - find isHttpVersion $ - getHeaders r - where - toVersion (Header _ x) = x - -setHttpVersion :: HasHeaders a => a -> String -> a -setHttpVersion r v = - setHeaders r $ - withVersion v $ - dropHttpVersion $ - getHeaders r - -dropHttpVersion :: [Header] -> [Header] -dropHttpVersion hs = filter (not.isHttpVersion) hs - -isHttpVersion :: Header -> Bool -isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True -isHttpVersion _ = False - - - ------------------------------------------------------------------ ------------------- HTTP Send / Recv ---------------------------------- ------------------------------------------------------------------ - -data ResponseNextStep - = Continue - | Retry - | Done - | ExpectEntity - | DieHorribly String - -matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep -matchResponse rqst rsp = - case rsp of - (1,0,0) -> Continue - (1,0,1) -> Done -- upgrade to TLS - (1,_,_) -> Continue -- default - (2,0,4) -> Done - (2,0,5) -> Done - (2,_,_) -> ans - (3,0,4) -> Done - (3,0,5) -> Done - (3,_,_) -> ans - (4,1,7) -> Retry -- Expectation failed - (4,_,_) -> ans - (5,_,_) -> ans - (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") - where - ans | rqst == HEAD = Done - | otherwise = ExpectEntity - - - ------------------------------------------------------------------ ------------------- A little friendly funtionality --------------- ------------------------------------------------------------------ - - -{- - I had a quick look around but couldn't find any RFC about - the encoding of data on the query string. I did find an - IETF memo, however, so this is how I justify the urlEncode - and urlDecode methods. - - Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) - - Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. - Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" - URI delims: "<" | ">" | "#" | "%" | <"> - Unallowed ASCII: - - Also unallowed: any non-us-ascii character - - Escape method: char -> '%' a b where a, b :: Hex digits --} - -replacement_character :: Char -replacement_character = '\xfffd' - --- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format. --- --- Shamelessly stolen from utf-8string-0.3.7 -encodeChar :: Char -> [Word8] -encodeChar = map fromIntegral . go . ord - where - go oc - | oc <= 0x7f = [oc] - - | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) - , 0x80 + oc .&. 0x3f - ] - - | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - | otherwise = [ 0xf0 + (oc `shiftR` 18) - , 0x80 + ((oc `shiftR` 12) .&. 0x3f) - , 0x80 + ((oc `shiftR` 6) .&. 0x3f) - , 0x80 + oc .&. 0x3f - ] - --- | Decode a UTF8 string packed into a list of Word8 values, directly to String --- --- Shamelessly stolen from utf-8string-0.3.7 -decode :: [Word8] -> String -decode [ ] = "" -decode (c:cs) - | c < 0x80 = chr (fromEnum c) : decode cs - | c < 0xc0 = replacement_character : decode cs - | c < 0xe0 = multi1 - | c < 0xf0 = multi_byte 2 0xf 0x800 - | c < 0xf8 = multi_byte 3 0x7 0x10000 - | c < 0xfc = multi_byte 4 0x3 0x200000 - | c < 0xfe = multi_byte 5 0x1 0x4000000 - | otherwise = replacement_character : decode cs - where - multi1 = case cs of - c1 : ds | c1 .&. 0xc0 == 0x80 -> - let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) - in if d >= 0x000080 then toEnum d : decode ds - else replacement_character : decode ds - _ -> replacement_character : decode cs - - multi_byte :: Int -> Word8 -> Int -> [Char] - multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) - where - aux 0 rs acc - | overlong <= acc && acc <= 0x10ffff && - (acc < 0xd800 || 0xdfff < acc) && - (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs - | otherwise = replacement_character : decode rs - - aux n (r:rs) acc - | r .&. 0xc0 == 0x80 = aux (n-1) rs - $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) - - aux _ rs _ = replacement_character : decode rs - - --- This function is a bit funny because potentially the input String could contain some actual Unicode --- characters (though this shouldn't happen for most use cases), so we have to preserve those characters --- while simultaneously decoding any UTF-8 data -urlDecode :: String -> String -urlDecode = go [] - where - go bs ('%':a:b:rest) = go (fromIntegral (16 * digitToInt a + digitToInt b) : bs) rest - go bs (h:t) | fromEnum h < 256 = go (fromIntegral (fromEnum h) : bs) t -- Treat ASCII as just another byte of UTF-8 - go [] [] = [] - go [] (h:t) = h : go [] t -- h >= 256, so can't be part of any UTF-8 byte sequence - go bs rest = decode (reverse bs) ++ go [] rest - - -urlEncode :: String -> String -urlEncode [] = [] -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) - where - escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs) - - showH :: Word8 -> String -> String - showH x xs - | x <= 9 = to (o_0 + x) : xs - | otherwise = to (o_A + (x-10)) : xs - where - to = toEnum . fromIntegral - fro = fromIntegral . fromEnum - - o_0 = fro '0' - o_A = fro 'A' - --- Encode form variables, useable in either the --- query part of a URI, or the body of a POST request. --- I have no source for this information except experience, --- this sort of encoding worked fine in CGI programming. -urlEncodeVars :: [(String,String)] -> String -urlEncodeVars ((n,v):t) = - let (same,diff) = partition ((==n) . fst) t - in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) - ++ urlEncodeRest diff - where urlEncodeRest [] = [] - urlEncodeRest diff = '&' : urlEncodeVars diff -urlEncodeVars [] = [] - --- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ --- header. -getAuth :: Monad m => Request ty -> m URIAuthority -getAuth r = - -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) - case parseURIAuthority auth of - Just x -> return x - Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" - 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 = - (if doClose then replaceHeader HdrConnection "close" else id) $ - insertHeaderIfMissing HdrHost h $ - r { rqURI = (rqURI r){ uriScheme = "" - , uriAuthority = Nothing - }} - --- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options --- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option -data NormalizeRequestOptions ty - = NormalizeRequestOptions - { normDoClose :: Bool - , normForProxy :: Bool - , normUserAgent :: Maybe String - , normCustoms :: [RequestNormalizer ty] - } - --- | @RequestNormalizer@ is the shape of a (pure) function that rewrites --- a request into some normalized form. -type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty - -defaultNormalizeRequestOptions :: NormalizeRequestOptions ty -defaultNormalizeRequestOptions = NormalizeRequestOptions - { normDoClose = False - , normForProxy = False - , normUserAgent = Just defaultUserAgent - , normCustoms = [] - } - --- | @normalizeRequest opts req@ is the entry point to use to normalize your --- request prior to transmission (or other use.) Normalization is controlled --- via the @NormalizeRequestOptions@ record. -normalizeRequest :: NormalizeRequestOptions ty - -> Request ty - -> Request ty -normalizeRequest opts req = foldr (\ f -> f opts) req normalizers - where - --normalizers :: [RequestNormalizer ty] - normalizers = - ( normalizeHostURI - : normalizeBasicAuth - : normalizeConnectionClose - : normalizeUserAgent - : normCustoms opts - ) - --- | @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 = - case normUserAgent opts of - Nothing -> req - Just ua -> - case findHeader HdrUserAgent req of - Just u | u /= defaultUserAgent -> req - _ -> replaceHeader HdrUserAgent ua req - --- | @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 - | normDoClose opts = replaceHeader HdrConnection "close" req - | otherwise = req - --- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@ --- if the "user:pass@" part is present in the "http://user:pass@host/path" --- of the URI. If Authorization header was present already it is not replaced. -normalizeBasicAuth :: RequestNormalizer ty -normalizeBasicAuth _ req = - case getAuth req of - Just uriauth -> - case (user uriauth, password uriauth) of - (Just u, Just p) -> - insertHeaderIfMissing HdrAuthorization astr req - where - astr = "Basic " ++ base64encode (u ++ ":" ++ p) - base64encode = Base64.encode . stringToOctets :: String -> String - stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8] - (_, _) -> req - Nothing ->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 = - case splitRequestURI uri of - ("",_uri_abs) - | 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 - hst = case span (/='@') user_hst of - (as,'@':bs) -> - case span (/=':') as of - (_,_:_) -> bs - _ -> user_hst - _ -> user_hst - - (user_hst, pNum) = - case span isDigit (reverse h) of - (ds,':':bs) -> (reverse bs, ':':reverse ds) - _ -> (h,"") - | 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 - | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass - where - uri0 = rqURI req - -- stub out the user:pass - uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} - - forProxy = normForProxy opts - -{- Comments re: above rewriting: - RFC 2616, section 5.1.2: - "The most common form of Request-URI is that used to identify a - 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." - 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 - is a Host header. --} - -splitRequestURI :: URI -> ({-authority-}String, URI) -splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing}) - --- 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 = - insertHeaderIfMissing HdrHost - (uriToAuthorityString $ rqURI rq) - rq - --- Looks for a "Connection" header with the value "close". --- Returns True when this is found. -findConnClose :: [Header] -> Bool -findConnClose hdrs = - maybe False - (\ x -> map toLower (trim x) == "close") - (lookupHeader HdrConnection hdrs) - --- | Used when we know exactly how many bytes to expect. -linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) -linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) - --- | Used when nothing about data is known, --- Unfortunately waiting for a socket closure --- causes bad behaviour. Here we just --- take data once and give up the rest. -hopefulTransfer :: BufferOp a - -> IO (Result a) - -> [a] - -> IO (Result ([Header],a)) -hopefulTransfer bufOps readL strs - = readL >>= - either (\v -> return $ Left v) - (\more -> if (buf_isEmpty bufOps more) - then return (Right ([], buf_concat bufOps $ reverse strs)) - else hopefulTransfer bufOps readL (more:strs)) - --- | A necessary feature of HTTP\/1.1 --- Also the only transfer variety likely to --- return any footers. -chunkedTransfer :: BufferOp a - -> IO (Result a) - -> (Int -> IO (Result a)) - -> IO (Result ([Header], a)) -chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0 - -chunkedTransferC :: BufferOp a - -> IO (Result a) - -> (Int -> IO (Result a)) - -> [a] - -> Int - -> IO (Result ([Header], a)) -chunkedTransferC bufOps readL readBlk acc n = do - v <- readL - case v of - Left e -> return (Left e) - Right line - | size == 0 -> - -- last chunk read; look for trailing headers.. - fmapE (\ strs -> do - ftrs <- parseHeaders (map (buf_toStr bufOps) strs) - -- insert (computed) Content-Length header. - let ftrs' = Header HdrContentLength (show n) : ftrs - return (ftrs',buf_concat bufOps (reverse acc))) - - (readTillEmpty2 bufOps readL []) - - | otherwise -> do - some <- readBlk size - case some of - Left e -> return (Left e) - Right cdata -> 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 - | buf_isEmpty bufOps line = 0 - | otherwise = - case readHex (buf_toStr bufOps line) of - (hx,_):_ -> hx - _ -> 0 - --- | Maybe in the future we will have a sensible thing --- to do here, at that time we might want to change --- the name. -uglyDeathTransfer :: String -> IO (Result ([Header],a)) -uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") - --- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) -readTillEmpty1 :: BufferOp a - -> IO (Result a) - -> IO (Result [a]) -readTillEmpty1 bufOps readL = - readL >>= - either (return . Left) - (\ s -> - if buf_isLineTerm bufOps s - then readTillEmpty1 bufOps readL - else readTillEmpty2 bufOps readL [s]) - --- | Read lines until an empty line (CRLF), --- also accepts a connection close as end of --- input, which is not an HTTP\/1.1 compliant --- thing to do - so probably indicates an --- error condition. -readTillEmpty2 :: BufferOp a - -> IO (Result a) - -> [a] - -> IO (Result [a]) -readTillEmpty2 bufOps readL list = - readL >>= - either (return . Left) - (\ s -> - if buf_isLineTerm bufOps s || buf_isEmpty bufOps s - then return (Right $ reverse (s:list)) - else readTillEmpty2 bufOps readL (s:list)) - --- --- Misc --- - --- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific --- tweaks better go here. -catchIO :: IO a -> (IOException -> IO a) -> IO a -catchIO a h = Exception.catch a h - -catchIO_ :: IO a -> IO a -> IO a -catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) - -responseParseError :: String -> String -> Result a -responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v)) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Cookie.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Cookie.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Cookie.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Cookie.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,141 +0,0 @@ ------------------------------------------------------------------------------ --- | --- 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(..) - , cookieMatch -- :: (String,String) -> Cookie -> Bool - - -- functions for translating cookies and headers. - , cookiesToHeader -- :: [Cookie] -> Header - , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) - ) where - -import Network.HTTP.Headers - -import Data.Char -import Data.List -import Data.Maybe - -import Text.ParserCombinators.Parsec - ( Parser, char, many, many1, satisfy, parse, option, try - , (<|>), sepBy1 - ) - ------------------------------------------------------------------- ------------------------ Cookie Stuff ----------------------------- ------------------------------------------------------------------- - --- | @Cookie@ is the Haskell representation of HTTP cookie values. --- See its relevant specs for authoritative details. -data Cookie - = MkCookie - { ckDomain :: String - , ckName :: String - , ckValue :: String - , ckPath :: Maybe String - , ckComment :: Maybe String - , ckVersion :: Maybe String - } - deriving(Show,Read) - -instance Eq Cookie where - a == b = ckDomain a == ckDomain b - && ckName a == ckName b - && ckPath a == ckPath b - --- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header. -cookiesToHeader :: [Cookie] -> Header -cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs) - --- | Turn a list of cookies into a key=value pair list, separated by --- semicolons. -mkCookieHeaderValue :: [Cookie] -> String -mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1 - where - mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c - --- | @cookieMatch (domain,path) ck@ performs the standard cookie --- match wrt the given domain and path. -cookieMatch :: (String, String) -> Cookie -> Bool -cookieMatch (dom,path) ck = - ckDomain ck `isSuffixOf` dom && - case ckPath ck of - Nothing -> True - Just p -> p `isPrefixOf` path - - --- | @processCookieHeaders dom hdrs@ -processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) -processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs - --- | @headerToCookies dom hdr acc@ -headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) -headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = - case parse cookies "" val of - Left{} -> (val:accErr, accCookie) - Right x -> (accErr, x ++ accCookie) - where - cookies :: Parser [Cookie] - cookies = sepBy1 cookie (char ',') - - cookie :: Parser Cookie - cookie = - do name <- word - _ <- spaces_l - _ <- char '=' - _ <- spaces_l - val1 <- cvalue - args <- cdetail - 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 $ - try (do _ <- spaces_l - _ <- char ';' - _ <- spaces_l - s1 <- word - _ <- spaces_l - s2 <- option "" (char '=' >> spaces_l >> cvalue) - return (map toLower s1,s2) - ) - - mkCookie :: String -> String -> [(String,String)] -> Cookie - mkCookie nm cval more = - MkCookie { ckName = nm - , ckValue = cval - , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) - , ckPath = lookup "path" more - , ckVersion = lookup "version" more - , ckComment = lookup "comment" more - } -headerToCookies _ _ acc = acc - - - - -word, quotedstring :: Parser String -quotedstring = - do _ <- char '"' -- " - str <- many (satisfy $ not . (=='"')) - _ <- char '"' - return str - -word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/HandleStream.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/HandleStream.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/HandleStream.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/HandleStream.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,252 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP.HandleStream --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- A 'HandleStream'-based version of "Network.HTTP" interface. --- --- For more detailed information about what the individual exports do, please consult --- the documentation for "Network.HTTP". /Notice/ however that the functions here do --- 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 - ( 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 - ------------------------------------------------------------------ ------------------- Imports -------------------------------------- ------------------------------------------------------------------ - -import Network.BufferType -import Network.Stream ( fmapE, Result ) -import Network.StreamDebugger ( debugByteStream ) -import Network.TCP (HStream(..), HandleStream ) - -import Network.HTTP.Base -import Network.HTTP.Headers -import Network.HTTP.Utils ( trim, readsOne ) - -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import Control.Exception (onException) -import Control.Monad (when) - ------------------------------------------------------------------ ------------------- Misc ----------------------------------------- ------------------------------------------------------------------ - --- | @simpleHTTP@ transmits a resource across a non-persistent connection. -simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) -simpleHTTP r = do - auth <- getAuth r - failHTTPS (rqURI r) - c <- openStream (host auth) (fromMaybe 80 (port auth)) - simpleHTTP_ c r - --- | @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 - auth <- getAuth r - failHTTPS (rqURI r) - c0 <- openStream (host auth) (fromMaybe 80 (port auth)) - c <- debugByteStream httpLogFile c0 - simpleHTTP_ c r - --- | Like 'simpleHTTP', but acting on an already opened stream. -simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) -simpleHTTP_ s r = sendHTTP s r - --- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over --- @hStream@, but does not alter the status of the connection, nor request it to be --- closed upon receiving the response. -sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) -sendHTTP conn rq = sendHTTP_notify conn rq (return ()) - --- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but --- lets you supply an IO @action@ to execute once the request has been successfully --- transmitted over the connection. Useful when you want to set up tracing of --- request transmission and its performance. -sendHTTP_notify :: HStream ty - => HandleStream ty - -> Request ty - -> IO () - -> IO (Result (Response ty)) -sendHTTP_notify conn rq onSendComplete = do - when providedClose $ (closeOnEnd conn True) - onException (sendMain conn rq onSendComplete) - (close conn) - where - providedClose = findConnClose (rqHeaders rq) - --- From RFC 2616, section 8.2.3: --- 'Because of the presence of older implementations, the protocol allows --- ambiguous situations in which a client may send "Expect: 100- --- continue" without receiving either a 417 (Expectation Failed) status --- or a 100 (Continue) status. Therefore, when a client sends this --- header field to an origin server (possibly via a proxy) from which it --- has never seen a 100 (Continue) status, the client SHOULD NOT wait --- for an indefinite period before sending the request body.' --- --- Since we would wait forever, I have disabled use of 100-continue for now. -sendMain :: HStream ty - => HandleStream ty - -> Request ty - -> (IO ()) - -> IO (Result (Response ty)) -sendMain conn rqst onSendComplete = do - --let str = if null (rqBody rqst) - -- then show rqst - -- else show (insertHeader HdrExpect "100-continue" rqst) - -- TODO review throwing away of result - _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) - -- write body immediately, don't wait for 100 CONTINUE - -- TODO review throwing away of result - _ <- writeBlock conn (rqBody rqst) - onSendComplete - rsp <- getResponseHead conn - switchResponse conn True False rsp rqst - - -- Hmmm, this could go bad if we keep getting "100 Continue" - -- responses... Except this should never happen according - -- to the RFC. - -switchResponse :: HStream ty - => HandleStream ty - -> Bool {- allow retry? -} - -> Bool {- is body sent? -} - -> Result ResponseData - -> Request ty - -> IO (Result (Response ty)) -switchResponse _ _ _ (Left e) _ = return (Left e) - -- retry on connreset? - -- 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 = - case matchResponse (rqMethod rqst) cd of - Continue - | not bdy_sent -> do {- Time to send the body -} - writeBlock conn (rqBody rqst) >>= either (return . Left) - (\ _ -> do - rsp <- getResponseHead conn - switchResponse conn allow_retry True rsp rqst) - | otherwise -> do {- keep waiting -} - rsp <- getResponseHead conn - switchResponse conn allow_retry bdy_sent rsp rqst - - Retry -> do {- Request with "Expect" header failed. - Trouble is the request contains Expects - other than "100-Continue" -} - -- TODO review throwing away of result - _ <- writeBlock conn ((buf_append bufferOps) - (buf_fromStr bufferOps (show rqst)) - (rqBody rqst)) - rsp <- getResponseHead conn - switchResponse conn False bdy_sent rsp rqst - - Done -> do - when (findConnClose hdrs) - (closeOnEnd conn True) - return (Right $ Response cd rn hdrs (buf_empty bufferOps)) - - DieHorribly str -> do - close conn - return (responseParseError "Invalid response:" str) - ExpectEntity -> do - r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ - maybe (maybe (hopefulTransfer bo (readLine conn) []) - (\ x -> - readsOne (linearTransfer (readBlock conn)) - (return$responseParseError "unrecognized content-length value" x) - x) - cl) - (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) - (uglyDeathTransfer "sendHTTP")) - tc - case r of - Left{} -> do - close conn - return r - Right (Response _ _ hs _) -> do - when (findConnClose hs) - (closeOnEnd conn True) - return r - - where - tc = lookupHeader HdrTransferEncoding hdrs - cl = lookupHeader HdrContentLength hdrs - bo = bufferOps - --- reads and parses headers -getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData) -getResponseHead conn = - fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) - (readTillEmpty1 bufferOps (readLine conn)) - --- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ -receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) -receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest - where - -- reads and parses headers - getRequestHead :: IO (Result RequestData) - getRequestHead = do - fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) - (readTillEmpty1 bufferOps (readLine conn)) - - processRequest (rm,uri,hdrs) = - fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $ - maybe - (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer "" - (\ x -> readsOne (linearTransfer (readBlock conn)) - (return$responseParseError "unrecognized Content-Length value" x) - x) - - cl) - (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) - (uglyDeathTransfer "receiveHTTP")) - tc - where - -- FIXME : Also handle 100-continue. - tc = lookupHeader HdrTransferEncoding hdrs - cl = lookupHeader HdrContentLength hdrs - bo = bufferOps - --- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over --- 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 - -- TODO: review throwing away of result - _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) - -- write body immediately, don't wait for 100 CONTINUE - -- TODO: review throwing away of result - _ <- writeBlock conn (rspBody rsp) - return () - ------------------------------------------------------------------------------- - -headerName :: String -> String -headerName x = map toLower (trim x) - -ifChunked :: a -> a -> String -> a -ifChunked a b s = - case headerName s of - "chunked" -> a - _ -> b - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Headers.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Headers.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Headers.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Headers.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,306 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP.Headers --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- This module provides the data types for representing HTTP headers, and --- operations for looking up header values and working with sequences of --- 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 - - , Header(..) - , mkHeader -- :: HeaderName -> String -> Header - , hdrName -- :: Header -> HeaderName - , hdrValue -- :: Header -> String - - , HeaderName(..) - - , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a - , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a - , insertHeaders -- :: HasHeaders a => [Header] -> a -> a - , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header] - , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a - , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String - , lookupHeader -- :: HeaderName -> [Header] -> Maybe String - - , parseHeader -- :: parseHeader :: String -> Result Header - , parseHeaders -- :: [String] -> Result [Header] - - , headerMap -- :: [(String, HeaderName)] - - , HeaderSetter - ) where - -import Data.Char (toLower) -import Network.Stream (Result, failParse) -import Network.HTTP.Utils ( trim, split, crlf ) - --- | The @Header@ data type pairs header names & values. -data Header = Header HeaderName String - -hdrName :: Header -> HeaderName -hdrName (Header h _) = h - -hdrValue :: Header -> String -hdrValue (Header _ v) = v - --- | Header constructor as a function, hiding above rep. -mkHeader :: HeaderName -> String -> Header -mkHeader = Header - -instance Show Header where - show (Header key value) = shows key (':':' ':value ++ crlf) - --- | HTTP @HeaderName@ type, a Haskell data constructor for each --- specification-defined header, prefixed with @Hdr@ and CamelCased, --- (i.e., eliding the @-@ in the process.) Should you require using --- a custom header, there's the @HdrCustom@ constructor which takes --- a @String@ argument. --- --- 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 - -- Generic Headers -- - = HdrCacheControl - | HdrConnection - | HdrDate - | HdrPragma - | HdrTransferEncoding - | HdrUpgrade - | HdrVia - -- Request Headers -- - | HdrAccept - | HdrAcceptCharset - | HdrAcceptEncoding - | HdrAcceptLanguage - | HdrAuthorization - | HdrCookie - | HdrExpect - | HdrFrom - | HdrHost - | HdrIfModifiedSince - | HdrIfMatch - | HdrIfNoneMatch - | HdrIfRange - | HdrIfUnmodifiedSince - | HdrMaxForwards - | HdrProxyAuthorization - | HdrRange - | HdrReferer - | HdrUserAgent - -- Response Headers - | HdrAge - | HdrLocation - | HdrProxyAuthenticate - | HdrPublic - | HdrRetryAfter - | HdrServer - | HdrSetCookie - | HdrTE - | HdrTrailer - | HdrVary - | HdrWarning - | HdrWWWAuthenticate - -- Entity Headers - | HdrAllow - | HdrContentBase - | HdrContentEncoding - | HdrContentLanguage - | HdrContentLength - | HdrContentLocation - | HdrContentMD5 - | HdrContentRange - | HdrContentType - | HdrETag - | HdrExpires - | HdrLastModified - -- | MIME entity headers (for sub-parts) - | HdrContentTransferEncoding - -- | Allows for unrecognised or experimental headers. - | HdrCustom String -- not in header map below. - deriving(Eq) - --- | @headerMap@ is a straight assoc list for translating between header names --- and values. -headerMap :: [ (String,HeaderName) ] -headerMap = - [ p "Cache-Control" HdrCacheControl - , p "Connection" HdrConnection - , p "Date" HdrDate - , p "Pragma" HdrPragma - , p "Transfer-Encoding" HdrTransferEncoding - , p "Upgrade" HdrUpgrade - , p "Via" HdrVia - , p "Accept" HdrAccept - , p "Accept-Charset" HdrAcceptCharset - , p "Accept-Encoding" HdrAcceptEncoding - , p "Accept-Language" HdrAcceptLanguage - , p "Authorization" HdrAuthorization - , p "Cookie" HdrCookie - , p "Expect" HdrExpect - , p "From" HdrFrom - , p "Host" HdrHost - , p "If-Modified-Since" HdrIfModifiedSince - , p "If-Match" HdrIfMatch - , p "If-None-Match" HdrIfNoneMatch - , p "If-Range" HdrIfRange - , p "If-Unmodified-Since" HdrIfUnmodifiedSince - , p "Max-Forwards" HdrMaxForwards - , p "Proxy-Authorization" HdrProxyAuthorization - , p "Range" HdrRange - , p "Referer" HdrReferer - , p "User-Agent" HdrUserAgent - , p "Age" HdrAge - , p "Location" HdrLocation - , p "Proxy-Authenticate" HdrProxyAuthenticate - , p "Public" HdrPublic - , p "Retry-After" HdrRetryAfter - , p "Server" HdrServer - , p "Set-Cookie" HdrSetCookie - , p "TE" HdrTE - , p "Trailer" HdrTrailer - , p "Vary" HdrVary - , p "Warning" HdrWarning - , p "WWW-Authenticate" HdrWWWAuthenticate - , p "Allow" HdrAllow - , p "Content-Base" HdrContentBase - , p "Content-Encoding" HdrContentEncoding - , p "Content-Language" HdrContentLanguage - , p "Content-Length" HdrContentLength - , p "Content-Location" HdrContentLocation - , p "Content-MD5" HdrContentMD5 - , p "Content-Range" HdrContentRange - , p "Content-Type" HdrContentType - , p "ETag" HdrETag - , p "Expires" HdrExpires - , p "Last-Modified" HdrLastModified - , p "Content-Transfer-Encoding" HdrContentTransferEncoding - ] - where - p a b = (a,b) - -instance Show HeaderName where - show (HdrCustom s) = s - show x = case filter ((==x).snd) headerMap of - [] -> error "headerMap incomplete" - (h:_) -> fst h - --- | @HasHeaders@ is a type class for types containing HTTP headers, allowing --- you to write overloaded header manipulation functions --- for both 'Request' and 'Response' data types, for instance. -class HasHeaders x where - getHeaders :: x -> [Header] - setHeaders :: x -> [Header] -> x - --- Header manipulation functions - -type HeaderSetter a = HeaderName -> String -> a -> a - --- | @insertHeader hdr val x@ inserts a header with the given header name --- and value. Does not check for existing headers with same name, allowing --- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.) -insertHeader :: HasHeaders a => HeaderSetter a -insertHeader name value x = setHeaders x newHeaders - where - newHeaders = (Header name value) : getHeaders x - --- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous --- header with name @hdr@ exists in @x@. -insertHeaderIfMissing :: HasHeaders a => HeaderSetter a -insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) - where - newHeaders list@(h@(Header n _): rest) - | n == name = list - | otherwise = h : newHeaders rest - newHeaders [] = [Header name value] - --- | @replaceHeader hdr val o@ replaces the header @hdr@ with the --- 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 -insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) - --- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@. -retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] -retrieveHeaders name x = filter matchname (getHeaders x) - where - matchname (Header n _) = n == name - --- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first --- header that matches, if any. -findHeader :: HasHeaders a => HeaderName -> a -> Maybe String -findHeader n x = lookupHeader n (getHeaders x) - --- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the --- list @hdrs@. -lookupHeader :: HeaderName -> [Header] -> Maybe String -lookupHeader _ [] = Nothing -lookupHeader v (Header n s:t) - | v == n = Just s - | otherwise = lookupHeader v t - --- | @parseHeader headerNameAndValueString@ tries to unscramble a --- @header: value@ pairing and returning it as a 'Header'. -parseHeader :: String -> Result Header -parseHeader str = - case split ':' str of - Nothing -> failParse ("Unable to parse header: " ++ str) - Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v) - where - fn k = case map snd $ filter (match k . fst) headerMap of - [] -> (HdrCustom k) - (h:_) -> h - - 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) . - joinExtended "" - where - -- Joins consecutive lines where the second line - -- begins with ' ' or '\t'. - joinExtended old [] = [old] - joinExtended old (h : t) - | isLineExtension h = joinExtended (old ++ ' ' : tail h) t - | otherwise = old : joinExtended h t - - isLineExtension (x:_) = x == ' ' || x == '\t' - isLineExtension _ = False - - clean [] = [] - clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t - | otherwise = h : clean t - - -- tolerant of errors? should parse - -- errors here be reported or ignored? - -- currently ignored. - catRslts :: [a] -> [Result a] -> Result [a] - catRslts list (h:t) = - case h of - Left _ -> catRslts list t - Right v -> catRslts (v:list) t - catRslts list [] = Right $ reverse list diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/MD5Aux.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/MD5Aux.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/MD5Aux.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/MD5Aux.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,343 +0,0 @@ -module Network.HTTP.MD5Aux - (md5, md5s, md5i, - MD5(..), ABCD(..), - Zord64, Str(..), BoolList(..), WordList(..)) where - -import Data.Char (ord, chr) -import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) -import Data.Word (Word32, Word64) - -rotL :: Word32 -> Int -> Word32 -rotL x = rotateL x - -type Zord64 = Word64 - --- ===================== TYPES AND CLASS DEFINTIONS ======================== - - -type XYZ = (Word32, Word32, Word32) -type Rotation = Int -newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) -newtype Str = Str String -newtype BoolList = BoolList [Bool] -newtype WordList = WordList ([Word32], Word64) - --- Anything we want to work out the MD5 of must be an instance of class MD5 - -class MD5 a where - get_next :: a -> ([Word32], Int, a) -- get the next blocks worth - -- \ \ \------ the rest of the input - -- \ \--------- the number of bits returned - -- \--------------- the bits returned in 32bit words - len_pad :: Word64 -> a -> a -- append the padding and length - finished :: a -> Bool -- Have we run out of input yet? - - --- Mainly exists because it's fairly easy to do MD5s on input where the --- length is not a multiple of 8 - -instance MD5 BoolList where - get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) - where (ys, zs) = splitAt 512 s - len_pad l (BoolList bs) - = BoolList (bs ++ [True] - ++ replicate (fromIntegral $ (447 - l) .&. 511) False - ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] - ) - where mangle [] = [] - mangle xs = reverse ys ++ mangle zs - where (ys, zs) = splitAt 8 xs - finished (BoolList s) = s == [] - - --- The string instance is fairly straightforward - -instance MD5 Str where - get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) - where (ys, zs) = splitAt 64 s - len_pad c64 (Str s) = Str (s ++ padding ++ l) - where padding = '\128':replicate (fromIntegral zeros) '\000' - zeros = shiftR ((440 - c64) .&. 511) 3 - l = length_to_chars 8 c64 - finished (Str s) = s == "" - - --- YA instance that is believed will be useful - -instance MD5 WordList where - get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) - where (xs, ys) = splitAt 16 ws - taken = if l > 511 then 512 else l .&. 511 - len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) - where beginning = if length ws > 0 then start ++ lastone' else [] - start = init ws - lastone = last ws - offset = c64 .&. 31 - lastone' = [if offset > 0 then lastone + theone else lastone] - theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) - (fromIntegral $ offset .&. (31 - 7)) - nextish = if offset == 0 then [128] else [] - c64' = c64 + (32 - offset) - num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) - blanks = replicate num_blanks 0 - lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) - topsize = fromIntegral $ shiftR c64 32 - size = [lowsize, topsize] - newlen = l .&. (complement 511) - + if c64 .&. 511 >= 448 then 1024 else 512 - finished (WordList (_, z)) = z == 0 - - -instance Num ABCD where - ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) - - (-) = error "(-){ABCD}: no instance method defined" - (*) = error "(*){ABCD}: no instance method defined" - signum = error "signum{ABCD}: no instance method defined" - fromInteger = error "fromInteger{ABCD}: no instance method defined" - abs = error "abs{ABCD}: no instance method defined" --- ===================== EXPORTED FUNCTIONS ======================== - - --- The simplest function, gives you the MD5 of a string as 4-tuple of --- 32bit words. - -md5 :: (MD5 a) => a -> ABCD -md5 m = md5_main False 0 magic_numbers m - - --- Returns a hex number ala the md5sum program - -md5s :: (MD5 a) => a -> String -md5s = abcd_to_string . md5 - - --- Returns an integer equivalent to the above hex number - -md5i :: (MD5 a) => a -> Integer -md5i = abcd_to_integer . md5 - - --- ===================== THE CORE ALGORITHM ======================== - - --- Decides what to do. The first argument indicates if padding has been --- added. The second is the length mod 2^64 so far. Then we have the --- starting state, the rest of the string and the final state. - -md5_main :: (MD5 a) => - Bool -- Have we added padding yet? - -> Word64 -- The length so far mod 2^64 - -> ABCD -- The initial state - -> a -- The non-processed portion of the message - -> ABCD -- The resulting state -md5_main padded ilen abcd m - = if finished m && padded - then abcd - else md5_main padded' (ilen + 512) (abcd + abcd') m'' - where (m16, l, m') = get_next m - len' = ilen + fromIntegral l - ((m16', _, m''), padded') = if not padded && l < 512 - then (get_next $ len_pad len' m, True) - else ((m16, l, m'), padded) - abcd' = md5_do_block abcd m16' - - --- md5_do_block processes a 512 bit block by calling md5_round 4 times to --- apply each round with the correct constants and permutations of the --- block - -md5_do_block :: ABCD -- Initial state - -> [Word32] -- The block to be processed - 16 32bit words - -> ABCD -- Resulting state -md5_do_block abcd0 w = abcd4 - where (r1, r2, r3, r4) = rounds - {- - map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] - -- [(5 * x + 1) `mod` 16 | x <- [0..15]] - map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] - -- [(3 * x + 5) `mod` 16 | x <- [0..15]] - map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] - -- [(7 * x) `mod` 16 | x <- [0..15]] - -} - perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] - = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] - perm5 _ = error "broke at perm5" - perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] - = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] - perm3 _ = error "broke at perm3" - perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] - = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] - perm7 _ = error "broke at perm7" - abcd1 = md5_round md5_f abcd0 w r1 - abcd2 = md5_round md5_g abcd1 (perm5 w) r2 - abcd3 = md5_round md5_h abcd2 (perm3 w) r3 - abcd4 = md5_round md5_i abcd3 (perm7 w) r4 - - --- md5_round does one of the rounds. It takes an auxiliary function and foldls --- (md5_inner_function f) to repeatedly apply it to the initial state with the --- correct constants - -md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I - -- for those of you with a copy of - -- the prayer book^W^WRFC) - -> ABCD -- Initial state - -> [Word32] -- The 16 32bit words of input - -> [(Rotation, Word32)] -- The list of 16 rotations and - -- additive constants - -> ABCD -- Resulting state -md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' - where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns - - --- Apply one of the functions md5_[fghi] and put the new ABCD together - -md5_inner_function :: (XYZ -> Word32) -- Auxiliary function - -> ABCD -- Initial state - -> (Rotation, Word32) -- The rotation and additive - -- constant (X[i] + T[j]) - -> ABCD -- Resulting state -md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) - where mid_a = a + f(b,c,d) + ki - rot_a = rotL mid_a s - a' = b + rot_a - - --- The 4 auxiliary functions - -md5_f :: XYZ -> Word32 -md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) -{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} - -md5_g :: XYZ -> Word32 -md5_g (x, y, z) = md5_f (z, x, y) -{- was: (x .&. z) .|. (y .&. (complement z)) -} - -md5_h :: XYZ -> Word32 -md5_h (x, y, z) = x `xor` y `xor` z - -md5_i :: XYZ -> Word32 -md5_i (x, y, z) = y `xor` (x .|. (complement z)) - - --- The magic numbers from the RFC. - -magic_numbers :: ABCD -magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) - - --- The 4 lists of (rotation, additive constant) tuples, one for each round - -rounds :: ([(Rotation, Word32)], - [(Rotation, Word32)], - [(Rotation, Word32)], - [(Rotation, Word32)]) -rounds = (r1, r2, r3, r4) - where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), - (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), - (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), - (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), - (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), - (s14, 0x49b40821)] - r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), - (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), - (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), - (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), - (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), - (s24, 0x8d2a4c8a)] - r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), - (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), - (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), - (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), - (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), - (s34, 0xc4ac5665)] - r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), - (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), - (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), - (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), - (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), - (s44, 0xeb86d391)] - s11 = 7 - s12 = 12 - s13 = 17 - s14 = 22 - s21 = 5 - s22 = 9 - s23 = 14 - s24 = 20 - s31 = 4 - s32 = 11 - s33 = 16 - s34 = 23 - s41 = 6 - s42 = 10 - s43 = 15 - s44 = 21 - - --- ===================== CONVERSION FUNCTIONS ======================== - - --- Turn the 4 32 bit words into a string representing the hex number they --- represent. - -abcd_to_string :: ABCD -> String -abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] - - --- Split the 32 bit word up, swap the chunks over and convert the numbers --- to their hex equivalents. - -display_32bits_as_hex :: Word32 -> String -display_32bits_as_hex w = swap_pairs cs - where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] - getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) - swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs - swap_pairs _ = [] - --- Convert to an integer, performing endianness magic as we go - -abcd_to_integer :: ABCD -> Integer -abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) - + rev_num b * 2^(64 :: Int) - + rev_num c * 2^(32 :: Int) - + rev_num d - -rev_num :: Word32 -> Integer -rev_num i = toInteger j `mod` (2^(32 :: Int)) - -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ - where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) - 0 [0,8,16,24] - --- Used to convert a 64 byte string to 16 32bit words - -string_to_word32s :: String -> [Word32] -string_to_word32s "" = [] -string_to_word32s ss = this:string_to_word32s ss' - where (s, ss') = splitAt 4 ss - this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s - - --- Used to convert a list of 512 bools to 16 32bit words - -bools_to_word32s :: [Bool] -> [Word32] -bools_to_word32s [] = [] -bools_to_word32s bs = this:bools_to_word32s rest - where (bs1, bs1') = splitAt 8 bs - (bs2, bs2') = splitAt 8 bs1' - (bs3, bs3') = splitAt 8 bs2' - (bs4, rest) = splitAt 8 bs3' - this = boolss_to_word32 [bs1, bs2, bs3, bs4] - bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 - boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 - - --- Convert the size into a list of characters used by the len_pad function --- for strings - -length_to_chars :: Int -> Word64 -> String -length_to_chars 0 _ = [] -length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) - where this = chr $ fromIntegral $ n .&. 255 - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Proxy.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Proxy.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Proxy.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Proxy.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,214 +0,0 @@ -{-# LANGUAGE CPP #-} ------------------------------------------------------------------------------ --- | --- 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(..) - , noProxy -- :: Proxy - , fetchProxy -- :: Bool -> IO Proxy - , parseProxy -- :: String -> Maybe Proxy - ) where - -{- -#if !defined(WIN32) && defined(mingw32_HOST_OS) -#define WIN32 1 -#endif --} - -import Control.Monad ( when, mplus, join, liftM2 ) - -#if defined(WIN32) -import Network.HTTP.Base ( catchIO ) -import Control.Monad ( liftM ) -import Data.List ( isPrefixOf ) -#endif -import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) -import Network.HTTP.Auth -import Network.URI - ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString ) -import System.IO ( hPutStrLn, stderr ) -import System.Environment - -{- -#if !defined(WIN32) && defined(mingw32_HOST_OS) -#define WIN32 1 -#endif --} - -#if defined(WIN32) -import System.Win32.Types ( DWORD, HKEY ) -import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx ) -import Control.Exception ( bracket ) -import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca ) -#endif - --- | HTTP proxies (or not) are represented via 'Proxy', specifying if a --- proxy should be used for the request (see 'Network.Browser.setProxy') -data Proxy - = NoProxy -- ^ Don't use a proxy. - | Proxy String - (Maybe Authority) -- ^ Use the proxy given. Should be of the - -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". - -- Additionally, an optional 'Authority' for authentication with the proxy. - - -noProxy :: Proxy -noProxy = NoProxy - --- | @envProxyString@ locates proxy server settings by looking --- up env variable @HTTP_PROXY@ (or its lower-case equivalent.) --- If no mapping found, returns @Nothing@. -envProxyString :: IO (Maybe String) -envProxyString = do - env <- getEnvironment - return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) - --- | @proxyString@ tries to locate the user's proxy server setting. --- Consults environment variable, and in case of Windows, by querying --- the Registry (cf. @registryProxyString@.) -proxyString :: IO (Maybe String) -proxyString = liftM2 mplus envProxyString windowsProxyString - -windowsProxyString :: IO (Maybe String) -#if !defined(WIN32) -windowsProxyString = return Nothing -#else -windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString - -registryProxyLoc :: (HKEY,String) -registryProxyLoc = (hive, path) - where - -- 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 - -- end up in the following place: - hive = hKEY_CURRENT_USER - 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. -registryProxyString :: IO (Maybe String) -registryProxyString = catchIO - (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do - enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" - if enable - then fmap Just $ regQueryValue hkey (Just "ProxyServer") - else return Nothing) - (\_ -> return Nothing) - --- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..." --- even though the following article indicates otherwise --- https://support.microsoft.com/en-us/kb/819961 --- --- to be sure, parse strings where each entry in the ';'-separated list above is --- either in the format "protocol=..." or "protocol://..." --- --- only return the first "http" of them, if it exists -parseWindowsProxy :: String -> Maybe String -parseWindowsProxy s = - case proxies of - x:_ -> Just x - _ -> Nothing - where - parts = split ';' s - pr x = case break (== '=') x of - (p, []) -> p -- might be in format http:// - (p, u) -> p ++ "://" ++ drop 1 u - - proxies = filter (isPrefixOf "http://") . map pr $ parts - - split :: Eq a => a -> [a] -> [[a]] - split _ [] = [] - split a xs = case break (a ==) xs of - (ys, []) -> [ys] - (ys, _:zs) -> ys:split a zs - -#endif - --- | @fetchProxy flg@ gets the local proxy settings and parse the string --- into a @Proxy@ value. If you want to be informed of ill-formed proxy --- configuration strings, supply @True@ for @flg@. --- Proxy settings are sourced from the @HTTP_PROXY@ environment variable, --- and in the case of Windows platforms, by consulting IE/WinInet's proxy --- setting in the Registry. -fetchProxy :: Bool -> IO Proxy -fetchProxy warnIfIllformed = do - mstr <- proxyString - case mstr of - Nothing -> return NoProxy - Just str -> case parseProxy str of - Just p -> return p - Nothing -> do - when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines - [ "invalid http proxy uri: " ++ show str - , "proxy uri must be http with a hostname" - , "ignoring http proxy, trying a direct connection" - ] - return NoProxy - --- | @parseProxy str@ translates a proxy server string into a @Proxy@ value; --- returns @Nothing@ if not well-formed. -parseProxy :: String -> Maybe Proxy -parseProxy "" = Nothing -parseProxy str = join - . fmap uri2proxy - $ parseHttpURI str - `mplus` parseHttpURI ("http://" ++ str) - where - parseHttpURI str' = - case parseAbsoluteURI str' of - Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri) - _ -> Nothing - - -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ - -- which lack the @\"http://\"@ URI scheme. The problem is that - -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme - -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. - -- - -- So our strategy is to try parsing as normal uri first and if it lacks the - -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. - -- - --- | tidy up user portion, don't want the trailing "\@". -fixUserInfo :: URI -> URI -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) - } = - Just (Proxy (hst ++ prt) auth) - where - auth = - case auth' of - [] -> Nothing - as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) - where - (usr,pwd) = chopAtDelim ':' as - -uri2proxy _ = Nothing - --- utilities -#if defined(WIN32) -regQueryValueDWORD :: HKEY -> String -> IO DWORD -regQueryValueDWORD hkey name = alloca $ \ptr -> do - -- TODO: this throws away the key type returned by regQueryValueEx - -- we should check it's what we expect instead - _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) - peek ptr - -#endif diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Stream.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Stream.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Stream.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Stream.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,236 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP.Stream --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- Transmitting HTTP requests and responses holding @String@ in their payload bodies. --- This is one of the implementation modules for the "Network.HTTP" interface, representing --- request and response content as @String@s and transmitting them in non-packed form --- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. --- It is mostly here for backwards compatibility, representing how requests and responses --- were transmitted up until the 4.x releases of the HTTP package. --- --- For more detailed information about what the individual exports do, please consult --- the documentation for "Network.HTTP". /Notice/ however that the functions here do --- 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.Stream - - , simpleHTTP -- :: Request_String -> IO (Result Response_String) - , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) - , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) - , 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 - ------------------------------------------------------------------ ------------------- Imports -------------------------------------- ------------------------------------------------------------------ - -import Network.Stream -import Network.StreamDebugger (debugStream) -import Network.TCP (openTCPPort) -import Network.BufferType ( stringBufferOp ) - -import Network.HTTP.Base -import Network.HTTP.Headers -import Network.HTTP.Utils ( trim ) - -import Data.Char (toLower) -import Data.Maybe (fromMaybe) -import Control.Exception (onException) -import Control.Monad (when) - - --- Turn on to enable HTTP traffic logging -debug :: Bool -debug = False - --- File that HTTP traffic logs go to -httpLogFile :: String -httpLogFile = "http-debug.log" - ------------------------------------------------------------------ ------------------- Misc ----------------------------------------- ------------------------------------------------------------------ - - --- | Simple way to transmit a resource across a non-persistent connection. -simpleHTTP :: Request_String -> IO (Result Response_String) -simpleHTTP r = do - auth <- getAuth r - c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) - simpleHTTP_ c r - --- | Like 'simpleHTTP', but acting on an already opened stream. -simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) -simpleHTTP_ s r - | not debug = sendHTTP s r - | otherwise = do - s' <- debugStream httpLogFile s - sendHTTP s' r - -sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) -sendHTTP conn rq = sendHTTP_notify conn rq (return ()) - -sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) -sendHTTP_notify conn rq onSendComplete = do - when providedClose $ (closeOnEnd conn True) - onException (sendMain conn rq onSendComplete) - (close conn) - where - providedClose = findConnClose (rqHeaders rq) - --- From RFC 2616, section 8.2.3: --- 'Because of the presence of older implementations, the protocol allows --- ambiguous situations in which a client may send "Expect: 100- --- continue" without receiving either a 417 (Expectation Failed) status --- or a 100 (Continue) status. Therefore, when a client sends this --- header field to an origin server (possibly via a proxy) from which it --- has never seen a 100 (Continue) status, the client SHOULD NOT wait --- for an indefinite period before sending the request body.' --- --- 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 - --let str = if null (rqBody rqst) - -- then show rqst - -- else show (insertHeader HdrExpect "100-continue" rqst) - -- TODO review throwing away of result - _ <- writeBlock conn (show rqst) - -- write body immediately, don't wait for 100 CONTINUE - -- TODO review throwing away of result - _ <- writeBlock conn (rqBody rqst) - onSendComplete - rsp <- getResponseHead conn - switchResponse conn True False rsp rqst - --- reads and parses headers -getResponseHead :: Stream s => s -> IO (Result ResponseData) -getResponseHead conn = do - lor <- readTillEmpty1 stringBufferOp (readLine conn) - return $ lor >>= parseResponseHead - --- Hmmm, this could go bad if we keep getting "100 Continue" --- responses... Except this should never happen according --- to the RFC. -switchResponse :: Stream s - => s - -> Bool {- allow retry? -} - -> Bool {- is body sent? -} - -> Result ResponseData - -> Request_String - -> IO (Result Response_String) -switchResponse _ _ _ (Left e) _ = return (Left e) - -- retry on connreset? - -- 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 = - case matchResponse (rqMethod rqst) cd of - Continue - | not bdy_sent -> {- Time to send the body -} - do { val <- writeBlock conn (rqBody rqst) - ; case val of - Left e -> return (Left e) - Right _ -> - do { rsp <- getResponseHead conn - ; switchResponse conn allow_retry True rsp rqst - } - } - | otherwise -> {- keep waiting -} - do { rsp <- getResponseHead conn - ; switchResponse conn allow_retry bdy_sent rsp rqst - } - - Retry -> {- Request with "Expect" header failed. - Trouble is the request contains Expects - other than "100-Continue" -} - do { -- TODO review throwing away of result - _ <- writeBlock conn (show rqst ++ rqBody rqst) - ; rsp <- getResponseHead conn - ; switchResponse conn False bdy_sent rsp rqst - } - - Done -> do - when (findConnClose hdrs) - (closeOnEnd conn True) - return (Right $ Response cd rn hdrs "") - - DieHorribly str -> do - close conn - return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) - - ExpectEntity -> - let tc = lookupHeader HdrTransferEncoding hdrs - cl = lookupHeader HdrContentLength hdrs - in - do { rslt <- case tc of - Nothing -> - case cl of - Just x -> linearTransfer (readBlock conn) (read x :: Int) - Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] - Just x -> - case map toLower (trim x) of - "chunked" -> chunkedTransfer stringBufferOp - (readLine conn) (readBlock conn) - _ -> uglyDeathTransfer "sendHTTP" - ; case rslt of - Left e -> close conn >> return (Left e) - Right (ftrs,bdy) -> do - when (findConnClose (hdrs++ftrs)) - (closeOnEnd conn True) - return (Right (Response cd rn (hdrs++ftrs) bdy)) - } - --- | 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 - where - -- reads and parses headers - getRequestHead :: IO (Result RequestData) - getRequestHead = - do { lor <- readTillEmpty1 stringBufferOp (readLine conn) - ; return $ lor >>= parseRequestHead - } - - processRequest (Left e) = return $ Left e - processRequest (Right (rm,uri,hdrs)) = - do -- FIXME : Also handle 100-continue. - let tc = lookupHeader HdrTransferEncoding hdrs - cl = lookupHeader HdrContentLength hdrs - rslt <- case tc of - Nothing -> - case cl of - Just x -> linearTransfer (readBlock conn) (read x :: Int) - Nothing -> return (Right ([], "")) -- hopefulTransfer "" - Just x -> - case map toLower (trim x) of - "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 --- 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 - _ <- writeBlock conn (show rsp) - -- write body immediately, don't wait for 100 CONTINUE - -- TODO review throwing away of result - _ <- writeBlock conn (rspBody rsp) - return () diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Utils.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Utils.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP/Utils.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP/Utils.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,111 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP.Utils --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- Set of utility functions and definitions used by package modules. --- -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]) - - ) where - -import Data.Char -import Data.List ( elemIndex ) -import Data.Maybe ( fromMaybe ) - --- | @crlf@ is our beloved two-char line terminator. -crlf :: String -crlf = "\r\n" - --- | @lf@ is a tolerated line terminator, per RFC 2616 section 19.3. -lf :: String -lf = "\n" - --- | @sp@ lets you save typing one character. -sp :: String -sp = " " - --- | @split delim ls@ splits a list into two parts, the @delim@ occurring --- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is --- returned. -split :: Eq a => a -> [a] -> Maybe ([a],[a]) -split delim list = case delim `elemIndex` list of - Nothing -> Nothing - Just x -> Just $ splitAt x list - --- | @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 -trimL xs = dropWhile isSpace xs - --- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace') --- from @str@. -trimR :: String -> String -trimR str = fromMaybe "" $ foldr trimIt Nothing str - where - trimIt x (Just xs) = Just (x:xs) - 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 = - case break (==c) xs of - (_,[]) -> [xs] - (as,_:bs) -> as : splitBy c bs - --- | @readsOne f def str@ tries to 'read' @str@, taking --- 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 = - case reads str of - ((v,_):_) -> f v - _ -> n - - --- | @dropWhileTail p ls@ chops off trailing elements from @ls@ --- until @p@ returns @False@. -dropWhileTail :: (a -> Bool) -> [a] -> [a] -dropWhileTail f ls = - case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] } - where - chop x (Just xs) = Just (x:xs) - chop x _ - | f x = Nothing - | otherwise = Just [x] - --- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence --- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second --- list is empty and the first is equal to @ls@. -chopAtDelim :: Eq a => a -> [a] -> ([a],[a]) -chopAtDelim elt xs = - case break (==elt) xs of - (_,[]) -> (xs,[]) - (as,_:bs) -> (as,bs) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/HTTP.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/HTTP.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,265 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.HTTP --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- The 'Network.HTTP' module provides a simple interface for sending and --- receiving content over HTTP in Haskell. Here's how to fetch a document from --- a URL and return it as a String: --- --- > --- > simpleHTTP (getRequest "http://www.haskell.org/") >>= fmap (take 100) . getResponseBody --- > -- fetch document and return it (as a 'String'.) --- --- Other functions let you control the submission and transfer of HTTP --- 'Request's and 'Response's more carefully, letting you integrate the use --- of 'Network.HTTP' functionality into your application. --- --- The module also exports the main types of the package, 'Request' and 'Response', --- along with 'Header' and functions for working with these. --- --- The actual functionality is implemented by modules in the @Network.HTTP.*@ --- 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 --- 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 --- 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 --- @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.Base - , module Network.HTTP.Headers - - {- 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) - , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) - , receiveHTTP -- :: Stream s => s -> IO (Result Request) - , 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 - ------------------------------------------------------------------ ------------------- Imports -------------------------------------- ------------------------------------------------------------------ - -import Network.HTTP.Headers -import Network.HTTP.Base -import qualified Network.HTTP.HandleStream as S --- old implementation: import Network.HTTP.Stream -import Network.TCP -import Network.Stream ( Result ) -import Network.URI ( parseURI ) - -import Data.Maybe ( fromMaybe ) - -{- - Note: if you switch over/back to using Network.HTTP.Stream here, you'll - have to wrap the results from 'openStream' as Connections via 'hstreamToConnection' - prior to delegating to the Network.HTTP.Stream functions. --} - --- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent --- connection to the HTTP server that @req@ is destined for, followed by transmitting --- it and gathering up the response as a 'Result'. Prior to sending the request, --- it is normalized (via 'normalizeRequest'). If you have to mediate the request --- via an HTTP proxy, you will have to normalize the request yourself. Or switch to --- using 'Network.Browser' instead. --- --- Examples: --- --- > simpleHTTP (getRequest "http://hackage.haskell.org/") --- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/") - -simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty)) -simpleHTTP r = do - auth <- getAuth r - failHTTPS (rqURI r) - 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 - let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r - S.sendHTTP s norm_r - --- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over --- @hStream@, but does not alter the status of the connection, nor request it to be --- 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 - S.sendHTTP conn norm_r - --- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but --- lets you supply an IO @action@ to execute once the request has been successfully --- transmitted over the connection. Useful when you want to set up tracing of --- request transmission and its performance. -sendHTTP_notify :: HStream ty - => HandleStream ty - -> Request ty - -> IO () - -> IO (Result (Response ty)) -sendHTTP_notify conn rq onSendComplete = do - let norm_r = normalizeRequest defaultNormalizeRequestOptions rq - S.sendHTTP_notify conn norm_r onSendComplete - --- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ -receiveHTTP :: HStream ty => HandleStream ty -> IO (Result (Request ty)) -receiveHTTP conn = S.receiveHTTP conn - --- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over --- 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 = S.respondHTTP conn rsp - - --- | A convenience constructor for a GET 'Request'. --- --- If the URL isn\'t syntactically valid, the function raises an error. -getRequest - :: String -- ^URL to fetch - -> Request_String -- ^The constructed request -getRequest urlString = - case parseURI urlString of - Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) - Just u -> mkRequest GET u - --- | A convenience constructor for a HEAD 'Request'. --- --- If the URL isn\'t syntactically valid, the function raises an error. -headRequest - :: String -- ^URL to fetch - -> Request_String -- ^The constructed request -headRequest urlString = - case parseURI urlString of - Nothing -> error ("headRequest: Not a valid URL - " ++ urlString) - Just u -> mkRequest HEAD u - --- | A convenience constructor for a POST 'Request'. --- --- If the URL isn\'t syntactically valid, the function raises an error. -postRequest - :: String -- ^URL to POST to - -> Request_String -- ^The constructed request -postRequest urlString = - case parseURI urlString of - Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) - Just u -> mkRequest POST u - --- | A convenience constructor for a POST 'Request'. --- --- It constructs a request and sets the body as well as --- the Content-Type and Content-Length headers. The contents of the body --- are forced to calculate the value for the Content-Length header. --- --- If the URL isn\'t syntactically valid, the function raises an error. -postRequestWithBody - :: String -- ^URL to POST to - -> String -- ^Content-Type of body - -> String -- ^The body of the request - -> Request_String -- ^The constructed request -postRequestWithBody urlString typ body = - case parseURI urlString of - Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString) - Just u -> setRequestBody (mkRequest POST u) (typ, body) - --- | @getResponseBody response@ takes the response of a HTTP requesting action and --- tries to extricate the body of the 'Response' @response@. If the request action --- returned an error, an IO exception is raised. -getResponseBody :: Result (Response ty) -> IO ty -getResponseBody (Left err) = fail (show err) -getResponseBody (Right r) = return (rspBody r) - --- | @getResponseBody response@ takes the response of a HTTP requesting action and --- tries to extricate the status code of the 'Response' @response@. If the request action --- returned an error, an IO exception is raised. -getResponseCode :: Result (Response ty) -> IO ResponseCode -getResponseCode (Left err) = fail (show err) -getResponseCode (Right r) = return (rspCode r) - - --- --- * TODO --- - request pipelining --- - https upgrade (includes full TLS, i.e. SSL, implementation) --- - use of Stream classes will pay off --- - consider C implementation of encryption\/decryption --- - 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@] --- If this header is present in any request or --- response, and it's value is "close", then --- 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 --- header has the value \"100-continue\". After --- 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 --- or will generate an error response (probably 4xx). --- --- --- * Response code notes --- Some response codes induce special behaviour: --- --- [@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 --- request attempt (without Expect header), unless no Expect header --- had been added (in which case 417 response is returned). diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/StreamDebugger.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/StreamDebugger.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/StreamDebugger.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/StreamDebugger.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,103 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.StreamDebugger --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- Implements debugging of @Stream@s. Originally part of Gray's\/Bringert's --- HTTP module. --- --- * Changes by Robin Bate Boerop : --- - Created. Made minor formatting changes. --- ------------------------------------------------------------------------------ -module Network.StreamDebugger - ( StreamDebugger - , debugStream - , debugByteStream - ) where - -import Network.Stream (Stream(..)) -import System.IO - ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, - hSetBuffering, BufferMode(NoBuffering) - ) -import Network.TCP ( HandleStream, HStream, - StreamHooks(..), setStreamHooks, getStreamHooks ) - --- | Allows stream logging. Refer to 'debugStream' below. -data StreamDebugger x - = Dbg Handle x - -instance (Stream x) => Stream (StreamDebugger x) where - readBlock (Dbg h x) n = - do val <- readBlock x n - hPutStrLn h ("--readBlock " ++ show n) - hPutStrLn h (show val) - return val - readLine (Dbg h x) = - do val <- readLine x - hPutStrLn h ("--readLine") - hPutStrLn h (show val) - return val - writeBlock (Dbg h x) str = - do val <- writeBlock x str - hPutStrLn h ("--writeBlock" ++ show str) - hPutStrLn h (show val) - return val - close (Dbg h x) = - do hPutStrLn h "--closing..." - hFlush h - close x - hPutStrLn h "--closed." - hClose h - closeOnEnd (Dbg h x) f = - do hPutStrLn h ("--close-on-end.." ++ show f) - 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 = - 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 - case sh of - Just h - | hook_name h == file -> return stream -- reuse the stream hooks. - _ -> do - h <- openFile file AppendMode - hSetBuffering h NoBuffering - hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") - setStreamHooks stream (debugStreamHooks h file) - return stream - -debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty -debugStreamHooks h nm = - StreamHooks - { hook_readBlock = \ toStr n val -> do - let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} - hPutStrLn h ("--readBlock " ++ show n) - hPutStrLn h (either show show eval) - , hook_readLine = \ toStr val -> do - let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} - hPutStrLn h ("--readLine") - hPutStrLn h (either show show eval) - , hook_writeBlock = \ toStr str val -> do - hPutStrLn h ("--writeBlock " ++ show val) - hPutStrLn h (toStr str) - , hook_close = do - hPutStrLn h "--closing..." - hFlush h - hClose h - , hook_name = nm - } diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/Stream.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/Stream.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/Stream.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/Stream.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,91 +0,0 @@ ------------------------------------------------------------------------------ --- | --- Module : Network.Stream --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- An library for creating abstract streams. Originally part of Gray's\/Bringert's --- HTTP module. --- --- * Changes by Robin Bate Boerop : --- - Removed unnecessary import statements. --- - Moved Debug code to StreamDebugger.hs --- - Moved Socket-related code to StreamSocket.hs. --- --- * Changes by Simon Foster: --- - Split Network.HTTPmodule up into to separate --- Network.[Stream,TCP,HTTP] modules ------------------------------------------------------------------------------ -module Network.Stream - ( Stream(..) - , ConnError(..) - , Result - , bindE - , fmapE - - , failParse -- :: String -> Result a - , failWith -- :: ConnError -> Result a - , failMisc -- :: String -> Result a - ) where - -import Control.Monad.Error - -data ConnError - = ErrorReset - | ErrorClosed - | ErrorParse String - | 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) - -failParse :: String -> Result a -failParse x = failWith (ErrorParse x) - -failWith :: ConnError -> Result a -failWith x = Left x - -bindE :: Result a -> (a -> Result b) -> Result b -bindE (Left e) _ = Left e -bindE (Right v) f = f v - -fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b) -fmapE f a = do - x <- a - case x of - Left e -> return (Left e) - Right r -> return (f r) - --- | This is the type returned by many exported network functions. -type Result a = Either ConnError {- error -} - a {- result -} - --- | Streams should make layering of TLS protocol easier in future, --- they allow reading/writing to files etc for debugging, --- they allow use of protocols other than TCP/IP --- and they allow customisation. --- --- Instances of this class should not trim --- 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 - readLine :: x -> IO (Result String) - readBlock :: x -> Int -> IO (Result String) - writeBlock :: x -> String -> IO (Result ()) - close :: x -> IO () - closeOnEnd :: x -> Bool -> IO () - -- ^ True => shutdown the connection when response has been read / end-of-stream - -- has been reached. diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/StreamSocket.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/StreamSocket.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/StreamSocket.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/StreamSocket.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,93 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} ------------------------------------------------------------------------------ --- | --- Module : Network.StreamSocket --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module. --- --- * Changes by Robin Bate Boerop : --- - Made dependencies explicit in import statements. --- - Removed false dependencies in import statements. --- - Created separate module for instance Stream Socket. --- --- * Changes by Simon Foster: --- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules --- ------------------------------------------------------------------------------ -module Network.StreamSocket - ( handleSocketError - , myrecv - ) where - -import Network.Stream - ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result - ) -import Network.Socket - ( Socket, getSocketOption, shutdown, send, recv, sClose - , ShutdownCmd(ShutdownBoth), SocketOption(SoError) - ) - -import Network.HTTP.Base ( catchIO ) -import Control.Monad (liftM) -import Control.Exception as Exception (IOException) -import System.IO.Error (isEOFError) - --- | Exception handler for socket operations. -handleSocketError :: Socket -> IOException -> IO (Result a) -handleSocketError sk e = - do se <- getSocketOption sk SoError - case se of - 0 -> ioError e - 10054 -> return $ Left ErrorReset -- reset - _ -> return $ Left $ ErrorMisc $ show se - -myrecv :: Socket -> Int -> IO String -myrecv sock len = - let handler e = if isEOFError e then return [] else ioError e - in catchIO (recv sock len) handler - -instance Stream Socket where - readBlock sk n = readBlockSocket sk n - readLine sk = readLineSocket sk - writeBlock sk str = writeBlockSocket sk str - close sk = do - -- This slams closed the connection (which is considered rude for TCP\/IP) - shutdown sk ShutdownBoth - sClose sk - closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. - -readBlockSocket :: Socket -> Int -> IO (Result String) -readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) - where - fn x = do { str <- myrecv sk x - ; let len = length str - ; if len < x - then ( fn (x-len) >>= \more -> return (str++more) ) - else return str - } - --- Use of the following function is discouraged. --- 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) -readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk) - where - fn str = do - c <- myrecv sk 1 -- like eating through a straw. - 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 - fn [] = return () - fn x = send sk x >>= \i -> fn (drop i x) - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/TCP.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/TCP.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Network/TCP.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Network/TCP.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,414 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} ------------------------------------------------------------------------------ --- | --- Module : Network.TCP --- Copyright : See LICENSE file --- License : BSD --- --- Maintainer : Ganesh Sittampalam --- Stability : experimental --- Portability : non-portable (not tested) --- --- Some utility functions for working with the Haskell @network@ package. Mostly --- for internal use by the @Network.HTTP@ code. --- ------------------------------------------------------------------------------ -module Network.TCP - ( Connection - , EndPoint(..) - , openTCPPort - , isConnectedTo - - , openTCPConnection - , socketConnection - , isTCPConnectedTo - - , HandleStream - , HStream(..) - - , StreamHooks(..) - , nullHooks - , setStreamHooks - , getStreamHooks - , hstreamToConnection - - ) where - -import Network.Socket - ( Socket, SocketOption(KeepAlive) - , SocketType(Stream), connect - , shutdown, ShutdownCmd(..) - , sClose, setSocketOption, getPeerName - , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo - , defaultHints, addrFamily, withSocketsDo - , addrSocketType, addrAddress - ) -import qualified Network.Stream as Stream - ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) -import Network.Stream - ( ConnError(..) - , Result - , failWith - , failMisc - ) -import Network.BufferType - -import Network.HTTP.Base ( catchIO ) -import Network.Socket ( socketToHandle ) - -import Data.Char ( toLower ) -import Data.Word ( Word8 ) -import Control.Concurrent -import Control.Exception ( onException ) -import Control.Monad ( liftM, when ) -import System.IO ( Handle, hFlush, IOMode(..), hClose ) -import System.IO.Error ( isEOFError ) - -import qualified Data.ByteString as Strict -import qualified Data.ByteString.Lazy as Lazy - ------------------------------------------------------------------ ------------------- TCP Connections ------------------------------ ------------------------------------------------------------------ - --- | The 'Connection' newtype is a wrapper that allows us to make --- connections an instance of the Stream class, without GHC extensions. --- While this looks sort of like a generic reference to the transport --- layer it is actually TCP specific, which can be seen in the --- implementation of the 'Stream Connection' instance. -newtype Connection = Connection (HandleStream String) - -newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} - -data EndPoint = EndPoint { epHost :: String, epPort :: Int } - -instance Eq EndPoint where - EndPoint host1 port1 == EndPoint host2 port2 = - map toLower host1 == map toLower host2 && port1 == port2 - -data Conn a - = MkConn { connSock :: ! Socket - , connHandle :: Handle - , connBuffer :: BufferOp a - , connInput :: Maybe a - , connEndPoint :: EndPoint - , connHooks :: Maybe (StreamHooks a) - , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. - } - | ConnClosed - deriving(Eq) - -hstreamToConnection :: HandleStream String -> Connection -hstreamToConnection h = Connection h - -connHooks' :: Conn a -> Maybe (StreamHooks a) -connHooks' ConnClosed{} = Nothing -connHooks' x = connHooks x - --- all of these are post-op hooks -data StreamHooks ty - = StreamHooks - { hook_readLine :: (ty -> String) -> Result ty -> IO () - , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO () - , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO () - , hook_close :: IO () - , hook_name :: String -- hack alert: name of the hook itself. - } - -instance Eq ty => Eq (StreamHooks ty) where - (==) _ _ = True - -nullHooks :: StreamHooks ty -nullHooks = StreamHooks - { hook_readLine = \ _ _ -> return () - , hook_readBlock = \ _ _ _ -> return () - , hook_writeBlock = \ _ _ _ -> return () - , hook_close = return () - , hook_name = "" - } - -setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () -setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) - -getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty)) -getStreamHooks h = readMVar (getRef h) >>= return.connHooks - --- | @HStream@ overloads the use of 'HandleStream's, letting you --- overload the handle operations over the type that is communicated --- across the handle. It comes in handy for @Network.HTTP@ 'Request' --- and 'Response's as the payload representation isn't fixed, but overloaded. --- --- 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) - readLine :: HandleStream bufType -> IO (Result bufType) - readBlock :: HandleStream bufType -> Int -> IO (Result bufType) - writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) - close :: HandleStream bufType -> IO () - closeQuick :: HandleStream bufType -> IO () - closeOnEnd :: HandleStream bufType -> Bool -> IO () - -instance HStream Strict.ByteString where - openStream = openTCPConnection - openSocketStream = socketConnection - readBlock c n = readBlockBS c n - readLine c = readLineBS c - writeBlock c str = writeBlockBS c str - close c = closeIt c Strict.null True - closeQuick c = closeIt c Strict.null False - closeOnEnd c f = closeEOF c f - -instance HStream Lazy.ByteString where - openStream = \ a b -> openTCPConnection_ a b True - openSocketStream = \ a b c -> socketConnection_ a b c True - readBlock c n = readBlockBS c n - readLine c = readLineBS c - writeBlock c str = writeBlockBS c str - close c = closeIt c Lazy.null True - closeQuick c = closeIt c Lazy.null False - closeOnEnd c f = closeEOF c f - -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 - close (Connection c) = Network.TCP.close c - closeOnEnd (Connection c) f = Network.TCP.closeEOF c f - -instance HStream String where - openStream = openTCPConnection - openSocketStream = socketConnection - readBlock ref n = readBlockBS ref n - - -- 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, - -- since in general messages are serialised in their entirety. - writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) - - -- Closes a Connection. Connection will no longer - -- allow any of the other Stream functions. Notice that a Connection may close - -- 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 --- may trigger a network connection. -openTCPPort :: String -> Int -> IO Connection -openTCPPort uri port = openTCPConnection uri port >>= return.Connection - --- Add a "persistent" option? Current persistent is default. --- Use "Result" type for synchronous exception reporting? -openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty) -openTCPConnection uri port = openTCPConnection_ uri port False - -openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) -openTCPConnection_ uri port stashInput = do - -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes - -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether - -- it should, or whether all call sites should be using something different instead, but - -- the simplest short-term fix is to strip any surrounding square brackets here. - -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986. - let fixedUri = - case uri of - '[':(rest@(c:_)) | last rest == ']' - -> if c == 'v' || c == 'V' - then error $ "Unsupported post-IPv6 address " ++ uri - else init rest - _ -> uri - - - -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows - -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally - -- like this as it just does a once-only installation of a shutdown handler to run at program exit, - -- rather than actually shutting down after the action - addrinfos <- withSocketsDo $ getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just fixedUri) (Just . show $ port) - case addrinfos of - [] -> fail "openTCPConnection: getAddrInfo returned no address information" - (a:_) -> do - s <- socket (addrFamily a) Stream defaultProtocol - onException (do - setSocketOption s KeepAlive 1 - connect s (addrAddress a) - socketConnection_ fixedUri port s stashInput - ) (sClose s) - --- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. -socketConnection :: BufferType ty - => String - -> Int - -> Socket - -> IO (HandleStream ty) -socketConnection hst port sock = socketConnection_ hst port sock False - --- Internal function used to control the on-demand streaming of input --- for /lazy/ streams. -socketConnection_ :: BufferType ty - => String - -> Int - -> Socket - -> Bool - -> IO (HandleStream 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 - { connSock = sock - , connHandle = h - , connBuffer = bufferOps - , connInput = mb - , connEndPoint = EndPoint hst port - , connHooks = Nothing - , connCloseEOF = False - } - v <- newMVar conn - return (HandleStream v) - -closeConnection :: HStream a => HandleStream a -> IO Bool -> IO () -closeConnection ref readL = do - -- won't hold onto the lock for the duration - -- we are draining it...ToDo: have Connection - -- into a shutting-down state so that other - -- threads will simply back off if/when attempting - -- to also close it. - c <- readMVar (getRef ref) - closeConn c `catchIO` (\_ -> return ()) - modifyMVar_ (getRef ref) (\ _ -> return ConnClosed) - where - -- Be kind to peer & close gracefully. - closeConn ConnClosed = return () - closeConn conn = do - let sk = connSock conn - hFlush (connHandle conn) - shutdown sk ShutdownSend - suck readL - hClose (connHandle conn) - shutdown sk ShutdownReceive - sClose sk - - suck :: IO Bool -> IO () - suck rd = do - f <- rd - if f then return () else suck rd - --- | Checks both that the underlying Socket is connected --- and that the connection peer matches the given --- host name (which is recorded locally). -isConnectedTo :: Connection -> EndPoint -> IO Bool -isConnectedTo (Connection conn) endPoint = isTCPConnectedTo conn endPoint - -isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool -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 - -readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a) -readBlockBS ref n = onNonClosedDo ref $ \ conn -> do - x <- bufferGetBlock ref n - maybe (return ()) - (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) - (connHooks' conn) - return x - --- This function uses a buffer, at this time the buffer is just 1000 characters. --- (however many bytes this is is left for the user to decipher) -readLineBS :: HStream a => HandleStream a -> IO (Result a) -readLineBS ref = onNonClosedDo ref $ \ conn -> do - x <- bufferReadLine ref - maybe (return ()) - (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) - (connHooks' conn) - return x - --- 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 - x <- bufferPutBlock (connBuffer conn) (connHandle conn) b - maybe (return ()) - (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) - (connHooks' conn) - return x - -closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO () -closeIt c p b = do - closeConnection c (if b - then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True} - else return True) - conn <- readMVar (getRef c) - maybe (return ()) - (hook_close) - (connHooks' conn) - -closeEOF :: HandleStream ty -> Bool -> IO () -closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg}) - -bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a) -bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do - case connInput conn of - Just c -> do - let (a,b) = buf_splitAt (connBuffer conn) n c - modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) - return (return a) - _ -> do - catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return) - (\ e -> - if isEOFError e - then do - when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) - return (return (buf_empty (connBuffer conn))) - else return (failMisc (show e))) - -bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) -bufferPutBlock ops h b = - catchIO (buf_hPut ops h b >> hFlush h >> return (return ())) - (\ e -> return (failMisc (show e))) - -bufferReadLine :: HStream a => HandleStream a -> IO (Result a) -bufferReadLine ref = onNonClosedDo ref $ \ conn -> do - case connInput conn of - Just c -> do - let (a,b0) = buf_span (connBuffer conn) (/='\n') c - let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0 - modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) - return (return (buf_append (connBuffer conn) a newl)) - _ -> catchIO - (buf_hGetLine (connBuffer conn) (connHandle conn) >>= - return . return . appendNL (connBuffer conn)) - (\ e -> - if isEOFError e - then do - when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) - return (return (buf_empty (connBuffer conn))) - else return (failMisc (show e))) - where - -- 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') - -onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b) -onNonClosedDo h act = do - x <- readMVar (getRef h) - case x of - ConnClosed{} -> return (failWith ErrorClosed) - _ -> act x - diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Setup.lhs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Setup.lhs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/Setup.lhs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 @@ -1,8 +0,0 @@ -#!/usr/bin/env runghc - -> module Main where - -> import Distribution.Simple - -> main :: IO () -> main = defaultMain diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/test/Httpd.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/test/Httpd.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/test/Httpd.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/test/Httpd.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,158 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Httpd - ( Request, Response, Server - , mkResponse - , reqMethod, reqURI, reqHeaders, reqBody - , shed -#ifdef WARP_TESTS - , warp -#endif - ) - where - -import Control.Applicative -import Control.Arrow ( (***) ) -import Control.DeepSeq -import Control.Monad -import Control.Monad.Trans ( liftIO ) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString.Char8 as BC -import qualified Data.ByteString.Lazy.Char8 as BLC -#ifdef WARP_TESTS -import qualified Data.CaseInsensitive as CI -#endif -import Data.Maybe ( fromJust ) -import Network.URI ( URI, parseRelativeReference ) - -import Network.Socket - ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily - , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6) - , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr) - ) -#ifdef WARP_TESTS -#if MIN_VERSION_network(2,4,0) -import Network.Socket ( bind ) -#else -import Network.Socket ( bindSocket, Socket, SockAddr ) -#endif -#endif - -import qualified Network.Shed.Httpd as Shed - ( Request, Response(Response), initServer - , reqMethod, reqURI, reqHeaders, reqBody - ) -#ifdef WARP_TESTS -#if !MIN_VERSION_wai(3,0,0) -import qualified Data.Conduit.Lazy as Warp -#endif - -import qualified Network.HTTP.Types as Warp - ( Status(..) ) -import qualified Network.Wai as Warp -import qualified Network.Wai.Handler.Warp as Warp - ( runSettingsSocket, defaultSettings, setPort ) -#endif - -data Request = Request - { - reqMethod :: String, - reqURI :: URI, - reqHeaders :: [(String, String)], - reqBody :: String - } - -data Response = Response - { - respStatus :: Int, - respHeaders :: [(String, String)], - respBody :: String - } - -mkResponse :: Int -> [(String, String)] -> String -> Response -mkResponse = Response - -type Server = Int -> (Request -> IO Response) -> IO () - -shed :: Server -shed port handler = - () <$ Shed.initServer - port - (liftM responseToShed . handler . requestFromShed) - where - responseToShed (Response status hdrs body) = - Shed.Response status hdrs body - chomp = reverse . strip '\r' . reverse - strip c (c':str) | c == c' = str - strip c str = str - requestFromShed request = - Request - { - reqMethod = Shed.reqMethod request, - reqURI = Shed.reqURI request, - reqHeaders = map (id *** chomp) $ Shed.reqHeaders request, - reqBody = Shed.reqBody request - } - -#if !MIN_VERSION_bytestring(0,10,0) -instance NFData B.ByteString where - rnf = rnf . B.length -#endif - -#ifdef WARP_TESTS -#if !MIN_VERSION_network(2,4,0) -bind :: Socket -> SockAddr -> IO () -bind = bindSocket -#endif - -warp :: Bool -> Server -warp ipv6 port handler = do - addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) - (Just $ if ipv6 then "::1" else "127.0.0.1") - (Just . show $ port) - case addrinfos of - [] -> fail "Couldn't obtain address information in warp" - (addri:_) -> do - sock <- socket (addrFamily addri) Stream defaultProtocol - setSocketOption sock ReuseAddr 1 - bind sock (addrAddress addri) - listen sock 5 -#if MIN_VERSION_wai(3,0,0) - Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do - request <- requestFromWarp warpRequest - response <- handler request - warpRespond (responseToWarp response) -#else - Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do - request <- requestFromWarp warpRequest - response <- handler request - return (responseToWarp response) -#endif - where - responseToWarp (Response status hdrs body) = - Warp.responseLBS - (Warp.Status status B.empty) - (map headerToWarp hdrs) - (BLC.pack body) - headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value) - headerFromWarp (name, value) = - (BC.unpack (CI.original name), BC.unpack value) - requestFromWarp request = do -#if MIN_VERSION_wai(3,0,1) - body <- fmap BLC.unpack $ Warp.strictRequestBody request -#else - body <- fmap BLC.unpack $ Warp.lazyRequestBody request - body `deepseq` return () -#endif - return $ - Request - { - reqMethod = BC.unpack (Warp.requestMethod request), - reqURI = fromJust . parseRelativeReference . - BC.unpack . Warp.rawPathInfo $ - request, - reqHeaders = map headerFromWarp (Warp.requestHeaders request), - reqBody = body - } -#endif diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/test/httpTests.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/test/httpTests.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/test/httpTests.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/test/httpTests.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,668 +0,0 @@ -{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-} -import Control.Concurrent - -import Control.Applicative ((<$)) -import Control.Concurrent (threadDelay) -import Control.Exception (try) -import qualified Data.ByteString.Lazy.Char8 as BL (pack) -import Data.Char (isSpace) -import qualified Data.Digest.Pure.MD5 as MD5 (md5) -import Data.List.Split (splitOn) -import Data.Maybe (fromJust) -import System.IO.Error (userError) - -import qualified Httpd -import qualified UnitTests - -import Network.Browser -import Network.HTTP -import Network.HTTP.Base -import Network.HTTP.Auth -import Network.HTTP.Headers -import Network.Stream (Result) -import Network.URI (uriPath, parseURI) - -import System.Environment (getArgs) -import System.Info (os) -import System.IO (getChar) - -import Test.Framework (defaultMainWithArgs, testGroup) -import Test.Framework.Providers.HUnit -import Test.HUnit - - -basicGetRequest :: (?testUrl :: ServerAddress) => Assertion -basicGetRequest = do - response <- simpleHTTP (getRequest (?testUrl "/basic/get")) - code <- getResponseCode response - assertEqual "HTTP status code" (2, 0, 0) code - body <- getResponseBody response - assertEqual "Receiving expected response" "It works." body - -basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion -basicGetRequestLBS = do - response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get"))))) - code <- getResponseCode response - assertEqual "HTTP status code" (2, 0, 0) code - body <- getResponseBody response - assertEqual "Receiving expected response" (BL.pack "It works.") body - -basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion -basicHeadRequest = do - response <- simpleHTTP (headRequest (?testUrl "/basic/head")) - code <- getResponseCode response - assertEqual "HTTP status code" (2, 0, 0) code - body <- getResponseBody response - -- the body should be empty, since this is a HEAD request - assertEqual "Receiving expected response" "" body - -basicExample :: (?testUrl :: ServerAddress) => Assertion -basicExample = do - result <- - -- sample code from Network.HTTP haddock, with URL changed - -- Note there's also a copy of the example in the .cabal file - simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody - assertEqual "Receiving expected response" (take 100 haskellOrgText) result - -secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion -secureGetRequest = do - response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything")) - assertEqual "Threw expected exception" - (Left (userError "https not supported")) - (fmap show response) -- fmap show because Response isn't in Eq - -basicPostRequest :: (?testUrl :: ServerAddress) => Assertion -basicPostRequest = do - let sendBody = "body" - response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post") - "text/plain" - sendBody - code <- getResponseCode response - assertEqual "HTTP status code" (2, 0, 0) code - body <- getResponseBody response - assertEqual "Receiving expected response" - (show (Just "text/plain", Just "4", sendBody)) - body - -userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion -userpwAuthFailure = do - response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic")) - code <- getResponseCode response - body <- getResponseBody response - assertEqual "HTTP status code" ((4, 0, 1), - "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body) - -- in case of 401, the server returns the contents of the Authz header - -userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion -userpwAuthSuccess = do - response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic")) - code <- getResponseCode response - body <- getResponseBody response - assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) - -basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion -basicAuthFailure = do - response <- simpleHTTP (getRequest (?testUrl "/auth/basic")) - code <- getResponseCode response - body <- getResponseBody response - assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body) - -credentialsBasic :: (?testUrl :: ServerAddress) => Authority -credentialsBasic = AuthBasic "Testing realm" "test" "password" - (fromJust . parseURI . ?testUrl $ "/auth/basic") - -basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion -basicAuthSuccess = do - let req = getRequest (?testUrl "/auth/basic") - let authString = withAuthority credentialsBasic req - let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req } - response <- simpleHTTP reqWithAuth - code <- getResponseCode response - body <- getResponseBody response - assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) - -utf8URLEncode :: Assertion -utf8URLEncode = do - assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com" - assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD" - assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE" - -utf8URLDecode :: Assertion -utf8URLDecode = do - assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com" - assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow" - assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好" - assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо" - -browserExample :: (?testUrl :: ServerAddress) => Assertion -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 - (_, rsp) - <- Network.Browser.browse $ do - setAllowRedirects True -- handle HTTP redirects - request $ getRequest (?testUrl "/browser/example") - return (take 100 (rspBody rsp)) - assertEqual "Receiving expected response" (take 100 haskellOrgText) result - --- A vanilla HTTP request using Browser shouln't send a cookie header -browserNoCookie :: (?testUrl :: ServerAddress) => Assertion -browserNoCookie = do - (_, response) <- browse $ do - setOutHandler (const $ return ()) - request $ getRequest (?testUrl "/browser/no-cookie") - let code = rspCode response - assertEqual "HTTP status code" (2, 0, 0) code - - --- Regression test --- * Browser sends vanilla request to server --- * Server sets one cookie "hello=world" --- * Browser sends a second request --- --- Expected: Server gets single cookie with "hello=world" --- Actual: Server gets 3 extra cookies, which are actually cookie attributes: --- "$Version=0;hello=world;$Domain=localhost:8080\r" -browserOneCookie :: (?testUrl :: ServerAddress) => Assertion -browserOneCookie = do - (_, response) <- browse $ do - setOutHandler (const $ return ()) - -- This first requests returns a single Set-Cookie: hello=world - _ <- request $ getRequest (?testUrl "/browser/one-cookie/1") - - -- This second request should send a single Cookie: hello=world - request $ getRequest (?testUrl "/browser/one-cookie/2") - let body = rspBody response - assertEqual "Receiving expected response" "" body - let code = rspCode response - assertEqual "HTTP status code" (2, 0, 0) code - -browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion -browserTwoCookies = do - (_, response) <- browse $ do - setOutHandler (const $ return ()) - -- This first request returns two cookies - _ <- request $ getRequest (?testUrl "/browser/two-cookies/1") - - -- This second request should send them back - request $ getRequest (?testUrl "/browser/two-cookies/2") - let body = rspBody response - assertEqual "Receiving expected response" "" body - let code = rspCode response - assertEqual "HTTP status code" (2, 0, 0) code - - -browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion -browserFollowsRedirect n = do - (_, response) <- browse $ do - setOutHandler (const $ return ()) - request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") - assertEqual "Receiving expected response from server" - ((2, 0, 0), "It works.") - (rspCode response, rspBody response) - -browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion -browserReturnsRedirect n = do - (_, response) <- browse $ do - setOutHandler (const $ return ()) - request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") - assertEqual "Receiving expected response from server" - ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "") - (rspCode response, rspBody response) - -authGenBasic _ "Testing realm" = return $ Just ("test", "password") -authGenBasic _ realm = fail $ "Unexpected realm " ++ realm - -browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion -browserBasicAuth = do - (_, response) <- browse $ do - setOutHandler (const $ return ()) - - setAuthorityGen authGenBasic - - request $ getRequest (?testUrl "/auth/basic") - - assertEqual "Receiving expected response from server" - ((2, 0, 0), "Here's the secret") - (rspCode response, rspBody response) - -authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword") -authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm - -browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion -browserDigestAuth = do - (_, response) <- browse $ do - setOutHandler (const $ return ()) - - setAuthorityGen authGenDigest - - request $ getRequest (?testUrl "/auth/digest") - - assertEqual "Receiving expected response from server" - ((2, 0, 0), "Here's the digest secret") - (rspCode response, rspBody response) - - - -browserAlt :: (?altTestUrl :: ServerAddress) => Assertion -browserAlt = do - (response) <- browse $ do - - setOutHandler (const $ return ()) - - (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") - - return response1 - - assertEqual "Receiving expected response from alternate server" - ((2, 0, 0), "This is the alternate server.") - (rspCode response, rspBody response) - --- test that requests to multiple servers on the same host --- don't get confused with each other -browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion -browserBoth = do - (response1, response2) <- browse $ do - setOutHandler (const $ return ()) - - (_, response1) <- request $ getRequest (?testUrl "/basic/get") - (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") - - return (response1, response2) - - assertEqual "Receiving expected response from main server" - ((2, 0, 0), "It works.") - (rspCode response1, rspBody response1) - - assertEqual "Receiving expected response from alternate server" - ((2, 0, 0), "This is the alternate server.") - (rspCode response2, rspBody response2) - --- test that requests to multiple servers on the same host --- don't get confused with each other -browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion -browserBothReversed = do - (response1, response2) <- browse $ do - setOutHandler (const $ return ()) - - (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") - (_, response1) <- request $ getRequest (?testUrl "/basic/get") - - return (response1, response2) - - assertEqual "Receiving expected response from main server" - ((2, 0, 0), "It works.") - (rspCode response1, rspBody response1) - - assertEqual "Receiving expected response from alternate server" - ((2, 0, 0), "This is the alternate server.") - (rspCode response2, rspBody response2) - -browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion -browserSecureRequest = do - res <- try $ browse $ do - setOutHandler (const $ return ()) - - request $ getRequest (?secureTestUrl "/anything") - - assertEqual "Threw expected exception" - (Left (userError "https not supported")) - (fmap show res) -- fmap show because Response isn't in Eq - --- in case it tries to reuse the connection -browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion -browserSecureRequestAfterInsecure = do - res <- try $ browse $ do - setOutHandler (const $ return ()) - - request $ getRequest (?testUrl "/basic/get") - request $ getRequest (?secureTestUrl "/anything") - - assertEqual "Threw expected exception" - (Left (userError "https not supported")) - (fmap show res) -- fmap show because Response isn't in Eq - -browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion -browserRedirectToSecure = do - res <- try $ browse $ do - setOutHandler (const $ return ()) - setErrHandler fail - - request $ getRequest (?testUrl "/browser/redirect/secure/301/anything") - - assertEqual "Threw expected exception" - (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything")) - (fmap show res) -- fmap show because Response isn't in Eq - -browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion -browserTwoRequests = do - (response1, response2) <- browse $ do - setOutHandler (const $ return ()) - - (_, response1) <- request $ getRequest (?testUrl "/basic/get") - (_, response2) <- request $ getRequest (?testUrl "/basic/get2") - - return (response1, response2) - - assertEqual "Receiving expected response from main server" - ((2, 0, 0), "It works.") - (rspCode response1, rspBody response1) - - assertEqual "Receiving expected response from main server" - ((2, 0, 0), "It works (2).") - (rspCode response2, rspBody response2) - - -browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion -browserTwoRequestsAlt = do - (response1, response2) <- browse $ do - - setOutHandler (const $ return ()) - - (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") - (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2") - - return (response1, response2) - - assertEqual "Receiving expected response from alternate server" - ((2, 0, 0), "This is the alternate server.") - (rspCode response1, rspBody response1) - - assertEqual "Receiving expected response from alternate server" - ((2, 0, 0), "This is the alternate server (2).") - (rspCode response2, rspBody response2) - -browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion -browserTwoRequestsBoth = do - (response1, response2, response3, response4) <- browse $ do - setOutHandler (const $ return ()) - - (_, response1) <- request $ getRequest (?testUrl "/basic/get") - (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") - (_, response3) <- request $ getRequest (?testUrl "/basic/get2") - (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2") - - return (response1, response2, response3, response4) - - assertEqual "Receiving expected response from main server" - ((2, 0, 0), "It works.") - (rspCode response1, rspBody response1) - - assertEqual "Receiving expected response from alternate server" - ((2, 0, 0), "This is the alternate server.") - (rspCode response2, rspBody response2) - - assertEqual "Receiving expected response from main server" - ((2, 0, 0), "It works (2).") - (rspCode response3, rspBody response3) - - assertEqual "Receiving expected response from alternate server" - ((2, 0, 0), "This is the alternate server (2).") - (rspCode response4, rspBody response4) - -hasPrefix :: String -> String -> Maybe String -hasPrefix [] ys = Just ys -hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys -hasPrefix _ _ = Nothing - -maybeRead :: Read a => String -> Maybe a -maybeRead s = - case reads s of - [(v, "")] -> Just v - _ -> Nothing - -splitFields = map (toPair '=' . trim isSpace) . splitOn "," - -toPair c str = case break (==c) str of - (left, _:right) -> (left, right) - _ -> error $ "No " ++ show c ++ " in " ++ str -trim f = dropWhile f . reverse . dropWhile f . reverse - -isSubsetOf xs ys = all (`elem` ys) xs - --- first bits of result text from haskell.org (just to give some representative text) -haskellOrgText = - "\ -\\t\ -\\t\ -\\t\t\ -\\t\t\t\t" - -digestMatch - username realm password - nonce opaque - method relativeURI makeAbsolute - headers - = - common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers) - where - common = [("username", show username), ("realm", show realm), ("nonce", show nonce), - ("opaque", show opaque)] - md5 = show . MD5.md5 . BL.pack - ha1 = md5 (username++":"++realm++":"++password) - ha2 uri = md5 (method++":"++uri) - response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri) - mkUncommon uri hash = [("uri", show uri), ("response", show hash)] - relative = mkUncommon relativeURI (response relativeURI) - absoluteURI = makeAbsolute relativeURI - absolute = mkUncommon absoluteURI (response absoluteURI) - -processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) - => Httpd.Request - -> IO Httpd.Response -processRequest req = do - 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." - ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." - ("POST", "/basic/post") -> - let typ = lookup "Content-Type" (Httpd.reqHeaders req) - len = lookup "Content-Length" (Httpd.reqHeaders req) - body = Httpd.reqBody req - in return $ Httpd.mkResponse 200 [] (show (typ, len, body)) - - ("GET", "/basic/example") -> - return $ Httpd.mkResponse 200 [] haskellOrgText - - ("GET", "/auth/basic") -> - case lookup "Authorization" (Httpd.reqHeaders req) of - Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret" - x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x) - - ("GET", "/auth/digest") -> - case lookup "Authorization" (Httpd.reqHeaders req) of - Just (hasPrefix "Digest " -> Just (splitFields -> items)) - | digestMatch "test" "Digest testing realm" "digestpassword" - "87e4" "057d" - "GET" "/auth/digest" ?testUrl - items - -> return $ Httpd.mkResponse 200 [] "Here's the digest secret" - x -> return $ Httpd.mkResponse - 401 - [("WWW-Authenticate", - "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")] - (show x) - - ("GET", "/browser/example") -> - return $ Httpd.mkResponse 200 [] haskellOrgText - ("GET", "/browser/no-cookie") -> - case lookup "Cookie" (Httpd.reqHeaders req) of - Nothing -> return $ Httpd.mkResponse 200 [] "" - Just s -> return $ Httpd.mkResponse 500 [] s - ("GET", "/browser/one-cookie/1") -> - return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] "" - ("GET", "/browser/one-cookie/2") -> - case lookup "Cookie" (Httpd.reqHeaders req) of - Just "hello=world" -> return $ Httpd.mkResponse 200 [] "" - Just s -> return $ Httpd.mkResponse 500 [] s - Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) - ("GET", "/browser/two-cookies/1") -> - return $ Httpd.mkResponse 200 - [("Set-Cookie", "hello=world") - ,("Set-Cookie", "goodbye=cruelworld")] - "" - ("GET", "/browser/two-cookies/2") -> - case lookup "Cookie" (Httpd.reqHeaders req) of - -- TODO generalise the cookie parsing to allow for whitespace/ordering variations - Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] "" - Just s -> return $ Httpd.mkResponse 500 [] s - Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) - ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> - return $ Httpd.mkResponse n [("Location", rest)] "" - ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> - return $ Httpd.mkResponse n [("Location", ?testUrl rest)] "" - ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> - return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] "" - _ -> return $ Httpd.mkResponse 500 [] "Unknown request" - -altProcessRequest :: Httpd.Request -> IO Httpd.Response -altProcessRequest req = do - 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" - -maybeTestGroup True name xs = testGroup name xs -maybeTestGroup False name _ = testGroup name [] - -basicTests = - testGroup "Basic tests" - [ testCase "Basic GET request" basicGetRequest - , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS - , testCase "Network.HTTP example code" basicExample - , testCase "Secure GET request" secureGetRequest - , testCase "Basic POST request" basicPostRequest - , testCase "Basic HEAD request" basicHeadRequest - , testCase "URI user:pass Auth failure" userpwAuthFailure - , testCase "URI user:pass Auth success" userpwAuthSuccess - , testCase "Basic Auth failure" basicAuthFailure - , testCase "Basic Auth success" basicAuthSuccess - , testCase "UTF-8 urlEncode" utf8URLEncode - , testCase "UTF-8 urlDecode" utf8URLDecode - ] - -browserTests = - testGroup "Browser tests" - [ testGroup "Basic" - [ - testCase "Network.Browser example code" browserExample - , testCase "Two requests" browserTwoRequests - ] - , testGroup "Secure" - [ - testCase "Secure request" browserSecureRequest - , testCase "After insecure" browserSecureRequestAfterInsecure - , testCase "Redirection" browserRedirectToSecure - ] - , testGroup "Cookies" - [ testCase "No cookie header" browserNoCookie - , testCase "One cookie" browserOneCookie - , testCase "Two cookies" browserTwoCookies - ] - , testGroup "Redirection" - [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection - -- 300 Multiple Choices: client has to handle this - testCase "300" (browserReturnsRedirect 300) - -- 301 Moved Permanently: should follow - , testCase "301" (browserFollowsRedirect 301) - -- 302 Found: should follow - , testCase "302" (browserFollowsRedirect 302) - -- 303 See Other: should follow (directly for GETs) - , testCase "303" (browserFollowsRedirect 303) - -- 304 Not Modified: maybe Browser could do something intelligent based on - -- being given locally cached content and sending If-Modified-Since, but it - -- doesn't at the moment - , testCase "304" (browserReturnsRedirect 304) - -- 305 Use Proxy: test harness doesn't have a proxy (yet) - -- 306 Switch Proxy: obsolete - -- 307 Temporary Redirect: should follow - , testCase "307" (browserFollowsRedirect 307) - -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this - , testCase "308" (browserReturnsRedirect 308) - ] - , testGroup "Authentication" - [ testCase "Basic" browserBasicAuth - , testCase "Digest" browserDigestAuth - ] - ] - -port80Tests = - testGroup "Multiple servers" - [ testCase "Alternate server" browserAlt - , testCase "Both servers" browserBoth - , testCase "Both servers (reversed)" browserBothReversed - , testCase "Two requests - alternate server" browserTwoRequestsAlt - , testCase "Two requests - both servers" browserTwoRequestsBoth - ] - -data InetFamily = IPv4 | IPv6 - -familyToLocalhost :: InetFamily -> String -familyToLocalhost IPv4 = "127.0.0.1" -familyToLocalhost IPv6 = "[::1]" - -urlRoot :: InetFamily -> String -> Int -> String -urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam -urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n - -secureRoot :: InetFamily -> String -> Int -> String -secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam -secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n - -type ServerAddress = String -> String - -httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress -httpAddress fam userpw port p = urlRoot fam userpw port ++ p -httpsAddress fam userpw port p = secureRoot fam userpw port ++ p - -main :: IO () -main = do - args <- getArgs - - let servers = - [ ("httpd-shed", Httpd.shed, IPv4) -#ifdef WARP_TESTS - , ("warp.v6", Httpd.warp True, IPv6) - , ("warp.v4", Httpd.warp False, IPv4) -#endif - ] - basePortNum, altPortNum :: Int - basePortNum = 5812 - altPortNum = 80 - numberedServers = zip [basePortNum..] servers - - let setupNormalTests = do - flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do - let ?testUrl = httpAddress family "" portNum - ?userpwUrl = httpAddress family "test:password@" portNum - ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum - ?secureTestUrl = httpsAddress family "" portNum - _ <- forkIO $ server portNum processRequest - return $ testGroup serverName [basicTests, browserTests] - - let setupAltTests = do - let (portNum, (_, server,family)) = head numberedServers - let ?testUrl = httpAddress family "" portNum - ?altTestUrl = httpAddress family "" altPortNum - _ <- forkIO $ server altPortNum altProcessRequest - return port80Tests - - case args of - ["server"] -> do -- run only the harness servers for diagnostic/debug purposes - -- halt on any keypress - _ <- setupNormalTests - _ <- setupAltTests - _ <- getChar - return () - ("--withport80":args) -> do - normalTests <- setupNormalTests - altTests <- setupAltTests - _ <- threadDelay 1000000 -- Give the server time to start :-( - defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args - args -> do -- run the test harness as normal - normalTests <- setupNormalTests - _ <- threadDelay 1000000 -- Give the server time to start :-( - defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/test/UnitTests.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/test/UnitTests.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.8/test/UnitTests.hs 2017-11-16 23:22:27.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.8/test/UnitTests.hs 1970-01-01 00:00:00.000000000 +0000 @@ -1,32 +0,0 @@ -module UnitTests ( unitTests ) where - -import Network.HTTP.Base -import Network.URI - -import Data.Maybe ( fromJust ) - -import Test.Framework ( testGroup ) -import Test.Framework.Providers.HUnit -import Test.HUnit - -parseIPv4Address :: Assertion -parseIPv4Address = - assertEqual "127.0.0.1 address is recognised" - (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313})) - (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo")))) - - -parseIPv6Address :: Assertion -parseIPv6Address = - assertEqual "::1 address" - (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313})) - (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo")))) - -unitTests = - [testGroup "Unit tests" - [ testGroup "URI parsing" - [ testCase "Parse IPv4 address" parseIPv4Address - , testCase "Parse IPv6 address" parseIPv6Address - ] - ] - ] diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/CHANGES cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/CHANGES --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/CHANGES 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/CHANGES 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,119 @@ + * If the URI contains "user:pass@" part, use it for Basic Authorization + * Add a test harness. + * Don't leak a socket when getHostAddr throws an exception. + * Send cookies in request format, not response format. + * Moved BrowserAction to be a StateT IO, with instances for + Applicative, MonadIO, MonadState. + * Add method to control size of connection pool. + * Consider both host and port when reusing connections. + * Handle response code 304 "not modified" properly. + * Fix digest authentication by fixing md5 output string rep. + * Make the default user agent string follow the package version. + * Document lack of HTTPS support and fail when clients try + to use it instead of silently falling back to HTTP. + * Add helper to set the request type and body. + +Version 4000.1.2: release 2011-08-11 + * Turn off buffering for the debug log. + * Update installation instructions. + * Bump base dependency to support GHC 7.2. + +Version 4000.1.1: release 2010-11-28 + * Be tolerant of LF (instead of CRLF which is the spec) in responses. + +Version 4000.1.0: release 2010-11-09 + * Retroactively fixed CHANGES to refer to 4000.x.x instead of + 4004.x.x. + * Fix problem with close looping on certain URLs due to trying + to munch the rest of the stream even on EOF. Modified from + a fix by Daniel Wagner. + * This involves a new class member for HStream and is thus an + API change, but one that will only affect clients that + define their own payload type to replace String/ByteString. + * Applied patch by Antoine Latter to fix problem with 301 and 307 + redirects. + +Version 4000.0.10: release 2010-10-29 + * Bump base dependency to support GHC 7.0. + * Stop using 'fail' from the Either monad and instead build Left + values explicitly; the behaviour of fail is changing in GHC 7.0 + and this avoids being sensitive to the change. + +Version 4000.0.9: release 2009-12-20 + + * Export headerMap from Network.HTTP.Headers + (suggested by David Leuschner.) + * Fix Network.TCP.{isTCPConnectedTo,isConnectedTo} to be useful. + * Always delay closing non-persistent connections until we reach EOF. + Delaying it until then is vital when reading the response out as a + lazy ByteString; all of the I/O may not have happened by the time we + were returning the HTTP response. Bug manifested itself occasionally + with larger responses. Courtesy of Valery Vorotyntsev; both untiring bug + hunt and fix. + * drop unused type argument from Network.Browser.BrowserEvent; needlessly general. + (patch provided by Daniel Wagner.) + +Version 4000.0.8: release 2009-08-05 + + * Incorporated proxy setting lookup and parsing contribution + by Eric Kow; provided in Network.HTTP.Proxy + * Factor out HTTP Cookies and Auth handling into separate + modules Network.HTTP.Cookie, Network.HTTP.Auth + * new Network.Browser functionality for hooking up the + proxy detection code in Network.HTTP.Proxy: + + setCheckForProxy :: Bool -> BrowserAction t () + getCheckForProxy :: BrowserAction t Bool + + If you do 'setCheckForProxy True' within a browser + session, the proxy-checking code will be called upon. + Use 'getCheckForProxy' to get the current setting for + this flag. + + * Network.Browser: if HTTP Basic Auth is allowed and + server doesn't 401-challenge with an WWW-Authenticate: + header, simply assume / realm and proceed. Preferable + than failing, even if server is the wrong. + +Version 4000.0.7: release 2009-05-22 + + * Minor release. + * Added + Network.TCP.openSocketStream :: (BufferType t) + => String {-host-} + -> Socket + -> IO (HandleStream t) + + for interfacing to pre-existing @Socket@s. Contributed and + suggested by . + +Version 4000.0.6: release 2009-04-21; changes from 4000.0.5 + + * Network.Browser: use HTTP.HandleStream.sendHTTP_notify, not HTTP.sendHTTP_notify + when issuing requests. The latter runs the risk of undoing request normalization. + * Network.HTTP.Base.normalizeRequest: when normalizing proxy-bound requests, + insert a Host: header if none present. Set it to the destination server authority, + not the proxy. + * Network.Browser: don't fail on seeing invalid cookie values, but report them + as errors and continue. + +Version 4000.0.5: release 2009-03-30; changes from 4000.0.4 + + * Get serious about comments and Haddock documentation. + * Cleaned up normalization of requests, fixing bugs and bringing together + previous disparate attempts at handling this. + * RequestMethod now supports custom verbs; use the (Custom String) constructor + * Beef up Network.HTTP.Base's support for normalizing requests and URIs: + + * added splitRequestURI which divides a URI into two; the Authority portion + (as a String) and the input URI sans the authority portion. Useful when + wanting to split up a request's URI into its Host: and abs_path pieces. + * added normalizeRequest :: Bool -> Request ty -> Request ty, which + fixes up a requests URI path and Host: info depending on whether it is + destined for a proxy or not (controlled by the Bool.) + * moved defaultRequest, defaultRequest_, libUA from Network.Browser + to Network.HTTP.Base + * added mkRequest :: RequestMethod -> URI -> Bool -> Request ty + for constructing normalized&sane Request bases on top of which + you can add custom headers, body payload etc. + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/HTTP.cabal cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/HTTP.cabal --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/HTTP.cabal 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/HTTP.cabal 2017-12-13 10:27:55.000000000 +0000 @@ -0,0 +1,182 @@ +Name: HTTP +Version: 4000.3.9 +Cabal-Version: >= 1.8 +Build-type: Simple +License: BSD3 +License-file: LICENSE +Author: Warrick Gray +Maintainer: Ganesh Sittampalam +Homepage: https://github.com/haskell/HTTP +Category: Network +Synopsis: A library for client-side HTTP +Description: + + The HTTP package supports client-side web programming in Haskell. It lets you set up + HTTP connections, transmitting requests and processing the responses coming back, all + from within the comforts of Haskell. It's dependent on the network package to operate, + but other than that, the implementation is all written in Haskell. + . + A basic API for issuing single HTTP requests + receiving responses is provided. On top + of that, a session-level abstraction is also on offer (the @BrowserAction@ monad); + it taking care of handling the management of persistent connections, proxies, + state (cookies) and authentication credentials required to handle multi-step + interactions with a web server. + . + The representation of the bytes flowing across is extensible via the use of a type class, + letting you pick the representation of requests and responses that best fits your use. + Some pre-packaged, common instances are provided for you (@ByteString@, @String@). + . + Here's an example use: + . + > + > do + > rsp <- Network.HTTP.simpleHTTP (getRequest "http://www.haskell.org/") + > -- fetch document and return it (as a 'String'.) + > fmap (take 100) (getResponseBody rsp) + > + > do + > (_, rsp) + > <- Network.Browser.browse $ do + > setAllowRedirects True -- handle HTTP redirects + > request $ getRequest "http://www.haskell.org/" + > return (take 100 (rspBody rsp)) + . + __Note:__ This package does not support HTTPS connections. + If you need HTTPS, take a look at the following packages: + . + * + . + * (in combination with + ) + . + * + . + * + . + +Extra-Source-Files: CHANGES + +Source-Repository head + type: git + location: https://github.com/haskell/HTTP.git + +Flag mtl1 + description: Use the old mtl version 1. + default: False + +Flag warn-as-error + default: False + description: Build with warnings-as-errors + manual: True + +Flag network23 + description: Use version 2.3.x or below of the network package + default: False + +Flag conduit10 + description: Use version 1.0.x or below of the conduit package (for the test suite) + default: False + +Flag warp-tests + description: Test against warp + default: True + manual: True + +flag network-uri + description: Get Network.URI from the network-uri package + default: True + +Library + Exposed-modules: + Network.BufferType, + Network.Stream, + Network.StreamDebugger, + Network.StreamSocket, + Network.TCP, + Network.HTTP, + Network.HTTP.Headers, + Network.HTTP.Base, + Network.HTTP.Stream, + Network.HTTP.Auth, + Network.HTTP.Cookie, + Network.HTTP.Proxy, + Network.HTTP.HandleStream, + Network.Browser + Other-modules: + Network.HTTP.Base64, + Network.HTTP.MD5Aux, + Network.HTTP.Utils + Paths_HTTP + GHC-options: -fwarn-missing-signatures -Wall + + -- note the test harness constraints should be kept in sync with these + -- where dependencies are shared + Build-depends: base >= 4.3.0.0 && < 4.11, parsec >= 2.0 && < 3.2 + Build-depends: array >= 0.3.0.2 && < 0.6, bytestring >= 0.9.1.5 && < 0.11 + Build-depends: time >= 1.1.2.3 && < 1.9 + + Extensions: FlexibleInstances + + if flag(mtl1) + Build-depends: mtl >= 1.1.1.0 && < 1.2 + CPP-Options: -DMTL1 + else + Build-depends: mtl >= 2.0 && < 2.3 + + if flag(network-uri) + Build-depends: network-uri == 2.6.*, network == 2.6.* + else + Build-depends: network >= 2.2.1.8 && < 2.6 + + if flag(warn-as-error) + ghc-options: -Werror + + if os(windows) + Build-depends: Win32 >= 2.2.0.0 && < 2.6 + +Test-Suite test + type: exitcode-stdio-1.0 + + hs-source-dirs: test + main-is: httpTests.hs + + other-modules: + Httpd + UnitTests + + -- 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.11, + deepseq >= 1.3.0.0 && < 1.5, + pureMD5 >= 0.2.4 && < 2.2, + base >= 4.3.0.0 && < 4.11, + 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.* + else + Build-depends: network >= 2.2.1.5 && < 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.3 + + if flag(conduit10) + build-depends: + conduit >= 1.0.8 && < 1.1 + else + build-depends: + conduit >= 1.1 && < 1.3, + conduit-extra >= 1.1 && < 1.3 + + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/LICENSE cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/LICENSE --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/LICENSE 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/LICENSE 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,46 @@ +Copyright (c) 2002, Warrick Gray +Copyright (c) 2002-2005, Ian Lynagh +Copyright (c) 2003-2006, Bjorn Bringert +Copyright (c) 2004, Andre Furtado +Copyright (c) 2004-2005, Dominic Steinitz +Copyright (c) 2007, Robin Bate Boerop +Copyright (c) 2008-2010, Sigbjorn Finne +Copyright (c) 2009, Eric Kow +Copyright (c) 2010, Antoine Latter +Copyright (c) 2004, 2010-2011, Ganesh Sittampalam +Copyright (c) 2011, Duncan Coutts +Copyright (c) 2011, Matthew Gruen +Copyright (c) 2011, Jeremy Yallop +Copyright (c) 2011, Eric Hesselink +Copyright (c) 2011, Yi Huang +Copyright (c) 2011, Tom Lokhorst + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/Browser.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/Browser.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/Browser.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/Browser.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,1091 @@ +{-# LANGUAGE MultiParamTypeClasses, GeneralizedNewtypeDeriving, CPP, FlexibleContexts #-} +{- | + +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 +HTTP. Additional features supported are: + +* HTTP Authentication handling + +* Transparent handling of redirects + +* Cookie stores + transmission. + +* Transaction logging + +* Proxy-mediated connections. + +Example use: + +> do +> (_, rsp) +> <- Network.Browser.browse $ do +> setAllowRedirects True -- handle HTTP redirects +> request $ getRequest "http://www.haskell.org/" +> return (take 100 (rspBody rsp)) + +-} +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 + , addAuthority + , Challenge(..) + , Qop(..) + , Algorithm(..) + + , getAuthorityGen + , setAuthorityGen + , setAllowBasicAuth + , getAllowBasicAuth + + , setMaxErrorRetries -- :: Maybe Int -> BrowserAction t () + , getMaxErrorRetries -- :: BrowserAction t (Maybe Int) + + , setMaxPoolSize -- :: Int -> BrowserAction t () + , getMaxPoolSize -- :: BrowserAction t (Maybe Int) + + , setMaxAuthAttempts -- :: Maybe Int -> BrowserAction t () + , getMaxAuthAttempts -- :: BrowserAction t (Maybe Int) + + , setCookieFilter -- :: (URI -> Cookie -> IO Bool) -> BrowserAction t () + , 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 + + , setCheckForProxy -- :: Bool -> BrowserAction t () + , 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 + ) where + +import Network.URI + ( URI(..) + , URIAuth(..) + , parseURI, parseURIReference, relativeTo + ) +import Network.StreamDebugger (debugByteStream) +import Network.HTTP hiding ( sendHTTP_notify ) +import Network.HTTP.HandleStream ( sendHTTP_notify ) +import Network.HTTP.Auth +import Network.HTTP.Cookie +import Network.HTTP.Proxy + +import Network.Stream ( ConnError(..), Result ) +import Network.BufferType + +import Data.Char (toLower) +import Data.List (isPrefixOf) +import Data.Maybe (fromMaybe, listToMaybe, catMaybes ) +import Control.Applicative (Applicative (..), (<$>)) +#ifdef MTL1 +import Control.Monad (filterM, forM_, when, ap) +#else +import Control.Monad (filterM, forM_, when) +#endif +import Control.Monad.State (StateT (..), MonadIO (..), modify, gets, withStateT, evalStateT, MonadState (..)) + +import qualified System.IO + ( hSetBuffering, hPutStr, stdout, stdin, hGetChar + , BufferMode(NoBuffering, LineBuffering) + ) +import Data.Time.Clock ( UTCTime, getCurrentTime ) + + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @defaultCookieFilter@ is the initial cookie acceptance filter. +-- It welcomes them all into the store @:-)@ +defaultCookieFilter :: URI -> Cookie -> IO Bool +defaultCookieFilter _url _cky = return True + +-- | @userCookieFilter@ is a handy acceptance filter, asking the +-- user if he/she is willing to accept an incoming cookie before +-- adding it to the store. +userCookieFilter :: URI -> Cookie -> IO Bool +userCookieFilter url cky = do + do putStrLn ("Set-Cookie received when requesting: " ++ show url) + case ckComment cky of + Nothing -> return () + Just x -> putStrLn ("Cookie Comment:\n" ++ x) + let pth = maybe "" ('/':) (ckPath cky) + putStrLn ("Domain/Path: " ++ ckDomain cky ++ pth) + putStrLn (ckName cky ++ '=' : ckValue cky) + System.IO.hSetBuffering System.IO.stdout System.IO.NoBuffering + System.IO.hSetBuffering System.IO.stdin System.IO.NoBuffering + System.IO.hPutStr System.IO.stdout "Accept [y/n]? " + x <- System.IO.hGetChar System.IO.stdin + System.IO.hSetBuffering System.IO.stdin System.IO.LineBuffering + System.IO.hSetBuffering System.IO.stdout System.IO.LineBuffering + return (toLower x == 'y') + +-- | @addCookie c@ adds a cookie to the browser state, removing duplicates. +addCookie :: Cookie -> BrowserAction t () +addCookie c = modify (\b -> b{bsCookies = c : filter (/=c) (bsCookies b) }) + +-- | @setCookies cookies@ replaces the set of cookies known to +-- the browser to @cookies@. Useful when wanting to restore cookies +-- used across 'browse' invocations. +setCookies :: [Cookie] -> BrowserAction t () +setCookies cs = modify (\b -> b { bsCookies=cs }) + +-- | @getCookies@ returns the current set of cookies known to +-- the browser. +getCookies :: BrowserAction t [Cookie] +getCookies = gets bsCookies + +-- ...get domain specific cookies... +-- ... this needs changing for consistency with rfc2109... +-- ... currently too broad. +getCookiesFor :: String -> String -> BrowserAction t [Cookie] +getCookiesFor dom path = + do cks <- getCookies + return (filter cookiematch cks) + where + cookiematch :: Cookie -> Bool + cookiematch = cookieMatch (dom,path) + + +-- | @setCookieFilter fn@ sets the cookie acceptance filter to @fn@. +setCookieFilter :: (URI -> Cookie -> IO Bool) -> BrowserAction t () +setCookieFilter f = modify (\b -> b { bsCookieFilter=f }) + +-- | @getCookieFilter@ returns the current cookie acceptance filter. +getCookieFilter :: BrowserAction t (URI -> Cookie -> IO Bool) +getCookieFilter = gets bsCookieFilter + +------------------------------------------------------------------ +----------------------- Authorisation Stuff ---------------------- +------------------------------------------------------------------ + +{- + +The browser handles 401 responses in the following manner: + 1) extract all WWW-Authenticate headers from a 401 response + 2) rewrite each as a Challenge object, using "headerToChallenge" + 3) pick a challenge to respond to, usually the strongest + challenge understood by the client, using "pickChallenge" + 4) generate a username/password combination using the browsers + "bsAuthorityGen" function (the default behaviour is to ask + the user) + 5) build an Authority object based upon the challenge and user + data, store this new Authority in the browser state + 6) convert the Authority to a request header and add this + to a request using "withAuthority" + 7) send the amended request + +Note that by default requests are annotated with authority headers +before the first sending, based upon previously generated Authority +objects (which contain domain information). Once a specific authority +is added to a rejected request this predictive annotation is suppressed. + +407 responses are handled in a similar manner, except + a) Authorities are not collected, only a single proxy authority + is kept by the browser + b) If the proxy used by the browser (type Proxy) is NoProxy, then + a 407 response will generate output on the "err" stream and + the response will be returned. + + +Notes: + - 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 + - doesn't properly receive AuthenticationInfo headers, so fails + to use next-nonce etc + +-} + +-- | Return authorities for a given domain and path. +-- Assumes "dom" is lower case +getAuthFor :: String -> String -> BrowserAction t [Authority] +getAuthFor dom pth = getAuthorities >>= return . (filter match) + where + match :: Authority -> Bool + match au@AuthBasic{} = matchURI (auSite au) + match au@AuthDigest{} = or (map matchURI (auDomain au)) + + matchURI :: URI -> Bool + matchURI s = (uriToAuthorityString s == dom) && (uriPath s `isPrefixOf` pth) + + +-- | @getAuthorities@ return the current set of @Authority@s known +-- to the browser. +getAuthorities :: BrowserAction t [Authority] +getAuthorities = gets bsAuthorities + +-- @setAuthorities as@ replaces the Browser's known set +-- of 'Authority's to @as@. +setAuthorities :: [Authority] -> BrowserAction t () +setAuthorities as = modify (\b -> b { bsAuthorities=as }) + +-- @addAuthority a@ adds 'Authority' @a@ to the Browser's +-- set of known authorities. +addAuthority :: Authority -> BrowserAction t () +addAuthority a = modify (\b -> b { bsAuthorities=a:bsAuthorities b }) + +-- | @getAuthorityGen@ returns the current authority generator +getAuthorityGen :: BrowserAction t (URI -> String -> IO (Maybe (String,String))) +getAuthorityGen = gets bsAuthorityGen + +-- | @setAuthorityGen genAct@ sets the auth generator to @genAct@. +setAuthorityGen :: (URI -> String -> IO (Maybe (String,String))) -> BrowserAction t () +setAuthorityGen f = modify (\b -> b { bsAuthorityGen=f }) + +-- | @setAllowBasicAuth onOff@ enables\/disables HTTP Basic Authentication. +setAllowBasicAuth :: Bool -> BrowserAction t () +setAllowBasicAuth ba = modify (\b -> b { bsAllowBasicAuth=ba }) + +getAllowBasicAuth :: BrowserAction t Bool +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 + | fromMaybe 0 mb < 0 = return () + | otherwise = modify (\ b -> b{bsMaxAuthAttempts=mb}) + +-- | @getMaxAuthAttempts@ returns the current max auth attempts. If @Nothing@, +-- the browser's default is used. +getMaxAuthAttempts :: BrowserAction t (Maybe Int) +getMaxAuthAttempts = gets bsMaxAuthAttempts + +-- | @setMaxErrorRetries mbMax@ sets the maximum number of attempts at +-- transmitting a request. If @Nothing@, rever to default max. +setMaxErrorRetries :: Maybe Int -> BrowserAction t () +setMaxErrorRetries mb + | fromMaybe 0 mb < 0 = return () + | otherwise = modify (\ b -> b{bsMaxErrorRetries=mb}) + +-- | @getMaxErrorRetries@ returns the current max number of error retries. +getMaxErrorRetries :: BrowserAction t (Maybe Int) +getMaxErrorRetries = gets bsMaxErrorRetries + +-- TO BE CHANGED!!! +pickChallenge :: Bool -> [Challenge] -> Maybe Challenge +pickChallenge allowBasic [] + | allowBasic = Just (ChalBasic "/") -- manufacture a challenge if one missing; more robust. +pickChallenge _ ls = listToMaybe ls + +-- | Retrieve a likely looking authority for a Request. +anticipateChallenge :: Request ty -> BrowserAction t (Maybe Authority) +anticipateChallenge rq = + let uri = rqURI rq in + do { authlist <- getAuthFor (uriAuthToString $ reqURIAuth rq) (uriPath uri) + ; return (listToMaybe authlist) + } + +-- | Asking the user to respond to a challenge +challengeToAuthority :: URI -> Challenge -> BrowserAction t (Maybe Authority) +challengeToAuthority uri ch + | not (answerable ch) = return Nothing + | otherwise = do + -- prompt user for authority + prompt <- getAuthorityGen + userdetails <- liftIO $ prompt uri (chRealm ch) + case userdetails of + Nothing -> return Nothing + Just (u,p) -> return (Just $ buildAuth ch u p) + where + answerable :: Challenge -> Bool + answerable ChalBasic{} = True + answerable chall = (chAlgorithm chall) == Just AlgMD5 + + buildAuth :: Challenge -> String -> String -> Authority + buildAuth (ChalBasic r) u p = + AuthBasic { auSite=uri + , auRealm=r + , auUsername=u + , auPassword=p + } + + -- note to self: this is a pretty stupid operation + -- to perform isn't it? ChalX and AuthX are so very + -- similar. + buildAuth (ChalDigest r d n o _stale a q) u p = + AuthDigest { auRealm=r + , auUsername=u + , auPassword=p + , auDomain=d + , auNonce=n + , auOpaque=o + , auAlgorithm=a + , auQop=q + } + + +------------------------------------------------------------------ +------------------ Browser State Actions ------------------------- +------------------------------------------------------------------ + + +-- | @BrowserState@ is the (large) record type tracking the current +-- settings of the browser. +data BrowserState connection + = BS { bsErr, bsOut :: String -> IO () + , bsCookies :: [Cookie] + , bsCookieFilter :: URI -> Cookie -> IO Bool + , bsAuthorityGen :: URI -> String -> IO (Maybe (String,String)) + , bsAuthorities :: [Authority] + , bsAllowRedirects :: Bool + , bsAllowBasicAuth :: Bool + , bsMaxRedirects :: Maybe Int + , bsMaxErrorRetries :: Maybe Int + , bsMaxAuthAttempts :: Maybe Int + , bsMaxPoolSize :: Maybe Int + , bsConnectionPool :: [connection] + , bsCheckProxy :: Bool + , bsProxy :: Proxy + , bsDebug :: Maybe String + , bsEvent :: Maybe (BrowserEvent -> BrowserAction connection ()) + , bsRequestID :: RequestID + , bsUserAgent :: Maybe String + } + +instance Show (BrowserState t) where + show bs = "BrowserState { " + ++ shows (bsCookies bs) ("\n" + {- ++ show (bsAuthorities bs) ++ "\n"-} + ++ "AllowRedirects: " ++ shows (bsAllowRedirects bs) "} ") + +-- | @BrowserAction@ is the IO monad, but carrying along a 'BrowserState'. +newtype BrowserAction conn a + = BA { unBA :: StateT (BrowserState conn) IO a } +#ifdef MTL1 + deriving (Functor, Monad, MonadIO, MonadState (BrowserState conn)) + +instance Applicative (BrowserAction conn) where + pure = return + (<*>) = ap +#else + deriving (Functor, Applicative, Monad, MonadIO, MonadState (BrowserState conn)) +#endif + +runBA :: BrowserState conn -> BrowserAction conn a -> IO a +runBA bs = flip evalStateT bs . unBA + +-- | @browse act@ is the toplevel action to perform a 'BrowserAction'. +-- Example use: @browse (request (getRequest yourURL))@. +browse :: BrowserAction conn a -> IO a +browse = runBA defaultBrowserState + +-- | The default browser state has the settings +defaultBrowserState :: BrowserState t +defaultBrowserState = res + where + res = BS + { bsErr = putStrLn + , bsOut = putStrLn + , bsCookies = [] + , bsCookieFilter = defaultCookieFilter + , bsAuthorityGen = \ _uri _realm -> do + bsErr res "No action for prompting/generating user+password credentials provided (use: setAuthorityGen); returning Nothing" + return Nothing + , bsAuthorities = [] + , bsAllowRedirects = True + , bsAllowBasicAuth = False + , bsMaxRedirects = Nothing + , bsMaxErrorRetries = Nothing + , bsMaxAuthAttempts = Nothing + , bsMaxPoolSize = Nothing + , bsConnectionPool = [] + , bsCheckProxy = defaultAutoProxyDetect + , bsProxy = noProxy + , bsDebug = Nothing + , bsEvent = Nothing + , bsRequestID = 0 + , bsUserAgent = Nothing + } + +{-# DEPRECATED getBrowserState "Use Control.Monad.State.get instead." #-} +-- | @getBrowserState@ returns the current browser config. Useful +-- for restoring state across 'BrowserAction's. +getBrowserState :: BrowserAction t (BrowserState t) +getBrowserState = get + +-- | @withBrowserAction st act@ performs @act@ with 'BrowserState' @st@. +withBrowserState :: BrowserState t -> BrowserAction t a -> BrowserAction t a +withBrowserState bs = BA . withStateT (const bs) . unBA + +-- | @nextRequest act@ performs the browser action @act@ as +-- the next request, i.e., setting up a new request context +-- before doing so. +nextRequest :: BrowserAction t a -> BrowserAction t a +nextRequest act = do + let updReqID st = + let + rid = succ (bsRequestID st) + in + rid `seq` st{bsRequestID=rid} + modify updReqID + act + +-- | Lifts an IO action into the 'BrowserAction' monad. +{-# DEPRECATED ioAction "Use Control.Monad.Trans.liftIO instead." #-} +ioAction :: IO a -> BrowserAction t a +ioAction = liftIO + +-- | @setErrHandler@ sets the IO action to call when +-- the browser reports running errors. To disable any +-- such, set it to @const (return ())@. +setErrHandler :: (String -> IO ()) -> BrowserAction t () +setErrHandler h = modify (\b -> b { bsErr=h }) + +-- | @setOutHandler@ sets the IO action to call when +-- the browser chatters info on its running. To disable any +-- such, set it to @const (return ())@. +setOutHandler :: (String -> IO ()) -> BrowserAction t () +setOutHandler h = modify (\b -> b { bsOut=h }) + +out, err :: String -> BrowserAction t () +out s = do { f <- gets bsOut ; liftIO $ f s } +err s = do { f <- gets bsErr ; liftIO $ f s } + +-- | @setAllowRedirects onOff@ toggles the willingness to +-- follow redirects (HTTP responses with 3xx status codes). +setAllowRedirects :: Bool -> BrowserAction t () +setAllowRedirects bl = modify (\b -> b {bsAllowRedirects=bl}) + +-- | @getAllowRedirects@ returns current setting of the do-chase-redirects flag. +getAllowRedirects :: BrowserAction t Bool +getAllowRedirects = gets bsAllowRedirects + +-- | @setMaxRedirects maxCount@ sets the maxiumum number of forwarding hops +-- we are willing to jump through. A no-op if the count is negative; if zero, +-- the max is set to whatever default applies. Notice that setting the max +-- redirects count does /not/ enable following of redirects itself; use +-- 'setAllowRedirects' to do so. +setMaxRedirects :: Maybe Int -> BrowserAction t () +setMaxRedirects c + | fromMaybe 0 c < 0 = return () + | otherwise = modify (\b -> b{bsMaxRedirects=c}) + +-- | @getMaxRedirects@ returns the current setting for the max-redirect count. +-- If @Nothing@, the "Network.Browser"'s default is used. +getMaxRedirects :: BrowserAction t (Maybe Int) +getMaxRedirects = gets bsMaxRedirects + +-- | @setMaxPoolSize maxCount@ sets the maximum size of the connection pool +-- that is used to cache connections between requests +setMaxPoolSize :: Maybe Int -> BrowserAction t () +setMaxPoolSize c = modify (\b -> b{bsMaxPoolSize=c}) + +-- | @getMaxPoolSize@ gets the maximum size of the connection pool +-- that is used to cache connections between requests. +-- If @Nothing@, the "Network.Browser"'s default is used. +getMaxPoolSize :: BrowserAction t (Maybe Int) +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 +-- 'Authority' information in @mbAuth@. +setProxy :: Proxy -> BrowserAction t () +setProxy p = + -- Note: if user _explicitly_ sets the proxy, we turn + -- off any auto-detection of proxies. + modify (\b -> b {bsProxy = p, bsCheckProxy=False}) + +-- | @getProxy@ returns the current proxy settings. If +-- the auto-proxy flag is set to @True@, @getProxy@ will +-- perform the necessary +getProxy :: BrowserAction t Proxy +getProxy = do + p <- gets bsProxy + case p of + -- Note: if there is a proxy, no need to perform any auto-detect. + -- Presumably this is the user's explicit and preferred proxy server. + Proxy{} -> return p + NoProxy{} -> do + flg <- gets bsCheckProxy + if not flg + 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. + setProxy np + return np + +-- | @setCheckForProxy flg@ sets the one-time check for proxy +-- flag to @flg@. If @True@, the session will try to determine +-- the proxy server is locally configured. See 'Network.HTTP.Proxy.fetchProxy' +-- for details of how this done. +setCheckForProxy :: Bool -> BrowserAction t () +setCheckForProxy flg = modify (\ b -> b{bsCheckProxy=flg}) + +-- | @getCheckForProxy@ returns the current check-proxy setting. +-- Notice that this may not be equal to @True@ if the session has +-- set it to that via 'setCheckForProxy' and subsequently performed +-- some HTTP protocol interactions. i.e., the flag return represents +-- whether a proxy will be checked for again before any future protocol +-- interactions. +getCheckForProxy :: BrowserAction t Bool +getCheckForProxy = gets bsCheckProxy + +-- | @setDebugLog mbFile@ turns off debug logging iff @mbFile@ +-- is @Nothing@. If set to @Just fStem@, logs of browser activity +-- is appended to files of the form @fStem-url-authority@, i.e., +-- @fStem@ is just the prefix for a set of log files, one per host/authority. +setDebugLog :: Maybe String -> BrowserAction t () +setDebugLog v = modify (\b -> b {bsDebug=v}) + +-- | @setUserAgent ua@ sets the current @User-Agent:@ string to @ua@. It +-- will be used if no explicit user agent header is found in subsequent requests. +-- +-- A common form of user agent string is @\"name\/version (details)\"@. For +-- example @\"cabal-install/0.10.2 (HTTP 4000.1.2)\"@. Including the version +-- of this HTTP package can be helpful if you ever need to track down HTTP +-- compatability quirks. This version is available via 'httpPackageVersion'. +-- For more info see . +-- +setUserAgent :: String -> BrowserAction t () +setUserAgent ua = modify (\b -> b{bsUserAgent=Just ua}) + +-- | @getUserAgent@ returns the current @User-Agent:@ default string. +getUserAgent :: BrowserAction t String +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 +-- forwards we've gone through. +data RequestState + = RequestState + { reqDenies :: Int -- ^ number of 401 responses so far + , reqRedirects :: Int -- ^ number of redirects so far + , reqRetries :: Int -- ^ number of retries so far + , reqStopOnDeny :: Bool -- ^ whether to pre-empt 401 response + } + +type RequestID = Int -- yeah, it will wrap around. + +nullRequestState :: RequestState +nullRequestState = RequestState + { reqDenies = 0 + , reqRedirects = 0 + , reqRetries = 0 + , reqStopOnDeny = True + } + +-- | @BrowserEvent@ is the event record type that a user-defined handler, set +-- via 'setEventHandler', will be passed. It indicates various state changes +-- encountered in the processing of a given 'RequestID', along with timestamps +-- at which they occurred. +data BrowserEvent + = BrowserEvent + { browserTimestamp :: UTCTime + , browserRequestID :: RequestID + , browserRequestURI :: {-URI-}String + , browserEventType :: BrowserEventType + } + +-- | 'BrowserEventType' is the enumerated list of events that the browser +-- internals will report to a user-defined event handler. +data BrowserEventType + = OpenConnection + | ReuseConnection + | RequestSent + | ResponseEnd ResponseData + | ResponseFinish +{- not yet, you will have to determine these via the ResponseEnd event. + | Redirect + | 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 +-- notified of browser events during the processing of a request +-- by the Browser pipeline. +setEventHandler :: Maybe (BrowserEvent -> BrowserAction ty ()) -> BrowserAction ty () +setEventHandler mbH = modify (\b -> b { bsEvent=mbH}) + +buildBrowserEvent :: BrowserEventType -> {-URI-}String -> RequestID -> IO BrowserEvent +buildBrowserEvent bt uri reqID = do + ct <- getCurrentTime + return BrowserEvent + { browserTimestamp = ct + , browserRequestID = reqID + , browserRequestURI = uri + , browserEventType = bt + } + +reportEvent :: BrowserEventType -> {-URI-}String -> BrowserAction t () +reportEvent bt uri = do + st <- get + case bsEvent st of + Nothing -> return () + Just evH -> 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 +-- request forwardings. +defaultMaxRetries :: Int +defaultMaxRetries = 4 + +-- | The default number of error retries we are willing to perform. +defaultMaxErrorRetries :: Int +defaultMaxErrorRetries = 4 + +-- | The default maximum HTTP Authentication attempts we will make for +-- a single request. +defaultMaxAuthAttempts :: Int +defaultMaxAuthAttempts = 2 + +-- | The default setting for auto-proxy detection. +-- You may change this within a session via 'setAutoProxyDetect'. +-- To avoid initial backwards compatibility issues, leave this as @False@. +defaultAutoProxyDetect :: Bool +defaultAutoProxyDetect = False + +-- | @request httpRequest@ tries to submit the 'Request' @httpRequest@ +-- to some HTTP server (possibly going via a /proxy/, see 'setProxy'.) +-- Upon successful delivery, the URL where the response was fetched from +-- is returned along with the 'Response' itself. +request :: HStream ty + => Request ty + -> BrowserAction (HandleStream ty) (URI,Response ty) +request req = nextRequest $ do + res <- request' nullVal initialState req + reportEvent ResponseFinish (show (rqURI req)) + case res of + Right r -> return r + Left e -> do + let errStr = ("Network.Browser.request: Error raised " ++ show e) + err errStr + fail errStr + where + initialState = nullRequestState + nullVal = buf_empty bufferOps + +-- | Internal helper function, explicitly carrying along per-request +-- counts. +request' :: HStream ty + => ty + -> RequestState + -> Request ty + -> BrowserAction (HandleStream ty) (Result (URI,Response ty)) +request' nullVal rqState rq = do + let uri = rqURI rq + failHTTPS uri + let uria = reqURIAuth rq + -- add cookies to request + cookies <- getCookiesFor (uriAuthToString uria) (uriPath uri) +{- Not for now: + (case uriUserInfo uria of + "" -> id + xs -> + case chopAtDelim ':' xs of + (_,[]) -> id + (usr,pwd) -> withAuth + AuthBasic{ auUserName = usr + , auPassword = pwd + , auRealm = "/" + , auSite = uri + }) $ do +-} + 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 + auth <- anticipateChallenge rq + case auth of + Nothing -> return rq + Just x -> return (insertHeader HdrAuthorization (withAuthority x rq) rq) + let rq'' = if not $ null cookies then insertHeaders [cookiesToHeader cookies] rq' else rq' + p <- getProxy + def_ua <- gets bsUserAgent + let defaultOpts = + case p of + NoProxy -> defaultNormalizeRequestOptions{normUserAgent=def_ua} + Proxy _ ath -> + defaultNormalizeRequestOptions + { normForProxy = True + , normUserAgent = def_ua + , normCustoms = + maybe [] + (\ authS -> [\ _ r -> insertHeader HdrProxyAuthorization (withAuthority authS r) r]) + ath + } + let final_req = normalizeRequest defaultOpts rq'' + out ("Sending:\n" ++ show final_req) + e_rsp <- + case p of + NoProxy -> dorequest (reqURIAuth rq'') final_req + Proxy str _ath -> do + let notURI + | null pt || null hst = + URIAuth{ uriUserInfo = "" + , uriRegName = str + , uriPort = "" + } + | otherwise = + URIAuth{ uriUserInfo = "" + , uriRegName = hst + , uriPort = pt + } + -- If the ':' is dropped from port below, dorequest will assume port 80. Leave it! + where (hst, pt) = span (':'/=) str + -- Proxy can take multiple forms - look for http://host:port first, + -- then host:port. Fall back to just the string given (probably a host name). + let proxyURIAuth = + maybe notURI + (\parsed -> maybe notURI id (uriAuthority parsed)) + (parseURI str) + + out $ "proxy uri host: " ++ uriRegName proxyURIAuth ++ ", port: " ++ uriPort proxyURIAuth + dorequest proxyURIAuth final_req + mbMx <- getMaxErrorRetries + case e_rsp of + 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=[] }) + request' nullVal rqState{reqRetries=succ (reqRetries rqState)} rq + | otherwise -> + return (Left v) + Right rsp -> do + out ("Received:\n" ++ show rsp) + -- add new cookies to browser state + handleCookies uri (uriAuthToString $ reqURIAuth rq) + (retrieveHeaders HdrSetCookie rsp) + -- Deal with "Connection: close" in response. + handleConnectionClose (reqURIAuth rq) (retrieveHeaders HdrConnection rsp) + mbMxAuths <- getMaxAuthAttempts + case rspCode rsp of + (4,0,1) -- Credentials not sent or refused. + | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do + out "401 - credentials again refused; exceeded retry count (2)" + return (Right (uri,rsp)) + | otherwise -> do + out "401 - credentials not supplied or refused; retrying.." + let hdrs = retrieveHeaders HdrWWWAuthenticate rsp + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> do + out "no challenge" + return (Right (uri,rsp)) {- do nothing -} + Just x -> do + au <- challengeToAuthority uri x + case au of + Nothing -> do + out "no auth" + return (Right (uri,rsp)) {- do nothing -} + Just au' -> do + out "Retrying request with new credentials" + request' nullVal + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } + (insertHeader HdrAuthorization (withAuthority au' rq) rq) + + (4,0,7) -- Proxy Authentication required + | reqDenies rqState > fromMaybe defaultMaxAuthAttempts mbMxAuths -> do + out "407 - proxy authentication required; max deny count exceeeded (2)" + return (Right (uri,rsp)) + | otherwise -> do + out "407 - proxy authentication required" + let hdrs = retrieveHeaders HdrProxyAuthenticate rsp + flg <- getAllowBasicAuth + case pickChallenge flg (catMaybes $ map (headerToChallenge uri) hdrs) of + Nothing -> return (Right (uri,rsp)) {- do nothing -} + Just x -> do + au <- challengeToAuthority uri x + case au of + Nothing -> return (Right (uri,rsp)) {- do nothing -} + Just au' -> do + pxy <- gets bsProxy + case pxy of + NoProxy -> do + err "Proxy authentication required without proxy!" + return (Right (uri,rsp)) + Proxy px _ -> do + out "Retrying with proxy authentication" + setProxy (Proxy px (Just au')) + request' nullVal + rqState{ reqDenies = succ(reqDenies rqState) + , reqStopOnDeny = False + } + rq + + (3,0,x) | x `elem` [2,3,1,7] -> do + out ("30" ++ show x ++ " - redirect") + allow_redirs <- allowRedirect rqState + case allow_redirs of + False -> return (Right (uri,rsp)) + _ -> do + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location: header in redirect response" + return (Right (uri,rsp)) + (Header _ u:_) -> + case parseURIReference u of + Nothing -> do + err ("Parse of Location: header in a redirect response failed: " ++ u) + return (Right (uri,rsp)) + Just newURI + | {-uriScheme newURI_abs /= uriScheme uri && -}(not (supportedScheme newURI_abs)) -> do + err ("Unable to handle redirect, unsupported scheme: " ++ show newURI_abs) + 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) + , reqStopOnDeny = True + } + rq2 + where + newURI_abs = uriDefaultTo newURI uri + + (3,0,5) -> + case retrieveHeaders HdrLocation rsp of + [] -> do + err "No Location header in proxy redirect response." + return (Right (uri,rsp)) + (Header _ u:_) -> + case parseURIReference u of + Nothing -> do + err ("Parse of Location header in a proxy redirect response failed: " ++ u) + return (Right (uri,rsp)) + Just newuri -> do + out ("Retrying with proxy " ++ show newuri ++ "...") + setProxy (Proxy (uriToAuthorityString newuri) Nothing) + request' nullVal rqState{ reqDenies = 0 + , reqRedirects = 0 + , reqRetries = succ (reqRetries rqState) + , reqStopOnDeny = True + } + rq + _ -> return (Right (uri,rsp)) + +-- | The internal request handling state machine. +dorequest :: (HStream ty) + => URIAuth + -> Request ty + -> BrowserAction (HandleStream ty) + (Result (Response ty)) +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 <- + case conn of + [] -> do + out ("Creating new connection to " ++ uriAuthToString hst) + reportEvent OpenConnection (show (rqURI rqst)) + c <- liftIO $ openStream (uriRegName hst) uPort + updateConnectionPool c + dorequest2 c rqst + (c:_) -> do + out ("Recovering connection to " ++ uriAuthToString hst) + reportEvent ReuseConnection (show (rqURI rqst)) + dorequest2 c rqst + 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 + onSendComplete = + maybe (return ()) + (\evh -> do + x <- buildBrowserEvent RequestSent (show (rqURI r)) (bsRequestID st) + runBA st (evh x) + return ()) + (bsEvent st) + liftIO $ + maybe (sendHTTP_notify c r onSendComplete) + (\ f -> do + c' <- debugByteStream (f++'-': uriAuthToString hst) c + sendHTTP_notify c' r onSendComplete) + dbg + +updateConnectionPool :: HStream hTy + => HandleStream hTy + -> BrowserAction (HandleStream hTy) () +updateConnectionPool c = do + pool <- gets bsConnectionPool + let len_pool = length pool + maxPoolSize <- fromMaybe defaultMaxPoolSize <$> gets bsMaxPoolSize + when (len_pool > maxPoolSize) + (liftIO $ close (last 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 + +cleanConnectionPool :: HStream hTy + => URIAuth -> BrowserAction (HandleStream hTy) () +cleanConnectionPool uri = do + let ep = EndPoint (uriRegName uri) (uriAuthPort Nothing uri) + pool <- gets bsConnectionPool + bad <- liftIO $ mapM (\c -> c `isTCPConnectedTo` ep) pool + let tmp = zip bad pool + newpool = map snd $ filter (not . fst) tmp + toclose = map snd $ filter fst tmp + liftIO $ forM_ toclose close + modify (\b -> b { bsConnectionPool = newpool }) + +handleCookies :: URI -> String -> [Header] -> BrowserAction t () +handleCookies _ _ [] = return () -- cut short the silliness. +handleCookies uri dom cookieHeaders = do + when (not $ null errs) + (err $ unlines ("Errors parsing these cookie values: ":errs)) + when (not $ null newCookies) + (out $ foldl (\x y -> x ++ "\n " ++ show y) "Cookies received:" newCookies) + filterfn <- getCookieFilter + newCookies' <- liftIO (filterM (filterfn uri) newCookies) + when (not $ null newCookies') + (out $ "Accepting cookies with names: " ++ unwords (map ckName newCookies')) + mapM_ addCookie newCookies' + where + (errs, newCookies) = processCookieHeaders dom cookieHeaders + +handleConnectionClose :: HStream hTy + => URIAuth -> [Header] + -> BrowserAction (HandleStream hTy) () +handleConnectionClose _ [] = return () +handleConnectionClose uri headers = do + let doClose = any (== "close") $ map headerToConnType headers + when doClose $ cleanConnectionPool uri + where headerToConnType (Header _ t) = map toLower t + +------------------------------------------------------------------ +----------------------- Miscellaneous ---------------------------- +------------------------------------------------------------------ + +allowRedirect :: RequestState -> BrowserAction t Bool +allowRedirect rqState = do + rd <- getAllowRedirects + mbMxRetries <- getMaxRedirects + return (rd && (reqRedirects rqState <= fromMaybe defaultMaxRetries mbMxRetries)) + +-- | Return @True@ iff the package is able to handle requests and responses +-- over it. +supportedScheme :: URI -> Bool +supportedScheme u = uriScheme u == "http:" + +-- | @uriDefaultTo a b@ returns a URI that is consistent with the first +-- argument URI @a@ when read in the context of the second URI @b@. +-- If the second argument is not sufficient context for determining +-- a full URI then anarchy reins. +uriDefaultTo :: URI -> URI -> URI +#if MIN_VERSION_network(2,4,0) +uriDefaultTo a b = a `relativeTo` b +#else +uriDefaultTo a b = maybe a id (a `relativeTo` b) +#endif + + +-- This form junk is completely untested... + +type FormVar = (String,String) + +data Form = Form RequestMethod URI [FormVar] + +formToRequest :: Form -> Request_String +formToRequest (Form m u vs) = + let enc = urlEncodeVars vs + in case m of + GET -> Request { rqMethod=GET + , rqHeaders=[ Header HdrContentLength "0" ] + , rqBody="" + , rqURI=u { uriQuery= '?' : enc } -- What about old query? + } + POST -> Request { rqMethod=POST + , rqHeaders=[ Header HdrContentType "application/x-www-form-urlencoded", + Header HdrContentLength (show $ length enc) ] + , rqBody=enc + , rqURI=u + } + _ -> error ("unexpected request: " ++ show m) + + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/BufferType.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/BufferType.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/BufferType.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/BufferType.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,164 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.BufferType +-- Description : Abstract representation of request and response buffer types. +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- In order to give the user freedom in how request and response content +-- is represented, a sufficiently abstract representation is needed of +-- these internally. The "Network.BufferType" module provides this, defining +-- the 'BufferType' class and its ad-hoc representation of buffer operations +-- via the 'BufferOp' record. +-- +-- 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(..) + , strictBufferOp + , lazyBufferOp + , stringBufferOp + ) where + + +import qualified Data.ByteString as Strict hiding ( unpack, pack, span ) +import qualified Data.ByteString.Char8 as Strict ( unpack, pack, span ) +import qualified Data.ByteString.Lazy as Lazy hiding ( pack, unpack,span ) +import qualified Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack, span ) +import System.IO ( Handle ) +import Data.Word ( Word8 ) + +import Network.HTTP.Utils ( crlf, lf ) + +-- | The @BufferType@ class encodes, in a mixed-mode way, the interface +-- 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 + +instance BufferType Lazy.ByteString where + bufferOps = lazyBufferOp + +instance BufferType Strict.ByteString where + bufferOps = strictBufferOp + +instance BufferType String where + bufferOps = stringBufferOp + +-- | @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. +-- +-- Along with IO operations is an ad-hoc collection of functions for working +-- with these abstract buffers, as needed by the internals of the code +-- that processes requests and responses. +-- +-- We supply three default @BufferOp@ values, for @String@ along with the +-- strict and lazy versions of @ByteString@. To add others, provide @BufferOp@ +-- definitions for +data BufferOp a + = BufferOp + { buf_hGet :: Handle -> Int -> IO a + , buf_hGetContents :: Handle -> IO a + , buf_hPut :: Handle -> a -> IO () + , buf_hGetLine :: Handle -> IO a + , buf_empty :: a + , buf_append :: a -> a -> a + , buf_concat :: [a] -> a + , buf_fromStr :: String -> a + , buf_toStr :: a -> String + , buf_snoc :: a -> Word8 -> a + , buf_splitAt :: Int -> a -> (a,a) + , buf_span :: (Char -> Bool) -> a -> (a,a) + , buf_isLineTerm :: a -> Bool + , buf_isEmpty :: a -> Bool + } + +instance Eq (BufferOp a) where + _ == _ = False + +-- | @strictBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-lazy kind. +strictBufferOp :: BufferOp Strict.ByteString +strictBufferOp = + BufferOp + { buf_hGet = Strict.hGet + , buf_hGetContents = Strict.hGetContents + , buf_hPut = Strict.hPut + , buf_hGetLine = Strict.hGetLine + , buf_append = Strict.append + , buf_concat = Strict.concat + , buf_fromStr = Strict.pack + , buf_toStr = Strict.unpack + , buf_snoc = Strict.snoc + , buf_splitAt = Strict.splitAt + , buf_span = Strict.span + , 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 + } + where + p_crlf = Strict.pack crlf + p_lf = Strict.pack lf + +-- | @lazyBufferOp@ is the 'BufferOp' definition over @ByteString@s, +-- the non-strict kind. +lazyBufferOp :: BufferOp Lazy.ByteString +lazyBufferOp = + BufferOp + { buf_hGet = Lazy.hGet + , buf_hGetContents = Lazy.hGetContents + , buf_hPut = Lazy.hPut + , buf_hGetLine = \ h -> Strict.hGetLine h >>= \ l -> return (Lazy.fromChunks [l]) + , buf_append = Lazy.append + , buf_concat = Lazy.concat + , buf_fromStr = Lazy.pack + , buf_toStr = Lazy.unpack + , buf_snoc = Lazy.snoc + , buf_splitAt = \ i x -> Lazy.splitAt (fromIntegral i) x + , buf_span = Lazy.span + , 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 + } + where + p_crlf = Lazy.pack crlf + p_lf = Lazy.pack lf + +-- | @stringBufferOp@ is the 'BufferOp' definition over @String@s. +-- It is defined in terms of @strictBufferOp@ operations, +-- unpacking/converting to @String@ when needed. +stringBufferOp :: BufferOp String +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) + , buf_hGetLine = \ h -> buf_hGetLine strictBufferOp h >>= return . Strict.unpack + , buf_append = (++) + , buf_concat = concat + , buf_fromStr = id + , buf_toStr = id + , buf_snoc = \ a x -> a ++ [toEnum (fromIntegral x)] + , buf_splitAt = splitAt + , 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 + } + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Auth.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Auth.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Auth.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Auth.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,221 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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(..) + , Algorithm(..) + , Challenge(..) + , Qop(..) + + , headerToChallenge -- :: URI -> Header -> Maybe Challenge + , withAuthority -- :: Authority -> Request ty -> String + ) where + +import Network.URI +import Network.HTTP.Base +import Network.HTTP.Utils +import Network.HTTP.Headers ( Header(..) ) +import qualified Network.HTTP.MD5Aux as MD5 (md5s, Str(Str)) +import qualified Network.HTTP.Base64 as Base64 (encode) +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, spaces, sepBy1 ) + +import Data.Char +import Data.Maybe +import Data.Word ( Word8 ) + +-- | @Authority@ specifies the HTTP Authentication method to use for +-- a given domain/realm; @Basic@ or @Digest@. +data Authority + = AuthBasic { auRealm :: String + , auUsername :: String + , auPassword :: String + , auSite :: URI + } + | AuthDigest{ auRealm :: String + , auUsername :: String + , auPassword :: String + , auNonce :: String + , auAlgorithm :: Maybe Algorithm + , auDomain :: [URI] + , auOpaque :: Maybe String + , auQop :: [Qop] + } + + +data Challenge + = ChalBasic { chRealm :: String } + | ChalDigest { chRealm :: String + , chDomain :: [URI] + , chNonce :: String + , chOpaque :: Maybe String + , chStale :: Bool + , chAlgorithm ::Maybe Algorithm + , chQop :: [Qop] + } + +-- | @Algorithm@ controls the digest algorithm to, @MD5@ or @MD5Session@. +data Algorithm = AlgMD5 | AlgMD5sess + deriving(Eq) + +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 + AuthBasic{} -> "Basic " ++ base64encode (auUsername a ++ ':' : auPassword a) + AuthDigest{} -> + "Digest " ++ + concat [ "username=" ++ quo (auUsername a) + , ",realm=" ++ quo (auRealm a) + , ",nonce=" ++ quo (auNonce a) + , ",uri=" ++ quo digesturi + , ",response=" ++ quo rspdigest + -- plus optional stuff: + , fromMaybe "" (fmap (\ alg -> ",algorithm=" ++ quo (show alg)) (auAlgorithm a)) + , fromMaybe "" (fmap (\ o -> ",opaque=" ++ quo o) (auOpaque a)) + , if null (auQop a) then "" else ",qop=auth" + ] + where + quo s = '"':s ++ "\"" + + rspdigest = map toLower (kd (md5 a1) (noncevalue ++ ":" ++ md5 a2)) + + a1, a2 :: String + a1 = auUsername a ++ ":" ++ auRealm a ++ ":" ++ auPassword a + + {- + If the "qop" directive's value is "auth" or is unspecified, then A2 + is: + A2 = Method ":" digest-uri-value + If the "qop" value is "auth-int", then A2 is: + A2 = Method ":" digest-uri-value ":" H(entity-body) + -} + a2 = show (rqMethod rq) ++ ":" ++ digesturi + + digesturi = show (rqURI rq) + noncevalue = auNonce a + +type Octet = Word8 + +-- FIXME: these probably only work right for latin-1 strings +stringToOctets :: String -> [Octet] +stringToOctets = map (fromIntegral . fromEnum) + +base64encode :: String -> String +base64encode = Base64.encode . stringToOctets + +md5 :: String -> String +md5 = MD5.md5s . MD5.Str + +kd :: String -> String -> String +kd a b = md5 (a ++ ":" ++ b) + + + + +-- | @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) = + case parse challenge "" str of + Left{} -> Nothing + Right (name,props) -> case name of + "basic" -> mkBasic props + "digest" -> mkDigest props + _ -> Nothing + where + challenge :: Parser (String,[(String,String)]) + challenge = + do { nme <- word + ; spaces + ; pps <- cprops + ; return (map toLower nme,pps) + } + + cprops = sepBy1 cprop comma + + comma = do { spaces ; _ <- char ',' ; spaces } + + cprop = + do { nm <- word + ; _ <- char '=' + ; val <- quotedstring + ; return (map toLower nm,val) + } + + mkBasic, mkDigest :: [(String,String)] -> Maybe Challenge + + mkBasic params = fmap ChalBasic (lookup "realm" params) + + mkDigest params = + -- with Maybe monad + do { r <- lookup "realm" params + ; n <- lookup "nonce" params + ; return $ + ChalDigest { chRealm = r + , chDomain = (annotateURIs + $ map parseURI + $ words + $ fromMaybe [] + $ lookup "domain" params) + , chNonce = n + , chOpaque = lookup "opaque" params + , chStale = "true" == (map toLower + $ fromMaybe "" (lookup "stale" params)) + , chAlgorithm= readAlgorithm (fromMaybe "MD5" $ lookup "algorithm" params) + , chQop = readQop (fromMaybe "" $ lookup "qop" params) + } + } + + annotateURIs :: [Maybe URI] -> [URI] +#if MIN_VERSION_network(2,4,0) + annotateURIs = map (`relativeTo` baseURI) . catMaybes +#else + annotateURIs = (map (\u -> fromMaybe u (u `relativeTo` baseURI))) . catMaybes +#endif + + -- Change These: + readQop :: String -> [Qop] + readQop = catMaybes . (map strToQop) . (splitBy ',') + + strToQop qs = case map toLower (trim qs) of + "auth" -> Just QopAuth + "auth-int" -> Just QopAuthInt + _ -> Nothing + + readAlgorithm astr = case map toLower (trim astr) of + "md5" -> Just AlgMD5 + "md5-sess" -> Just AlgMD5sess + _ -> Nothing + +word, quotedstring :: Parser String +quotedstring = + do { _ <- char '"' -- " + ; str <- many (satisfy $ not . (=='"')) + ; _ <- char '"' + ; return str + } + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Base64.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Base64.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Base64.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Base64.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,282 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Codec.Binary.Base64 +-- Copyright : (c) Dominic Steinitz 2005, Warrick Gray 2002 +-- License : BSD-style (see the file ReadMe.tex) +-- +-- Maintainer : dominic.steinitz@blueyonder.co.uk +-- Stability : experimental +-- Portability : portable +-- +-- Base64 encoding and decoding functions provided by Warwick Gray. +-- See +-- and . +-- +----------------------------------------------------------------------------- + +module Network.HTTP.Base64 + ( encode + , decode + , chop72 + , Octet + ) where + +{------------------------------------------------------------------------ +This is what RFC2045 had to say: + +6.8. Base64 Content-Transfer-Encoding + + The Base64 Content-Transfer-Encoding is designed to represent + arbitrary sequences of octets in a form that need not be humanly + readable. The encoding and decoding algorithms are simple, but the + encoded data are consistently only about 33 percent larger than the + unencoded data. This encoding is virtually identical to the one used + in Privacy Enhanced Mail (PEM) applications, as defined in RFC 1421. + + A 65-character subset of US-ASCII is used, enabling 6 bits to be + represented per printable character. (The extra 65th character, "=", + is used to signify a special processing function.) + + NOTE: This subset has the important property that it is represented + identically in all versions of ISO 646, including US-ASCII, and all + characters in the subset are also represented identically in all + versions of EBCDIC. Other popular encodings, such as the encoding + used by the uuencode utility, Macintosh binhex 4.0 [RFC-1741], and + the base85 encoding specified as part of Level 2 PostScript, do not + share these properties, and thus do not fulfill the portability + requirements a binary transport encoding for mail must meet. + + The encoding process represents 24-bit groups of input bits as output + strings of 4 encoded characters. Proceeding from left to right, a + 24-bit input group is formed by concatenating 3 8bit input groups. + These 24 bits are then treated as 4 concatenated 6-bit groups, each + of which is translated into a single digit in the base64 alphabet. + When encoding a bit stream via the base64 encoding, the bit stream + must be presumed to be ordered with the most-significant-bit first. + That is, the first bit in the stream will be the high-order bit in + the first 8bit byte, and the eighth bit will be the low-order bit in + the first 8bit byte, and so on. + + Each 6-bit group is used as an index into an array of 64 printable + characters. The character referenced by the index is placed in the + output string. These characters, identified in Table 1, below, are + selected so as to be universally representable, and the set excludes + characters with particular significance to SMTP (e.g., ".", CR, LF) + and to the multipart boundary delimiters defined in RFC 2046 (e.g., + "-"). + + + + Table 1: The Base64 Alphabet + + Value Encoding Value Encoding Value Encoding Value Encoding + 0 A 17 R 34 i 51 z + 1 B 18 S 35 j 52 0 + 2 C 19 T 36 k 53 1 + 3 D 20 U 37 l 54 2 + 4 E 21 V 38 m 55 3 + 5 F 22 W 39 n 56 4 + 6 G 23 X 40 o 57 5 + 7 H 24 Y 41 p 58 6 + 8 I 25 Z 42 q 59 7 + 9 J 26 a 43 r 60 8 + 10 K 27 b 44 s 61 9 + 11 L 28 c 45 t 62 + + 12 M 29 d 46 u 63 / + 13 N 30 e 47 v + 14 O 31 f 48 w (pad) = + 15 P 32 g 49 x + 16 Q 33 h 50 y + + The encoded output stream must be represented in lines of no more + than 76 characters each. All line breaks or other characters not + found in Table 1 must be ignored by decoding software. In base64 + data, characters other than those in Table 1, line breaks, and other + white space probably indicate a transmission error, about which a + warning message or even a message rejection might be appropriate + under some circumstances. + + Special processing is performed if fewer than 24 bits are available + at the end of the data being encoded. A full encoding quantum is + always completed at the end of a body. When fewer than 24 input bits + are available in an input group, zero bits are added (on the right) + to form an integral number of 6-bit groups. Padding at the end of + the data is performed using the "=" character. Since all base64 + input is an integral number of octets, only the following cases can + arise: (1) the final quantum of encoding input is an integral + multiple of 24 bits; here, the final unit of encoded output will be + an integral multiple of 4 characters with no "=" padding, (2) the + final quantum of encoding input is exactly 8 bits; here, the final + unit of encoded output will be two characters followed by two "=" + padding characters, or (3) the final quantum of encoding input is + exactly 16 bits; here, the final unit of encoded output will be three + characters followed by one "=" padding character. + + Because it is used only for padding at the end of the data, the + occurrence of any "=" characters may be taken as evidence that the + end of the data has been reached (without truncation in transit). No + such assurance is possible, however, when the number of octets + transmitted was a multiple of three and no "=" characters are + present. + + Any characters outside of the base64 alphabet are to be ignored in + base64-encoded data. + + Care must be taken to use the proper octets for line breaks if base64 + encoding is applied directly to text material that has not been + converted to canonical form. In particular, text line breaks must be + converted into CRLF sequences prior to base64 encoding. The + important thing to note is that this may be done directly by the + encoder rather than in a prior canonicalization step in some + implementations. + + NOTE: There is no need to worry about quoting potential boundary + delimiters within base64-encoded bodies within multipart entities + because no hyphen characters are used in the base64 encoding. + +----------------------------------------------------------------------------} + +{- + +The following properties should hold: + + decode . encode = id + decode . chop72 . encode = id + +I.E. Both "encode" and "chop72 . encode" are valid methods of encoding input, +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. +-} + + +import Data.Array (Array, array, (!)) +import Data.Bits (shiftL, shiftR, (.&.), (.|.)) +import Data.Char (chr, ord) +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') + , (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') + , (30,'e'), (31,'f'), (32,'g'), (33,'h'), (34,'i'), (35,'j') + , (36,'k'), (37,'l'), (38,'m'), (39,'n'), (40,'o'), (41,'p') + , (42,'q'), (43,'r'), (44,'s'), (45,'t'), (46,'u'), (47,'v') + , (48,'w'), (49,'x'), (50,'y'), (51,'z'), (52,'0'), (53,'1') + , (54,'2'), (55,'3'), (56,'4'), (57,'5'), (58,'6'), (59,'7') + , (60,'8'), (61,'9'), (62,'+'), (63,'/') ] + + +-- 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 +-- 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) = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6 .|. d) + in (chr (n `shiftR` 16 .&. 0xff)) + : (chr (n `shiftR` 8 .&. 0xff)) + : (chr (n .&. 0xff)) : int4_char3 t + +int4_char3 [a,b,c] = + let n = (a `shiftL` 18 .|. b `shiftL` 12 .|. c `shiftL` 6) + in [ (chr (n `shiftR` 16 .&. 0xff)) + , (chr (n `shiftR` 8 .&. 0xff)) ] + +int4_char3 [a,b] = + let n = (a `shiftL` 18 .|. b `shiftL` 12) + in [ (chr (n `shiftR` 16 .&. 0xff)) ] + +int4_char3 [_] = error "Network.HTTP.Base64.int4_char3: impossible number of Ints." + +int4_char3 [] = [] + + + + +-- Convert triplets of characters to +-- 4 base64 integers. The last entries +-- in the list may not produce 4 integers, +-- 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) + = 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 + +char3_int4 [a,b] + = let n = (ord a `shiftL` 16 .|. ord b `shiftL` 8) + 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)] + +char3_int4 [] = [] + + +-- Retrieve base64 char, given an array index integer in the range [0..63] +enc1 :: Int -> Char +enc1 ch = encodeArray!ch + + +-- | Cut up a string into 72 char lines, each line terminated by CRLF. + +chop72 :: String -> String +chop72 str = let (bgn,end) = splitAt 70 str + in if null end then bgn else "\r\n" ++ chop72 end + + +-- Pads a base64 code to a multiple of 4 characters, using the special +-- '=' character. +quadruplets :: [Char] -> [Char] +quadruplets (a:b:c:d:t) = a:b:c:d:quadruplets t +quadruplets [a,b,c] = [a,b,c,'='] -- 16bit tail unit +quadruplets [a,b] = [a,b,'=','='] -- 8bit tail unit +quadruplets [_] = error "Network.HTTP.Base64.quadruplets: impossible number of characters." +quadruplets [] = [] -- 24bit tail unit + + +enc :: [Int] -> [Char] +enc = quadruplets . map enc1 + + +dcd :: String -> [Int] +dcd [] = [] +dcd (h:t) + | h <= 'Z' && h >= 'A' = ord h - ord 'A' : dcd t + | h >= '0' && h <= '9' = ord h - ord '0' + 52 : dcd t + | h >= 'a' && h <= 'z' = ord h - ord 'a' + 26 : dcd t + | h == '+' = 62 : dcd t + | h == '/' = 63 : dcd t + | h == '=' = [] -- terminate data stream + | otherwise = dcd t + + +-- Principal encoding and decoding functions. + +encode :: [Octet] -> String +encode = enc . char3_int4 . (map (chr .fromIntegral)) + +{- +prop_base64 os = + os == (f . g . h) os + where types = (os :: [Word8]) + f = map (fromIntegral. ord) + g = decode . encode + h = map (chr . fromIntegral) +-} + +decode :: String -> [Octet] +decode = (map (fromIntegral . ord)) . int4_char3 . dcd diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Base.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Base.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Base.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Base.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,994 @@ +{-# LANGUAGE ScopedTypeVariables #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Base +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Definitions of @Request@ and @Response@ types along with functions +-- for normalizing them. It is assumed to be an internal module; user +-- code should, if possible, import @Network.HTTP@ to access the functionality +-- that this module provides. +-- +-- Additionally, the module exports internal functions for working with URLs, +-- and for handling the processing of requests and responses coming back. +-- +----------------------------------------------------------------------------- +module Network.HTTP.Base + ( + -- ** Constants + httpVersion -- :: String + + -- ** HTTP + , Request(..) + , Response(..) + , RequestMethod(..) + + , Request_String + , Response_String + , HTTPRequest + , HTTPResponse + + -- ** URL Encoding + , urlEncode + , urlDecode + , urlEncodeVars + + -- ** URI authority parsing + , URIAuthority(..) + , parseURIAuthority + + -- internal + , uriToAuthorityString -- :: URI -> String + , uriAuthToString -- :: URIAuth -> String + , uriAuthPort -- :: Maybe URI -> URIAuth -> Int + , reqURIAuth -- :: Request ty -> URIAuth + + , parseResponseHead -- :: [String] -> Result ResponseData + , parseRequestHead -- :: [String] -> Result RequestData + + , ResponseNextStep(..) + , matchResponse + , ResponseData + , ResponseCode + , RequestData + + , NormalizeRequestOptions(..) + , defaultNormalizeRequestOptions -- :: NormalizeRequestOptions ty + , RequestNormalizer + + , normalizeRequest -- :: NormalizeRequestOptions ty -> Request ty -> Request ty + + , splitRequestURI + + , getAuth + , normalizeRequestURI + , normalizeHostHeader + , findConnClose + + -- internal export (for the use by Network.HTTP.{Stream,ByteStream} ) + , linearTransfer + , hopefulTransfer + , chunkedTransfer + , uglyDeathTransfer + , readTillEmpty1 + , readTillEmpty2 + + , defaultGETRequest + , defaultGETRequest_ + , mkRequest + , setRequestBody + + , defaultUserAgent + , httpPackageVersion + , libUA {- backwards compatibility, will disappear..soon -} + + , catchIO + , catchIO_ + , responseParseError + + , getRequestVersion + , getResponseVersion + , setRequestVersion + , setResponseVersion + + , failHTTPS + + ) where + +import Network.URI + ( URI(uriAuthority, uriPath, uriScheme) + , URIAuth(URIAuth, uriUserInfo, uriRegName, uriPort) + , parseURIReference + ) + +import Control.Monad ( guard ) +import Control.Monad.Error () +import Data.Bits ( (.&.), (.|.), shiftL, shiftR ) +import Data.Word ( Word8 ) +import Data.Char ( digitToInt, intToDigit, toLower, isDigit, + isAscii, isAlphaNum, ord, chr ) +import Data.List ( partition, find ) +import Data.Maybe ( listToMaybe, fromMaybe ) +import Numeric ( readHex ) + +import Network.Stream +import Network.BufferType ( BufferOp(..), BufferType(..) ) +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim, crlf, sp, readsOne ) +import qualified Network.HTTP.Base64 as Base64 (encode) + +import Text.Read.Lex (readDecP) +import Text.ParserCombinators.ReadP + ( ReadP, readP_to_S, char, (<++), look, munch, munch1 ) + +import Control.Exception as Exception (catch, IOException) + +import qualified Paths_HTTP as Self (version) +import Data.Version (showVersion) + +----------------------------------------------------------------- +------------------ URI Authority parsing ------------------------ +----------------------------------------------------------------- + +data URIAuthority = URIAuthority { user :: Maybe String, + password :: Maybe String, + host :: String, + port :: Maybe Int + } deriving (Eq,Show) + +-- | Parse the authority part of a URL. +-- +-- > RFC 1732, section 3.1: +-- > +-- > //:@:/ +-- > Some or all of the parts ":@", ":", +-- > ":", and "/" may be excluded. +parseURIAuthority :: String -> Maybe URIAuthority +parseURIAuthority s = listToMaybe (map fst (readP_to_S pURIAuthority s)) + + +pURIAuthority :: ReadP URIAuthority +pURIAuthority = do + (u,pw) <- (pUserInfo `before` char '@') + <++ return (Nothing, Nothing) + h <- rfc2732host <++ munch (/=':') + p <- orNothing (char ':' >> readDecP) + look >>= guard . null + return URIAuthority{ user=u, password=pw, host=h, port=p } + +-- RFC2732 adds support for '[literal-ipv6-address]' in the host part of a URL +rfc2732host :: ReadP String +rfc2732host = do + _ <- char '[' + res <- munch1 (/=']') + _ <- char ']' + return res + +pUserInfo :: ReadP (Maybe String, Maybe String) +pUserInfo = do + u <- orNothing (munch (`notElem` ":@")) + p <- orNothing (char ':' >> munch (/='@')) + return (u,p) + +before :: Monad m => m a -> m b -> m a +before a b = a >>= \x -> b >> return x + +orNothing :: ReadP a -> ReadP (Maybe a) +orNothing p = fmap Just p <++ return Nothing + +-- This function duplicates old Network.URI.authority behaviour. +uriToAuthorityString :: URI -> String +uriToAuthorityString u = maybe "" uriAuthToString (uriAuthority u) + +uriAuthToString :: URIAuth -> String +uriAuthToString ua = + concat [ uriUserInfo ua + , uriRegName ua + , uriPort ua + ] + +uriAuthPort :: Maybe URI -> URIAuth -> Int +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) = + case map toLower $ uriScheme url of + "http:" -> default_http + "https:" -> default_https + -- todo: refine + _ -> default_http + + default_http = 80 + default_https = 443 + +failHTTPS :: Monad m => URI -> m () +failHTTPS uri + | map toLower (uriScheme uri) == "https:" = fail "https not supported" + | otherwise = return () + +-- Fish out the authority from a possibly normalized Request, i.e., +-- the information may either be in the request's URI or inside +-- the Host: header. +reqURIAuth :: Request ty -> URIAuth +reqURIAuth req = + case uriAuthority (rqURI req) of + Just ua -> ua + _ -> case lookupHeader HdrHost (rqHeaders req) of + Nothing -> error ("reqURIAuth: no URI authority for: " ++ show req) + Just h -> + case toHostPort h of + (ht,p) -> URIAuth { uriUserInfo = "" + , uriRegName = ht + , uriPort = p + } + where + -- Note: just in case you're wondering..the convention is to include the ':' + -- in the port part.. + toHostPort h = break (==':') h + +----------------------------------------------------------------- +------------------ HTTP Messages -------------------------------- +----------------------------------------------------------------- + + +-- Protocol version +httpVersion :: String +httpVersion = "HTTP/1.1" + + +-- | The HTTP request method, to be used in the 'Request' object. +-- We are missing a few of the stranger methods, but these are +-- not really necessary until we add full TLS. +data RequestMethod = HEAD | PUT | GET | POST | DELETE | OPTIONS | TRACE | CONNECT | Custom String + deriving(Eq) + +instance Show RequestMethod where + show x = + case x of + HEAD -> "HEAD" + PUT -> "PUT" + GET -> "GET" + POST -> "POST" + DELETE -> "DELETE" + OPTIONS -> "OPTIONS" + TRACE -> "TRACE" + CONNECT -> "CONNECT" + Custom c -> c + +rqMethodMap :: [(String, RequestMethod)] +rqMethodMap = [("HEAD", HEAD), + ("PUT", PUT), + ("GET", GET), + ("POST", POST), + ("DELETE", DELETE), + ("OPTIONS", OPTIONS), + ("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 + +-- Hmm..I really want to use these for the record +-- type, but it will upset codebases wanting to +-- migrate (and live with using pre-HTTPbis versions.) +type HTTPRequest a = Request a +type HTTPResponse a = Response a + +-- | An HTTP Request. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output. +data Request a = + Request { rqURI :: URI -- ^ might need changing in future + -- 1) to support '*' uri in OPTIONS request + -- 2) transparent support for both relative + -- & absolute uris, although this should + -- already work (leave scheme & host parts empty). + , rqMethod :: RequestMethod + , rqHeaders :: [Header] + , rqBody :: a + } + +-- Notice that request body is not included, +-- this show function is used to serialise +-- a request for the transport link, we send +-- the body separately where possible. +instance Show (Request a) where + show req@(Request u m h _) = + show m ++ sp ++ alt_uri ++ sp ++ ver ++ crlf + ++ 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 } + else u + +instance HasHeaders (Request a) where + getHeaders = rqHeaders + setHeaders rq hdrs = rq { rqHeaders=hdrs } + +-- | For easy pattern matching, HTTP response codes @xyz@ are +-- represented as @(x,y,z)@. +type ResponseCode = (Int,Int,Int) + +-- | @ResponseData@ contains the head of a response payload; +-- HTTP response code, accompanying text description + header +-- fields. +type ResponseData = (ResponseCode,String,[Header]) + +-- | @RequestData@ contains the head of a HTTP request; method, +-- its URL along with the auxillary/supporting header data. +type RequestData = (RequestMethod,URI,[Header]) + +-- | An HTTP Response. +-- The 'Show' instance of this type is used for message serialisation, +-- which means no body data is output, additionally the output will +-- show an HTTP version of 1.1 instead of the actual version returned +-- by a server. +data Response a = + Response { rspCode :: ResponseCode + , rspReason :: String + , rspHeaders :: [Header] + , rspBody :: a + } + +-- 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 _) = + ver ++ ' ' : map intToDigit [a,b,c] ++ ' ' : reason ++ crlf + ++ foldr (++) [] (map show (dropHttpVersion headers)) ++ crlf + where + ver = fromMaybe httpVersion (getResponseVersion rsp) + +instance HasHeaders (Response a) where + getHeaders = rspHeaders + setHeaders rsp hdrs = rsp { rspHeaders=hdrs } + + +------------------------------------------------------------------ +------------------ Request Building ------------------------------ +------------------------------------------------------------------ + +-- | Deprecated. Use 'defaultUserAgent' +libUA :: String +libUA = "hs-HTTP-4000.0.9" +{-# DEPRECATED libUA "Use defaultUserAgent instead (but note the user agent name change)" #-} + +-- | A default user agent string. The string is @\"haskell-HTTP/$version\"@ +-- where @$version@ is the version of this HTTP package. +-- +defaultUserAgent :: String +defaultUserAgent = "haskell-HTTP/" ++ httpPackageVersion + +-- | The version of this HTTP package as a string, e.g. @\"4000.1.2\"@. This +-- may be useful to include in a user agent string so that you can determine +-- from server logs what version of this package HTTP clients are using. +-- This can be useful for tracking down HTTP compatibility quirks. +-- +httpPackageVersion :: String +httpPackageVersion = showVersion Self.version + +defaultGETRequest :: URI -> Request_String +defaultGETRequest uri = defaultGETRequest_ uri + +defaultGETRequest_ :: BufferType a => URI -> Request a +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 +-- 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 = + Request { rqURI = uri + , rqBody = empty + , rqHeaders = [ Header HdrContentLength "0" + , Header HdrUserAgent defaultUserAgent + ] + , rqMethod = meth + } + + empty = buf_empty (toBufOps req) + +-- set rqBody, Content-Type and Content-Length headers. +setRequestBody :: Request_String -> (String, String) -> Request_String +setRequestBody req (typ, body) = req' { rqBody=body } + where + req' = replaceHeader HdrContentType typ . + replaceHeader HdrContentLength (show $ length body) $ + req + +{- + -- stub out the user info. + updAuth = fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri) + + withHost = + case uriToAuthorityString uri{uriAuthority=updAuth} of + "" -> id + h -> ((Header HdrHost h):) + + uri_req + | forProxy = uri + | otherwise = snd (splitRequestURI uri) +-} + + +toBufOps :: BufferType a => Request a -> BufferOp a +toBufOps _ = bufferOps + +----------------------------------------------------------------- +------------------ Parsing -------------------------------------- +----------------------------------------------------------------- + +-- Parsing a request +parseRequestHead :: [String] -> Result RequestData +parseRequestHead [] = Left ErrorClosed +parseRequestHead (com:hdrs) = do + (version,rqm,uri) <- requestCommand com (words com) + hdrs' <- parseHeaders hdrs + return (rqm,uri,withVer version hdrs') + where + withVer [] hs = hs + withVer (h:_) hs = withVersion h hs + + requestCommand l _yes@(rqm:uri:version) = + case (parseURIReference uri, lookup rqm rqMethodMap) of + (Just u, Just r) -> return (version,r,u) + (Just u, Nothing) -> return (version,Custom rqm,u) + _ -> parse_err l + requestCommand l _ + | null l = failWith ErrorClosed + | otherwise = parse_err l + + parse_err l = responseParseError "parseRequestHead" + ("Request command line parse failure: " ++ l) + +-- Parsing a response +parseResponseHead :: [String] -> Result ResponseData +parseResponseHead [] = failWith ErrorClosed +parseResponseHead (sts:hdrs) = do + (version,code,reason) <- responseStatus sts (words sts) + hdrs' <- parseHeaders hdrs + return (code,reason, withVersion version hdrs') + where + responseStatus _l _yes@(version:code:reason) = + return (version,match code,concatMap (++" ") reason) + responseStatus l _no + | null l = failWith ErrorClosed -- an assumption + | otherwise = parse_err l + + parse_err l = + responseParseError + "parseResponseHead" + ("Response status line parse failure: " ++ l) + + match [a,b,c] = (digitToInt a, + digitToInt b, + digitToInt c) + match _ = (-1,-1,-1) -- will create appropriate behaviour + +-- To avoid changing the @RequestData@ and @ResponseData@ types +-- just for this (and the upstream backwards compat. woes that +-- will result in), encode version info as a custom header. +-- Used by 'parseResponseData' and 'parseRequestData'. +-- +-- Note: the Request and Response types do not currently represent +-- 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 + | v == httpVersion = hs -- don't bother adding it if the default. + | otherwise = (Header (HdrCustom "X-HTTP-Version") v) : hs + +-- | @getRequestVersion req@ returns the HTTP protocol version of +-- the request @req@. If @Nothing@, the default 'httpVersion' can be assumed. +getRequestVersion :: Request a -> Maybe String +getRequestVersion r = getHttpVersion r + +-- | @setRequestVersion v req@ returns a new request, identical to +-- @req@, but with its HTTP version set to @v@. +setRequestVersion :: String -> Request a -> Request a +setRequestVersion s r = setHttpVersion r s + + +-- | @getResponseVersion rsp@ returns the HTTP protocol version of +-- the response @rsp@. If @Nothing@, the default 'httpVersion' can be +-- assumed. +getResponseVersion :: Response a -> Maybe String +getResponseVersion r = getHttpVersion r + +-- | @setResponseVersion v rsp@ returns a new response, identical to +-- @rsp@, but with its HTTP version set to @v@. +setResponseVersion :: String -> Response a -> Response a +setResponseVersion s r = setHttpVersion r s + +-- internal functions for accessing HTTP-version info in +-- requests and responses. Not exported as it exposes ho +-- version info is represented internally. + +getHttpVersion :: HasHeaders a => a -> Maybe String +getHttpVersion r = + fmap toVersion $ + find isHttpVersion $ + getHeaders r + where + toVersion (Header _ x) = x + +setHttpVersion :: HasHeaders a => a -> String -> a +setHttpVersion r v = + setHeaders r $ + withVersion v $ + dropHttpVersion $ + getHeaders r + +dropHttpVersion :: [Header] -> [Header] +dropHttpVersion hs = filter (not.isHttpVersion) hs + +isHttpVersion :: Header -> Bool +isHttpVersion (Header (HdrCustom "X-HTTP-Version") _) = True +isHttpVersion _ = False + + + +----------------------------------------------------------------- +------------------ HTTP Send / Recv ---------------------------------- +----------------------------------------------------------------- + +data ResponseNextStep + = Continue + | Retry + | Done + | ExpectEntity + | DieHorribly String + +matchResponse :: RequestMethod -> ResponseCode -> ResponseNextStep +matchResponse rqst rsp = + case rsp of + (1,0,0) -> Continue + (1,0,1) -> Done -- upgrade to TLS + (1,_,_) -> Continue -- default + (2,0,4) -> Done + (2,0,5) -> Done + (2,_,_) -> ans + (3,0,4) -> Done + (3,0,5) -> Done + (3,_,_) -> ans + (4,1,7) -> Retry -- Expectation failed + (4,_,_) -> ans + (5,_,_) -> ans + (a,b,c) -> DieHorribly ("Response code " ++ map intToDigit [a,b,c] ++ " not recognised") + where + ans | rqst == HEAD = Done + | otherwise = ExpectEntity + + + +----------------------------------------------------------------- +------------------ A little friendly funtionality --------------- +----------------------------------------------------------------- + + +{- + I had a quick look around but couldn't find any RFC about + the encoding of data on the query string. I did find an + IETF memo, however, so this is how I justify the urlEncode + and urlDecode methods. + + Doc name: draft-tiwari-appl-wxxx-forms-01.txt (look on www.ietf.org) + + Reserved chars: ";", "/", "?", ":", "@", "&", "=", "+", ",", and "$" are reserved. + Unwise: "{" | "}" | "|" | "\" | "^" | "[" | "]" | "`" + URI delims: "<" | ">" | "#" | "%" | <"> + Unallowed ASCII: + + Also unallowed: any non-us-ascii character + + Escape method: char -> '%' a b where a, b :: Hex digits +-} + +replacement_character :: Char +replacement_character = '\xfffd' + +-- | Encode a single Haskell Char to a list of Word8 values, in UTF8 format. +-- +-- Shamelessly stolen from utf-8string-0.3.7 +encodeChar :: Char -> [Word8] +encodeChar = map fromIntegral . go . ord + where + go oc + | oc <= 0x7f = [oc] + + | oc <= 0x7ff = [ 0xc0 + (oc `shiftR` 6) + , 0x80 + oc .&. 0x3f + ] + + | oc <= 0xffff = [ 0xe0 + (oc `shiftR` 12) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + | otherwise = [ 0xf0 + (oc `shiftR` 18) + , 0x80 + ((oc `shiftR` 12) .&. 0x3f) + , 0x80 + ((oc `shiftR` 6) .&. 0x3f) + , 0x80 + oc .&. 0x3f + ] + +-- | Decode a UTF8 string packed into a list of Word8 values, directly to String +-- +-- Shamelessly stolen from utf-8string-0.3.7 +decode :: [Word8] -> String +decode [ ] = "" +decode (c:cs) + | c < 0x80 = chr (fromEnum c) : decode cs + | c < 0xc0 = replacement_character : decode cs + | c < 0xe0 = multi1 + | c < 0xf0 = multi_byte 2 0xf 0x800 + | c < 0xf8 = multi_byte 3 0x7 0x10000 + | c < 0xfc = multi_byte 4 0x3 0x200000 + | c < 0xfe = multi_byte 5 0x1 0x4000000 + | otherwise = replacement_character : decode cs + where + multi1 = case cs of + c1 : ds | c1 .&. 0xc0 == 0x80 -> + let d = ((fromEnum c .&. 0x1f) `shiftL` 6) .|. fromEnum (c1 .&. 0x3f) + in if d >= 0x000080 then toEnum d : decode ds + else replacement_character : decode ds + _ -> replacement_character : decode cs + + multi_byte :: Int -> Word8 -> Int -> [Char] + multi_byte i mask overlong = aux i cs (fromEnum (c .&. mask)) + where + aux 0 rs acc + | overlong <= acc && acc <= 0x10ffff && + (acc < 0xd800 || 0xdfff < acc) && + (acc < 0xfffe || 0xffff < acc) = chr acc : decode rs + | otherwise = replacement_character : decode rs + + aux n (r:rs) acc + | r .&. 0xc0 == 0x80 = aux (n-1) rs + $ shiftL acc 6 .|. fromEnum (r .&. 0x3f) + + aux _ rs _ = replacement_character : decode rs + + +-- This function is a bit funny because potentially the input String could contain some actual Unicode +-- characters (though this shouldn't happen for most use cases), so we have to preserve those characters +-- while simultaneously decoding any UTF-8 data +urlDecode :: String -> String +urlDecode = go [] + where + go bs ('%':a:b:rest) = go (fromIntegral (16 * digitToInt a + digitToInt b) : bs) rest + go bs (h:t) | fromEnum h < 256 = go (fromIntegral (fromEnum h) : bs) t -- Treat ASCII as just another byte of UTF-8 + go [] [] = [] + go [] (h:t) = h : go [] t -- h >= 256, so can't be part of any UTF-8 byte sequence + go bs rest = decode (reverse bs) ++ go [] rest + + +urlEncode :: String -> String +urlEncode [] = [] +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) + where + escape b rs = '%':showH (b `div` 16) (showH (b `mod` 16) rs) + + showH :: Word8 -> String -> String + showH x xs + | x <= 9 = to (o_0 + x) : xs + | otherwise = to (o_A + (x-10)) : xs + where + to = toEnum . fromIntegral + fro = fromIntegral . fromEnum + + o_0 = fro '0' + o_A = fro 'A' + +-- Encode form variables, useable in either the +-- query part of a URI, or the body of a POST request. +-- I have no source for this information except experience, +-- this sort of encoding worked fine in CGI programming. +urlEncodeVars :: [(String,String)] -> String +urlEncodeVars ((n,v):t) = + let (same,diff) = partition ((==n) . fst) t + in urlEncode n ++ '=' : foldl (\x y -> x ++ ',' : urlEncode y) (urlEncode $ v) (map snd same) + ++ urlEncodeRest diff + where urlEncodeRest [] = [] + urlEncodeRest diff = '&' : urlEncodeVars diff +urlEncodeVars [] = [] + +-- | @getAuth req@ fishes out the authority portion of the URL in a request's @Host@ +-- header. +getAuth :: Monad m => Request ty -> m URIAuthority +getAuth r = + -- ToDo: verify that Network.URI functionality doesn't take care of this (now.) + case parseURIAuthority auth of + Just x -> return x + Nothing -> fail $ "Network.HTTP.Base.getAuth: Error parsing URI authority '" ++ auth ++ "'" + 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 = + (if doClose then replaceHeader HdrConnection "close" else id) $ + insertHeaderIfMissing HdrHost h $ + r { rqURI = (rqURI r){ uriScheme = "" + , uriAuthority = Nothing + }} + +-- | @NormalizeRequestOptions@ brings together the various defaulting\/normalization options +-- over 'Request's. Use 'defaultNormalizeRequestOptions' for the standard selection of option +data NormalizeRequestOptions ty + = NormalizeRequestOptions + { normDoClose :: Bool + , normForProxy :: Bool + , normUserAgent :: Maybe String + , normCustoms :: [RequestNormalizer ty] + } + +-- | @RequestNormalizer@ is the shape of a (pure) function that rewrites +-- a request into some normalized form. +type RequestNormalizer ty = NormalizeRequestOptions ty -> Request ty -> Request ty + +defaultNormalizeRequestOptions :: NormalizeRequestOptions ty +defaultNormalizeRequestOptions = NormalizeRequestOptions + { normDoClose = False + , normForProxy = False + , normUserAgent = Just defaultUserAgent + , normCustoms = [] + } + +-- | @normalizeRequest opts req@ is the entry point to use to normalize your +-- request prior to transmission (or other use.) Normalization is controlled +-- via the @NormalizeRequestOptions@ record. +normalizeRequest :: NormalizeRequestOptions ty + -> Request ty + -> Request ty +normalizeRequest opts req = foldr (\ f -> f opts) req normalizers + where + --normalizers :: [RequestNormalizer ty] + normalizers = + ( normalizeHostURI + : normalizeBasicAuth + : normalizeConnectionClose + : normalizeUserAgent + : normCustoms opts + ) + +-- | @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 = + case normUserAgent opts of + Nothing -> req + Just ua -> + case findHeader HdrUserAgent req of + Just u | u /= defaultUserAgent -> req + _ -> replaceHeader HdrUserAgent ua req + +-- | @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 + | normDoClose opts = replaceHeader HdrConnection "close" req + | otherwise = req + +-- | @normalizeBasicAuth opts req@ sets the header @Authorization: Basic...@ +-- if the "user:pass@" part is present in the "http://user:pass@host/path" +-- of the URI. If Authorization header was present already it is not replaced. +normalizeBasicAuth :: RequestNormalizer ty +normalizeBasicAuth _ req = + case getAuth req of + Just uriauth -> + case (user uriauth, password uriauth) of + (Just u, Just p) -> + insertHeaderIfMissing HdrAuthorization astr req + where + astr = "Basic " ++ base64encode (u ++ ":" ++ p) + base64encode = Base64.encode . stringToOctets :: String -> String + stringToOctets = map (fromIntegral . fromEnum) :: String -> [Word8] + (_, _) -> req + Nothing ->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 = + case splitRequestURI uri of + ("",_uri_abs) + | 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 + hst = case span (/='@') user_hst of + (as,'@':bs) -> + case span (/=':') as of + (_,_:_) -> bs + _ -> user_hst + _ -> user_hst + + (user_hst, pNum) = + case span isDigit (reverse h) of + (ds,':':bs) -> (reverse bs, ':':reverse ds) + _ -> (h,"") + | 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 + | otherwise -> replaceHeader HdrHost h req{rqURI=uri_abs} -- Note: _not_ stubbing out user:pass + where + uri0 = rqURI req + -- stub out the user:pass + uri = uri0{uriAuthority=fmap (\ x -> x{uriUserInfo=""}) (uriAuthority uri0)} + + forProxy = normForProxy opts + +{- Comments re: above rewriting: + RFC 2616, section 5.1.2: + "The most common form of Request-URI is that used to identify a + 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." + 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 + is a Host header. +-} + +splitRequestURI :: URI -> ({-authority-}String, URI) +splitRequestURI uri = (uriToAuthorityString uri, uri{uriScheme="", uriAuthority=Nothing}) + +-- 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 = + insertHeaderIfMissing HdrHost + (uriToAuthorityString $ rqURI rq) + rq + +-- Looks for a "Connection" header with the value "close". +-- Returns True when this is found. +findConnClose :: [Header] -> Bool +findConnClose hdrs = + maybe False + (\ x -> map toLower (trim x) == "close") + (lookupHeader HdrConnection hdrs) + +-- | Used when we know exactly how many bytes to expect. +linearTransfer :: (Int -> IO (Result a)) -> Int -> IO (Result ([Header],a)) +linearTransfer readBlk n = fmapE (\str -> Right ([],str)) (readBlk n) + +-- | Used when nothing about data is known, +-- Unfortunately waiting for a socket closure +-- causes bad behaviour. Here we just +-- take data once and give up the rest. +hopefulTransfer :: BufferOp a + -> IO (Result a) + -> [a] + -> IO (Result ([Header],a)) +hopefulTransfer bufOps readL strs + = readL >>= + either (\v -> return $ Left v) + (\more -> if (buf_isEmpty bufOps more) + then return (Right ([], buf_concat bufOps $ reverse strs)) + else hopefulTransfer bufOps readL (more:strs)) + +-- | A necessary feature of HTTP\/1.1 +-- Also the only transfer variety likely to +-- return any footers. +chunkedTransfer :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result a)) + -> IO (Result ([Header], a)) +chunkedTransfer bufOps readL readBlk = chunkedTransferC bufOps readL readBlk [] 0 + +chunkedTransferC :: BufferOp a + -> IO (Result a) + -> (Int -> IO (Result a)) + -> [a] + -> Int + -> IO (Result ([Header], a)) +chunkedTransferC bufOps readL readBlk acc n = do + v <- readL + case v of + Left e -> return (Left e) + Right line + | size == 0 -> + -- last chunk read; look for trailing headers.. + fmapE (\ strs -> do + ftrs <- parseHeaders (map (buf_toStr bufOps) strs) + -- insert (computed) Content-Length header. + let ftrs' = Header HdrContentLength (show n) : ftrs + return (ftrs',buf_concat bufOps (reverse acc))) + + (readTillEmpty2 bufOps readL []) + + | otherwise -> do + some <- readBlk size + case some of + Left e -> return (Left e) + Right cdata -> 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 + | buf_isEmpty bufOps line = 0 + | otherwise = + case readHex (buf_toStr bufOps line) of + (hx,_):_ -> hx + _ -> 0 + +-- | Maybe in the future we will have a sensible thing +-- to do here, at that time we might want to change +-- the name. +uglyDeathTransfer :: String -> IO (Result ([Header],a)) +uglyDeathTransfer loc = return (responseParseError loc "Unknown Transfer-Encoding") + +-- | Remove leading crlfs then call readTillEmpty2 (not required by RFC) +readTillEmpty1 :: BufferOp a + -> IO (Result a) + -> IO (Result [a]) +readTillEmpty1 bufOps readL = + readL >>= + either (return . Left) + (\ s -> + if buf_isLineTerm bufOps s + then readTillEmpty1 bufOps readL + else readTillEmpty2 bufOps readL [s]) + +-- | Read lines until an empty line (CRLF), +-- also accepts a connection close as end of +-- input, which is not an HTTP\/1.1 compliant +-- thing to do - so probably indicates an +-- error condition. +readTillEmpty2 :: BufferOp a + -> IO (Result a) + -> [a] + -> IO (Result [a]) +readTillEmpty2 bufOps readL list = + readL >>= + either (return . Left) + (\ s -> + if buf_isLineTerm bufOps s || buf_isEmpty bufOps s + then return (Right $ reverse (s:list)) + else readTillEmpty2 bufOps readL (s:list)) + +-- +-- Misc +-- + +-- | @catchIO a h@ handles IO action exceptions throughout codebase; version-specific +-- tweaks better go here. +catchIO :: IO a -> (IOException -> IO a) -> IO a +catchIO a h = Exception.catch a h + +catchIO_ :: IO a -> IO a -> IO a +catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h) + +responseParseError :: String -> String -> Result a +responseParseError loc v = failWith (ErrorParse (loc ++ ' ':v)) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Cookie.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Cookie.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Cookie.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Cookie.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,141 @@ +----------------------------------------------------------------------------- +-- | +-- 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(..) + , cookieMatch -- :: (String,String) -> Cookie -> Bool + + -- functions for translating cookies and headers. + , cookiesToHeader -- :: [Cookie] -> Header + , processCookieHeaders -- :: String -> [Header] -> ([String], [Cookie]) + ) where + +import Network.HTTP.Headers + +import Data.Char +import Data.List +import Data.Maybe + +import Text.ParserCombinators.Parsec + ( Parser, char, many, many1, satisfy, parse, option, try + , (<|>), sepBy1 + ) + +------------------------------------------------------------------ +----------------------- Cookie Stuff ----------------------------- +------------------------------------------------------------------ + +-- | @Cookie@ is the Haskell representation of HTTP cookie values. +-- See its relevant specs for authoritative details. +data Cookie + = MkCookie + { ckDomain :: String + , ckName :: String + , ckValue :: String + , ckPath :: Maybe String + , ckComment :: Maybe String + , ckVersion :: Maybe String + } + deriving(Show,Read) + +instance Eq Cookie where + a == b = ckDomain a == ckDomain b + && ckName a == ckName b + && ckPath a == ckPath b + +-- | @cookieToHeaders ck@ serialises @Cookie@s to an HTTP request header. +cookiesToHeader :: [Cookie] -> Header +cookiesToHeader cs = Header HdrCookie (mkCookieHeaderValue cs) + +-- | Turn a list of cookies into a key=value pair list, separated by +-- semicolons. +mkCookieHeaderValue :: [Cookie] -> String +mkCookieHeaderValue = intercalate "; " . map mkCookieHeaderValue1 + where + mkCookieHeaderValue1 c = ckName c ++ "=" ++ ckValue c + +-- | @cookieMatch (domain,path) ck@ performs the standard cookie +-- match wrt the given domain and path. +cookieMatch :: (String, String) -> Cookie -> Bool +cookieMatch (dom,path) ck = + ckDomain ck `isSuffixOf` dom && + case ckPath ck of + Nothing -> True + Just p -> p `isPrefixOf` path + + +-- | @processCookieHeaders dom hdrs@ +processCookieHeaders :: String -> [Header] -> ([String], [Cookie]) +processCookieHeaders dom hdrs = foldr (headerToCookies dom) ([],[]) hdrs + +-- | @headerToCookies dom hdr acc@ +headerToCookies :: String -> Header -> ([String], [Cookie]) -> ([String], [Cookie]) +headerToCookies dom (Header HdrSetCookie val) (accErr, accCookie) = + case parse cookies "" val of + Left{} -> (val:accErr, accCookie) + Right x -> (accErr, x ++ accCookie) + where + cookies :: Parser [Cookie] + cookies = sepBy1 cookie (char ',') + + cookie :: Parser Cookie + cookie = + do name <- word + _ <- spaces_l + _ <- char '=' + _ <- spaces_l + val1 <- cvalue + args <- cdetail + 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 $ + try (do _ <- spaces_l + _ <- char ';' + _ <- spaces_l + s1 <- word + _ <- spaces_l + s2 <- option "" (char '=' >> spaces_l >> cvalue) + return (map toLower s1,s2) + ) + + mkCookie :: String -> String -> [(String,String)] -> Cookie + mkCookie nm cval more = + MkCookie { ckName = nm + , ckValue = cval + , ckDomain = map toLower (fromMaybe dom (lookup "domain" more)) + , ckPath = lookup "path" more + , ckVersion = lookup "version" more + , ckComment = lookup "comment" more + } +headerToCookies _ _ acc = acc + + + + +word, quotedstring :: Parser String +quotedstring = + do _ <- char '"' -- " + str <- many (satisfy $ not . (=='"')) + _ <- char '"' + return str + +word = many1 (satisfy (\x -> isAlphaNum x || x=='_' || x=='.' || x=='-' || x==':')) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/HandleStream.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/HandleStream.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/HandleStream.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/HandleStream.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,252 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.HandleStream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- A 'HandleStream'-based version of "Network.HTTP" interface. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- 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 + ( 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 + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.BufferType +import Network.Stream ( fmapE, Result ) +import Network.StreamDebugger ( debugByteStream ) +import Network.TCP (HStream(..), HandleStream ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim, readsOne ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Exception (onException) +import Control.Monad (when) + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + +-- | @simpleHTTP@ transmits a resource across a non-persistent connection. +simpleHTTP :: HStream ty => Request ty -> IO (Result (Response ty)) +simpleHTTP r = do + auth <- getAuth r + failHTTPS (rqURI r) + c <- openStream (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | @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 + auth <- getAuth r + failHTTPS (rqURI r) + c0 <- openStream (host auth) (fromMaybe 80 (port auth)) + c <- debugByteStream httpLogFile c0 + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +simpleHTTP_ s r = sendHTTP s r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- closed upon receiving the response. +sendHTTP :: HStream ty => HandleStream ty -> Request ty -> IO (Result (Response ty)) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + onException (sendMain conn rq onSendComplete) + (close conn) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- Since we would wait forever, I have disabled use of 100-continue for now. +sendMain :: HStream ty + => HandleStream ty + -> Request ty + -> (IO ()) + -> IO (Result (Response ty)) +sendMain conn rqst onSendComplete = do + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + -- TODO review throwing away of result + _ <- writeBlock conn (buf_fromStr bufferOps $ show rqst) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst + + -- Hmmm, this could go bad if we keep getting "100 Continue" + -- responses... Except this should never happen according + -- to the RFC. + +switchResponse :: HStream ty + => HandleStream ty + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request ty + -> IO (Result (Response ty)) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- 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 = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> do {- Time to send the body -} + writeBlock conn (rqBody rqst) >>= either (return . Left) + (\ _ -> do + rsp <- getResponseHead conn + switchResponse conn allow_retry True rsp rqst) + | otherwise -> do {- keep waiting -} + rsp <- getResponseHead conn + switchResponse conn allow_retry bdy_sent rsp rqst + + Retry -> do {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + -- TODO review throwing away of result + _ <- writeBlock conn ((buf_append bufferOps) + (buf_fromStr bufferOps (show rqst)) + (rqBody rqst)) + rsp <- getResponseHead conn + switchResponse conn False bdy_sent rsp rqst + + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) + return (Right $ Response cd rn hdrs (buf_empty bufferOps)) + + DieHorribly str -> do + close conn + return (responseParseError "Invalid response:" str) + ExpectEntity -> do + r <- fmapE (\ (ftrs,bdy) -> Right (Response cd rn (hdrs++ftrs) bdy)) $ + maybe (maybe (hopefulTransfer bo (readLine conn) []) + (\ x -> + readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized content-length value" x) + x) + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "sendHTTP")) + tc + case r of + Left{} -> do + close conn + return r + Right (Response _ _ hs _) -> do + when (findConnClose hs) + (closeOnEnd conn True) + return r + + where + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- reads and parses headers +getResponseHead :: HStream ty => HandleStream ty -> IO (Result ResponseData) +getResponseHead conn = + fmapE (\es -> parseResponseHead (map (buf_toStr bufferOps) es)) + (readTillEmpty1 bufferOps (readLine conn)) + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream bufTy => HandleStream bufTy -> IO (Result (Request bufTy)) +receiveHTTP conn = getRequestHead >>= either (return . Left) processRequest + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = do + fmapE (\es -> parseRequestHead (map (buf_toStr bufferOps) es)) + (readTillEmpty1 bufferOps (readLine conn)) + + processRequest (rm,uri,hdrs) = + fmapE (\ (ftrs,bdy) -> Right (Request uri rm (hdrs++ftrs) bdy)) $ + maybe + (maybe (return (Right ([], buf_empty bo))) -- hopefulTransfer "" + (\ x -> readsOne (linearTransfer (readBlock conn)) + (return$responseParseError "unrecognized Content-Length value" x) + x) + + cl) + (ifChunked (chunkedTransfer bo (readLine conn) (readBlock conn)) + (uglyDeathTransfer "receiveHTTP")) + tc + where + -- FIXME : Also handle 100-continue. + tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + bo = bufferOps + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- 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 + -- TODO: review throwing away of result + _ <- writeBlock conn (buf_fromStr bufferOps $ show rsp) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO: review throwing away of result + _ <- writeBlock conn (rspBody rsp) + return () + +------------------------------------------------------------------------------ + +headerName :: String -> String +headerName x = map toLower (trim x) + +ifChunked :: a -> a -> String -> a +ifChunked a b s = + case headerName s of + "chunked" -> a + _ -> b + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Headers.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Headers.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Headers.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Headers.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,306 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Headers +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- This module provides the data types for representing HTTP headers, and +-- operations for looking up header values and working with sequences of +-- 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 + + , Header(..) + , mkHeader -- :: HeaderName -> String -> Header + , hdrName -- :: Header -> HeaderName + , hdrValue -- :: Header -> String + + , HeaderName(..) + + , insertHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaderIfMissing -- :: HasHeaders a => HeaderName -> String -> a -> a + , insertHeaders -- :: HasHeaders a => [Header] -> a -> a + , retrieveHeaders -- :: HasHeaders a => HeaderName -> a -> [Header] + , replaceHeader -- :: HasHeaders a => HeaderName -> String -> a -> a + , findHeader -- :: HasHeaders a => HeaderName -> a -> Maybe String + , lookupHeader -- :: HeaderName -> [Header] -> Maybe String + + , parseHeader -- :: parseHeader :: String -> Result Header + , parseHeaders -- :: [String] -> Result [Header] + + , headerMap -- :: [(String, HeaderName)] + + , HeaderSetter + ) where + +import Data.Char (toLower) +import Network.Stream (Result, failParse) +import Network.HTTP.Utils ( trim, split, crlf ) + +-- | The @Header@ data type pairs header names & values. +data Header = Header HeaderName String + +hdrName :: Header -> HeaderName +hdrName (Header h _) = h + +hdrValue :: Header -> String +hdrValue (Header _ v) = v + +-- | Header constructor as a function, hiding above rep. +mkHeader :: HeaderName -> String -> Header +mkHeader = Header + +instance Show Header where + show (Header key value) = shows key (':':' ':value ++ crlf) + +-- | HTTP @HeaderName@ type, a Haskell data constructor for each +-- specification-defined header, prefixed with @Hdr@ and CamelCased, +-- (i.e., eliding the @-@ in the process.) Should you require using +-- a custom header, there's the @HdrCustom@ constructor which takes +-- a @String@ argument. +-- +-- 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 + -- Generic Headers -- + = HdrCacheControl + | HdrConnection + | HdrDate + | HdrPragma + | HdrTransferEncoding + | HdrUpgrade + | HdrVia + -- Request Headers -- + | HdrAccept + | HdrAcceptCharset + | HdrAcceptEncoding + | HdrAcceptLanguage + | HdrAuthorization + | HdrCookie + | HdrExpect + | HdrFrom + | HdrHost + | HdrIfModifiedSince + | HdrIfMatch + | HdrIfNoneMatch + | HdrIfRange + | HdrIfUnmodifiedSince + | HdrMaxForwards + | HdrProxyAuthorization + | HdrRange + | HdrReferer + | HdrUserAgent + -- Response Headers + | HdrAge + | HdrLocation + | HdrProxyAuthenticate + | HdrPublic + | HdrRetryAfter + | HdrServer + | HdrSetCookie + | HdrTE + | HdrTrailer + | HdrVary + | HdrWarning + | HdrWWWAuthenticate + -- Entity Headers + | HdrAllow + | HdrContentBase + | HdrContentEncoding + | HdrContentLanguage + | HdrContentLength + | HdrContentLocation + | HdrContentMD5 + | HdrContentRange + | HdrContentType + | HdrETag + | HdrExpires + | HdrLastModified + -- | MIME entity headers (for sub-parts) + | HdrContentTransferEncoding + -- | Allows for unrecognised or experimental headers. + | HdrCustom String -- not in header map below. + deriving(Eq) + +-- | @headerMap@ is a straight assoc list for translating between header names +-- and values. +headerMap :: [ (String,HeaderName) ] +headerMap = + [ p "Cache-Control" HdrCacheControl + , p "Connection" HdrConnection + , p "Date" HdrDate + , p "Pragma" HdrPragma + , p "Transfer-Encoding" HdrTransferEncoding + , p "Upgrade" HdrUpgrade + , p "Via" HdrVia + , p "Accept" HdrAccept + , p "Accept-Charset" HdrAcceptCharset + , p "Accept-Encoding" HdrAcceptEncoding + , p "Accept-Language" HdrAcceptLanguage + , p "Authorization" HdrAuthorization + , p "Cookie" HdrCookie + , p "Expect" HdrExpect + , p "From" HdrFrom + , p "Host" HdrHost + , p "If-Modified-Since" HdrIfModifiedSince + , p "If-Match" HdrIfMatch + , p "If-None-Match" HdrIfNoneMatch + , p "If-Range" HdrIfRange + , p "If-Unmodified-Since" HdrIfUnmodifiedSince + , p "Max-Forwards" HdrMaxForwards + , p "Proxy-Authorization" HdrProxyAuthorization + , p "Range" HdrRange + , p "Referer" HdrReferer + , p "User-Agent" HdrUserAgent + , p "Age" HdrAge + , p "Location" HdrLocation + , p "Proxy-Authenticate" HdrProxyAuthenticate + , p "Public" HdrPublic + , p "Retry-After" HdrRetryAfter + , p "Server" HdrServer + , p "Set-Cookie" HdrSetCookie + , p "TE" HdrTE + , p "Trailer" HdrTrailer + , p "Vary" HdrVary + , p "Warning" HdrWarning + , p "WWW-Authenticate" HdrWWWAuthenticate + , p "Allow" HdrAllow + , p "Content-Base" HdrContentBase + , p "Content-Encoding" HdrContentEncoding + , p "Content-Language" HdrContentLanguage + , p "Content-Length" HdrContentLength + , p "Content-Location" HdrContentLocation + , p "Content-MD5" HdrContentMD5 + , p "Content-Range" HdrContentRange + , p "Content-Type" HdrContentType + , p "ETag" HdrETag + , p "Expires" HdrExpires + , p "Last-Modified" HdrLastModified + , p "Content-Transfer-Encoding" HdrContentTransferEncoding + ] + where + p a b = (a,b) + +instance Show HeaderName where + show (HdrCustom s) = s + show x = case filter ((==x).snd) headerMap of + [] -> error "headerMap incomplete" + (h:_) -> fst h + +-- | @HasHeaders@ is a type class for types containing HTTP headers, allowing +-- you to write overloaded header manipulation functions +-- for both 'Request' and 'Response' data types, for instance. +class HasHeaders x where + getHeaders :: x -> [Header] + setHeaders :: x -> [Header] -> x + +-- Header manipulation functions + +type HeaderSetter a = HeaderName -> String -> a -> a + +-- | @insertHeader hdr val x@ inserts a header with the given header name +-- and value. Does not check for existing headers with same name, allowing +-- duplicates to be introduce (use 'replaceHeader' if you want to avoid this.) +insertHeader :: HasHeaders a => HeaderSetter a +insertHeader name value x = setHeaders x newHeaders + where + newHeaders = (Header name value) : getHeaders x + +-- | @insertHeaderIfMissing hdr val x@ adds the new header only if no previous +-- header with name @hdr@ exists in @x@. +insertHeaderIfMissing :: HasHeaders a => HeaderSetter a +insertHeaderIfMissing name value x = setHeaders x (newHeaders $ getHeaders x) + where + newHeaders list@(h@(Header n _): rest) + | n == name = list + | otherwise = h : newHeaders rest + newHeaders [] = [Header name value] + +-- | @replaceHeader hdr val o@ replaces the header @hdr@ with the +-- 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 +insertHeaders hdrs x = setHeaders x (getHeaders x ++ hdrs) + +-- | @retrieveHeaders hdrNm x@ gets a list of headers with 'HeaderName' @hdrNm@. +retrieveHeaders :: HasHeaders a => HeaderName -> a -> [Header] +retrieveHeaders name x = filter matchname (getHeaders x) + where + matchname (Header n _) = n == name + +-- | @findHeader hdrNm x@ looks up @hdrNm@ in @x@, returning the first +-- header that matches, if any. +findHeader :: HasHeaders a => HeaderName -> a -> Maybe String +findHeader n x = lookupHeader n (getHeaders x) + +-- | @lookupHeader hdr hdrs@ locates the first header matching @hdr@ in the +-- list @hdrs@. +lookupHeader :: HeaderName -> [Header] -> Maybe String +lookupHeader _ [] = Nothing +lookupHeader v (Header n s:t) + | v == n = Just s + | otherwise = lookupHeader v t + +-- | @parseHeader headerNameAndValueString@ tries to unscramble a +-- @header: value@ pairing and returning it as a 'Header'. +parseHeader :: String -> Result Header +parseHeader str = + case split ':' str of + Nothing -> failParse ("Unable to parse header: " ++ str) + Just (k,v) -> return $ Header (fn k) (trim $ drop 1 v) + where + fn k = case map snd $ filter (match k . fst) headerMap of + [] -> (HdrCustom k) + (h:_) -> h + + 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) . + joinExtended "" + where + -- Joins consecutive lines where the second line + -- begins with ' ' or '\t'. + joinExtended old [] = [old] + joinExtended old (h : t) + | isLineExtension h = joinExtended (old ++ ' ' : tail h) t + | otherwise = old : joinExtended h t + + isLineExtension (x:_) = x == ' ' || x == '\t' + isLineExtension _ = False + + clean [] = [] + clean (h:t) | h `elem` "\t\r\n" = ' ' : clean t + | otherwise = h : clean t + + -- tolerant of errors? should parse + -- errors here be reported or ignored? + -- currently ignored. + catRslts :: [a] -> [Result a] -> Result [a] + catRslts list (h:t) = + case h of + Left _ -> catRslts list t + Right v -> catRslts (v:list) t + catRslts list [] = Right $ reverse list diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/MD5Aux.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/MD5Aux.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/MD5Aux.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/MD5Aux.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,343 @@ +module Network.HTTP.MD5Aux + (md5, md5s, md5i, + MD5(..), ABCD(..), + Zord64, Str(..), BoolList(..), WordList(..)) where + +import Data.Char (ord, chr) +import Data.Bits (rotateL, shiftL, shiftR, (.&.), (.|.), xor, complement) +import Data.Word (Word32, Word64) + +rotL :: Word32 -> Int -> Word32 +rotL x = rotateL x + +type Zord64 = Word64 + +-- ===================== TYPES AND CLASS DEFINTIONS ======================== + + +type XYZ = (Word32, Word32, Word32) +type Rotation = Int +newtype ABCD = ABCD (Word32, Word32, Word32, Word32) deriving (Eq, Show) +newtype Str = Str String +newtype BoolList = BoolList [Bool] +newtype WordList = WordList ([Word32], Word64) + +-- Anything we want to work out the MD5 of must be an instance of class MD5 + +class MD5 a where + get_next :: a -> ([Word32], Int, a) -- get the next blocks worth + -- \ \ \------ the rest of the input + -- \ \--------- the number of bits returned + -- \--------------- the bits returned in 32bit words + len_pad :: Word64 -> a -> a -- append the padding and length + finished :: a -> Bool -- Have we run out of input yet? + + +-- Mainly exists because it's fairly easy to do MD5s on input where the +-- length is not a multiple of 8 + +instance MD5 BoolList where + get_next (BoolList s) = (bools_to_word32s ys, length ys, BoolList zs) + where (ys, zs) = splitAt 512 s + len_pad l (BoolList bs) + = BoolList (bs ++ [True] + ++ replicate (fromIntegral $ (447 - l) .&. 511) False + ++ [l .&. (shiftL 1 x) > 0 | x <- (mangle [0..63])] + ) + where mangle [] = [] + mangle xs = reverse ys ++ mangle zs + where (ys, zs) = splitAt 8 xs + finished (BoolList s) = s == [] + + +-- The string instance is fairly straightforward + +instance MD5 Str where + get_next (Str s) = (string_to_word32s ys, 8 * length ys, Str zs) + where (ys, zs) = splitAt 64 s + len_pad c64 (Str s) = Str (s ++ padding ++ l) + where padding = '\128':replicate (fromIntegral zeros) '\000' + zeros = shiftR ((440 - c64) .&. 511) 3 + l = length_to_chars 8 c64 + finished (Str s) = s == "" + + +-- YA instance that is believed will be useful + +instance MD5 WordList where + get_next (WordList (ws, l)) = (xs, fromIntegral taken, WordList (ys, l - taken)) + where (xs, ys) = splitAt 16 ws + taken = if l > 511 then 512 else l .&. 511 + len_pad c64 (WordList (ws, l)) = WordList (beginning ++ nextish ++ blanks ++ size, newlen) + where beginning = if length ws > 0 then start ++ lastone' else [] + start = init ws + lastone = last ws + offset = c64 .&. 31 + lastone' = [if offset > 0 then lastone + theone else lastone] + theone = shiftL (shiftR 128 (fromIntegral $ offset .&. 7)) + (fromIntegral $ offset .&. (31 - 7)) + nextish = if offset == 0 then [128] else [] + c64' = c64 + (32 - offset) + num_blanks = (fromIntegral $ shiftR ((448 - c64') .&. 511) 5) + blanks = replicate num_blanks 0 + lowsize = fromIntegral $ c64 .&. (shiftL 1 32 - 1) + topsize = fromIntegral $ shiftR c64 32 + size = [lowsize, topsize] + newlen = l .&. (complement 511) + + if c64 .&. 511 >= 448 then 1024 else 512 + finished (WordList (_, z)) = z == 0 + + +instance Num ABCD where + ABCD (a1, b1, c1, d1) + ABCD (a2, b2, c2, d2) = ABCD (a1 + a2, b1 + b2, c1 + c2, d1 + d2) + + (-) = error "(-){ABCD}: no instance method defined" + (*) = error "(*){ABCD}: no instance method defined" + signum = error "signum{ABCD}: no instance method defined" + fromInteger = error "fromInteger{ABCD}: no instance method defined" + abs = error "abs{ABCD}: no instance method defined" +-- ===================== EXPORTED FUNCTIONS ======================== + + +-- The simplest function, gives you the MD5 of a string as 4-tuple of +-- 32bit words. + +md5 :: (MD5 a) => a -> ABCD +md5 m = md5_main False 0 magic_numbers m + + +-- Returns a hex number ala the md5sum program + +md5s :: (MD5 a) => a -> String +md5s = abcd_to_string . md5 + + +-- Returns an integer equivalent to the above hex number + +md5i :: (MD5 a) => a -> Integer +md5i = abcd_to_integer . md5 + + +-- ===================== THE CORE ALGORITHM ======================== + + +-- Decides what to do. The first argument indicates if padding has been +-- added. The second is the length mod 2^64 so far. Then we have the +-- starting state, the rest of the string and the final state. + +md5_main :: (MD5 a) => + Bool -- Have we added padding yet? + -> Word64 -- The length so far mod 2^64 + -> ABCD -- The initial state + -> a -- The non-processed portion of the message + -> ABCD -- The resulting state +md5_main padded ilen abcd m + = if finished m && padded + then abcd + else md5_main padded' (ilen + 512) (abcd + abcd') m'' + where (m16, l, m') = get_next m + len' = ilen + fromIntegral l + ((m16', _, m''), padded') = if not padded && l < 512 + then (get_next $ len_pad len' m, True) + else ((m16, l, m'), padded) + abcd' = md5_do_block abcd m16' + + +-- md5_do_block processes a 512 bit block by calling md5_round 4 times to +-- apply each round with the correct constants and permutations of the +-- block + +md5_do_block :: ABCD -- Initial state + -> [Word32] -- The block to be processed - 16 32bit words + -> ABCD -- Resulting state +md5_do_block abcd0 w = abcd4 + where (r1, r2, r3, r4) = rounds + {- + map (\x -> w !! x) [1,6,11,0,5,10,15,4,9,14,3,8,13,2,7,12] + -- [(5 * x + 1) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [5,8,11,14,1,4,7,10,13,0,3,6,9,12,15,2] + -- [(3 * x + 5) `mod` 16 | x <- [0..15]] + map (\x -> w !! x) [0,7,14,5,12,3,10,1,8,15,6,13,4,11,2,9] + -- [(7 * x) `mod` 16 | x <- [0..15]] + -} + perm5 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c1,c6,c11,c0,c5,c10,c15,c4,c9,c14,c3,c8,c13,c2,c7,c12] + perm5 _ = error "broke at perm5" + perm3 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c5,c8,c11,c14,c1,c4,c7,c10,c13,c0,c3,c6,c9,c12,c15,c2] + perm3 _ = error "broke at perm3" + perm7 [c0,c1,c2,c3,c4,c5,c6,c7,c8,c9,c10,c11,c12,c13,c14,c15] + = [c0,c7,c14,c5,c12,c3,c10,c1,c8,c15,c6,c13,c4,c11,c2,c9] + perm7 _ = error "broke at perm7" + abcd1 = md5_round md5_f abcd0 w r1 + abcd2 = md5_round md5_g abcd1 (perm5 w) r2 + abcd3 = md5_round md5_h abcd2 (perm3 w) r3 + abcd4 = md5_round md5_i abcd3 (perm7 w) r4 + + +-- md5_round does one of the rounds. It takes an auxiliary function and foldls +-- (md5_inner_function f) to repeatedly apply it to the initial state with the +-- correct constants + +md5_round :: (XYZ -> Word32) -- Auxiliary function (F, G, H or I + -- for those of you with a copy of + -- the prayer book^W^WRFC) + -> ABCD -- Initial state + -> [Word32] -- The 16 32bit words of input + -> [(Rotation, Word32)] -- The list of 16 rotations and + -- additive constants + -> ABCD -- Resulting state +md5_round f abcd s ns = foldl (md5_inner_function f) abcd ns' + where ns' = zipWith (\x (y, z) -> (y, x + z)) s ns + + +-- Apply one of the functions md5_[fghi] and put the new ABCD together + +md5_inner_function :: (XYZ -> Word32) -- Auxiliary function + -> ABCD -- Initial state + -> (Rotation, Word32) -- The rotation and additive + -- constant (X[i] + T[j]) + -> ABCD -- Resulting state +md5_inner_function f (ABCD (a, b, c, d)) (s, ki) = ABCD (d, a', b, c) + where mid_a = a + f(b,c,d) + ki + rot_a = rotL mid_a s + a' = b + rot_a + + +-- The 4 auxiliary functions + +md5_f :: XYZ -> Word32 +md5_f (x, y, z) = z `xor` (x .&. (y `xor` z)) +{- optimised version of: (x .&. y) .|. ((complement x) .&. z) -} + +md5_g :: XYZ -> Word32 +md5_g (x, y, z) = md5_f (z, x, y) +{- was: (x .&. z) .|. (y .&. (complement z)) -} + +md5_h :: XYZ -> Word32 +md5_h (x, y, z) = x `xor` y `xor` z + +md5_i :: XYZ -> Word32 +md5_i (x, y, z) = y `xor` (x .|. (complement z)) + + +-- The magic numbers from the RFC. + +magic_numbers :: ABCD +magic_numbers = ABCD (0x67452301, 0xefcdab89, 0x98badcfe, 0x10325476) + + +-- The 4 lists of (rotation, additive constant) tuples, one for each round + +rounds :: ([(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)], + [(Rotation, Word32)]) +rounds = (r1, r2, r3, r4) + where r1 = [(s11, 0xd76aa478), (s12, 0xe8c7b756), (s13, 0x242070db), + (s14, 0xc1bdceee), (s11, 0xf57c0faf), (s12, 0x4787c62a), + (s13, 0xa8304613), (s14, 0xfd469501), (s11, 0x698098d8), + (s12, 0x8b44f7af), (s13, 0xffff5bb1), (s14, 0x895cd7be), + (s11, 0x6b901122), (s12, 0xfd987193), (s13, 0xa679438e), + (s14, 0x49b40821)] + r2 = [(s21, 0xf61e2562), (s22, 0xc040b340), (s23, 0x265e5a51), + (s24, 0xe9b6c7aa), (s21, 0xd62f105d), (s22, 0x2441453), + (s23, 0xd8a1e681), (s24, 0xe7d3fbc8), (s21, 0x21e1cde6), + (s22, 0xc33707d6), (s23, 0xf4d50d87), (s24, 0x455a14ed), + (s21, 0xa9e3e905), (s22, 0xfcefa3f8), (s23, 0x676f02d9), + (s24, 0x8d2a4c8a)] + r3 = [(s31, 0xfffa3942), (s32, 0x8771f681), (s33, 0x6d9d6122), + (s34, 0xfde5380c), (s31, 0xa4beea44), (s32, 0x4bdecfa9), + (s33, 0xf6bb4b60), (s34, 0xbebfbc70), (s31, 0x289b7ec6), + (s32, 0xeaa127fa), (s33, 0xd4ef3085), (s34, 0x4881d05), + (s31, 0xd9d4d039), (s32, 0xe6db99e5), (s33, 0x1fa27cf8), + (s34, 0xc4ac5665)] + r4 = [(s41, 0xf4292244), (s42, 0x432aff97), (s43, 0xab9423a7), + (s44, 0xfc93a039), (s41, 0x655b59c3), (s42, 0x8f0ccc92), + (s43, 0xffeff47d), (s44, 0x85845dd1), (s41, 0x6fa87e4f), + (s42, 0xfe2ce6e0), (s43, 0xa3014314), (s44, 0x4e0811a1), + (s41, 0xf7537e82), (s42, 0xbd3af235), (s43, 0x2ad7d2bb), + (s44, 0xeb86d391)] + s11 = 7 + s12 = 12 + s13 = 17 + s14 = 22 + s21 = 5 + s22 = 9 + s23 = 14 + s24 = 20 + s31 = 4 + s32 = 11 + s33 = 16 + s34 = 23 + s41 = 6 + s42 = 10 + s43 = 15 + s44 = 21 + + +-- ===================== CONVERSION FUNCTIONS ======================== + + +-- Turn the 4 32 bit words into a string representing the hex number they +-- represent. + +abcd_to_string :: ABCD -> String +abcd_to_string (ABCD (a,b,c,d)) = concat $ map display_32bits_as_hex [a,b,c,d] + + +-- Split the 32 bit word up, swap the chunks over and convert the numbers +-- to their hex equivalents. + +display_32bits_as_hex :: Word32 -> String +display_32bits_as_hex w = swap_pairs cs + where cs = map (\x -> getc $ (shiftR w (4*x)) .&. 15) [0..7] + getc n = (['0'..'9'] ++ ['a'..'f']) !! (fromIntegral n) + swap_pairs (x1:x2:xs) = x2:x1:swap_pairs xs + swap_pairs _ = [] + +-- Convert to an integer, performing endianness magic as we go + +abcd_to_integer :: ABCD -> Integer +abcd_to_integer (ABCD (a,b,c,d)) = rev_num a * 2^(96 :: Int) + + rev_num b * 2^(64 :: Int) + + rev_num c * 2^(32 :: Int) + + rev_num d + +rev_num :: Word32 -> Integer +rev_num i = toInteger j `mod` (2^(32 :: Int)) + -- NHC's fault ~~~~~~~~~~~~~~~~~~~~~ + where j = foldl (\so_far next -> shiftL so_far 8 + (shiftR i next .&. 255)) + 0 [0,8,16,24] + +-- Used to convert a 64 byte string to 16 32bit words + +string_to_word32s :: String -> [Word32] +string_to_word32s "" = [] +string_to_word32s ss = this:string_to_word32s ss' + where (s, ss') = splitAt 4 ss + this = foldr (\c w -> shiftL w 8 + (fromIntegral.ord) c) 0 s + + +-- Used to convert a list of 512 bools to 16 32bit words + +bools_to_word32s :: [Bool] -> [Word32] +bools_to_word32s [] = [] +bools_to_word32s bs = this:bools_to_word32s rest + where (bs1, bs1') = splitAt 8 bs + (bs2, bs2') = splitAt 8 bs1' + (bs3, bs3') = splitAt 8 bs2' + (bs4, rest) = splitAt 8 bs3' + this = boolss_to_word32 [bs1, bs2, bs3, bs4] + bools_to_word8 = foldl (\w b -> shiftL w 1 + if b then 1 else 0) 0 + boolss_to_word32 = foldr (\w8 w -> shiftL w 8 + bools_to_word8 w8) 0 + + +-- Convert the size into a list of characters used by the len_pad function +-- for strings + +length_to_chars :: Int -> Word64 -> String +length_to_chars 0 _ = [] +length_to_chars p n = this:length_to_chars (p-1) (shiftR n 8) + where this = chr $ fromIntegral $ n .&. 255 + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Proxy.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Proxy.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Proxy.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Proxy.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,214 @@ +{-# LANGUAGE CPP #-} +----------------------------------------------------------------------------- +-- | +-- 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(..) + , noProxy -- :: Proxy + , fetchProxy -- :: Bool -> IO Proxy + , parseProxy -- :: String -> Maybe Proxy + ) where + +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + +import Control.Monad ( when, mplus, join, liftM2 ) + +#if defined(WIN32) +import Network.HTTP.Base ( catchIO ) +import Control.Monad ( liftM ) +import Data.List ( isPrefixOf ) +#endif +import Network.HTTP.Utils ( dropWhileTail, chopAtDelim ) +import Network.HTTP.Auth +import Network.URI + ( URI(..), URIAuth(..), parseAbsoluteURI, unEscapeString ) +import System.IO ( hPutStrLn, stderr ) +import System.Environment + +{- +#if !defined(WIN32) && defined(mingw32_HOST_OS) +#define WIN32 1 +#endif +-} + +#if defined(WIN32) +import System.Win32.Types ( DWORD, HKEY ) +import System.Win32.Registry( hKEY_CURRENT_USER, regOpenKey, regCloseKey, regQueryValue, regQueryValueEx ) +import Control.Exception ( bracket ) +import Foreign ( toBool, Storable(peek, sizeOf), castPtr, alloca ) +#endif + +-- | HTTP proxies (or not) are represented via 'Proxy', specifying if a +-- proxy should be used for the request (see 'Network.Browser.setProxy') +data Proxy + = NoProxy -- ^ Don't use a proxy. + | Proxy String + (Maybe Authority) -- ^ Use the proxy given. Should be of the + -- form "http:\/\/host:port", "host", "host:port", or "http:\/\/host". + -- Additionally, an optional 'Authority' for authentication with the proxy. + + +noProxy :: Proxy +noProxy = NoProxy + +-- | @envProxyString@ locates proxy server settings by looking +-- up env variable @HTTP_PROXY@ (or its lower-case equivalent.) +-- If no mapping found, returns @Nothing@. +envProxyString :: IO (Maybe String) +envProxyString = do + env <- getEnvironment + return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env) + +-- | @proxyString@ tries to locate the user's proxy server setting. +-- Consults environment variable, and in case of Windows, by querying +-- the Registry (cf. @registryProxyString@.) +proxyString :: IO (Maybe String) +proxyString = liftM2 mplus envProxyString windowsProxyString + +windowsProxyString :: IO (Maybe String) +#if !defined(WIN32) +windowsProxyString = return Nothing +#else +windowsProxyString = liftM (>>= parseWindowsProxy) registryProxyString + +registryProxyLoc :: (HKEY,String) +registryProxyLoc = (hive, path) + where + -- 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 + -- end up in the following place: + hive = hKEY_CURRENT_USER + 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. +registryProxyString :: IO (Maybe String) +registryProxyString = catchIO + (bracket (uncurry regOpenKey registryProxyLoc) regCloseKey $ \hkey -> do + enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable" + if enable + then fmap Just $ regQueryValue hkey (Just "ProxyServer") + else return Nothing) + (\_ -> return Nothing) + +-- the proxy string is in the format "http=x.x.x.x:yyyy;https=...;ftp=...;socks=..." +-- even though the following article indicates otherwise +-- https://support.microsoft.com/en-us/kb/819961 +-- +-- to be sure, parse strings where each entry in the ';'-separated list above is +-- either in the format "protocol=..." or "protocol://..." +-- +-- only return the first "http" of them, if it exists +parseWindowsProxy :: String -> Maybe String +parseWindowsProxy s = + case proxies of + x:_ -> Just x + _ -> Nothing + where + parts = split ';' s + pr x = case break (== '=') x of + (p, []) -> p -- might be in format http:// + (p, u) -> p ++ "://" ++ drop 1 u + + proxies = filter (isPrefixOf "http://") . map pr $ parts + + split :: Eq a => a -> [a] -> [[a]] + split _ [] = [] + split a xs = case break (a ==) xs of + (ys, []) -> [ys] + (ys, _:zs) -> ys:split a zs + +#endif + +-- | @fetchProxy flg@ gets the local proxy settings and parse the string +-- into a @Proxy@ value. If you want to be informed of ill-formed proxy +-- configuration strings, supply @True@ for @flg@. +-- Proxy settings are sourced from the @HTTP_PROXY@ environment variable, +-- and in the case of Windows platforms, by consulting IE/WinInet's proxy +-- setting in the Registry. +fetchProxy :: Bool -> IO Proxy +fetchProxy warnIfIllformed = do + mstr <- proxyString + case mstr of + Nothing -> return NoProxy + Just str -> case parseProxy str of + Just p -> return p + Nothing -> do + when warnIfIllformed $ System.IO.hPutStrLn System.IO.stderr $ unlines + [ "invalid http proxy uri: " ++ show str + , "proxy uri must be http with a hostname" + , "ignoring http proxy, trying a direct connection" + ] + return NoProxy + +-- | @parseProxy str@ translates a proxy server string into a @Proxy@ value; +-- returns @Nothing@ if not well-formed. +parseProxy :: String -> Maybe Proxy +parseProxy "" = Nothing +parseProxy str = join + . fmap uri2proxy + $ parseHttpURI str + `mplus` parseHttpURI ("http://" ++ str) + where + parseHttpURI str' = + case parseAbsoluteURI str' of + Just uri@URI{uriAuthority = Just{}} -> Just (fixUserInfo uri) + _ -> Nothing + + -- Note: we need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@ + -- which lack the @\"http://\"@ URI scheme. The problem is that + -- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme + -- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@. + -- + -- So our strategy is to try parsing as normal uri first and if it lacks the + -- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix. + -- + +-- | tidy up user portion, don't want the trailing "\@". +fixUserInfo :: URI -> URI +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) + } = + Just (Proxy (hst ++ prt) auth) + where + auth = + case auth' of + [] -> Nothing + as -> Just (AuthBasic "" (unEscapeString usr) (unEscapeString pwd) uri) + where + (usr,pwd) = chopAtDelim ':' as + +uri2proxy _ = Nothing + +-- utilities +#if defined(WIN32) +regQueryValueDWORD :: HKEY -> String -> IO DWORD +regQueryValueDWORD hkey name = alloca $ \ptr -> do + -- TODO: this throws away the key type returned by regQueryValueEx + -- we should check it's what we expect instead + _ <- regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD)) + peek ptr + +#endif diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Stream.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Stream.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Stream.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Stream.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,236 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Stream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Transmitting HTTP requests and responses holding @String@ in their payload bodies. +-- This is one of the implementation modules for the "Network.HTTP" interface, representing +-- request and response content as @String@s and transmitting them in non-packed form +-- (cf. "Network.HTTP.HandleStream" and its use of @ByteString@s.) over 'Stream' handles. +-- It is mostly here for backwards compatibility, representing how requests and responses +-- were transmitted up until the 4.x releases of the HTTP package. +-- +-- For more detailed information about what the individual exports do, please consult +-- the documentation for "Network.HTTP". /Notice/ however that the functions here do +-- 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.Stream + + , simpleHTTP -- :: Request_String -> IO (Result Response_String) + , simpleHTTP_ -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , sendHTTP -- :: Stream s => s -> Request_String -> IO (Result Response_String) + , 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 + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.Stream +import Network.StreamDebugger (debugStream) +import Network.TCP (openTCPPort) +import Network.BufferType ( stringBufferOp ) + +import Network.HTTP.Base +import Network.HTTP.Headers +import Network.HTTP.Utils ( trim ) + +import Data.Char (toLower) +import Data.Maybe (fromMaybe) +import Control.Exception (onException) +import Control.Monad (when) + + +-- Turn on to enable HTTP traffic logging +debug :: Bool +debug = False + +-- File that HTTP traffic logs go to +httpLogFile :: String +httpLogFile = "http-debug.log" + +----------------------------------------------------------------- +------------------ Misc ----------------------------------------- +----------------------------------------------------------------- + + +-- | Simple way to transmit a resource across a non-persistent connection. +simpleHTTP :: Request_String -> IO (Result Response_String) +simpleHTTP r = do + auth <- getAuth r + c <- openTCPPort (host auth) (fromMaybe 80 (port auth)) + simpleHTTP_ c r + +-- | Like 'simpleHTTP', but acting on an already opened stream. +simpleHTTP_ :: Stream s => s -> Request_String -> IO (Result Response_String) +simpleHTTP_ s r + | not debug = sendHTTP s r + | otherwise = do + s' <- debugStream httpLogFile s + sendHTTP s' r + +sendHTTP :: Stream s => s -> Request_String -> IO (Result Response_String) +sendHTTP conn rq = sendHTTP_notify conn rq (return ()) + +sendHTTP_notify :: Stream s => s -> Request_String -> IO () -> IO (Result Response_String) +sendHTTP_notify conn rq onSendComplete = do + when providedClose $ (closeOnEnd conn True) + onException (sendMain conn rq onSendComplete) + (close conn) + where + providedClose = findConnClose (rqHeaders rq) + +-- From RFC 2616, section 8.2.3: +-- 'Because of the presence of older implementations, the protocol allows +-- ambiguous situations in which a client may send "Expect: 100- +-- continue" without receiving either a 417 (Expectation Failed) status +-- or a 100 (Continue) status. Therefore, when a client sends this +-- header field to an origin server (possibly via a proxy) from which it +-- has never seen a 100 (Continue) status, the client SHOULD NOT wait +-- for an indefinite period before sending the request body.' +-- +-- 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 + --let str = if null (rqBody rqst) + -- then show rqst + -- else show (insertHeader HdrExpect "100-continue" rqst) + -- TODO review throwing away of result + _ <- writeBlock conn (show rqst) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rqBody rqst) + onSendComplete + rsp <- getResponseHead conn + switchResponse conn True False rsp rqst + +-- reads and parses headers +getResponseHead :: Stream s => s -> IO (Result ResponseData) +getResponseHead conn = do + lor <- readTillEmpty1 stringBufferOp (readLine conn) + return $ lor >>= parseResponseHead + +-- Hmmm, this could go bad if we keep getting "100 Continue" +-- responses... Except this should never happen according +-- to the RFC. +switchResponse :: Stream s + => s + -> Bool {- allow retry? -} + -> Bool {- is body sent? -} + -> Result ResponseData + -> Request_String + -> IO (Result Response_String) +switchResponse _ _ _ (Left e) _ = return (Left e) + -- retry on connreset? + -- 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 = + case matchResponse (rqMethod rqst) cd of + Continue + | not bdy_sent -> {- Time to send the body -} + do { val <- writeBlock conn (rqBody rqst) + ; case val of + Left e -> return (Left e) + Right _ -> + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry True rsp rqst + } + } + | otherwise -> {- keep waiting -} + do { rsp <- getResponseHead conn + ; switchResponse conn allow_retry bdy_sent rsp rqst + } + + Retry -> {- Request with "Expect" header failed. + Trouble is the request contains Expects + other than "100-Continue" -} + do { -- TODO review throwing away of result + _ <- writeBlock conn (show rqst ++ rqBody rqst) + ; rsp <- getResponseHead conn + ; switchResponse conn False bdy_sent rsp rqst + } + + Done -> do + when (findConnClose hdrs) + (closeOnEnd conn True) + return (Right $ Response cd rn hdrs "") + + DieHorribly str -> do + close conn + return $ responseParseError "sendHTTP" ("Invalid response: " ++ str) + + ExpectEntity -> + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + in + do { rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> hopefulTransfer stringBufferOp {-null (++) []-} (readLine conn) [] + Just x -> + case map toLower (trim x) of + "chunked" -> chunkedTransfer stringBufferOp + (readLine conn) (readBlock conn) + _ -> uglyDeathTransfer "sendHTTP" + ; case rslt of + Left e -> close conn >> return (Left e) + Right (ftrs,bdy) -> do + when (findConnClose (hdrs++ftrs)) + (closeOnEnd conn True) + return (Right (Response cd rn (hdrs++ftrs) bdy)) + } + +-- | 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 + where + -- reads and parses headers + getRequestHead :: IO (Result RequestData) + getRequestHead = + do { lor <- readTillEmpty1 stringBufferOp (readLine conn) + ; return $ lor >>= parseRequestHead + } + + processRequest (Left e) = return $ Left e + processRequest (Right (rm,uri,hdrs)) = + do -- FIXME : Also handle 100-continue. + let tc = lookupHeader HdrTransferEncoding hdrs + cl = lookupHeader HdrContentLength hdrs + rslt <- case tc of + Nothing -> + case cl of + Just x -> linearTransfer (readBlock conn) (read x :: Int) + Nothing -> return (Right ([], "")) -- hopefulTransfer "" + Just x -> + case map toLower (trim x) of + "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 +-- 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 + _ <- writeBlock conn (show rsp) + -- write body immediately, don't wait for 100 CONTINUE + -- TODO review throwing away of result + _ <- writeBlock conn (rspBody rsp) + return () diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Utils.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Utils.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP/Utils.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP/Utils.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,111 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP.Utils +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Set of utility functions and definitions used by package modules. +-- +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]) + + ) where + +import Data.Char +import Data.List ( elemIndex ) +import Data.Maybe ( fromMaybe ) + +-- | @crlf@ is our beloved two-char line terminator. +crlf :: String +crlf = "\r\n" + +-- | @lf@ is a tolerated line terminator, per RFC 2616 section 19.3. +lf :: String +lf = "\n" + +-- | @sp@ lets you save typing one character. +sp :: String +sp = " " + +-- | @split delim ls@ splits a list into two parts, the @delim@ occurring +-- at the head of the second list. If @delim@ isn't in @ls@, @Nothing@ is +-- returned. +split :: Eq a => a -> [a] -> Maybe ([a],[a]) +split delim list = case delim `elemIndex` list of + Nothing -> Nothing + Just x -> Just $ splitAt x list + +-- | @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 +trimL xs = dropWhile isSpace xs + +-- | @trimL str@ removes trailing whitespace (as defined by 'Data.Char.isSpace') +-- from @str@. +trimR :: String -> String +trimR str = fromMaybe "" $ foldr trimIt Nothing str + where + trimIt x (Just xs) = Just (x:xs) + 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 = + case break (==c) xs of + (_,[]) -> [xs] + (as,_:bs) -> as : splitBy c bs + +-- | @readsOne f def str@ tries to 'read' @str@, taking +-- 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 = + case reads str of + ((v,_):_) -> f v + _ -> n + + +-- | @dropWhileTail p ls@ chops off trailing elements from @ls@ +-- until @p@ returns @False@. +dropWhileTail :: (a -> Bool) -> [a] -> [a] +dropWhileTail f ls = + case foldr chop Nothing ls of { Just xs -> xs; Nothing -> [] } + where + chop x (Just xs) = Just (x:xs) + chop x _ + | f x = Nothing + | otherwise = Just [x] + +-- | @chopAtDelim elt ls@ breaks up @ls@ into two at first occurrence +-- of @elt@; @elt@ is elided too. If @elt@ does not occur, the second +-- list is empty and the first is equal to @ls@. +chopAtDelim :: Eq a => a -> [a] -> ([a],[a]) +chopAtDelim elt xs = + case break (==elt) xs of + (_,[]) -> (xs,[]) + (as,_:bs) -> (as,bs) diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/HTTP.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/HTTP.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,265 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.HTTP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- The 'Network.HTTP' module provides a simple interface for sending and +-- receiving content over HTTP in Haskell. Here's how to fetch a document from +-- a URL and return it as a String: +-- +-- > +-- > simpleHTTP (getRequest "http://www.haskell.org/") >>= fmap (take 100) . getResponseBody +-- > -- fetch document and return it (as a 'String'.) +-- +-- Other functions let you control the submission and transfer of HTTP +-- 'Request's and 'Response's more carefully, letting you integrate the use +-- of 'Network.HTTP' functionality into your application. +-- +-- The module also exports the main types of the package, 'Request' and 'Response', +-- along with 'Header' and functions for working with these. +-- +-- The actual functionality is implemented by modules in the @Network.HTTP.*@ +-- 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 +-- 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 +-- 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 +-- @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.Base + , module Network.HTTP.Headers + + {- 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) + , sendHTTP_notify -- :: Stream s => s -> Request -> IO () -> IO (Result Response) + , receiveHTTP -- :: Stream s => s -> IO (Result Request) + , 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 + +----------------------------------------------------------------- +------------------ Imports -------------------------------------- +----------------------------------------------------------------- + +import Network.HTTP.Headers +import Network.HTTP.Base +import qualified Network.HTTP.HandleStream as S +-- old implementation: import Network.HTTP.Stream +import Network.TCP +import Network.Stream ( Result ) +import Network.URI ( parseURI ) + +import Data.Maybe ( fromMaybe ) + +{- + Note: if you switch over/back to using Network.HTTP.Stream here, you'll + have to wrap the results from 'openStream' as Connections via 'hstreamToConnection' + prior to delegating to the Network.HTTP.Stream functions. +-} + +-- | @simpleHTTP req@ transmits the 'Request' @req@ by opening a /direct/, non-persistent +-- connection to the HTTP server that @req@ is destined for, followed by transmitting +-- it and gathering up the response as a 'Result'. Prior to sending the request, +-- it is normalized (via 'normalizeRequest'). If you have to mediate the request +-- via an HTTP proxy, you will have to normalize the request yourself. Or switch to +-- using 'Network.Browser' instead. +-- +-- Examples: +-- +-- > simpleHTTP (getRequest "http://hackage.haskell.org/") +-- > simpleHTTP (getRequest "http://hackage.haskell.org:8012/") + +simpleHTTP :: (HStream ty) => Request ty -> IO (Result (Response ty)) +simpleHTTP r = do + auth <- getAuth r + failHTTPS (rqURI r) + 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 + let norm_r = normalizeRequest defaultNormalizeRequestOptions{normDoClose=True} r + S.sendHTTP s norm_r + +-- | @sendHTTP hStream httpRequest@ transmits @httpRequest@ (after normalization) over +-- @hStream@, but does not alter the status of the connection, nor request it to be +-- 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 + S.sendHTTP conn norm_r + +-- | @sendHTTP_notify hStream httpRequest action@ behaves like 'sendHTTP', but +-- lets you supply an IO @action@ to execute once the request has been successfully +-- transmitted over the connection. Useful when you want to set up tracing of +-- request transmission and its performance. +sendHTTP_notify :: HStream ty + => HandleStream ty + -> Request ty + -> IO () + -> IO (Result (Response ty)) +sendHTTP_notify conn rq onSendComplete = do + let norm_r = normalizeRequest defaultNormalizeRequestOptions rq + S.sendHTTP_notify conn norm_r onSendComplete + +-- | @receiveHTTP hStream@ reads a 'Request' from the 'HandleStream' @hStream@ +receiveHTTP :: HStream ty => HandleStream ty -> IO (Result (Request ty)) +receiveHTTP conn = S.receiveHTTP conn + +-- | @respondHTTP hStream httpResponse@ transmits an HTTP 'Response' over +-- 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 = S.respondHTTP conn rsp + + +-- | A convenience constructor for a GET 'Request'. +-- +-- If the URL isn\'t syntactically valid, the function raises an error. +getRequest + :: String -- ^URL to fetch + -> Request_String -- ^The constructed request +getRequest urlString = + case parseURI urlString of + Nothing -> error ("getRequest: Not a valid URL - " ++ urlString) + Just u -> mkRequest GET u + +-- | A convenience constructor for a HEAD 'Request'. +-- +-- If the URL isn\'t syntactically valid, the function raises an error. +headRequest + :: String -- ^URL to fetch + -> Request_String -- ^The constructed request +headRequest urlString = + case parseURI urlString of + Nothing -> error ("headRequest: Not a valid URL - " ++ urlString) + Just u -> mkRequest HEAD u + +-- | A convenience constructor for a POST 'Request'. +-- +-- If the URL isn\'t syntactically valid, the function raises an error. +postRequest + :: String -- ^URL to POST to + -> Request_String -- ^The constructed request +postRequest urlString = + case parseURI urlString of + Nothing -> error ("postRequest: Not a valid URL - " ++ urlString) + Just u -> mkRequest POST u + +-- | A convenience constructor for a POST 'Request'. +-- +-- It constructs a request and sets the body as well as +-- the Content-Type and Content-Length headers. The contents of the body +-- are forced to calculate the value for the Content-Length header. +-- +-- If the URL isn\'t syntactically valid, the function raises an error. +postRequestWithBody + :: String -- ^URL to POST to + -> String -- ^Content-Type of body + -> String -- ^The body of the request + -> Request_String -- ^The constructed request +postRequestWithBody urlString typ body = + case parseURI urlString of + Nothing -> error ("postRequestWithBody: Not a valid URL - " ++ urlString) + Just u -> setRequestBody (mkRequest POST u) (typ, body) + +-- | @getResponseBody response@ takes the response of a HTTP requesting action and +-- tries to extricate the body of the 'Response' @response@. If the request action +-- returned an error, an IO exception is raised. +getResponseBody :: Result (Response ty) -> IO ty +getResponseBody (Left err) = fail (show err) +getResponseBody (Right r) = return (rspBody r) + +-- | @getResponseBody response@ takes the response of a HTTP requesting action and +-- tries to extricate the status code of the 'Response' @response@. If the request action +-- returned an error, an IO exception is raised. +getResponseCode :: Result (Response ty) -> IO ResponseCode +getResponseCode (Left err) = fail (show err) +getResponseCode (Right r) = return (rspCode r) + + +-- +-- * TODO +-- - request pipelining +-- - https upgrade (includes full TLS, i.e. SSL, implementation) +-- - use of Stream classes will pay off +-- - consider C implementation of encryption\/decryption +-- - 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@] +-- If this header is present in any request or +-- response, and it's value is "close", then +-- 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 +-- header has the value \"100-continue\". After +-- 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 +-- or will generate an error response (probably 4xx). +-- +-- +-- * Response code notes +-- Some response codes induce special behaviour: +-- +-- [@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 +-- request attempt (without Expect header), unless no Expect header +-- had been added (in which case 417 response is returned). diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/StreamDebugger.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/StreamDebugger.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/StreamDebugger.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/StreamDebugger.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,103 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamDebugger +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Implements debugging of @Stream@s. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Created. Made minor formatting changes. +-- +----------------------------------------------------------------------------- +module Network.StreamDebugger + ( StreamDebugger + , debugStream + , debugByteStream + ) where + +import Network.Stream (Stream(..)) +import System.IO + ( Handle, hFlush, hPutStrLn, IOMode(AppendMode), hClose, openFile, + hSetBuffering, BufferMode(NoBuffering) + ) +import Network.TCP ( HandleStream, HStream, + StreamHooks(..), setStreamHooks, getStreamHooks ) + +-- | Allows stream logging. Refer to 'debugStream' below. +data StreamDebugger x + = Dbg Handle x + +instance (Stream x) => Stream (StreamDebugger x) where + readBlock (Dbg h x) n = + do val <- readBlock x n + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (show val) + return val + readLine (Dbg h x) = + do val <- readLine x + hPutStrLn h ("--readLine") + hPutStrLn h (show val) + return val + writeBlock (Dbg h x) str = + do val <- writeBlock x str + hPutStrLn h ("--writeBlock" ++ show str) + hPutStrLn h (show val) + return val + close (Dbg h x) = + do hPutStrLn h "--closing..." + hFlush h + close x + hPutStrLn h "--closed." + hClose h + closeOnEnd (Dbg h x) f = + do hPutStrLn h ("--close-on-end.." ++ show f) + 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 = + 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 + case sh of + Just h + | hook_name h == file -> return stream -- reuse the stream hooks. + _ -> do + h <- openFile file AppendMode + hSetBuffering h NoBuffering + hPutStrLn h ("File \"" ++ file ++ "\" opened for appending.") + setStreamHooks stream (debugStreamHooks h file) + return stream + +debugStreamHooks :: HStream ty => Handle -> String -> StreamHooks ty +debugStreamHooks h nm = + StreamHooks + { hook_readBlock = \ toStr n val -> do + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + hPutStrLn h ("--readBlock " ++ show n) + hPutStrLn h (either show show eval) + , hook_readLine = \ toStr val -> do + let eval = case val of { Left e -> Left e ; Right v -> Right $ toStr v} + hPutStrLn h ("--readLine") + hPutStrLn h (either show show eval) + , hook_writeBlock = \ toStr str val -> do + hPutStrLn h ("--writeBlock " ++ show val) + hPutStrLn h (toStr str) + , hook_close = do + hPutStrLn h "--closing..." + hFlush h + hClose h + , hook_name = nm + } diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/Stream.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/Stream.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/Stream.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/Stream.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,91 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Network.Stream +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- An library for creating abstract streams. Originally part of Gray's\/Bringert's +-- HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Removed unnecessary import statements. +-- - Moved Debug code to StreamDebugger.hs +-- - Moved Socket-related code to StreamSocket.hs. +-- +-- * Changes by Simon Foster: +-- - Split Network.HTTPmodule up into to separate +-- Network.[Stream,TCP,HTTP] modules +----------------------------------------------------------------------------- +module Network.Stream + ( Stream(..) + , ConnError(..) + , Result + , bindE + , fmapE + + , failParse -- :: String -> Result a + , failWith -- :: ConnError -> Result a + , failMisc -- :: String -> Result a + ) where + +import Control.Monad.Error + +data ConnError + = ErrorReset + | ErrorClosed + | ErrorParse String + | 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) + +failParse :: String -> Result a +failParse x = failWith (ErrorParse x) + +failWith :: ConnError -> Result a +failWith x = Left x + +bindE :: Result a -> (a -> Result b) -> Result b +bindE (Left e) _ = Left e +bindE (Right v) f = f v + +fmapE :: (a -> Result b) -> IO (Result a) -> IO (Result b) +fmapE f a = do + x <- a + case x of + Left e -> return (Left e) + Right r -> return (f r) + +-- | This is the type returned by many exported network functions. +type Result a = Either ConnError {- error -} + a {- result -} + +-- | Streams should make layering of TLS protocol easier in future, +-- they allow reading/writing to files etc for debugging, +-- they allow use of protocols other than TCP/IP +-- and they allow customisation. +-- +-- Instances of this class should not trim +-- 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 + readLine :: x -> IO (Result String) + readBlock :: x -> Int -> IO (Result String) + writeBlock :: x -> String -> IO (Result ()) + close :: x -> IO () + closeOnEnd :: x -> Bool -> IO () + -- ^ True => shutdown the connection when response has been read / end-of-stream + -- has been reached. diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/StreamSocket.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/StreamSocket.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/StreamSocket.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/StreamSocket.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,93 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.StreamSocket +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Socket Stream instance. Originally part of Gray's\/Bringert's HTTP module. +-- +-- * Changes by Robin Bate Boerop : +-- - Made dependencies explicit in import statements. +-- - Removed false dependencies in import statements. +-- - Created separate module for instance Stream Socket. +-- +-- * Changes by Simon Foster: +-- - Split module up into to sepearate Network.[Stream,TCP,HTTP] modules +-- +----------------------------------------------------------------------------- +module Network.StreamSocket + ( handleSocketError + , myrecv + ) where + +import Network.Stream + ( Stream(..), ConnError(ErrorReset, ErrorMisc), Result + ) +import Network.Socket + ( Socket, getSocketOption, shutdown, send, recv, sClose + , ShutdownCmd(ShutdownBoth), SocketOption(SoError) + ) + +import Network.HTTP.Base ( catchIO ) +import Control.Monad (liftM) +import Control.Exception as Exception (IOException) +import System.IO.Error (isEOFError) + +-- | Exception handler for socket operations. +handleSocketError :: Socket -> IOException -> IO (Result a) +handleSocketError sk e = + do se <- getSocketOption sk SoError + case se of + 0 -> ioError e + 10054 -> return $ Left ErrorReset -- reset + _ -> return $ Left $ ErrorMisc $ show se + +myrecv :: Socket -> Int -> IO String +myrecv sock len = + let handler e = if isEOFError e then return [] else ioError e + in catchIO (recv sock len) handler + +instance Stream Socket where + readBlock sk n = readBlockSocket sk n + readLine sk = readLineSocket sk + writeBlock sk str = writeBlockSocket sk str + close sk = do + -- This slams closed the connection (which is considered rude for TCP\/IP) + shutdown sk ShutdownBoth + sClose sk + closeOnEnd _sk _ = return () -- can't really deal with this, so do run the risk of leaking sockets here. + +readBlockSocket :: Socket -> Int -> IO (Result String) +readBlockSocket sk n = (liftM Right $ fn n) `catchIO` (handleSocketError sk) + where + fn x = do { str <- myrecv sk x + ; let len = length str + ; if len < x + then ( fn (x-len) >>= \more -> return (str++more) ) + else return str + } + +-- Use of the following function is discouraged. +-- 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) +readLineSocket sk = (liftM Right $ fn "") `catchIO` (handleSocketError sk) + where + fn str = do + c <- myrecv sk 1 -- like eating through a straw. + 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 + fn [] = return () + fn x = send sk x >>= \i -> fn (drop i x) + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/TCP.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/TCP.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Network/TCP.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Network/TCP.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,414 @@ +{-# LANGUAGE TypeSynonymInstances #-} +----------------------------------------------------------------------------- +-- | +-- Module : Network.TCP +-- Copyright : See LICENSE file +-- License : BSD +-- +-- Maintainer : Ganesh Sittampalam +-- Stability : experimental +-- Portability : non-portable (not tested) +-- +-- Some utility functions for working with the Haskell @network@ package. Mostly +-- for internal use by the @Network.HTTP@ code. +-- +----------------------------------------------------------------------------- +module Network.TCP + ( Connection + , EndPoint(..) + , openTCPPort + , isConnectedTo + + , openTCPConnection + , socketConnection + , isTCPConnectedTo + + , HandleStream + , HStream(..) + + , StreamHooks(..) + , nullHooks + , setStreamHooks + , getStreamHooks + , hstreamToConnection + + ) where + +import Network.Socket + ( Socket, SocketOption(KeepAlive) + , SocketType(Stream), connect + , shutdown, ShutdownCmd(..) + , sClose, setSocketOption, getPeerName + , socket, Family(AF_UNSPEC), defaultProtocol, getAddrInfo + , defaultHints, addrFamily, withSocketsDo + , addrSocketType, addrAddress + ) +import qualified Network.Stream as Stream + ( Stream(readBlock, readLine, writeBlock, close, closeOnEnd) ) +import Network.Stream + ( ConnError(..) + , Result + , failWith + , failMisc + ) +import Network.BufferType + +import Network.HTTP.Base ( catchIO ) +import Network.Socket ( socketToHandle ) + +import Data.Char ( toLower ) +import Data.Word ( Word8 ) +import Control.Concurrent +import Control.Exception ( onException ) +import Control.Monad ( liftM, when ) +import System.IO ( Handle, hFlush, IOMode(..), hClose ) +import System.IO.Error ( isEOFError ) + +import qualified Data.ByteString as Strict +import qualified Data.ByteString.Lazy as Lazy + +----------------------------------------------------------------- +------------------ TCP Connections ------------------------------ +----------------------------------------------------------------- + +-- | The 'Connection' newtype is a wrapper that allows us to make +-- connections an instance of the Stream class, without GHC extensions. +-- While this looks sort of like a generic reference to the transport +-- layer it is actually TCP specific, which can be seen in the +-- implementation of the 'Stream Connection' instance. +newtype Connection = Connection (HandleStream String) + +newtype HandleStream a = HandleStream {getRef :: MVar (Conn a)} + +data EndPoint = EndPoint { epHost :: String, epPort :: Int } + +instance Eq EndPoint where + EndPoint host1 port1 == EndPoint host2 port2 = + map toLower host1 == map toLower host2 && port1 == port2 + +data Conn a + = MkConn { connSock :: ! Socket + , connHandle :: Handle + , connBuffer :: BufferOp a + , connInput :: Maybe a + , connEndPoint :: EndPoint + , connHooks :: Maybe (StreamHooks a) + , connCloseEOF :: Bool -- True => close socket upon reaching end-of-stream. + } + | ConnClosed + deriving(Eq) + +hstreamToConnection :: HandleStream String -> Connection +hstreamToConnection h = Connection h + +connHooks' :: Conn a -> Maybe (StreamHooks a) +connHooks' ConnClosed{} = Nothing +connHooks' x = connHooks x + +-- all of these are post-op hooks +data StreamHooks ty + = StreamHooks + { hook_readLine :: (ty -> String) -> Result ty -> IO () + , hook_readBlock :: (ty -> String) -> Int -> Result ty -> IO () + , hook_writeBlock :: (ty -> String) -> ty -> Result () -> IO () + , hook_close :: IO () + , hook_name :: String -- hack alert: name of the hook itself. + } + +instance Eq ty => Eq (StreamHooks ty) where + (==) _ _ = True + +nullHooks :: StreamHooks ty +nullHooks = StreamHooks + { hook_readLine = \ _ _ -> return () + , hook_readBlock = \ _ _ _ -> return () + , hook_writeBlock = \ _ _ _ -> return () + , hook_close = return () + , hook_name = "" + } + +setStreamHooks :: HandleStream ty -> StreamHooks ty -> IO () +setStreamHooks h sh = modifyMVar_ (getRef h) (\ c -> return c{connHooks=Just sh}) + +getStreamHooks :: HandleStream ty -> IO (Maybe (StreamHooks ty)) +getStreamHooks h = readMVar (getRef h) >>= return.connHooks + +-- | @HStream@ overloads the use of 'HandleStream's, letting you +-- overload the handle operations over the type that is communicated +-- across the handle. It comes in handy for @Network.HTTP@ 'Request' +-- and 'Response's as the payload representation isn't fixed, but overloaded. +-- +-- 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) + readLine :: HandleStream bufType -> IO (Result bufType) + readBlock :: HandleStream bufType -> Int -> IO (Result bufType) + writeBlock :: HandleStream bufType -> bufType -> IO (Result ()) + close :: HandleStream bufType -> IO () + closeQuick :: HandleStream bufType -> IO () + closeOnEnd :: HandleStream bufType -> Bool -> IO () + +instance HStream Strict.ByteString where + openStream = openTCPConnection + openSocketStream = socketConnection + readBlock c n = readBlockBS c n + readLine c = readLineBS c + writeBlock c str = writeBlockBS c str + close c = closeIt c Strict.null True + closeQuick c = closeIt c Strict.null False + closeOnEnd c f = closeEOF c f + +instance HStream Lazy.ByteString where + openStream = \ a b -> openTCPConnection_ a b True + openSocketStream = \ a b c -> socketConnection_ a b c True + readBlock c n = readBlockBS c n + readLine c = readLineBS c + writeBlock c str = writeBlockBS c str + close c = closeIt c Lazy.null True + closeQuick c = closeIt c Lazy.null False + closeOnEnd c f = closeEOF c f + +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 + close (Connection c) = Network.TCP.close c + closeOnEnd (Connection c) f = Network.TCP.closeEOF c f + +instance HStream String where + openStream = openTCPConnection + openSocketStream = socketConnection + readBlock ref n = readBlockBS ref n + + -- 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, + -- since in general messages are serialised in their entirety. + writeBlock ref str = writeBlockBS ref str -- (stringToBuf str) + + -- Closes a Connection. Connection will no longer + -- allow any of the other Stream functions. Notice that a Connection may close + -- 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 +-- may trigger a network connection. +openTCPPort :: String -> Int -> IO Connection +openTCPPort uri port = openTCPConnection uri port >>= return.Connection + +-- Add a "persistent" option? Current persistent is default. +-- Use "Result" type for synchronous exception reporting? +openTCPConnection :: BufferType ty => String -> Int -> IO (HandleStream ty) +openTCPConnection uri port = openTCPConnection_ uri port False + +openTCPConnection_ :: BufferType ty => String -> Int -> Bool -> IO (HandleStream ty) +openTCPConnection_ uri port stashInput = do + -- HACK: uri is sometimes obtained by calling Network.URI.uriRegName, and this includes + -- the surrounding square brackets for an RFC 2732 host like [::1]. It's not clear whether + -- it should, or whether all call sites should be using something different instead, but + -- the simplest short-term fix is to strip any surrounding square brackets here. + -- It shouldn't affect any as this is the only situation they can occur - see RFC 3986. + let fixedUri = + case uri of + '[':(rest@(c:_)) | last rest == ']' + -> if c == 'v' || c == 'V' + then error $ "Unsupported post-IPv6 address " ++ uri + else init rest + _ -> uri + + + -- use withSocketsDo here in case the caller hasn't used it, which would make getAddrInfo fail on Windows + -- although withSocketsDo is supposed to wrap the entire program, in practice it is safe to use it locally + -- like this as it just does a once-only installation of a shutdown handler to run at program exit, + -- rather than actually shutting down after the action + addrinfos <- withSocketsDo $ getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) (Just fixedUri) (Just . show $ port) + case addrinfos of + [] -> fail "openTCPConnection: getAddrInfo returned no address information" + (a:_) -> do + s <- socket (addrFamily a) Stream defaultProtocol + onException (do + setSocketOption s KeepAlive 1 + connect s (addrAddress a) + socketConnection_ fixedUri port s stashInput + ) (sClose s) + +-- | @socketConnection@, like @openConnection@ but using a pre-existing 'Socket'. +socketConnection :: BufferType ty + => String + -> Int + -> Socket + -> IO (HandleStream ty) +socketConnection hst port sock = socketConnection_ hst port sock False + +-- Internal function used to control the on-demand streaming of input +-- for /lazy/ streams. +socketConnection_ :: BufferType ty + => String + -> Int + -> Socket + -> Bool + -> IO (HandleStream 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 + { connSock = sock + , connHandle = h + , connBuffer = bufferOps + , connInput = mb + , connEndPoint = EndPoint hst port + , connHooks = Nothing + , connCloseEOF = False + } + v <- newMVar conn + return (HandleStream v) + +closeConnection :: HStream a => HandleStream a -> IO Bool -> IO () +closeConnection ref readL = do + -- won't hold onto the lock for the duration + -- we are draining it...ToDo: have Connection + -- into a shutting-down state so that other + -- threads will simply back off if/when attempting + -- to also close it. + c <- readMVar (getRef ref) + closeConn c `catchIO` (\_ -> return ()) + modifyMVar_ (getRef ref) (\ _ -> return ConnClosed) + where + -- Be kind to peer & close gracefully. + closeConn ConnClosed = return () + closeConn conn = do + let sk = connSock conn + hFlush (connHandle conn) + shutdown sk ShutdownSend + suck readL + hClose (connHandle conn) + shutdown sk ShutdownReceive + sClose sk + + suck :: IO Bool -> IO () + suck rd = do + f <- rd + if f then return () else suck rd + +-- | Checks both that the underlying Socket is connected +-- and that the connection peer matches the given +-- host name (which is recorded locally). +isConnectedTo :: Connection -> EndPoint -> IO Bool +isConnectedTo (Connection conn) endPoint = isTCPConnectedTo conn endPoint + +isTCPConnectedTo :: HandleStream ty -> EndPoint -> IO Bool +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 + +readBlockBS :: HStream a => HandleStream a -> Int -> IO (Result a) +readBlockBS ref n = onNonClosedDo ref $ \ conn -> do + x <- bufferGetBlock ref n + maybe (return ()) + (\ h -> hook_readBlock h (buf_toStr $ connBuffer conn) n x) + (connHooks' conn) + return x + +-- This function uses a buffer, at this time the buffer is just 1000 characters. +-- (however many bytes this is is left for the user to decipher) +readLineBS :: HStream a => HandleStream a -> IO (Result a) +readLineBS ref = onNonClosedDo ref $ \ conn -> do + x <- bufferReadLine ref + maybe (return ()) + (\ h -> hook_readLine h (buf_toStr $ connBuffer conn) x) + (connHooks' conn) + return x + +-- 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 + x <- bufferPutBlock (connBuffer conn) (connHandle conn) b + maybe (return ()) + (\ h -> hook_writeBlock h (buf_toStr $ connBuffer conn) b x) + (connHooks' conn) + return x + +closeIt :: HStream ty => HandleStream ty -> (ty -> Bool) -> Bool -> IO () +closeIt c p b = do + closeConnection c (if b + then readLineBS c >>= \ x -> case x of { Right xs -> return (p xs); _ -> return True} + else return True) + conn <- readMVar (getRef c) + maybe (return ()) + (hook_close) + (connHooks' conn) + +closeEOF :: HandleStream ty -> Bool -> IO () +closeEOF c flg = modifyMVar_ (getRef c) (\ co -> return co{connCloseEOF=flg}) + +bufferGetBlock :: HStream a => HandleStream a -> Int -> IO (Result a) +bufferGetBlock ref n = onNonClosedDo ref $ \ conn -> do + case connInput conn of + Just c -> do + let (a,b) = buf_splitAt (connBuffer conn) n c + modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b}) + return (return a) + _ -> do + catchIO (buf_hGet (connBuffer conn) (connHandle conn) n >>= return.return) + (\ e -> + if isEOFError e + then do + when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) + else return (failMisc (show e))) + +bufferPutBlock :: BufferOp a -> Handle -> a -> IO (Result ()) +bufferPutBlock ops h b = + catchIO (buf_hPut ops h b >> hFlush h >> return (return ())) + (\ e -> return (failMisc (show e))) + +bufferReadLine :: HStream a => HandleStream a -> IO (Result a) +bufferReadLine ref = onNonClosedDo ref $ \ conn -> do + case connInput conn of + Just c -> do + let (a,b0) = buf_span (connBuffer conn) (/='\n') c + let (newl,b1) = buf_splitAt (connBuffer conn) 1 b0 + modifyMVar_ (getRef ref) (\ co -> return co{connInput=Just b1}) + return (return (buf_append (connBuffer conn) a newl)) + _ -> catchIO + (buf_hGetLine (connBuffer conn) (connHandle conn) >>= + return . return . appendNL (connBuffer conn)) + (\ e -> + if isEOFError e + then do + when (connCloseEOF conn) $ catchIO (closeQuick ref) (\ _ -> return ()) + return (return (buf_empty (connBuffer conn))) + else return (failMisc (show e))) + where + -- 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') + +onNonClosedDo :: HandleStream a -> (Conn a -> IO (Result b)) -> IO (Result b) +onNonClosedDo h act = do + x <- readMVar (getRef h) + case x of + ConnClosed{} -> return (failWith ErrorClosed) + _ -> act x + diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Setup.lhs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Setup.lhs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/Setup.lhs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/Setup.lhs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,8 @@ +#!/usr/bin/env runghc + +> module Main where + +> import Distribution.Simple + +> main :: IO () +> main = defaultMain diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/test/Httpd.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/test/Httpd.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/test/Httpd.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/test/Httpd.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,158 @@ +{-# LANGUAGE CPP #-} + +module Httpd + ( Request, Response, Server + , mkResponse + , reqMethod, reqURI, reqHeaders, reqBody + , shed +#ifdef WARP_TESTS + , warp +#endif + ) + where + +import Control.Applicative +import Control.Arrow ( (***) ) +import Control.DeepSeq +import Control.Monad +import Control.Monad.Trans ( liftIO ) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Char8 as BC +import qualified Data.ByteString.Lazy.Char8 as BLC +#ifdef WARP_TESTS +import qualified Data.CaseInsensitive as CI +#endif +import Data.Maybe ( fromJust ) +import Network.URI ( URI, parseRelativeReference ) + +import Network.Socket + ( getAddrInfo, AddrInfo, defaultHints, addrAddress, addrFamily + , addrFlags, addrSocketType, AddrInfoFlag(AI_PASSIVE), socket, Family(AF_UNSPEC,AF_INET6) + , defaultProtocol, SocketType(Stream), listen, setSocketOption, SocketOption(ReuseAddr) + ) +#ifdef WARP_TESTS +#if MIN_VERSION_network(2,4,0) +import Network.Socket ( bind ) +#else +import Network.Socket ( bindSocket, Socket, SockAddr ) +#endif +#endif + +import qualified Network.Shed.Httpd as Shed + ( Request, Response(Response), initServer + , reqMethod, reqURI, reqHeaders, reqBody + ) +#ifdef WARP_TESTS +#if !MIN_VERSION_wai(3,0,0) +import qualified Data.Conduit.Lazy as Warp +#endif + +import qualified Network.HTTP.Types as Warp + ( Status(..) ) +import qualified Network.Wai as Warp +import qualified Network.Wai.Handler.Warp as Warp + ( runSettingsSocket, defaultSettings, setPort ) +#endif + +data Request = Request + { + reqMethod :: String, + reqURI :: URI, + reqHeaders :: [(String, String)], + reqBody :: String + } + +data Response = Response + { + respStatus :: Int, + respHeaders :: [(String, String)], + respBody :: String + } + +mkResponse :: Int -> [(String, String)] -> String -> Response +mkResponse = Response + +type Server = Int -> (Request -> IO Response) -> IO () + +shed :: Server +shed port handler = + () <$ Shed.initServer + port + (liftM responseToShed . handler . requestFromShed) + where + responseToShed (Response status hdrs body) = + Shed.Response status hdrs body + chomp = reverse . strip '\r' . reverse + strip c (c':str) | c == c' = str + strip c str = str + requestFromShed request = + Request + { + reqMethod = Shed.reqMethod request, + reqURI = Shed.reqURI request, + reqHeaders = map (id *** chomp) $ Shed.reqHeaders request, + reqBody = Shed.reqBody request + } + +#if !MIN_VERSION_bytestring(0,10,0) +instance NFData B.ByteString where + rnf = rnf . B.length +#endif + +#ifdef WARP_TESTS +#if !MIN_VERSION_network(2,4,0) +bind :: Socket -> SockAddr -> IO () +bind = bindSocket +#endif + +warp :: Bool -> Server +warp ipv6 port handler = do + addrinfos <- getAddrInfo (Just $ defaultHints { addrFamily = AF_UNSPEC, addrSocketType = Stream }) + (Just $ if ipv6 then "::1" else "127.0.0.1") + (Just . show $ port) + case addrinfos of + [] -> fail "Couldn't obtain address information in warp" + (addri:_) -> do + sock <- socket (addrFamily addri) Stream defaultProtocol + setSocketOption sock ReuseAddr 1 + bind sock (addrAddress addri) + listen sock 5 +#if MIN_VERSION_wai(3,0,0) + Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest warpRespond -> do + request <- requestFromWarp warpRequest + response <- handler request + warpRespond (responseToWarp response) +#else + Warp.runSettingsSocket (Warp.setPort port Warp.defaultSettings) sock $ \warpRequest -> do + request <- requestFromWarp warpRequest + response <- handler request + return (responseToWarp response) +#endif + where + responseToWarp (Response status hdrs body) = + Warp.responseLBS + (Warp.Status status B.empty) + (map headerToWarp hdrs) + (BLC.pack body) + headerToWarp (name, value) = (CI.mk (BC.pack name), BC.pack value) + headerFromWarp (name, value) = + (BC.unpack (CI.original name), BC.unpack value) + requestFromWarp request = do +#if MIN_VERSION_wai(3,0,1) + body <- fmap BLC.unpack $ Warp.strictRequestBody request +#else + body <- fmap BLC.unpack $ Warp.lazyRequestBody request + body `deepseq` return () +#endif + return $ + Request + { + reqMethod = BC.unpack (Warp.requestMethod request), + reqURI = fromJust . parseRelativeReference . + BC.unpack . Warp.rawPathInfo $ + request, + reqHeaders = map headerFromWarp (Warp.requestHeaders request), + reqBody = body + } +#endif diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/test/httpTests.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/test/httpTests.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/test/httpTests.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/test/httpTests.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,668 @@ +{-# LANGUAGE ImplicitParams, ViewPatterns, NoMonomorphismRestriction, CPP #-} +import Control.Concurrent + +import Control.Applicative ((<$)) +import Control.Concurrent (threadDelay) +import Control.Exception (try) +import qualified Data.ByteString.Lazy.Char8 as BL (pack) +import Data.Char (isSpace) +import qualified Data.Digest.Pure.MD5 as MD5 (md5) +import Data.List.Split (splitOn) +import Data.Maybe (fromJust) +import System.IO.Error (userError) + +import qualified Httpd +import qualified UnitTests + +import Network.Browser +import Network.HTTP +import Network.HTTP.Base +import Network.HTTP.Auth +import Network.HTTP.Headers +import Network.Stream (Result) +import Network.URI (uriPath, parseURI) + +import System.Environment (getArgs) +import System.Info (os) +import System.IO (getChar) + +import Test.Framework (defaultMainWithArgs, testGroup) +import Test.Framework.Providers.HUnit +import Test.HUnit + + +basicGetRequest :: (?testUrl :: ServerAddress) => Assertion +basicGetRequest = do + response <- simpleHTTP (getRequest (?testUrl "/basic/get")) + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + assertEqual "Receiving expected response" "It works." body + +basicGetRequestLBS :: (?testUrl :: ServerAddress) => Assertion +basicGetRequestLBS = do + response <- simpleHTTP (mkRequest GET (fromJust (parseURI (?testUrl ("/basic/get"))))) + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + assertEqual "Receiving expected response" (BL.pack "It works.") body + +basicHeadRequest :: (?testUrl :: ServerAddress) => Assertion +basicHeadRequest = do + response <- simpleHTTP (headRequest (?testUrl "/basic/head")) + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + -- the body should be empty, since this is a HEAD request + assertEqual "Receiving expected response" "" body + +basicExample :: (?testUrl :: ServerAddress) => Assertion +basicExample = do + result <- + -- sample code from Network.HTTP haddock, with URL changed + -- Note there's also a copy of the example in the .cabal file + simpleHTTP (getRequest (?testUrl "/basic/example")) >>= fmap (take 100) . getResponseBody + assertEqual "Receiving expected response" (take 100 haskellOrgText) result + +secureGetRequest :: (?secureTestUrl :: ServerAddress) => Assertion +secureGetRequest = do + response <- try $ simpleHTTP (getRequest (?secureTestUrl "/anything")) + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show response) -- fmap show because Response isn't in Eq + +basicPostRequest :: (?testUrl :: ServerAddress) => Assertion +basicPostRequest = do + let sendBody = "body" + response <- simpleHTTP $ postRequestWithBody (?testUrl "/basic/post") + "text/plain" + sendBody + code <- getResponseCode response + assertEqual "HTTP status code" (2, 0, 0) code + body <- getResponseBody response + assertEqual "Receiving expected response" + (show (Just "text/plain", Just "4", sendBody)) + body + +userpwAuthFailure :: (?baduserpwUrl :: ServerAddress) => Assertion +userpwAuthFailure = do + response <- simpleHTTP (getRequest (?baduserpwUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "HTTP status code" ((4, 0, 1), + "Just \"Basic dGVzdDp3cm9uZ3B3ZA==\"") (code, body) + -- in case of 401, the server returns the contents of the Authz header + +userpwAuthSuccess :: (?userpwUrl :: ServerAddress) => Assertion +userpwAuthSuccess = do + response <- simpleHTTP (getRequest (?userpwUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) + +basicAuthFailure :: (?testUrl :: ServerAddress) => Assertion +basicAuthFailure = do + response <- simpleHTTP (getRequest (?testUrl "/auth/basic")) + code <- getResponseCode response + body <- getResponseBody response + assertEqual "HTTP status code" ((4, 0, 1), "Nothing") (code, body) + +credentialsBasic :: (?testUrl :: ServerAddress) => Authority +credentialsBasic = AuthBasic "Testing realm" "test" "password" + (fromJust . parseURI . ?testUrl $ "/auth/basic") + +basicAuthSuccess :: (?testUrl :: ServerAddress) => Assertion +basicAuthSuccess = do + let req = getRequest (?testUrl "/auth/basic") + let authString = withAuthority credentialsBasic req + let reqWithAuth = req { rqHeaders = mkHeader HdrAuthorization authString:rqHeaders req } + response <- simpleHTTP reqWithAuth + code <- getResponseCode response + body <- getResponseBody response + assertEqual "Receiving expected response" ((2, 0, 0), "Here's the secret") (code, body) + +utf8URLEncode :: Assertion +utf8URLEncode = do + assertEqual "Normal URL" (urlEncode "what-a_mess.com") "what-a_mess.com" + assertEqual "Chinese URL" (urlEncode "好") "%E5%A5%BD" + assertEqual "Russian URL" (urlEncode "ололо") "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE" + +utf8URLDecode :: Assertion +utf8URLDecode = do + assertEqual "Normal URL" (urlDecode "what-a_mess.com") "what-a_mess.com" + assertEqual "Mixed URL" (urlDecode "UTFin进入-wow") "UTFin进入-wow" + assertEqual "Chinese URL" (urlDecode "%E5%A5%BD") "好" + assertEqual "Russian URL" (urlDecode "%D0%BE%D0%BB%D0%BE%D0%BB%D0%BE") "ололо" + +browserExample :: (?testUrl :: ServerAddress) => Assertion +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 + (_, rsp) + <- Network.Browser.browse $ do + setAllowRedirects True -- handle HTTP redirects + request $ getRequest (?testUrl "/browser/example") + return (take 100 (rspBody rsp)) + assertEqual "Receiving expected response" (take 100 haskellOrgText) result + +-- A vanilla HTTP request using Browser shouln't send a cookie header +browserNoCookie :: (?testUrl :: ServerAddress) => Assertion +browserNoCookie = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + request $ getRequest (?testUrl "/browser/no-cookie") + let code = rspCode response + assertEqual "HTTP status code" (2, 0, 0) code + + +-- Regression test +-- * Browser sends vanilla request to server +-- * Server sets one cookie "hello=world" +-- * Browser sends a second request +-- +-- Expected: Server gets single cookie with "hello=world" +-- Actual: Server gets 3 extra cookies, which are actually cookie attributes: +-- "$Version=0;hello=world;$Domain=localhost:8080\r" +browserOneCookie :: (?testUrl :: ServerAddress) => Assertion +browserOneCookie = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + -- This first requests returns a single Set-Cookie: hello=world + _ <- request $ getRequest (?testUrl "/browser/one-cookie/1") + + -- This second request should send a single Cookie: hello=world + request $ getRequest (?testUrl "/browser/one-cookie/2") + let body = rspBody response + assertEqual "Receiving expected response" "" body + let code = rspCode response + assertEqual "HTTP status code" (2, 0, 0) code + +browserTwoCookies :: (?testUrl :: ServerAddress) => Assertion +browserTwoCookies = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + -- This first request returns two cookies + _ <- request $ getRequest (?testUrl "/browser/two-cookies/1") + + -- This second request should send them back + request $ getRequest (?testUrl "/browser/two-cookies/2") + let body = rspBody response + assertEqual "Receiving expected response" "" body + let code = rspCode response + assertEqual "HTTP status code" (2, 0, 0) code + + +browserFollowsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion +browserFollowsRedirect n = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") + assertEqual "Receiving expected response from server" + ((2, 0, 0), "It works.") + (rspCode response, rspBody response) + +browserReturnsRedirect :: (?testUrl :: ServerAddress) => Int -> Assertion +browserReturnsRedirect n = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + request $ getRequest (?testUrl "/browser/redirect/relative/" ++ show n ++ "/basic/get") + assertEqual "Receiving expected response from server" + ((n `div` 100, n `mod` 100 `div` 10, n `mod` 10), "") + (rspCode response, rspBody response) + +authGenBasic _ "Testing realm" = return $ Just ("test", "password") +authGenBasic _ realm = fail $ "Unexpected realm " ++ realm + +browserBasicAuth :: (?testUrl :: ServerAddress) => Assertion +browserBasicAuth = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + + setAuthorityGen authGenBasic + + request $ getRequest (?testUrl "/auth/basic") + + assertEqual "Receiving expected response from server" + ((2, 0, 0), "Here's the secret") + (rspCode response, rspBody response) + +authGenDigest _ "Digest testing realm" = return $ Just ("test", "digestpassword") +authGenDigest _ realm = fail $ "Unexpected digest realm " ++ realm + +browserDigestAuth :: (?testUrl :: ServerAddress) => Assertion +browserDigestAuth = do + (_, response) <- browse $ do + setOutHandler (const $ return ()) + + setAuthorityGen authGenDigest + + request $ getRequest (?testUrl "/auth/digest") + + assertEqual "Receiving expected response from server" + ((2, 0, 0), "Here's the digest secret") + (rspCode response, rspBody response) + + + +browserAlt :: (?altTestUrl :: ServerAddress) => Assertion +browserAlt = do + (response) <- browse $ do + + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") + + return response1 + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response, rspBody response) + +-- test that requests to multiple servers on the same host +-- don't get confused with each other +browserBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion +browserBoth = do + (response1, response2) <- browse $ do + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") + + return (response1, response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response2, rspBody response2) + +-- test that requests to multiple servers on the same host +-- don't get confused with each other +browserBothReversed :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion +browserBothReversed = do + (response1, response2) <- browse $ do + setOutHandler (const $ return ()) + + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + + return (response1, response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response2, rspBody response2) + +browserSecureRequest :: (?secureTestUrl :: ServerAddress) => Assertion +browserSecureRequest = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + + request $ getRequest (?secureTestUrl "/anything") + + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show res) -- fmap show because Response isn't in Eq + +-- in case it tries to reuse the connection +browserSecureRequestAfterInsecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion +browserSecureRequestAfterInsecure = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + + request $ getRequest (?testUrl "/basic/get") + request $ getRequest (?secureTestUrl "/anything") + + assertEqual "Threw expected exception" + (Left (userError "https not supported")) + (fmap show res) -- fmap show because Response isn't in Eq + +browserRedirectToSecure :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) => Assertion +browserRedirectToSecure = do + res <- try $ browse $ do + setOutHandler (const $ return ()) + setErrHandler fail + + request $ getRequest (?testUrl "/browser/redirect/secure/301/anything") + + assertEqual "Threw expected exception" + (Left (userError $ "Unable to handle redirect, unsupported scheme: " ++ ?secureTestUrl "/anything")) + (fmap show res) -- fmap show because Response isn't in Eq + +browserTwoRequests :: (?testUrl :: ServerAddress) => Assertion +browserTwoRequests = do + (response1, response2) <- browse $ do + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + (_, response2) <- request $ getRequest (?testUrl "/basic/get2") + + return (response1, response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works (2).") + (rspCode response2, rspBody response2) + + +browserTwoRequestsAlt :: (?altTestUrl :: ServerAddress) => Assertion +browserTwoRequestsAlt = do + (response1, response2) <- browse $ do + + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?altTestUrl "/basic/get") + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get2") + + return (response1, response2) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server (2).") + (rspCode response2, rspBody response2) + +browserTwoRequestsBoth :: (?testUrl :: ServerAddress, ?altTestUrl :: ServerAddress) => Assertion +browserTwoRequestsBoth = do + (response1, response2, response3, response4) <- browse $ do + setOutHandler (const $ return ()) + + (_, response1) <- request $ getRequest (?testUrl "/basic/get") + (_, response2) <- request $ getRequest (?altTestUrl "/basic/get") + (_, response3) <- request $ getRequest (?testUrl "/basic/get2") + (_, response4) <- request $ getRequest (?altTestUrl "/basic/get2") + + return (response1, response2, response3, response4) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works.") + (rspCode response1, rspBody response1) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server.") + (rspCode response2, rspBody response2) + + assertEqual "Receiving expected response from main server" + ((2, 0, 0), "It works (2).") + (rspCode response3, rspBody response3) + + assertEqual "Receiving expected response from alternate server" + ((2, 0, 0), "This is the alternate server (2).") + (rspCode response4, rspBody response4) + +hasPrefix :: String -> String -> Maybe String +hasPrefix [] ys = Just ys +hasPrefix (x:xs) (y:ys) | x == y = hasPrefix xs ys +hasPrefix _ _ = Nothing + +maybeRead :: Read a => String -> Maybe a +maybeRead s = + case reads s of + [(v, "")] -> Just v + _ -> Nothing + +splitFields = map (toPair '=' . trim isSpace) . splitOn "," + +toPair c str = case break (==c) str of + (left, _:right) -> (left, right) + _ -> error $ "No " ++ show c ++ " in " ++ str +trim f = dropWhile f . reverse . dropWhile f . reverse + +isSubsetOf xs ys = all (`elem` ys) xs + +-- first bits of result text from haskell.org (just to give some representative text) +haskellOrgText = + "\ +\\t\ +\\t\ +\\t\t\ +\\t\t\t\t" + +digestMatch + username realm password + nonce opaque + method relativeURI makeAbsolute + headers + = + common `isSubsetOf` headers && (relative `isSubsetOf` headers || absolute `isSubsetOf` headers) + where + common = [("username", show username), ("realm", show realm), ("nonce", show nonce), + ("opaque", show opaque)] + md5 = show . MD5.md5 . BL.pack + ha1 = md5 (username++":"++realm++":"++password) + ha2 uri = md5 (method++":"++uri) + response uri = md5 (ha1 ++ ":" ++ nonce ++ ":" ++ ha2 uri) + mkUncommon uri hash = [("uri", show uri), ("response", show hash)] + relative = mkUncommon relativeURI (response relativeURI) + absoluteURI = makeAbsolute relativeURI + absolute = mkUncommon absoluteURI (response absoluteURI) + +processRequest :: (?testUrl :: ServerAddress, ?secureTestUrl :: ServerAddress) + => Httpd.Request + -> IO Httpd.Response +processRequest req = do + 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." + ("HEAD", "/basic/head") -> return $ Httpd.mkResponse 200 [] "Body for /basic/head." + ("POST", "/basic/post") -> + let typ = lookup "Content-Type" (Httpd.reqHeaders req) + len = lookup "Content-Length" (Httpd.reqHeaders req) + body = Httpd.reqBody req + in return $ Httpd.mkResponse 200 [] (show (typ, len, body)) + + ("GET", "/basic/example") -> + return $ Httpd.mkResponse 200 [] haskellOrgText + + ("GET", "/auth/basic") -> + case lookup "Authorization" (Httpd.reqHeaders req) of + Just "Basic dGVzdDpwYXNzd29yZA==" -> return $ Httpd.mkResponse 200 [] "Here's the secret" + x -> return $ Httpd.mkResponse 401 [("WWW-Authenticate", "Basic realm=\"Testing realm\"")] (show x) + + ("GET", "/auth/digest") -> + case lookup "Authorization" (Httpd.reqHeaders req) of + Just (hasPrefix "Digest " -> Just (splitFields -> items)) + | digestMatch "test" "Digest testing realm" "digestpassword" + "87e4" "057d" + "GET" "/auth/digest" ?testUrl + items + -> return $ Httpd.mkResponse 200 [] "Here's the digest secret" + x -> return $ Httpd.mkResponse + 401 + [("WWW-Authenticate", + "Digest realm=\"Digest testing realm\", opaque=\"057d\", nonce=\"87e4\"")] + (show x) + + ("GET", "/browser/example") -> + return $ Httpd.mkResponse 200 [] haskellOrgText + ("GET", "/browser/no-cookie") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + Nothing -> return $ Httpd.mkResponse 200 [] "" + Just s -> return $ Httpd.mkResponse 500 [] s + ("GET", "/browser/one-cookie/1") -> + return $ Httpd.mkResponse 200 [("Set-Cookie", "hello=world")] "" + ("GET", "/browser/one-cookie/2") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + Just "hello=world" -> return $ Httpd.mkResponse 200 [] "" + Just s -> return $ Httpd.mkResponse 500 [] s + Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) + ("GET", "/browser/two-cookies/1") -> + return $ Httpd.mkResponse 200 + [("Set-Cookie", "hello=world") + ,("Set-Cookie", "goodbye=cruelworld")] + "" + ("GET", "/browser/two-cookies/2") -> + case lookup "Cookie" (Httpd.reqHeaders req) of + -- TODO generalise the cookie parsing to allow for whitespace/ordering variations + Just "goodbye=cruelworld; hello=world" -> return $ Httpd.mkResponse 200 [] "" + Just s -> return $ Httpd.mkResponse 500 [] s + Nothing -> return $ Httpd.mkResponse 500 [] (show $ Httpd.reqHeaders req) + ("GET", hasPrefix "/browser/redirect/relative/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.mkResponse n [("Location", rest)] "" + ("GET", hasPrefix "/browser/redirect/absolute/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.mkResponse n [("Location", ?testUrl rest)] "" + ("GET", hasPrefix "/browser/redirect/secure/" -> Just (break (=='/') -> (maybeRead -> Just n, rest))) -> + return $ Httpd.mkResponse n [("Location", ?secureTestUrl rest)] "" + _ -> return $ Httpd.mkResponse 500 [] "Unknown request" + +altProcessRequest :: Httpd.Request -> IO Httpd.Response +altProcessRequest req = do + 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" + +maybeTestGroup True name xs = testGroup name xs +maybeTestGroup False name _ = testGroup name [] + +basicTests = + testGroup "Basic tests" + [ testCase "Basic GET request" basicGetRequest + , testCase "Basic GET request (lazy bytestring)" basicGetRequestLBS + , testCase "Network.HTTP example code" basicExample + , testCase "Secure GET request" secureGetRequest + , testCase "Basic POST request" basicPostRequest + , testCase "Basic HEAD request" basicHeadRequest + , testCase "URI user:pass Auth failure" userpwAuthFailure + , testCase "URI user:pass Auth success" userpwAuthSuccess + , testCase "Basic Auth failure" basicAuthFailure + , testCase "Basic Auth success" basicAuthSuccess + , testCase "UTF-8 urlEncode" utf8URLEncode + , testCase "UTF-8 urlDecode" utf8URLDecode + ] + +browserTests = + testGroup "Browser tests" + [ testGroup "Basic" + [ + testCase "Network.Browser example code" browserExample + , testCase "Two requests" browserTwoRequests + ] + , testGroup "Secure" + [ + testCase "Secure request" browserSecureRequest + , testCase "After insecure" browserSecureRequestAfterInsecure + , testCase "Redirection" browserRedirectToSecure + ] + , testGroup "Cookies" + [ testCase "No cookie header" browserNoCookie + , testCase "One cookie" browserOneCookie + , testCase "Two cookies" browserTwoCookies + ] + , testGroup "Redirection" + [ -- See http://en.wikipedia.org/wiki/List_of_HTTP_status_codes#3xx_Redirection + -- 300 Multiple Choices: client has to handle this + testCase "300" (browserReturnsRedirect 300) + -- 301 Moved Permanently: should follow + , testCase "301" (browserFollowsRedirect 301) + -- 302 Found: should follow + , testCase "302" (browserFollowsRedirect 302) + -- 303 See Other: should follow (directly for GETs) + , testCase "303" (browserFollowsRedirect 303) + -- 304 Not Modified: maybe Browser could do something intelligent based on + -- being given locally cached content and sending If-Modified-Since, but it + -- doesn't at the moment + , testCase "304" (browserReturnsRedirect 304) + -- 305 Use Proxy: test harness doesn't have a proxy (yet) + -- 306 Switch Proxy: obsolete + -- 307 Temporary Redirect: should follow + , testCase "307" (browserFollowsRedirect 307) + -- 308 Resume Incomplete: no support for Resumable HTTP so client has to handle this + , testCase "308" (browserReturnsRedirect 308) + ] + , testGroup "Authentication" + [ testCase "Basic" browserBasicAuth + , testCase "Digest" browserDigestAuth + ] + ] + +port80Tests = + testGroup "Multiple servers" + [ testCase "Alternate server" browserAlt + , testCase "Both servers" browserBoth + , testCase "Both servers (reversed)" browserBothReversed + , testCase "Two requests - alternate server" browserTwoRequestsAlt + , testCase "Two requests - both servers" browserTwoRequestsBoth + ] + +data InetFamily = IPv4 | IPv6 + +familyToLocalhost :: InetFamily -> String +familyToLocalhost IPv4 = "127.0.0.1" +familyToLocalhost IPv6 = "[::1]" + +urlRoot :: InetFamily -> String -> Int -> String +urlRoot fam userpw 80 = "http://" ++ userpw ++ familyToLocalhost fam +urlRoot fam userpw n = "http://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n + +secureRoot :: InetFamily -> String -> Int -> String +secureRoot fam userpw 443 = "https://" ++ userpw ++ familyToLocalhost fam +secureRoot fam userpw n = "https://" ++ userpw ++ familyToLocalhost fam ++ ":" ++ show n + +type ServerAddress = String -> String + +httpAddress, httpsAddress :: InetFamily -> String -> Int -> ServerAddress +httpAddress fam userpw port p = urlRoot fam userpw port ++ p +httpsAddress fam userpw port p = secureRoot fam userpw port ++ p + +main :: IO () +main = do + args <- getArgs + + let servers = + [ ("httpd-shed", Httpd.shed, IPv4) +#ifdef WARP_TESTS + , ("warp.v6", Httpd.warp True, IPv6) + , ("warp.v4", Httpd.warp False, IPv4) +#endif + ] + basePortNum, altPortNum :: Int + basePortNum = 5812 + altPortNum = 80 + numberedServers = zip [basePortNum..] servers + + let setupNormalTests = do + flip mapM numberedServers $ \(portNum, (serverName, server, family)) -> do + let ?testUrl = httpAddress family "" portNum + ?userpwUrl = httpAddress family "test:password@" portNum + ?baduserpwUrl = httpAddress family "test:wrongpwd@" portNum + ?secureTestUrl = httpsAddress family "" portNum + _ <- forkIO $ server portNum processRequest + return $ testGroup serverName [basicTests, browserTests] + + let setupAltTests = do + let (portNum, (_, server,family)) = head numberedServers + let ?testUrl = httpAddress family "" portNum + ?altTestUrl = httpAddress family "" altPortNum + _ <- forkIO $ server altPortNum altProcessRequest + return port80Tests + + case args of + ["server"] -> do -- run only the harness servers for diagnostic/debug purposes + -- halt on any keypress + _ <- setupNormalTests + _ <- setupAltTests + _ <- getChar + return () + ("--withport80":args) -> do + normalTests <- setupNormalTests + altTests <- setupAltTests + _ <- threadDelay 1000000 -- Give the server time to start :-( + defaultMainWithArgs (UnitTests.unitTests ++ normalTests ++ [altTests]) args + args -> do -- run the test harness as normal + normalTests <- setupNormalTests + _ <- threadDelay 1000000 -- Give the server time to start :-( + defaultMainWithArgs (UnitTests.unitTests ++ normalTests) args diff -Nru cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/test/UnitTests.hs cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/test/UnitTests.hs --- cabal-install-head-2.1+git20171204.0.2b835e6/src/HTTP-4000.3.9/test/UnitTests.hs 1970-01-01 00:00:00.000000000 +0000 +++ cabal-install-head-2.1+git20171213.0.b8c95ea/src/HTTP-4000.3.9/test/UnitTests.hs 2017-12-11 19:19:16.000000000 +0000 @@ -0,0 +1,32 @@ +module UnitTests ( unitTests ) where + +import Network.HTTP.Base +import Network.URI + +import Data.Maybe ( fromJust ) + +import Test.Framework ( testGroup ) +import Test.Framework.Providers.HUnit +import Test.HUnit + +parseIPv4Address :: Assertion +parseIPv4Address = + assertEqual "127.0.0.1 address is recognised" + (Just (URIAuthority {user = Nothing, password = Nothing, host = "127.0.0.1", port = Just 5313})) + (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://127.0.0.1:5313/foo")))) + + +parseIPv6Address :: Assertion +parseIPv6Address = + assertEqual "::1 address" + (Just (URIAuthority {user = Nothing, password = Nothing, host = "::1", port = Just 5313})) + (parseURIAuthority (uriToAuthorityString (fromJust (parseURI "http://[::1]:5313/foo")))) + +unitTests = + [testGroup "Unit tests" + [ testGroup "URI parsing" + [ testCase "Parse IPv4 address" parseIPv4Address + , testCase "Parse IPv6 address" parseIPv6Address + ] + ] + ]