VKHS 0.1.1 → 0.1.2

raw patch · 32 files changed

+4194/−36 lines, 32 filessetup-changed

Files

• LICENSE +30/−30
• Setup.hs +2/−2
• VKHS.cabal +6/−4
• src/Data/Label.hs +196/−0
• src/Data/Label/Abstract.hs +162/−0
• src/Data/Label/Derive.hs +240/−0
• src/Data/Label/Maybe.hs +111/−0
• src/Data/Label/MaybeM.hs +60/−0
• src/Data/Label/Pure.hs +94/−0
• src/Data/Label/PureM.hs +89/−0
• src/Network/Protocol/Cookie.hs +238/−0
• src/Network/Protocol/Http.hs +130/−0
• src/Network/Protocol/Http/Data.hs +176/−0
• src/Network/Protocol/Http/Headers.hs +153/−0
• src/Network/Protocol/Http/Parser.hs +174/−0
• src/Network/Protocol/Http/Printer.hs +88/−0
• src/Network/Protocol/Http/Status.hs +193/−0
• src/Network/Protocol/Mime.hs +695/−0
• src/Network/Protocol/Uri.hs +128/−0
• src/Network/Protocol/Uri/Chars.hs +48/−0
• src/Network/Protocol/Uri/Data.hs +214/−0
• src/Network/Protocol/Uri/Encode.hs +66/−0
• src/Network/Protocol/Uri/Parser.hs +308/−0
• src/Network/Protocol/Uri/Path.hs +102/−0
• src/Network/Protocol/Uri/Printer.hs +98/−0
• src/Network/Protocol/Uri/Query.hs +82/−0
• src/Network/Protocol/Uri/Remap.hs +74/−0
• src/Network/Shpider/Forms.hs +129/−0
• src/Test/Api.hs +16/−0
• src/Test/Data.hs +27/−0
• src/Test/Debug.hs +20/−0
• src/Web/VKHS/Curl.hs +45/−0

@@ -1,30 +1,30 @@-Copyright (c) 2012, Sergey Mironov--All rights reserved.--Redistribution and use in source and binary forms, with or without-modification, are permitted provided that the following conditions are met:--    * Redistributions of source code must retain the above copyright-      notice, this list of conditions and the following disclaimer.--    * Redistributions in binary form must reproduce the above-      copyright notice, this list of conditions and the following-      disclaimer in the documentation and/or other materials provided-      with the distribution.--    * Neither the name of Sergey Mironov nor the names of other-      contributors may be used to endorse or promote products derived-      from this software without specific prior written permission.--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS-"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT-LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR-A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT-OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,-SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT-LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,-DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY-THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT-(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE-OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.+Copyright (c) 2012, Sergey Mironov
+
+All rights reserved.
+
+Redistribution and use in source and binary forms, with or without
+modification, are permitted provided that the following conditions are met:
+
+    * Redistributions of source code must retain the above copyright
+      notice, this list of conditions and the following disclaimer.
+
+    * Redistributions in binary form must reproduce the above
+      copyright notice, this list of conditions and the following
+      disclaimer in the documentation and/or other materials provided
+      with the distribution.
+
+    * Neither the name of Sergey Mironov nor the names of other
+      contributors may be used to endorse or promote products derived
+      from this software without specific prior written permission.
+
+THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -1,2 +1,2 @@-import Distribution.Simple-main = defaultMain+import Distribution.Simple
+main = defaultMain

@@ -1,6 +1,6 @@  name:                VKHS-version:             0.1.1+version:             0.1.2 synopsis:            Provides access to Vkontakte social network, popular in Russia description:     Provides access to Vkontakte API methods. Library requires no interaction@@ -13,7 +13,7 @@ copyright:           Copyright (c) 2012, Sergey Mironov category:            Web build-type:          Simple-cabal-version:       >=1.8+cabal-version:       >=1.6 homepage:            http://github.com/ierton/vkhs  source-repository head@@ -22,11 +22,13 @@  library   hs-source-dirs:    src+  other-modules:     Test.Debug, Test.Data, Test.Api, Network.Shpider.Forms, Network.Protocol.Uri, Network.Protocol.Mime, Network.Protocol.Http, Network.Protocol.Cookie, Network.Protocol.Uri.Remap, Network.Protocol.Uri.Query, Network.Protocol.Uri.Printer, Network.Protocol.Uri.Path, Network.Protocol.Uri.Parser, Network.Protocol.Uri.Encode, Network.Protocol.Uri.Data, Network.Protocol.Uri.Chars, Network.Protocol.Http.Status, Network.Protocol.Http.Printer, Network.Protocol.Http.Parser, Network.Protocol.Http.Headers, Network.Protocol.Http.Data, Data.Label, Data.Label.PureM, Data.Label.Pure, Data.Label.MaybeM, Data.Label.Maybe, Data.Label.Derive, Data.Label.Abstract   exposed-modules:   Web.VKHS-                     Web.VKHS.Types-                     Web.VKHS.Login                      Web.VKHS.API                      Web.VKHS.API.JSON+                     Web.VKHS.Curl+                     Web.VKHS.Login+                     Web.VKHS.Types    build-depends:     base >=4.5 && <5,                      json ==0.5.*,

@@ -0,0 +1,196 @@+{-+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}++{-# LANGUAGE TypeOperators #-}+{- |+This package provides first class labels that can act as bidirectional record+fields. The labels can be derived automatically using Template Haskell which+means you don't have to write any boilerplate yourself. The labels are+implemented as lenses and are fully composable. Labels can be used to /get/,+/set/ and /modify/ parts of a datatype in a consistent way.+-}++module Data.Label+(++-- * Working with @fclabels@.++{- |+The lens datatype, conveniently called `:->', is an instance of the+"Control.Category" type class: meaning it has a proper identity and+composition. The library has support for automatically deriving labels from+record selectors that start with an underscore.++To illustrate this package, let's take the following two example datatypes.+-}++-- |+-- >{-# LANGUAGE TemplateHaskell, TypeOperators #-}+-- >import Control.Category+-- >import Data.Label+-- >import Prelude hiding ((.), id)+-- >+-- >data Person = Person+-- >  { _name   :: String+-- >  , _age    :: Int+-- >  , _isMale :: Bool+-- >  , _place  :: Place+-- >  } deriving Show+-- >+-- >data Place = Place+-- >  { _city+-- >  , _country+-- >  , _continent :: String+-- >  } deriving Show++{- |+Both datatypes are record types with all the labels prefixed with an+underscore. This underscore is an indication for our Template Haskell code to+derive lenses for these fields. Deriving lenses can be done with this simple+one-liner:++>mkLabels [''Person, ''Place]++For all labels a lens will created.++Now let's look at this example. This 71 year old fellow, my neighbour called+Jan, didn't mind using him as an example:++>jan :: Person+>jan = Person "Jan" 71 True (Place "Utrecht" "The Netherlands" "Europe")++When we want to be sure Jan is really as old as he claims we can use the `get`+function to get the age out as an integer:++>hisAge :: Int+>hisAge = get age jan++Consider he now wants to move to Amsterdam: what better place to spend your old+days. Using composition we can change the city value deep inside the structure:++>moveToAmsterdam :: Person -> Person+>moveToAmsterdam = set (city . place) "Amsterdam"++And now:++>ghci> moveToAmsterdam jan+>Person "Jan" 71 True (Place "Amsterdam" "The Netherlands" "Europe")++Composition is done using the @(`.`)@ operator which is part of the+"Control.Category" module. Make sure to import this module and hide the default+@(`.`)@, `id` function from the Haskell "Prelude".++-}++-- * Pure lenses.++  (:->)+, lens+, get+, set+, modify+-- , glue+, fmapL++-- * Views using @Applicative@.++{- |++Now, because Jan is an old guy, moving to another city is not a very easy task,+this really takes a while. It will probably take no less than two years before+he will actually be settled. To reflect this change it might be useful to have+a first class view on the `Person` datatype that only reveals the age and+city.  This can be done by using a neat `Applicative` functor instance:++>import Control.Applicative++>ageAndCity :: Person :-> (Int, String)+>ageAndCity = Lens $ (,) <$> fst `for` age <*> snd `for` city . place++Because the applicative type class on its own is not very capable of expressing+bidirectional relations, which we need for our lenses, the actual instance is+defined for an internal helper structure called `Point`. Points are a bit more+general than lenses. As you can see above, the `Label` constructor has to be+used to convert a `Point` back into a `Label`. The `for` function must be used+to indicate which partial destructor to use for which lens in the applicative+composition.++Now that we have an appropriate age+city view on the `Person` datatype (which+is itself a lens again), we can use the `modify` function to make Jan move to+Amsterdam over exactly two years:++>moveToAmsterdamOverTwoYears :: Person -> Person+>moveToAmsterdamOverTwoYears = modify ageAndCity (\(a, _) -> (a+2, "Amsterdam"))++>ghci> moveToAmsterdamOverTwoYears jan+>Person "Jan" 73 True (Place "Amsterdam" "The Netherlands" "Europe")++-}++, Lens (Lens)++-- * Working with bijections and isomorphisms.+-- +-- | This package contains a bijection datatype that encodes bidirectional+-- functions. Just like lenses, bijections can be composed using the+-- "Control.Category" type class. Bijections can be used to change the type of+-- a lens. The `Iso` type class, which can be seen as a bidirectional functor,+-- can be used to apply lenses to lenses.+-- +-- For example, when we want to treat the age of a person as a string we can do+-- the following:+-- +-- > ageAsString :: Person :-> String+-- > ageAsString = (Bij show read) `iso` age++, Bijection (..)+, Iso (..)+, for++-- * Derive labels using Template Haskell.+--+-- | We can either derive labels with or without type signatures. In the case+-- of multi-constructor datatypes some fields might not always be available and+-- the derived labels will be partial. Partial labels are provided with an+-- additional type context that forces them to be only usable using the+-- functions from "Data.Label.Maybe".++, mkLabels+, mkLabel+, mkLabelsWith+, mkLabelsMono+, mkLabelsNoTypes+)+where++import Data.Label.Abstract (Bijection(..), Iso(..), for, Lens(..))+import Data.Label.Pure+import Data.Label.Derive+

@@ -0,0 +1,162 @@+{-+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE+    TypeOperators+  , Arrows+  , TupleSections+  , FlexibleInstances+  , MultiParamTypeClasses+  #-}+module Data.Label.Abstract where++import Control.Arrow+import Prelude hiding ((.), id)+import Control.Applicative+import Control.Category++{-# INLINE _modify #-}+{-# INLINE lens    #-}+{-# INLINE get     #-}+{-# INLINE set     #-}+{-# INLINE modify  #-}+{-# INLINE bimap   #-}+{-# INLINE for     #-}+{-# INLINE liftBij #-}++-- | Abstract Point datatype. The getter and setter functions work in some+-- arrow.++data Point (~>) f i o = Point+  { _get :: f ~> o+  , _set :: (i, f) ~> f+  }++-- | Modification as a compositon of a getter and setter. Unfortunately,+-- `ArrowApply' is needed for this composition.++_modify :: ArrowApply (~>) => Point (~>) f i o -> (o ~> i, f) ~> f+_modify l = proc (m, f) -> do i <- m . _get l -<< f; _set l -< (i, f)++-- | Abstract Lens datatype. The getter and setter functions work in some+-- arrow. Arrows allow for effectful lenses, for example, lenses that might+-- fail or use state.++newtype Lens (~>) f a = Lens { unLens :: Point (~>) f a a }++-- | Create a lens out of a getter and setter.++lens :: (f ~> a) -> ((a, f) ~> f) -> Lens (~>) f a+lens g s = Lens (Point g s)++-- | Get the getter arrow from a lens.++get :: Arrow (~>) => Lens (~>) f a -> f ~> a+get = _get . unLens++-- | Get the setter arrow from a lens.++set :: Arrow (~>) => Lens (~>) f a -> (a, f) ~> f+set = _set . unLens++-- | Get the modifier arrow from a lens.++modify :: ArrowApply (~>) => Lens (~>) f o -> (o ~> o, f) ~> f+modify = _modify . unLens++instance ArrowApply (~>) => Category (Lens (~>)) where+  id = lens id (arr fst)+  Lens a . Lens b = lens (_get a . _get b) (_modify b . first (curryA (_set a)))+    where curryA f = arr (\i -> f . arr (i,))+  {-# INLINE id #-}+  {-# INLINE (.) #-}++instance Arrow (~>) => Functor (Point (~>) f i) where+  fmap f x = Point (arr f . _get x) (_set x)+  {-# INLINE fmap #-}++instance Arrow (~>) => Applicative (Point (~>) f i) where+  pure a  = Point (arr (const a)) (arr snd)+  a <*> b = Point (arr app . (_get a &&& _get b)) (_set b . (arr fst &&& _set a))+  {-# INLINE pure #-}+  {-# INLINE (<*>) #-}++-- | Make a 'Point' diverge in two directions.++bimap :: Arrow (~>) => (o' ~> o) -> (i ~> i') -> Point (~>) f i' o' -> Point (~>) f i o+bimap f g l = Point (f . _get l) (_set l . first g)++infix 8 `for`++for :: Arrow (~>) => (i ~> o) -> Lens (~>) f o -> Point (~>) f i o+for p = bimap id p . unLens++-- | The bijections datatype, an arrow that works in two directions. ++data Bijection (~>) a b = Bij { fw :: a ~> b, bw :: b ~> a }++-- | Bijections as categories.++instance Category (~>) => Category (Bijection (~>)) where+  id = Bij id id+  Bij a b . Bij c d = Bij (a . c) (d . b)+  {-# INLINE id #-}+  {-# INLINE (.) #-}++-- | Lifting 'Bijection's.++liftBij :: Functor f => Bijection (->) a b -> Bijection (->) (f a) (f b)+liftBij a = Bij (fmap (fw a)) (fmap (bw a))++-- | Apply Bijection to Lens++-- mapBij :: Bijection (->) b c -> Lens (->) a b -> Lens (->) a c+-- mapBij b l = lens g s where+--    g x = fw b (get l x)+--    s (a,x) = set l ((bw b a),x)++-- | The isomorphism type class is like a `Functor' but works in two directions.++infixr 8 `iso`++class Iso (~>) f where+  iso :: Bijection (~>) a b -> f a ~> f b++-- | We can diverge 'Lens'es using an isomorphism.++instance Arrow (~>) => Iso (~>) (Lens (~>) f) where+  iso bi = arr ((\a -> lens (fw bi . _get a) (_set a . first (bw bi))) . unLens)+  {-# INLINE iso #-}++-- | We can diverge 'Bijection's using an isomorphism.++instance Arrow (~>) => Iso (~>) (Bijection (~>) a) where+  iso = arr . (.)+  {-# INLINE iso #-}+

@@ -0,0 +1,240 @@+{-+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# OPTIONS -fno-warn-orphans #-}+{-# LANGUAGE+    TemplateHaskell+  , OverloadedStrings+  , FlexibleContexts+  , FlexibleInstances+  , TypeOperators+  #-}+module Data.Label.Derive+( mkLabels+, mkLabel+, mkLabelsWith+, mkLabelsMono+, mkLabelsNoTypes+) where++import Control.Arrow+import Control.Category+import Control.Monad+import Data.Char+import Data.Function (on)+import Data.Label.Abstract+import Data.Label.Pure ((:->))+import Data.Label.Maybe ((:~>))+import Data.List+import Data.Ord+import Data.String+import Language.Haskell.TH+import Language.Haskell.TH.Syntax+import Prelude hiding ((.), id)++-- Throw a fclabels specific error.++fclError :: String -> a+fclError err = error ("Data.Label.Derive: " ++ err)++-- | Derive lenses including type signatures for all the record selectors for a+-- collection of datatypes. The types will be polymorphic and can be used in an+-- arbitrary context.++mkLabels :: [Name] -> Q [Dec]+mkLabels = mkLabelsWith defaultMakeLabel++-- | Derive lenses including type signatures for all the record selectors in a+-- single datatype. The types will be polymorphic and can be used in an+-- arbitrary context.++mkLabel :: Name -> Q [Dec]+mkLabel = mkLabels . return++-- | Generate the label name from the record field name.+-- For instance, @drop 1 . dropWhile (/='_')@ creates a label @val@ from a+-- record @Rec { rec_val :: X }@.++mkLabelsWith :: (String -> String) -> [Name] -> Q [Dec]+mkLabelsWith makeLabel = liftM concat . mapM (derive1 makeLabel True False)++-- | Derive lenses including type signatures for all the record selectors in a+-- datatype. The signatures will be concrete and can only be used in the+-- appropriate context.++mkLabelsMono :: [Name] -> Q [Dec]+mkLabelsMono = liftM concat . mapM (derive1 defaultMakeLabel True True)++-- | Derive lenses without type signatures for all the record selectors in a+-- datatype.++mkLabelsNoTypes :: [Name] -> Q [Dec]+mkLabelsNoTypes = liftM concat . mapM (derive1 defaultMakeLabel False False)++-- Helpers to generate all labels for one datatype.++derive1 :: (String -> String) -> Bool -> Bool -> Name -> Q [Dec]+derive1 makeLabel signatures concrete datatype =+ do i <- reify datatype+    let -- Only process data and newtype declarations, filter out all+        -- constructors and the type variables.+        (tyname, cons, vars) =+          case i of+            TyConI (DataD    _ n vs cs _) -> (n, cs,  vs)+            TyConI (NewtypeD _ n vs c  _) -> (n, [c], vs)+            _                             -> fclError "Can only derive labels for datatypes and newtypes."++        -- We are only interested in lenses of record constructors.+        recordOnly = groupByCtor [ (f, n) | RecC n fs <- cons, f <- fs ]++    concat `liftM`+        mapM (derive makeLabel signatures concrete tyname vars (length cons))+            recordOnly++    where groupByCtor = map (\xs -> (fst (head xs), map snd xs))+                      . groupBy ((==) `on` (fst3 . fst))+                      . sortBy (comparing (fst3 . fst))+                      where fst3 (a, _, _) = a++-- Generate the code for the labels.++-- | Generate a name for the label. If the original selector starts with an+-- underscore, remove it and make the next character lowercase. Otherwise,+-- add 'l', and make the next character uppercase.+defaultMakeLabel :: String -> String+defaultMakeLabel field =+  case field of+    '_' : c : rest -> toLower c : rest+    f : rest       -> 'l' : toUpper f : rest+    n              -> fclError ("Cannot derive label for record selector with name: " ++ n)++derive :: (String -> String)+       -> Bool -> Bool -> Name -> [TyVarBndr] -> Int+       -> (VarStrictType, [Name]) -> Q [Dec]+derive makeLabel signatures concrete tyname vars total ((field, _, fieldtyp), ctors) =+  do (sign, body) <-+       if length ctors == total+       then function derivePureLabel+       else function deriveMaybeLabel++     return $+       if signatures+       then [sign, inline, body]+       else [inline, body]++  where++    -- Generate an inline declaration for the label.+    inline = PragmaD (InlineP labelName (InlineSpec True True (Just (True, 0))))+    labelName = mkName (makeLabel (nameBase field))++    -- Build a single record label definition for labels that might fail.+    deriveMaybeLabel = (if concrete then mono else poly, body)+      where+        mono = forallT prettyVars (return []) [t| $(inputType) :~> $(return prettyFieldtyp) |]+        poly = forallT forallVars (return [])+          [t| (ArrowChoice $(arrow), ArrowZero $(arrow))+              => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]+        body = [| lens (fromRight . $(getter)) (fromRight . $(setter)) |]+          where+            getter    = [| arr (\    p  -> $(caseE [|p|] (cases (bodyG [|p|]      ) ++ wild))) |]+            setter    = [| arr (\(v, p) -> $(caseE [|p|] (cases (bodyS [|p|] [|v|]) ++ wild))) |]+            cases b   = map (\ctor -> match (recP ctor []) (normalB b) []) ctors+            wild      = [match wildP (normalB [| Left () |]) []]+            bodyS p v = [| Right $( record p field v ) |]+            bodyG p   = [| Right $( varE field `appE` p ) |]++    -- Build a single record label definition for labels that cannot fail.+    derivePureLabel = (if concrete then mono else poly, body)+      where+        mono = forallT prettyVars (return []) [t| $(inputType) :-> $(return prettyFieldtyp) |]+        poly = forallT forallVars (return [])+          [t| Arrow $(arrow) => Lens $(arrow) $(inputType) $(return prettyFieldtyp) |]+        body = [| lens $(getter) $(setter) |]+          where+            getter = [| arr $(varE field) |]+            setter = [| arr (\(v, p) -> $(record [| p |] field [| v |])) |]++    -- Compute the type (including type variables of the record datatype.+    inputType = return $ foldr (flip AppT) (ConT tyname) (map tvToVarT (reverse prettyVars))++    -- Convert a type variable binder to a regular type variable.+    tvToVarT (PlainTV tv) = VarT tv+    tvToVarT _            = fclError "No support for special-kinded type variables."++    -- Prettify type variables.+    arrow          = varT (mkName "~>")+    prettyVars     = map prettyTyVar vars+    forallVars     = PlainTV (mkName "~>") : prettyVars+    prettyFieldtyp = prettyType fieldtyp++    -- Q style record updating.+    record rec fld val = val >>= \v -> recUpdE rec [return (fld, v)]++    -- Build a function declaration with both a type signature and body.+    function (s, b) = liftM2 (,) +        (sigD labelName s)+        (funD labelName [ clause [] (normalB b) [] ])++fromRight :: (ArrowChoice a, ArrowZero a) => a (Either b d) d+fromRight = zeroArrow ||| returnA++-------------------------------------------------------------------------------++-- Helper functions to prettify type variables.++prettyName :: Name -> Name+prettyName tv = mkName (takeWhile (/='_') (show tv))++prettyTyVar :: TyVarBndr -> TyVarBndr+prettyTyVar (PlainTV  tv   ) = PlainTV (prettyName tv)+prettyTyVar (KindedTV tv ki) = KindedTV (prettyName tv) ki++prettyType :: Type -> Type+prettyType (ForallT xs cx ty) = ForallT (map prettyTyVar xs) (map prettyPred cx) (prettyType ty)+prettyType (VarT nm         ) = VarT (prettyName nm)+prettyType (AppT ty tx      ) = AppT (prettyType ty) (prettyType tx)+prettyType (SigT ty ki      ) = SigT (prettyType ty) ki+prettyType ty                 = ty++prettyPred :: Pred -> Pred+prettyPred (ClassP nm tys) = ClassP (prettyName nm) (map prettyType tys)+prettyPred (EqualP ty tx ) = EqualP (prettyType ty) (prettyType tx)++-- IsString instances for TH types.++instance IsString Exp where+  fromString = VarE . mkName++instance IsString (Q Pat) where+  fromString = varP . mkName++instance IsString (Q Exp) where+  fromString = varE . mkName+

@@ -0,0 +1,111 @@+{-+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators, TupleSections #-}+module Data.Label.Maybe+( (:~>)+, lens+, get+, set+, set'+, modify+, modify'+, embed+, lift+)+where++import Control.Arrow+import Control.Category+import Control.Monad.Identity+import Control.Monad.Trans.Maybe+import Data.Maybe+import Prelude hiding ((.), id)+import qualified Data.Label.Abstract as A++type MaybeLens f a = A.Lens (Kleisli (MaybeT Identity)) f a++-- | Lens type for situations in which the accessor functions can fail. This is+-- useful, for example, when accessing fields in datatypes with multiple+-- constructors.++type f :~> a = MaybeLens f a++run :: Kleisli (MaybeT Identity) f a -> f -> Maybe a+run l = runIdentity . runMaybeT . runKleisli l++-- | Create a lens that can fail from a getter and a setter that can themselves+-- potentially fail.++lens :: (f -> Maybe a) -> (a -> f -> Maybe f) -> f :~> a+lens g s = A.lens (kl g) (kl (uncurry s))+  where kl a = Kleisli (MaybeT . Identity . a)++-- | Getter for a lens that can fail. When the field to which the lens points+-- is not accessible the getter returns 'Nothing'.++get :: (f :~> a) -> f -> Maybe a+get l = run (A.get l)++-- | Setter for a lens that can fail. When the field to which the lens points+-- is not accessible this function returns 'Nothing'.++set :: f :~> a -> a -> f -> Maybe f+set l v = run (A.set l . arr (v,))++-- | Like 'set' but return behaves like the identity function when the field+-- could not be set.++set' :: (f :~> a) -> a -> f -> f+set' l v f = f `fromMaybe` set l v f++-- | Modifier for a lens that can fail. When the field to which the lens points+-- is not accessible this function returns 'Nothing'.++modify :: (f :~> a) -> (a -> a) -> f -> Maybe f+modify l m = run (A.modify l . arr (arr m,))++-- | Like 'modify' but return behaves like the identity function when the field+-- could not be set.++modify' :: (f :~> a) -> (a -> a) -> f -> f+modify' l m f = f `fromMaybe` modify l m f++-- | Embed a pure lens that points to a `Maybe` field into a lens that might+-- fail.++embed :: A.Lens (->) f (Maybe a) -> f :~> a+embed l = lens (A.get l) (\a f -> Just (A.set l (Just a, f)))+++lift :: A.Lens(->) f a -> f :~> a+lift l = lens (\f -> Just $ A.get l f) (\a f -> Just $ A.set l (a,f))+++

@@ -0,0 +1,60 @@+{-+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators #-}+module Data.Label.MaybeM+(+-- * 'MonadState' lens operations.+  gets++-- * 'MonadReader' lens operations.+, asks+)+where++import Control.Monad+import Data.Label.Maybe ((:~>))+import qualified Control.Monad.Reader as M+import qualified Control.Monad.State  as M+import qualified Data.Label.Maybe     as L++-- | Get a value out of state, pointed to by the specified lens that might+-- fail.  When the lens getter fails this computation will fall back to+-- `mzero'.++gets :: (M.MonadState f m, MonadPlus m) => (f :~> a) -> m a+gets l = (L.get l `liftM` M.get) >>= (mzero `maybe` return)++-- | Fetch a value, pointed to by a lens that might fail, out of a reader+-- environment. When the lens getter fails this computation will fall back to+-- `mzero'.++asks :: (M.MonadReader f m, MonadPlus m) => (f :~> a) -> m a+asks l = (L.get l `liftM` M.ask) >>= (mzero `maybe` return)+

@@ -0,0 +1,94 @@+{-+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators #-}+module Data.Label.Pure+( (:->)+, lens+, get+, set+, modify+-- , glue+, fmapL+)+where++import qualified Data.Label.Abstract as A+import Control.Applicative++type PureLens f a = A.Lens (->) f a++-- | Pure lens type specialized for pure accessor functions.++type (f :-> a) = PureLens f a++-- | Create a pure lens from a getter and a setter.+--+-- We expect the following law to hold:+--+-- > get l (set l a f) == a+--+-- Or, equivalently:+--+-- > set l (get l f) f == f++lens :: (f -> a) -> (a -> f -> f) -> f :-> a+lens g s = A.lens g (uncurry s)++-- | Getter for a pure lens.++get :: (f :-> a) -> f -> a+get = A.get++-- | Setter for a pure lens.++set :: (f :-> a) -> a -> f -> f+set = curry . A.set++-- | Modifier for a pure lens.++modify :: (f :-> a) -> (a -> a) -> f -> f+modify = curry . A.modify+++fmapL :: (Alternative f) => (a :-> b) -> (f a :-> f b)+fmapL (A.Lens (A.Point g' s')) = lens g s where+    g a = fmap g' a+    s fb fa = ((\b a->s' (b,a)) <$> fb <*> fa) <|> fa++-- glue :: (Alternative f) => (o :-> f a) -> (a :-> b) -> (o :-> f b)+-- glue l1 l@(A.Lens (A.Point g2 s2)) = lens g s where+--     g o = fmap g2 (get l1 o)+--     s fb o = set l1 (set ll fb fa) o where+--         fa = get l1 o+--         ll = fmapL l++-- glue2 :: (Alternative f) => (o :-> f a) -> (a :-> f b) -> (o :-> f b)+-- glue2 l1 l2 = lens g s where+

@@ -0,0 +1,89 @@+{-+Copyright (c) Erik Hesselink & Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators  #-}+module Data.Label.PureM+(+-- * 'MonadState' lens operations.+  gets+, puts+, modify+, (=:)+, (=.)++-- * 'MonadReader' lens operations.+, asks+, local+)+where++import Data.Label.Pure ((:->))+import qualified Control.Monad.Reader as M+import qualified Control.Monad.State  as M+import qualified Data.Label.Pure      as L++-- | Get a value out of the state, pointed to by the specified lens.++gets :: M.MonadState s m => s :-> a -> m a+gets = M.gets . L.get++-- | Set a value somewhere in the state, pointed to by the specified lens.++puts :: M.MonadState s m => s :-> a -> a -> m ()+puts l = M.modify . L.set l++-- | Modify a value with a function somewhere in the state, pointed to by the+-- specified lens.++modify :: M.MonadState s m => s :-> a -> (a -> a) -> m ()+modify l = M.modify . L.modify l++-- | Alias for `puts' that reads like an assignment.++infixr 2 =:+(=:) :: M.MonadState s m => s :-> a -> a -> m ()+(=:) = puts++-- | Alias for `modify' that reads more or less like an assignment.++infixr 2 =.+(=.) :: M.MonadState s m => s :-> a -> (a -> a) -> m ()+(=.) = modify++-- | Fetch a value pointed to by a lens out of a reader environment.++asks :: M.MonadReader r m => (r :-> a) -> m a+asks = M.asks . L.get++-- | Execute a computation in a modified environment. The lens is used to+-- point out the part to modify.++local :: M.MonadReader r m => (r :-> b) -> (b -> b) -> m a -> m a+local l f = M.local (L.modify l f)+

@@ -0,0 +1,238 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}++{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Network.Protocol.Cookie+(++-- | For more information:+--   http://tools.ietf.org/html/rfc6265++-- * Cookie datatype.+  Cookie (Cookie)+, emptyShort+, empty+, cookie+, setCookie++, CookieShort (CookieShort)+, toShort++-- * Accessing cookies.+, name+, value+, comment+, commentURL+, discard+, domain+, maxAge+, expires+, path+, port+, secure+, version++-- * Collection of cookies.+, Cookies+, unCookies+, gather+, pickCookie+)+where++import Prelude hiding ((.), id)+import Control.Category+import Control.Monad (join)+import Data.Label+import qualified Data.Label.Abstract as A+import Data.Maybe+import Data.Char+import Data.Monoid+import Safe+import Data.List+import Network.Protocol.Uri.Query+import qualified Data.Map as M++-- | The `Cookie` data type containg one key/value pair with all the+-- (potentially optional) meta-data.++data Cookie =+  Cookie+    { _name       :: String+    , _value      :: String+    , _comment    :: Maybe String+    , _commentURL :: Maybe String+    , _discard    :: Maybe String+    , _domain     :: Maybe String+    , _maxAge     :: Maybe Int+    , _expires    :: Maybe String+    , _path       :: Maybe String+    , _port       :: [Int]+    , _secure     :: Bool+    , _version    :: Int+    } deriving(Show, Read, Eq)++$(mkLabels [''Cookie])+++-- | Short notation for cookies++data CookieShort = +  CookieShort+    { _s_name  :: String+    , _s_value   :: String+    } deriving (Show, Eq)++$(mkLabels [''CookieShort])++-- | Convert Cookie to CookieShort+toShort :: Cookie -> CookieShort+toShort c = CookieShort (get name c) (get value c)++emptyShort :: CookieShort+emptyShort = CookieShort "" ""++-- | Create an empty cookie.++empty :: Cookie+empty = Cookie "" "" Nothing Nothing Nothing Nothing Nothing Nothing Nothing [] False 0++-- | Show a semicolon separated list of attribute/value pairs. Only meta pairs+-- with significant values will be pretty printed.++showSetCookie :: Cookie -> ShowS+showSetCookie c =+    pair (get name c) (get value c)+  . opt  "comment"    (get comment c)+  . opt  "commentURL" (get commentURL c)+  . opt  "discard"    (get discard c)+  . opt  "domain"     (get domain c)+  . opt  "maxAge"     (fmap show $ get maxAge c)+  . opt  "expires"    (get expires c)+  . opt  "path"       (get path c)+  . lst  "port"       (map show $ get port c)+  . bool "secure"     (get secure c)+  . opt  "version"    (optval $ get version c)+  where+    attr a       = showString a+    val v        = showString ("=" ++ v)+    end          = showString "; "+    single a     = attr a . end+    pair a v     = attr a . val v . end+    opt a        = maybe id (pair a)+    lst _ []     = id+    lst a xs     = pair a $ intercalate "," xs+    bool _ False = id+    bool a True  = single a+    optval 0     = Nothing+    optval i     = Just (show i)++(!$) a b = b $ a+infixr 0 !$++parseSetCookie :: String -> Cookie+parseSetCookie s = +  let p = fw (keyValues ";" "=") s+  in Cookie+    { _name       = p !$ headMay >>> fmap fst >>> fromMaybe "" +    , _value      = p !$ headMay >>> fmap snd >>> fromMaybe ""+    , _comment    = p !$ lookup "comment"+    , _commentURL = p !$ lookup "commentURL"+    , _discard    = p !$ lookup "discard"+    , _domain     = p !$ lookup "domain"+    , _maxAge     = p !$ lookup "maxAge" >>> fmap readMay >>> join+    , _expires    = p !$ lookup "expires"+    , _path       = p !$ lookup "path"+    , _port       = p !$ lookup "port" >>> maybe [] (readDef [-1])+    , _secure     = p !$ lookup "secure" >>> maybe False (const True)+    , _version    = p !$ lookup "version" >>> maybe 1 (readDef 1)+    }++showCookie :: CookieShort -> String+showCookie c = _s_name c ++ "=" ++ _s_value c++parseCookie :: String -> CookieShort+parseCookie s =+  let p = fw (values "=") s+  in emptyShort+       { _s_name  = atDef "" p 0+       , _s_value = atDef "" p 1+       }++-- | Cookie parser and pretty printer as a lens. To be used in combination with+-- the /Set-Cookie/ header field.++setCookie :: Bijection (->) String Cookie+setCookie = Bij parseSetCookie (flip showSetCookie "")++-- cookieShort :: Bijection (->) String [CookieShort]+-- cookieShort = Bij parseCookie showCookie++-- | Cookie parser and pretty printer as a lens. To be used in combination with+-- the /Cookie/ header field.++cookie :: Bijection (->) String [CookieShort]+cookie = (A.liftBij $ Bij parseCookie showCookie) . values ";"++-- | A collection of multiple cookies. These can all be set in one single HTTP+-- /Set-Cookie/ header field.++data Cookies = Cookies { _unCookies :: M.Map String Cookie }+  deriving (Eq, Show, Read)++emptyC = Cookies M.empty++instance Monoid Cookies where+    mempty = emptyC+    mappend (Cookies a) (Cookies b) = Cookies (a`mappend`b)++$(mkLabels [''Cookies])++-- | Case-insensitive way of getting a cookie out of a collection by name.++pickCookie :: String -> Cookies :-> Maybe Cookie+pickCookie n = lookupL (map toLower n) . unCookies where+    lookupL k = lens (M.lookup k) (flip M.alter k . const)++-- | Convert a list to a cookies collection.++fromList :: [Cookie] -> Cookies+fromList = Cookies . M.fromList . map (\a -> (map toLower $ get name a, a))++-- | Get the cookies as a list.++toList :: Cookies -> [Cookie]+toList = map snd . M.toList . get unCookies++-- | Converts to/from cookie collection using a list++gather :: Bijection (->) [Cookie] Cookies+gather = Bij fromList toList+

@@ -0,0 +1,130 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+module Network.Protocol.Http+  (++  -- * HTTP message data types.++    Method (..)+  , Version+  , Key+  , Value+  , Headers (..)+  , Request (Request)+  , Response (Response)+  , Http (Http)++  -- * Creating (parts of) messages.++  , http10+  , http11+  , emptyHeaders+  , emptyRequest+  , emptyResponse++  -- * Accessing fields.++  , methods+  , major+  , minor+  , headers+  , version+  , headline+  , method+  , uri+  , asUri+  , status+  , normalizeHeader+  , header++  -- * Accessing specific header fields.++  , contentLength+  , connection+  , accept+  , acceptEncoding+  , acceptLanguage+  , cacheControl+  , keepAlive+  , setCookies+  , cookiesShort+  , location+  , contentType+  , date+  , hostname+  , server+  , userAgent+  , upgrade+  , lastModified+  , acceptRanges+  , eTag++  -- * Parsing HTTP messages.++  , parseRequest+  , parseResponse+  , parseResponseHead+  , parseHeaders++  -- * Exposure of internal parsec parsers.++  , pRequest+  , pResponse+  , pHeaders+  , pVersion+  , pMethod++  -- * Parser helper methods.++  , versionFromString+  , methodFromString++  -- * Printer helper methods.++  , showRequestLine+  , showResponseLine+  , printResponse+  , printRequest++  -- * Handling HTTP status codes.++  , Status (..)+  , statusFailure+  , statusFromCode+  , codeFromStatus++  ) where++import Network.Protocol.Http.Data+import Network.Protocol.Http.Parser+import Network.Protocol.Http.Printer+import Network.Protocol.Http.Headers+import Network.Protocol.Http.Status+

@@ -0,0 +1,176 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Network.Protocol.Http.Data where++import Control.Category+import Data.Char+import Data.List+import Data.List.Split+import Data.Label+import Network.Protocol.Http.Status+import Network.Protocol.Uri+import Prelude hiding ((.), id, lookup, mod)++-- | List of HTTP request methods.++data Method =+    OPTIONS+  | GET+  | HEAD+  | POST+  | PUT+  | DELETE+  | TRACE+  | CONNECT+  | OTHER String+  deriving (Read, Show, Eq)++-- | HTTP protocol version.++data Version = Version {_major :: Int, _minor :: Int}+  deriving (Read, Show, Eq, Ord)++type Key   = String+type Value = String++-- | HTTP headers as mapping from keys to values.++newtype Headers = Headers { unHeaders :: [(Key, Value)] } -- order seems to matter+  deriving (Read, Show, Eq)++-- | Request specific part of HTTP messages.++data Request = Request  { __method :: Method, __uri :: String }+  deriving (Read, Show, Eq)++-- | Response specific part of HTTP messages.++data Response = Response { __status :: Status }+  deriving (Read, Show, Eq)++-- | An HTTP message. The message body is *not* included.++data Http a = Http+  { _headline :: a+  , _version  :: Version+  , _headers  :: Headers+  } deriving (Read, Show, Eq)++-- | All recognized method constructors as a list.++methods :: [Method]+methods = [OPTIONS, GET, HEAD, POST, PUT, DELETE, TRACE, CONNECT]++-- | Create HTTP 1.0 version.++http10 :: Version+http10 = Version 1 0++-- | Create HTTP 1.1 version.++http11 :: Version+http11 = Version 1 1++-- | Create an empty set of headers.++emptyHeaders :: Headers+emptyHeaders = Headers []++-- | Create an empty HTTP request message.++emptyRequest :: Http Request+emptyRequest = Http (Request GET "") http11 emptyHeaders++-- | Create an empty HTTP response message.++emptyResponse :: Http Response+emptyResponse = Http (Response OK) http11 emptyHeaders++$(mkLabels [''Version, ''Request, ''Response, ''Http])++-- | Label to access the method part of an HTTP request message.++method :: Http Request :-> Method+method = _method . headline++-- | Label to access the URI part of an HTTP request message.++uri :: Http Request :-> String+uri = _uri . headline++-- | Label to access the URI part of an HTTP request message and access it as a+-- true URI data type.++asUri :: Http Request :-> Uri+asUri = (Bij toUri showUri) `iso` uri++-- | Label to access the status part of an HTTP response message.++status :: Http Response :-> Status+status = _status . headline++-- | Normalize the capitalization of an HTTP header key.++normalizeHeader :: Key -> Key+normalizeHeader = intercalate "-" . map casing . splitOn "-"+  where+  casing ""     = ""+  casing (x:xs) = toUpper x : map toLower xs++-- | Generic label to access an HTTP header field by key. Returns first matching+-- field++header :: Key -> Http a :-> Maybe Value+header key = lens+  (lookup (normalizeHeader key) . unHeaders . get headers)+  (\x -> modify headers (Headers . alter (normalizeHeader key) x . unHeaders))+  where+  alter :: Eq a => a -> Maybe b -> [(a, b)] -> [(a, b)]+  alter k v []                      = maybe [] (\w -> (k, w):[]) v+  alter k v ((x, y):xs) | k == x    = maybe xs (\w -> (k, w):xs) v+                        | otherwise = (x, y) : alter k v xs++-- | Label to access HTTP header fields, return a list of matching fields++headerMany :: Key -> Http a :-> [Value]+headerMany key = lens+  (map snd . filter (key_is (normalizeHeader key)) . unHeaders . get headers)+  (\x -> modify headers (Headers . alter (normalizeHeader key) x . unHeaders))+  where+  alter :: Eq a => a -> [b] -> [(a, b)] -> [(a, b)]+  alter k []     []                      = []+  alter k []     ((x, y):xs) | k == x    =          alter k [] xs+                             | otherwise = (x, y) : alter k [] xs+  alter k (v:vs) []                      = (k, v) : alter k vs []+  alter k (v:vs) ((x, y):xs) | k == x    = (k, v) : alter k vs xs+                             | otherwise = (x, y) : alter k (v:vs) xs+  key_is k' (k,v) = k==k'+

@@ -0,0 +1,153 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.++-}+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Http.Headers where {- doc ok -}++import Control.Category+import Control.Monad+import Data.Label as L+import Data.Monoid+import Data.Label.Abstract as A+import Network.Protocol.Http.Data+import Network.Protocol.Uri.Query+import Network.Protocol.Uri+import Network.Protocol.Cookie+import Prelude hiding ((.), id)+import Safe++-- | Access the /Content-Length/ header field.++contentLength :: (Show i, Read i, Integral i) => Http a :-> Maybe i+contentLength = (Bij (join . fmap readMay) (fmap show)) `iso` header "Content-Length"++-- | Access the /Connection/ header field.++connection :: Http a :-> Maybe String+connection = header "Connection"++-- | Access the /Accept/ header field.++accept :: Http a :-> Maybe Parameters+accept = liftBij (keyValues "," ";") `iso` header "Accept"++-- | Access the /Accept-Encoding/ header field.++acceptEncoding :: Http a :-> Maybe [String]+acceptEncoding = liftBij (values ",") `iso` header "Accept-Encoding"++-- | Access the /Accept-Language/ header field.++acceptLanguage :: Http a :-> Maybe [String]+acceptLanguage = liftBij (values ",") `iso` header "Accept-Language"++-- | Access the /Connection/ header field.++cacheControl :: Http a :-> Maybe String+cacheControl = header "Cache-Control"++-- | Access the /Keep-Alive/ header field.++keepAlive :: (Show i, Read i, Integral i) => Http a :-> Maybe i+keepAlive = (Bij (join . fmap readMay) (fmap show)) `iso` header "Keep-Alive"++maybe2list :: Bijection (->) b [c] -> (a :-> (Maybe b)) -> (a :-> [c])+maybe2list b l = L.lens g s where+   g x = maybe [] (fw b) (L.get l x)+   s [] x = L.set l (Nothing) x+   s c x = L.set l (Just $ bw b c) x++-- | Access the /Cookie/ header field.++cookiesShort :: Http Request :-> [CookieShort]+cookiesShort = maybe2list (cookie) (header "Cookie")++-- | Access the /Set-Cookie/ fields.++setCookies :: Http Response :-> Cookies+setCookies = (gather . liftBij setCookie) `iso` (headerMany "Set-Cookie")++-- | Access the /Location/ header field.++location :: Http a :-> Maybe Uri+location = liftBij (Bij toUri showUri) `iso` (header "Location")++-- | Access the /Content-Type/ header field. The content-type will be parsed+-- into a mimetype and optional charset.++contentType :: Http a :-> Maybe (String, String)+contentType = +        liftBij (Bij parser printer)+  `iso` liftBij (keyValues ";" "=")+  `iso` header "Content-Type"+  where +    printer (x, y) = (x, "") : ("charset", y) : []+    parser ((m, _):("charset", c):_) = (m, c)++-- | Access the /Date/ header field.++date :: Http a :-> Maybe String+date = header "Date"++-- | Access the /Host/ header field.++hostname :: Http a :-> Maybe String+hostname = header "Host"++-- | Access the /Server/ header field.++server :: Http a :-> Maybe String+server = header "Server"++-- | Access the /User-Agent/ header field.++userAgent :: Http a :-> Maybe String+userAgent = header "User-Agent"++-- | Access the /Upgrade/ header field.++upgrade :: Http a :-> Maybe String+upgrade = header "Upgrade"++-- | Access the /Last-Modified/ header field.++lastModified :: Http a :-> Maybe Value+lastModified = header "Last-Modified"++-- | Access the /Accept-Ranges/ header field.++acceptRanges :: Http a :-> Maybe Value+acceptRanges = header "Accept-Ranges"++-- | Access the /ETag/ header field.++eTag :: Http a :-> Maybe Value+eTag = header "ETag"+

@@ -0,0 +1,174 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators, FlexibleContexts #-}+module Network.Protocol.Http.Parser+(++-- * Top level message parsers.++  parseRequest+, parseResponseHead+, parseResponse+, parseHeaders++-- * Exposure of internal parsec parsers.++, pRequest+, pResponse+, pHeaders+, pVersion+, pMethod++-- * Helper methods.++, versionFromString+, methodFromString++)+where++import Control.Applicative hiding (empty)+import Data.Char+import Data.List hiding (insert)+import Network.Protocol.Http.Data+import Network.Protocol.Http.Status+import Text.Parsec hiding (many, (<|>))+import Text.Parsec.String++-- | Parse a string as an HTTP request message. This parser is very forgiving.++parseRequest :: String -> Either String (Http Request)+parseRequest = either (Left . show) (Right . id) . parse pRequest ""++-- | Parse a string as an HTTP response header message. This parser is very forgiving.++parseResponseHead :: String -> Either String (Http Response)+parseResponseHead = either (Left . show) (Right . id) . parse pResponse ""++-- | Parse a string as an HTTP response header and body. This parser is very forgiving.++parseResponse :: String -> Either String (Http Response, String)+parseResponse = either (Left . show) (Right . id) . parse fp ""+    where fp = (\a b->(a,b)) <$> pResponse <*> manyTill anyChar eof++-- | Parse a string as a list of HTTP headers.++parseHeaders :: String -> Either String Headers+parseHeaders = either (Left . show) (Right . id) . parse pHeaders ""++-- | Parsec parser to parse the header part of an HTTP request.++pRequest :: GenParser Char st (Http Request)+pRequest =+      (\m u v h -> Http (Request m u) v h)+  <$> (pMethod <* many1 (oneOf ls))+  <*> (many1 (noneOf ws) <* many1 (oneOf ls))+  <*> (pVersion <* eol)+  <*> (pHeaders <* eol)++-- | Parsec parser to parse the header part of an HTTP response.++pResponse :: GenParser Char st (Http Response)+pResponse =+      (\v s h -> Http (Response (statusFromCode $ read s)) v h)+  <$> (pVersion <* many1 (oneOf ls))+  <*> (many1 digit <* many1 (oneOf ls) <* many1 (noneOf lf) <* eol)+  <*> (pHeaders <* eol)++-- | Parsec parser to parse one or more, possibly multiline, HTTP header lines.++pHeaders :: GenParser Char st Headers+pHeaders = Headers <$> p+  where+    p = (\k v -> ((k, v):))+        <$> many1 (noneOf (':':ws)) <* string ":"+        <*> (intercalate ws <$> (many $ many1 (oneOf ls) *> many1 (noneOf lf) <* eol))+        <*> option [] p++-- | Parsec parser to parse HTTP versions. Recognizes X.X versions only.++pVersion :: GenParser Char st Version+pVersion = +      (\h l -> Version (ord h - ord '0') (ord l  - ord '0'))+  <$> (istring "HTTP/" *> digit)+  <*> (char '.'       *> digit)++-- | Parsec parser to parse an HTTP method. Parses arbitrary method but+-- actually recognizes the ones listed as a constructor for `Method'.++pMethod :: GenParser Char st Method+pMethod =+     choice+   $ map (\a -> a <$ (try . istring . show $ a)) methods+  ++ [OTHER <$> many (noneOf ws)]++-- | Recognizes HTTP protocol version 1.0 and 1.1, all other string will+-- produce version 1.1.++versionFromString :: String -> Version+versionFromString "HTTP/1.1" = http11+versionFromString "HTTP/1.0" = http10+versionFromString _          = http11++-- | Helper to turn fully capitalized string into request method.++methodFromString :: String -> Method+methodFromString "OPTIONS" = OPTIONS+methodFromString "GET"     = GET +methodFromString "HEAD"    = HEAD+methodFromString "POST"    = POST+methodFromString "PUT"     = PUT +methodFromString "DELETE"  = DELETE+methodFromString "TRACE"   = TRACE+methodFromString "CONNECT" = CONNECT+methodFromString xs        = OTHER xs++-- Helpers.++lf, ws, ls :: String+lf = "\r\n"+ws = " \t\r\n"+ls = " \t"++-- Optional parser with maybe result.++pMaybe :: GenParser Char st a -> GenParser Char st (Maybe a)+pMaybe a = option Nothing (Just <$> a)++-- Parse end of line, \r, \n or \r\n.++eol :: GenParser Char st ()+eol = () <$ ((char '\r' <* pMaybe (char '\n')) <|> char '\n')++-- Case insensitive string parser.++istring :: String -> GenParser Char st String+istring s = sequence (map (\c -> satisfy (\d -> toUpper c == toUpper d)) s)+

@@ -0,0 +1,88 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE FlexibleInstances #-}+module Network.Protocol.Http.Printer where++import Network.Protocol.Http.Data+import Network.Protocol.Http.Status++-- instance Show (Http Request) where+--   showsPrec _ r@(Http Request {} _ hs) =+--     showRequestLine r . shows hs . eol++printRequest :: Http Request -> String+printRequest r@(Http Request {} _ hs) = (showRequestLine r . showHeaders hs . eol) ""++-- instance Show (Http Response) where+--   showsPrec _ r@(Http Response {} _ hs) =+--     showResponseLine r . shows hs . eol++printResponse :: Http Response -> String+printResponse r@(Http Response {} _ hs) = (showResponseLine r . showHeaders hs . eol) ""++-- | Show HTTP request status line.++showRequestLine :: Http Request -> String -> String+showRequestLine (Http (Request m u) v _) =+    shows m . ss " " . ss u . ss " "+  . showVersion v . eol++-- | Show HTTP response status line.++showResponseLine :: Http Response -> String -> String+showResponseLine (Http (Response s) v _) =+    showVersion v . ss " "+  . shows (codeFromStatus s)+  . ss " " . shows s . eol++showHeaders :: Headers -> ShowS+showHeaders =+      foldr (\a b -> a . eol . b) id+    . map (\(k, a) -> ss k . ss ": " . ss a)+    . unHeaders++-- instance Show Headers where+--   showsPrec _ =+--       foldr (\a b -> a . eol . b) id+--     . map (\(k, a) -> ss k . ss ": " . ss a)+--     . unHeaders++showVersion :: Version -> ShowS+showVersion (Version a b) = ss "HTTP/" . shows a . ss "." . shows b++-- instance Show Version where+--   showsPrec _ (Version a b) = ss "HTTP/" . shows a . ss "." . shows b++eol :: ShowS+eol = ss "\r\n"++ss :: String -> ShowS+ss = showString+

@@ -0,0 +1,193 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+module Network.Protocol.Http.Status where {- doc ok -}++import Data.Bimap+import Data.Maybe+import Prelude hiding (lookup)++{- | HTTP status codes. -}++data Status =+    Continue                     -- ^ 100+  | SwitchingProtocols           -- ^ 101+  | OK                           -- ^ 200+  | Created                      -- ^ 201+  | Accepted                     -- ^ 202+  | NonAuthoritativeInformation  -- ^ 203+  | NoContent                    -- ^ 204+  | ResetContent                 -- ^ 205+  | PartialContent               -- ^ 206+  | MultipleChoices              -- ^ 300+  | MovedPermanently             -- ^ 301+  | Found                        -- ^ 302+  | SeeOther                     -- ^ 303+  | NotModified                  -- ^ 304+  | UseProxy                     -- ^ 305+  | TemporaryRedirect            -- ^ 307+  | BadRequest                   -- ^ 400+  | Unauthorized                 -- ^ 401+  | PaymentRequired              -- ^ 402+  | Forbidden                    -- ^ 403+  | NotFound                     -- ^ 404+  | MethodNotAllowed             -- ^ 405+  | NotAcceptable                -- ^ 406+  | ProxyAuthenticationRequired  -- ^ 407+  | RequestTimeOut               -- ^ 408+  | Conflict                     -- ^ 409+  | Gone                         -- ^ 410+  | LengthRequired               -- ^ 411+  | PreconditionFailed           -- ^ 412+  | RequestEntityTooLarge        -- ^ 413+  | RequestURITooLarge           -- ^ 414+  | UnsupportedMediaType         -- ^ 415+  | RequestedRangeNotSatisfiable -- ^ 416+  | ExpectationFailed            -- ^ 417+  | InternalServerError          -- ^ 500+  | NotImplemented               -- ^ 501+  | BadGateway                   -- ^ 502+  | ServiceUnavailable           -- ^ 503+  | GatewayTimeOut               -- ^ 504+  | HTTPVersionNotSupported      -- ^ 505+  | CustomStatus Int String+  deriving (Show, Read, Eq, Ord)++-- | rfc2616 sec6.1.1 Status Code and Reason Phrase.++printStatus :: Status -> String+printStatus Continue                     = "Continue"+printStatus SwitchingProtocols           = "Switching Protocols"+printStatus OK                           = "OK"+printStatus Created                      = "Created"+printStatus Accepted                     = "Accepted"+printStatus NonAuthoritativeInformation  = "Non-Authoritative Information"+printStatus NoContent                    = "No Content"+printStatus ResetContent                 = "Reset Content"+printStatus PartialContent               = "Partial Content"+printStatus MultipleChoices              = "Multiple Choices"+printStatus MovedPermanently             = "Moved Permanently"+printStatus Found                        = "Found"+printStatus SeeOther                     = "See Other"+printStatus NotModified                  = "Not Modified"+printStatus UseProxy                     = "Use Proxy"+printStatus TemporaryRedirect            = "Temporary Redirect"+printStatus BadRequest                   = "Bad Request"+printStatus Unauthorized                 = "Unauthorized"+printStatus PaymentRequired              = "Payment Required"+printStatus Forbidden                    = "Forbidden"+printStatus NotFound                     = "Not Found"+printStatus MethodNotAllowed             = "Method Not Allowed"+printStatus NotAcceptable                = "Not Acceptable"+printStatus ProxyAuthenticationRequired  = "Proxy Authentication Required"+printStatus RequestTimeOut               = "Request Time-out"+printStatus Conflict                     = "Conflict"+printStatus Gone                         = "Gone"+printStatus LengthRequired               = "Length Required"+printStatus PreconditionFailed           = "Precondition Failed"+printStatus RequestEntityTooLarge        = "Request Entity Too Large"+printStatus RequestURITooLarge           = "Request-URI Too Large"+printStatus UnsupportedMediaType         = "Unsupported Media Type"+printStatus RequestedRangeNotSatisfiable = "Requested range not satisfiable"+printStatus ExpectationFailed            = "Expectation Failed"+printStatus InternalServerError          = "Internal Server Error"+printStatus NotImplemented               = "Not Implemented"+printStatus BadGateway                   = "Bad Gateway"+printStatus ServiceUnavailable           = "Service Unavailable"+printStatus GatewayTimeOut               = "Gateway Time-out"+printStatus HTTPVersionNotSupported      = "HTTP Version not supported"+printStatus (CustomStatus _ s)           = s++{- |+RFC2616 sec6.1.1 Status Code and Reason Phrase.++Bidirectional mapping from status numbers to codes.+-}++statusCodes :: Bimap Int Status+statusCodes = fromList [+    (100, Continue)+  , (101, SwitchingProtocols)+  , (200, OK)+  , (201, Created)+  , (202, Accepted)+  , (203, NonAuthoritativeInformation)+  , (204, NoContent)+  , (205, ResetContent)+  , (206, PartialContent)+  , (300, MultipleChoices)+  , (301, MovedPermanently)+  , (302, Found)+  , (303, SeeOther)+  , (304, NotModified)+  , (305, UseProxy)+  , (307, TemporaryRedirect)+  , (400, BadRequest)+  , (401, Unauthorized)+  , (402, PaymentRequired)+  , (403, Forbidden)+  , (404, NotFound)+  , (405, MethodNotAllowed)+  , (406, NotAcceptable)+  , (407, ProxyAuthenticationRequired)+  , (408, RequestTimeOut)+  , (409, Conflict)+  , (410, Gone)+  , (411, LengthRequired)+  , (412, PreconditionFailed)+  , (413, RequestEntityTooLarge)+  , (414, RequestURITooLarge)+  , (415, UnsupportedMediaType)+  , (416, RequestedRangeNotSatisfiable)+  , (417, ExpectationFailed)+  , (500, InternalServerError)+  , (501, NotImplemented)+  , (502, BadGateway)+  , (503, ServiceUnavailable)+  , (504, GatewayTimeOut)+  , (505, HTTPVersionNotSupported)+  ]++-- | Every status greater-than or equal to 400 is considered to be a failure.+statusFailure :: Status -> Bool+statusFailure st = codeFromStatus st >= 400++-- | Conversion from status numbers to codes.+statusFromCode :: Int -> Status+statusFromCode num =+    fromMaybe (CustomStatus num "Unknown Status")+  $ lookup num statusCodes++-- | Conversion from status codes to numbers.+codeFromStatus :: Status -> Int+codeFromStatus (CustomStatus i _) = i+codeFromStatus st =+    fromMaybe 0 -- function is total, should not happen.+  $ lookupR st statusCodes+

@@ -0,0 +1,695 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}++module Network.Protocol.Mime where++import Data.Map+++{- |+Handling mime types. This module contains a mapping from file extensions to+mime-types taken from the Apache webserver project.+-}++type Mime = String++{- | Get the mimetype for the specified extension. -}++mime :: String -> Maybe Mime+mime ext = Data.Map.lookup ext extensionToMime++{- | The default mimetype is text/plain. -}++defaultMime :: Mime+defaultMime = "text/plain"++{- | The mapping from extension to mimetype. -}++extensionToMime :: Map String Mime+extensionToMime = fromList+  [ ("123",       "application/vnd.lotus-1-2-3")+  , ("3dml",      "text/vnd.in3d.3dml")+  , ("3g2",       "video/3gpp2")+  , ("3gp",       "video/3gpp")+  , ("ace",       "application/x-ace-compressed")+  , ("acu",       "application/vnd.acucobol")+  , ("acutc",     "application/vnd.acucorp")+  , ("aep",       "application/vnd.audiograph")+  , ("afp",       "application/vnd.ibm.modcap")+  , ("ai",        "application/postscript")+  , ("aif",       "audio/x-aiff")+  , ("aifc",      "audio/x-aiff")+  , ("aiff",      "audio/x-aiff")+  , ("ami",       "application/vnd.amiga.ami")+  , ("apr",       "application/vnd.lotus-approach")+  , ("asc",       "application/pgp-signature")+  , ("asf",       "application/vnd.ms-asf")+  , ("asf",       "video/x-ms-asf")+  , ("asm",       "text/x-asm")+  , ("aso",       "application/vnd.accpac.simply.aso")+  , ("asx",       "video/x-ms-asf")+  , ("atc",       "application/vnd.acucorp")+  , ("atom",      "application/atom+xml")+  , ("atomcat",   "application/atomcat+xml")+  , ("atomsvc",   "application/atomsvc+xml")+  , ("atx",       "application/vnd.antix.game-component")+  , ("au",        "audio/basic")+  , ("bat",       "application/x-msdownload")+  , ("bcpio",     "application/x-bcpio")+  , ("bdm",       "application/vnd.syncml.dm+wbxml")+  , ("bh2",       "application/vnd.fujitsu.oasysprs")+  , ("bin",       "application/octet-stream")+  , ("bmi",       "application/vnd.bmi")+  , ("bmp",       "image/bmp")+  , ("box",       "application/vnd.previewsystems.box")+  , ("boz",       "application/x-bzip2")+  , ("bpk",       "application/octet-stream")+  , ("btif",      "image/prs.btif")+  , ("bz",        "application/x-bzip")+  , ("bz2",       "application/x-bzip2")+  , ("c",         "text/x-c")+  , ("c4d",       "application/vnd.clonk.c4group")+  , ("c4f",       "application/vnd.clonk.c4group")+  , ("c4g",       "application/vnd.clonk.c4group")+  , ("c4p",       "application/vnd.clonk.c4group")+  , ("c4u",       "application/vnd.clonk.c4group")+  , ("cab",       "application/vnd.ms-cab-compressed")+  , ("cc",        "text/x-c")+  , ("ccxml",     "application/ccxml+xml")+  , ("cdbcmsg",   "application/vnd.contact.cmsg")+  , ("cdf",       "application/x-netcdf")+  , ("cdkey",     "application/vnd.mediastation.cdkey")+  , ("cdx",       "chemical/x-cdx")+  , ("cdxml",     "application/vnd.chemdraw+xml")+  , ("cdy",       "application/vnd.cinderella")+  , ("cer",       "application/pkix-cert")+  , ("cgm",       "image/cgm")+  , ("chat",      "application/x-chat")+  , ("chm",       "application/vnd.ms-htmlhelp")+  , ("chrt",      "application/vnd.kde.kchart")+  , ("cif",       "chemical/x-cif")+  , ("cii",       "application/vnd.anser-web-certificate-issue-initiation")+  , ("cil",       "application/vnd.ms-artgalry")+  , ("cla",       "application/vnd.claymore")+  , ("class",     "application/octet-stream")+  , ("clkk",      "application/vnd.crick.clicker.keyboard")+  , ("clkp",      "application/vnd.crick.clicker.palette")+  , ("clkt",      "application/vnd.crick.clicker.template")+  , ("clkw",      "application/vnd.crick.clicker.wordbank")+  , ("clkx",      "application/vnd.crick.clicker")+  , ("clp",       "application/x-msclip")+  , ("cmc",       "application/vnd.cosmocaller")+  , ("cmdf",      "chemical/x-cmdf")+  , ("cml",       "chemical/x-cml")+  , ("cmp",       "application/vnd.yellowriver-custom-menu")+  , ("cmx",       "image/x-cmx")+  , ("com",       "application/x-msdownload")+  , ("conf",      "text/plain")+  , ("cpio",      "application/x-cpio")+  , ("cpp",       "text/x-c")+  , ("cpt",       "application/mac-compactpro")+  , ("crd",       "application/x-mscardfile")+  , ("crl",       "application/pkix-crl")+  , ("crt",       "application/x-x509-ca-cert")+  , ("csh",       "application/x-csh")+  , ("csml",      "chemical/x-csml")+  , ("csp",       "application/vnd.commonspace")+  , ("css",       "text/css")+  , ("cst",       "application/vnd.commonspace")+  , ("csv",       "text/csv")+  , ("curl",      "application/vnd.curl")+  , ("cww",       "application/prs.cww")+  , ("cxx",       "text/x-c")+  , ("daf",       "application/vnd.mobius.daf")+  , ("davmount",  "application/davmount+xml")+  , ("dcr",       "application/x-director")+  , ("dd2",       "application/vnd.oma.dd2+xml")+  , ("ddd",       "application/vnd.fujixerox.ddd")+  , ("def",       "text/plain")+  , ("der",       "application/x-x509-ca-cert")+  , ("dfac",      "application/vnd.dreamfactory")+  , ("dic",       "text/x-c")+  , ("dir",       "application/x-director")+  , ("dis",       "application/vnd.mobius.dis")+  , ("dist",      "application/octet-stream")+  , ("distz",     "application/octet-stream")+  , ("djv",       "image/vnd.djvu")+  , ("djvu",      "image/vnd.djvu")+  , ("dll",       "application/x-msdownload")+  , ("dmg",       "application/octet-stream")+  , ("dms",       "application/octet-stream")+  , ("dna",       "application/vnd.dna")+  , ("doc",       "application/msword")+  , ("dot",       "application/msword")+  , ("dp",        "application/vnd.osgi.dp")+  , ("dpg",       "application/vnd.dpgraph")+  , ("dsc",       "text/prs.lines.tag")+  , ("dtd",       "application/xml-dtd")+  , ("dump",      "application/octet-stream")+  , ("dvi",       "application/x-dvi")+  , ("dwf",       "model/vnd.dwf")+  , ("dwg",       "image/vnd.dwg")+  , ("dxf",       "image/vnd.dxf")+  , ("dxp",       "application/vnd.spotfire.dxp")+  , ("dxr",       "application/x-director")+  , ("ecelp4800", "audio/vnd.nuera.ecelp4800")+  , ("ecelp7470", "audio/vnd.nuera.ecelp7470")+  , ("ecelp9600", "audio/vnd.nuera.ecelp9600")+  , ("ecma",      "application/ecmascript")+  , ("edm",       "application/vnd.novadigm.edm")+  , ("edx",       "application/vnd.novadigm.edx")+  , ("efif",      "application/vnd.picsel")+  , ("ei6",       "application/vnd.pg.osasli")+  , ("elc",       "application/octet-stream")+  , ("eml",       "message/rfc822")+  , ("eol",       "audio/vnd.digital-winds")+  , ("eot",       "application/vnd.ms-fontobject")+  , ("eps",       "application/postscript")+  , ("es3",       "application/vnd.eszigno3+xml")+  , ("esf",       "application/vnd.epson.esf")+  , ("et3",       "application/vnd.eszigno3+xml")+  , ("etx",       "text/x-setext")+  , ("exe",       "application/x-msdownload")+  , ("ext",       "application/vnd.novadigm.ext")+  , ("ez",        "application/andrew-inset")+  , ("ez2",       "application/vnd.ezpix-album")+  , ("ez3",       "application/vnd.ezpix-package")+  , ("f",         "text/x-fortran")+  , ("f77",       "text/x-fortran")+  , ("f90",       "text/x-fortran")+  , ("fbs",       "image/vnd.fastbidsheet")+  , ("fdf",       "application/vnd.fdf")+  , ("fe_launch", "application/vnd.denovo.fcselayout-link")+  , ("fg5",       "application/vnd.fujitsu.oasysgp")+  , ("fgd",       "application/x-director")+  , ("fli",       "video/x-fli")+  , ("flo",       "application/vnd.micrografx.flo")+  , ("flw",       "application/vnd.kde.kivio")+  , ("flx",       "text/vnd.fmi.flexstor")+  , ("fly",       "text/vnd.fly")+  , ("fm",        "application/vnd.framemaker")+  , ("fnc",       "application/vnd.frogans.fnc")+  , ("for",       "text/x-fortran")+  , ("fpx",       "image/vnd.fpx")+  , ("frame",     "application/vnd.framemaker")+  , ("fsc",       "application/vnd.fsc.weblaunch")+  , ("fst",       "image/vnd.fst")+  , ("ftc",       "application/vnd.fluxtime.clip")+  , ("fti",       "application/vnd.anser-web-funds-transfer-initiation")+  , ("fvt",       "video/vnd.fvt")+  , ("fzs",       "application/vnd.fuzzysheet")+  , ("g3",        "image/g3fax")+  , ("gac",       "application/vnd.groove-account")+  , ("gdl",       "model/vnd.gdl")+  , ("ghf",       "application/vnd.groove-help")+  , ("gif",       "image/gif")+  , ("gim",       "application/vnd.groove-identity-message")+  , ("gph",       "application/vnd.flographit")+  , ("gqf",       "application/vnd.grafeq")+  , ("gqs",       "application/vnd.grafeq")+  , ("gram",      "application/srgs")+  , ("grv",       "application/vnd.groove-injector")+  , ("grxml",     "application/srgs+xml")+  , ("gtar",      "application/x-gtar")+  , ("gtm",       "application/vnd.groove-tool-message")+  , ("gtw",       "model/vnd.gtw")+  , ("h",         "text/x-c")+  , ("h261",      "video/h261")+  , ("h263",      "video/h263")+  , ("h264",      "video/h264")+  , ("hbci",      "application/vnd.hbci")+  , ("hdf",       "application/x-hdf")+  , ("hh",        "text/x-c")+  , ("hlp",       "application/winhlp")+  , ("hpgl",      "application/vnd.hp-hpgl")+  , ("hpid",      "application/vnd.hp-hpid")+  , ("hps",       "application/vnd.hp-hps")+  , ("hqx",       "application/mac-binhex40")+  , ("htke",      "application/vnd.kenameaapp")+  , ("htm",       "text/html")+  , ("html",      "text/html")+  , ("hvd",       "application/vnd.yamaha.hv-dic")+  , ("hvp",       "application/vnd.yamaha.hv-voice")+  , ("hvs",       "application/vnd.yamaha.hv-script")+  , ("ico",       "image/vnd.microsoft.icon")+  , ("ics",       "text/calendar")+  , ("ief",       "image/ief")+  , ("ifb",       "text/calendar")+  , ("ifm",       "application/vnd.shana.informed.formdata")+  , ("iges",      "model/iges")+  , ("igl",       "application/vnd.igloader")+  , ("igs",       "model/iges")+  , ("igx",       "application/vnd.micrografx.igx")+  , ("iif",       "application/vnd.shana.informed.interchange")+  , ("imp",       "application/vnd.accpac.simply.imp")+  , ("ims",       "application/vnd.ms-ims")+  , ("in",        "text/plain")+  , ("ipk",       "application/vnd.shana.informed.package")+  , ("irm",       "application/vnd.ibm.rights-management")+  , ("irp",       "application/vnd.irepository.package+xml")+  , ("iso",       "application/octet-stream")+  , ("itp",       "application/vnd.shana.informed.formtemplate")+  , ("ivp",       "application/vnd.immervision-ivp")+  , ("ivu",       "application/vnd.immervision-ivu")+  , ("jad",       "text/vnd.sun.j2me.app-descriptor")+  , ("jam",       "application/vnd.jam")+  , ("java",      "text/x-java-source")+  , ("jisp",      "application/vnd.jisp")+  , ("jlt",       "application/vnd.hp-jlyt")+  , ("jpe",       "image/jpeg")+  , ("jpeg",      "image/jpeg")+  , ("jpg",       "image/jpeg")+  , ("jpgm",      "video/jpm")+  , ("jpgv",      "video/jpeg")+  , ("jpm",       "video/jpm")+  , ("js",        "application/javascript")+  , ("json",      "application/json")+  , ("kar",       "audio/midi")+  , ("karbon",    "application/vnd.kde.karbon")+  , ("kfo",       "application/vnd.kde.kformula")+  , ("kia",       "application/vnd.kidspiration")+  , ("kml",       "application/vnd.google-earth.kml+xml")+  , ("kmz",       "application/vnd.google-earth.kmz")+  , ("kne",       "application/vnd.kinar")+  , ("knp",       "application/vnd.kinar")+  , ("kon",       "application/vnd.kde.kontour")+  , ("kpr",       "application/vnd.kde.kpresenter")+  , ("kpt",       "application/vnd.kde.kpresenter")+  , ("ksp",       "application/vnd.kde.kspread")+  , ("ktr",       "application/vnd.kahootz")+  , ("ktz",       "application/vnd.kahootz")+  , ("kwd",       "application/vnd.kde.kword")+  , ("kwt",       "application/vnd.kde.kword")+  , ("latex",     "application/x-latex")+  , ("lbd",       "application/vnd.llamagraphics.life-balance.desktop")+  , ("lbe",       "application/vnd.llamagraphics.life-balance.exchange+xml")+  , ("les",       "application/vnd.hhe.lesson-player")+  , ("lha",       "application/octet-stream")+  , ("list",      "text/plain")+  , ("list3820",  "application/vnd.ibm.modcap")+  , ("listafp",   "application/vnd.ibm.modcap")+  , ("log",       "text/plain")+  , ("lrm",       "application/vnd.ms-lrm")+  , ("ltf",       "application/vnd.frogans.ltf")+  , ("lvp",       "audio/vnd.lucent.voice")+  , ("lwp",       "application/vnd.lotus-wordpro")+  , ("lzh",       "application/octet-stream")+  , ("m13",       "application/x-msmediaview")+  , ("m14",       "application/x-msmediaview")+  , ("m1v",       "video/mpeg")+  , ("m2a",       "audio/mpeg")+  , ("m2v",       "video/mpeg")+  , ("m3a",       "audio/mpeg")+  , ("m3u",       "audio/x-mpegurl")+  , ("m4u",       "video/vnd.mpegurl")+  , ("ma",        "application/mathematica")+  , ("mag",       "application/vnd.ecowin.chart")+  , ("maker",     "application/vnd.framemaker")+  , ("man",       "text/troff")+  , ("mathml",    "application/mathml+xml")+  , ("mb",        "application/mathematica")+  , ("mbk",       "application/vnd.mobius.mbk")+  , ("mbox",      "application/mbox")+  , ("mc1",       "application/vnd.medcalcdata")+  , ("mcd",       "application/vnd.mcd")+  , ("mdb",       "application/x-msaccess")+  , ("mdi",       "image/vnd.ms-modi")+  , ("me",        "text/troff")+  , ("mesh",      "model/mesh")+  , ("mfm",       "application/vnd.mfmp")+  , ("mgz",       "application/vnd.proteus.magazine")+  , ("mid",       "audio/midi")+  , ("midi",      "audio/midi")+  , ("mif",       "application/vnd.mif")+  , ("mime",      "message/rfc822")+  , ("mj2",       "video/mj2")+  , ("mjp2",      "video/mj2")+  , ("mlp",       "application/vnd.dolby.mlp")+  , ("mmd",       "application/vnd.chipnuts.karaoke-mmd")+  , ("mmf",       "application/vnd.smaf")+  , ("mmr",       "image/vnd.fujixerox.edmics-mmr")+  , ("mny",       "application/x-msmoney")+  , ("mov",       "video/quicktime")+  , ("mp2",       "audio/mpeg")+  , ("mp2a",      "audio/mpeg")+  , ("mp3",       "audio/mpeg")+  , ("mp4",       "video/mp4")+  , ("mp4a",      "audio/mp4")+  , ("mp4s",      "application/mp4")+  , ("mp4v",      "video/mp4")+  , ("mpc",       "application/vnd.mophun.certificate")+  , ("mpe",       "video/mpeg")+  , ("mpeg",      "video/mpeg")+  , ("mpg",       "video/mpeg")+  , ("mpg4",      "video/mp4")+  , ("mpga",      "audio/mpeg")+  , ("mpkg",      "application/vnd.apple.installer+xml")+  , ("mpm",       "application/vnd.blueice.multipass")+  , ("mpn",       "application/vnd.mophun.application")+  , ("mpp",       "application/vnd.ms-project")+  , ("mpt",       "application/vnd.ms-project")+  , ("mpy",       "application/vnd.ibm.minipay")+  , ("mqy",       "application/vnd.mobius.mqy")+  , ("mrc",       "application/marc")+  , ("ms",        "text/troff")+  , ("mscml",     "application/mediaservercontrol+xml")+  , ("mseq",      "application/vnd.mseq")+  , ("msf",       "application/vnd.epson.msf")+  , ("msh",       "model/mesh")+  , ("msi",       "application/x-msdownload")+  , ("msl",       "application/vnd.mobius.msl")+  , ("mts",       "model/vnd.mts")+  , ("mus",       "application/vnd.musician")+  , ("mvb",       "application/x-msmediaview")+  , ("mwf",       "application/vnd.mfer")+  , ("mxf",       "application/mxf")+  , ("mxl",       "application/vnd.recordare.musicxml")+  , ("mxml",      "application/xv+xml")+  , ("mxs",       "application/vnd.triscape.mxs")+  , ("mxu",       "video/vnd.mpegurl")+  , ("n-gage",    "application/vnd.nokia.n-gage.symbian.install")+  , ("nb",        "application/mathematica")+  , ("nc",        "application/x-netcdf")+  , ("ngdat",     "application/vnd.nokia.n-gage.data")+  , ("nlu",       "application/vnd.neurolanguage.nlu")+  , ("nml",       "application/vnd.enliven")+  , ("nnd",       "application/vnd.noblenet-directory")+  , ("nns",       "application/vnd.noblenet-sealer")+  , ("nnw",       "application/vnd.noblenet-web")+  , ("npx",       "image/vnd.net-fpx")+  , ("nsf",       "application/vnd.lotus-notes")+  , ("oa2",       "application/vnd.fujitsu.oasys2")+  , ("oa3",       "application/vnd.fujitsu.oasys3")+  , ("oas",       "application/vnd.fujitsu.oasys")+  , ("obd",       "application/x-msbinder")+  , ("oda",       "application/oda")+  , ("odc",       "application/vnd.oasis.opendocument.chart")+  , ("odf",       "application/vnd.oasis.opendocument.formula")+  , ("odg",       "application/vnd.oasis.opendocument.graphics")+  , ("odi",       "application/vnd.oasis.opendocument.image")+  , ("odp",       "application/vnd.oasis.opendocument.presentation")+  , ("ods",       "application/vnd.oasis.opendocument.spreadsheet")+  , ("odt",       "application/vnd.oasis.opendocument.text")+  , ("ogg",       "application/ogg")+  , ("oprc",      "application/vnd.palm")+  , ("org",       "application/vnd.lotus-organizer")+  , ("otc",       "application/vnd.oasis.opendocument.chart-template")+  , ("otf",       "application/vnd.oasis.opendocument.formula-template")+  , ("otg",       "application/vnd.oasis.opendocument.graphics-template")+  , ("oth",       "application/vnd.oasis.opendocument.text-web")+  , ("oti",       "application/vnd.oasis.opendocument.image-template")+  , ("otm",       "application/vnd.oasis.opendocument.text-master")+  , ("otp",       "application/vnd.oasis.opendocument.presentation-template")+  , ("ots",       "application/vnd.oasis.opendocument.spreadsheet-template")+  , ("ott",       "application/vnd.oasis.opendocument.text-template")+  , ("oxt",       "application/vnd.openofficeorg.extension")+  , ("p",         "text/x-pascal")+  , ("p10",       "application/pkcs10")+  , ("p12",       "application/x-pkcs12")+  , ("p7b",       "application/x-pkcs7-certificates")+  , ("p7c",       "application/pkcs7-mime")+  , ("p7m",       "application/pkcs7-mime")+  , ("p7r",       "application/x-pkcs7-certreqresp")+  , ("p7s",       "application/pkcs7-signature")+  , ("pas",       "text/x-pascal")+  , ("pbd",       "application/vnd.powerbuilder6")+  , ("pbm",       "image/x-portable-bitmap")+  , ("pcl",       "application/vnd.hp-pcl")+  , ("pclxl",     "application/vnd.hp-pclxl")+  , ("pct",       "image/x-pict")+  , ("pcx",       "image/x-pcx")+  , ("pdb",       "application/vnd.palm")+  , ("pdb",       "chemical/x-pdb")+  , ("pdf",       "application/pdf")+  , ("pfr",       "application/font-tdpfr")+  , ("pfx",       "application/x-pkcs12")+  , ("pgm",       "image/x-portable-graymap")+  , ("pgn",       "application/x-chess-pgn")+  , ("pgp",       "application/pgp-encrypted")+  , ("pic",       "image/x-pict")+  , ("pkg",       "application/octet-stream")+  , ("pki",       "application/pkixcmp")+  , ("pkipath",   "application/pkix-pkipath")+  , ("plb",       "application/vnd.3gpp.pic-bw-large")+  , ("plc",       "application/vnd.mobius.plc")+  , ("plf",       "application/vnd.pocketlearn")+  , ("pls",       "application/pls+xml")+  , ("pml",       "application/vnd.ctc-posml")+  , ("png",       "image/png")+  , ("pnm",       "image/x-portable-anymap")+  , ("portpkg",   "application/vnd.macports.portpkg")+  , ("pot",       "application/vnd.ms-powerpoint")+  , ("ppd",       "application/vnd.cups-ppd")+  , ("ppm",       "image/x-portable-pixmap")+  , ("pps",       "application/vnd.ms-powerpoint")+  , ("ppt",       "application/vnd.ms-powerpoint")+  , ("pqa",       "application/vnd.palm")+  , ("prc",       "application/vnd.palm")+  , ("pre",       "application/vnd.lotus-freelance")+  , ("prf",       "application/pics-rules")+  , ("ps",        "application/postscript")+  , ("psb",       "application/vnd.3gpp.pic-bw-small")+  , ("psd",       "image/vnd.adobe.photoshop")+  , ("ptid",      "application/vnd.pvi.ptid1")+  , ("pub",       "application/x-mspublisher")+  , ("pvb",       "application/vnd.3gpp.pic-bw-var")+  , ("pwn",       "application/vnd.3m.post-it-notes")+  , ("qam",       "application/vnd.epson.quickanime")+  , ("qbo",       "application/vnd.intu.qbo")+  , ("qfx",       "application/vnd.intu.qfx")+  , ("qps",       "application/vnd.publishare-delta-tree")+  , ("qt",        "video/quicktime")+  , ("qwd",       "application/vnd.quark.quarkxpress")+  , ("qwt",       "application/vnd.quark.quarkxpress")+  , ("qxb",       "application/vnd.quark.quarkxpress")+  , ("qxd",       "application/vnd.quark.quarkxpress")+  , ("qxl",       "application/vnd.quark.quarkxpress")+  , ("qxt",       "application/vnd.quark.quarkxpress")+  , ("ra",        "audio/x-pn-realaudio")+  , ("ram",       "audio/x-pn-realaudio")+  , ("rar",       "application/x-rar-compressed")+  , ("ras",       "image/x-cmu-raster")+  , ("rcprofile", "application/vnd.ipunplugged.rcprofile")+  , ("rdf",       "application/rdf+xml")+  , ("rdz",       "application/vnd.data-vision.rdz")+  , ("rep",       "application/vnd.businessobjects")+  , ("rgb",       "image/x-rgb")+  , ("rif",       "application/reginfo+xml")+  , ("rl",        "application/resource-lists+xml")+  , ("rlc",       "image/vnd.fujixerox.edmics-rlc")+  , ("rm",        "application/vnd.rn-realmedia")+  , ("rmi",       "audio/midi")+  , ("rmp",       "audio/x-pn-realaudio-plugin")+  , ("rms",       "application/vnd.jcp.javame.midlet-rms")+  , ("rnc",       "application/relax-ng-compact-syntax")+  , ("roff",      "text/troff")+  , ("rpss",      "application/vnd.nokia.radio-presets")+  , ("rpst",      "application/vnd.nokia.radio-preset")+  , ("rs",        "application/rls-services+xml")+  , ("rsd",       "application/rsd+xml")+  , ("rss",       "application/rss+xml")+  , ("rtf",       "application/rtf")+  , ("rtx",       "text/richtext")+  , ("s",         "text/x-asm")+  , ("saf",       "application/vnd.yamaha.smaf-audio")+  , ("sbml",      "application/sbml+xml")+  , ("sc",        "application/vnd.ibm.secure-container")+  , ("scd",       "application/x-msschedule")+  , ("scm",       "application/vnd.lotus-screencam")+  , ("sdkd",      "application/vnd.solent.sdkm+xml")+  , ("sdkm",      "application/vnd.solent.sdkm+xml")+  , ("sdp",       "application/sdp")+  , ("see",       "application/vnd.seemail")+  , ("sema",      "application/vnd.sema")+  , ("semd",      "application/vnd.semd")+  , ("semf",      "application/vnd.semf")+  , ("setpay",    "application/set-payment-initiation")+  , ("setreg",    "application/set-registration-initiation")+  , ("sfs",       "application/vnd.spotfire.sfs")+  , ("sgm",       "text/sgml")+  , ("sgml",      "text/sgml")+  , ("sh",        "application/x-sh")+  , ("shar",      "application/x-shar")+  , ("shf",       "application/shf+xml")+  , ("sig",       "application/pgp-signature")+  , ("silo",      "model/mesh")+  , ("sit",       "application/x-stuffit")+  , ("sitx",      "application/x-stuffitx")+  , ("skd",       "application/vnd.koan")+  , ("skm",       "application/vnd.koan")+  , ("skp",       "application/vnd.koan")+  , ("skt",       "application/vnd.koan")+  , ("slt",       "application/vnd.epson.salt")+  , ("smi",       "application/smil+xml")+  , ("smil",      "application/smil+xml")+  , ("snd",       "audio/basic")+  , ("so",        "application/octet-stream")+  , ("spc",       "application/x-pkcs7-certificates")+  , ("spf",       "application/vnd.yamaha.smaf-phrase")+  , ("spl",       "application/x-futuresplash")+  , ("spot",      "text/vnd.in3d.spot")+  , ("src",       "application/x-wais-source")+  , ("ssf",       "application/vnd.epson.ssf")+  , ("ssml",      "application/ssml+xml")+  , ("stf",       "application/vnd.wt.stf")+  , ("stk",       "application/hyperstudio")+  , ("str",       "application/vnd.pg.format")+  , ("sus",       "application/vnd.sus-calendar")+  , ("susp",      "application/vnd.sus-calendar")+  , ("sv4cpio",   "application/x-sv4cpio")+  , ("sv4crc",    "application/x-sv4crc")+  , ("svd",       "application/vnd.svd")+  , ("svg",       "image/svg+xml")+  , ("svgz",      "image/svg+xml")+  , ("swf",       "application/x-shockwave-flash")+  , ("t",         "text/troff")+  , ("tao",       "application/vnd.tao.intent-module-archive")+  , ("tar",       "application/x-tar")+  , ("tcl",       "application/x-tcl")+  , ("tex",       "application/x-tex")+  , ("texi",      "application/x-texinfo")+  , ("texinfo",   "application/x-texinfo")+  , ("text",      "text/plain")+  , ("tif",       "image/tiff")+  , ("tiff",      "image/tiff")+  , ("tmo",       "application/vnd.tmobile-livetv")+  , ("torrent",   "application/x-bittorrent")+  , ("tpl",       "application/vnd.groove-tool-template")+  , ("tpt",       "application/vnd.trid.tpt")+  , ("tr",        "text/troff")+  , ("tra",       "application/vnd.trueapp")+  , ("trm",       "application/x-msterminal")+  , ("tsv",       "text/tab-separated-values")+  , ("twd",       "application/vnd.simtech-mindmapper")+  , ("twds",      "application/vnd.simtech-mindmapper")+  , ("txd",       "application/vnd.genomatix.tuxedo")+  , ("txf",       "application/vnd.mobius.txf")+  , ("txt",       "text/plain")+  , ("ufd",       "application/vnd.ufdl")+  , ("ufdl",      "application/vnd.ufdl")+  , ("umj",       "application/vnd.umajin")+  , ("unityweb",  "application/vnd.unity")+  , ("uoml",      "application/vnd.uoml+xml")+  , ("uri",       "text/uri-list")+  , ("uris",      "text/uri-list")+  , ("urls",      "text/uri-list")+  , ("ustar",     "application/x-ustar")+  , ("utz",       "application/vnd.uiq.theme")+  , ("uu",        "text/x-uuencode")+  , ("vcd",       "application/x-cdlink")+  , ("vcf",       "text/x-vcard")+  , ("vcg",       "application/vnd.groove-vcard")+  , ("vcs",       "text/x-vcalendar")+  , ("vcx",       "application/vnd.vcx")+  , ("vis",       "application/vnd.visionary")+  , ("viv",       "video/vnd.vivo")+  , ("vrml",      "model/vrml")+  , ("vsd",       "application/vnd.visio")+  , ("vsf",       "application/vnd.vsf")+  , ("vss",       "application/vnd.visio")+  , ("vst",       "application/vnd.visio")+  , ("vsw",       "application/vnd.visio")+  , ("vtu",       "model/vnd.vtu")+  , ("vxml",      "application/voicexml+xml")+  , ("wav",       "audio/wav")+  , ("wav",       "audio/x-wav")+  , ("wax",       "audio/x-ms-wax")+  , ("wbmp",      "image/vnd.wap.wbmp")+  , ("wbs",       "application/vnd.criticaltools.wbs+xml")+  , ("wbxml",     "application/vnd.wap.wbxml")+  , ("wcm",       "application/vnd.ms-works")+  , ("wdb",       "application/vnd.ms-works")+  , ("wks",       "application/vnd.ms-works")+  , ("wm",        "video/x-ms-wm")+  , ("wma",       "audio/x-ms-wma")+  , ("wmd",       "application/x-ms-wmd")+  , ("wmf",       "application/x-msmetafile")+  , ("wml",       "text/vnd.wap.wml")+  , ("wmlc",      "application/vnd.wap.wmlc")+  , ("wmls",      "text/vnd.wap.wmlscript")+  , ("wmlsc",     "application/vnd.wap.wmlscriptc")+  , ("wmv",       "video/x-ms-wmv")+  , ("wmx",       "video/x-ms-wmx")+  , ("wmz",       "application/x-ms-wmz")+  , ("wpd",       "application/vnd.wordperfect")+  , ("wpl",       "application/vnd.ms-wpl")+  , ("wps",       "application/vnd.ms-works")+  , ("wqd",       "application/vnd.wqd")+  , ("wri",       "application/x-mswrite")+  , ("wrl",       "model/vrml")+  , ("wsdl",      "application/wsdl+xml")+  , ("wspolicy",  "application/wspolicy+xml")+  , ("wtb",       "application/vnd.webturbo")+  , ("wvx",       "video/x-ms-wvx")+  , ("x3d",       "application/vnd.hzn-3d-crossword")+  , ("xar",       "application/vnd.xara")+  , ("xbd",       "application/vnd.fujixerox.docuworks.binder")+  , ("xbm",       "image/x-xbitmap")+  , ("xdm",       "application/vnd.syncml.dm+xml")+  , ("xdp",       "application/vnd.adobe.xdp+xml")+  , ("xdw",       "application/vnd.fujixerox.docuworks")+  , ("xenc",      "application/xenc+xml")+  , ("xfdf",      "application/vnd.adobe.xfdf")+  , ("xfdl",      "application/vnd.xfdl")+  , ("xht",       "application/xhtml+xml")+  , ("xhtml",     "application/xhtml+xml")+  , ("xhvml",     "application/xv+xml")+  , ("xif",       "image/vnd.xiff")+  , ("xla",       "application/vnd.ms-excel")+  , ("xlc",       "application/vnd.ms-excel")+  , ("xlm",       "application/vnd.ms-excel")+  , ("xls",       "application/vnd.ms-excel")+  , ("xlt",       "application/vnd.ms-excel")+  , ("xlw",       "application/vnd.ms-excel")+  , ("xml",       "application/xml")+  , ("xo",        "application/vnd.olpc-sugar")+  , ("xop",       "application/xop+xml")+  , ("xpm",       "image/x-xpixmap")+  , ("xpr",       "application/vnd.is-xpr")+  , ("xps",       "application/vnd.ms-xpsdocument")+  , ("xpw",       "application/vnd.intercon.formnet")+  , ("xpx",       "application/vnd.intercon.formnet")+  , ("xsl",       "application/xml")+  , ("xslt",      "application/xslt+xml")+  , ("xsm",       "application/vnd.syncml+xml")+  , ("xspf",      "application/xspf+xml")+  , ("xul",       "application/vnd.mozilla.xul+xml")+  , ("xvm",       "application/xv+xml")+  , ("xvml",      "application/xv+xml")+  , ("xwd",       "image/x-xwindowdump")+  , ("xyz",       "chemical/x-xyz")+  , ("zaz",       "application/vnd.zzazz.deck+xml")+  , ("zip",       "application/zip")+  , ("zmm",       "application/vnd.handheld-entertainment+xml")+  , ("avi",       "video/x-msvideo")+  , ("movie",     "video/x-sgi-movie")+  , ("ice",       "x-conference/x-cooltalk")+  ]+

@@ -0,0 +1,128 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}++{-# LANGUAGE TemplateHaskell #-}+module Network.Protocol.Uri (++    {- | See rfc2396 for more info. -}++  -- * URI datatype.++    Scheme+  , RegName+  , Port+  , Query+  , Fragment+  , Hash+  , UserInfo+  , PathSegment+  , Parameters++  , Domain (..)+  , IPv4 (..)+  , Path (..)+  , Host (..)+  , Authority (..)+  , Uri (..)++  -- * Accessing parts of URIs.++  , relative+  , scheme+  , userinfo+  , authority+  , host+  , domain+  , ipv4+  , regname+  , port+  , path+  , segments+  , query+  , fragment++  -- * More advanced labels and functions.++  , pathAndQuery+  , queryParams+  , params+  , extension++  , remap++  -- * Encoding/decoding URI encoded strings.++  , encode+  , decode+  , encoded++  -- * Creating empty URIs.++  , mkUri+  , mkScheme+  , mkPath+  , mkAuthority+  , mkQuery+  , mkFragment+  , mkUserinfo+  , mkHost+  , mkPort++  -- * Parsing URIs.++  , toUri+  , parseUri+  , parseAbsoluteUri+  , parseAuthority+  , parsePath+  , parseHost++  -- * Printing URIs+  , showUri+  , showPath+  , showAuthority++  -- * Filename related utilities.++  , mimetype+  , normalize+  , jail+  , (/+)++  ) where++import Network.Protocol.Uri.Data+import Network.Protocol.Uri.Encode+import Network.Protocol.Uri.Parser+import Network.Protocol.Uri.Path+import Network.Protocol.Uri.Printer+import Network.Protocol.Uri.Query+import Network.Protocol.Uri.Remap+

@@ -0,0 +1,48 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+module Network.Protocol.Uri.Chars+  ( unreserved+  , genDelims+  , subDelims+  ) where++import Data.Char++-- 2.3.  Unreserved Characters+unreserved :: Char -> Bool+unreserved c = isAlphaNum c || elem c "-._~"++-- 2.2.  Reserved Characters+genDelims :: Char -> Bool+genDelims = flip elem ":/?#[]@"++subDelims :: Char -> Bool+subDelims = flip elem "!$&'()*+,;="+

@@ -0,0 +1,214 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TemplateHaskell, TypeOperators #-}+module Network.Protocol.Uri.Data where++import Prelude hiding ((.), id)+import Control.Category+import Data.Label+import Data.Maybe+import Network.Protocol.Uri.Encode++type Scheme      = String+type RegName     = String+type Port        = Int+type Query       = String+type Fragment    = String+type Hash        = String+type UserInfo    = String+type PathSegment = String++data IPv4 = IPv4 Int Int Int Int+  deriving (Show, Read, Eq, Ord)++data Domain = Domain { __parts :: [String] }+  deriving (Show, Read, Eq, Ord)++data Host =+    Hostname { __domain  :: Domain }+  | RegName  { __regname :: RegName }+  | IP       { __ipv4    :: IPv4   }+--  | IPv6     { __ipv6    :: IPv6   }+  deriving (Show, Read, Eq, Ord)++data Authority = Authority+  { __userinfo :: UserInfo+  , __host     :: Host+  , __port     :: Maybe Port+  }+  deriving (Show, Read, Eq, Ord)++data Path = Path { __segments :: [PathSegment] }+  deriving (Show, Read, Eq, Ord)++data Uri = Uri+  { _relative  :: Bool+  , _scheme    :: Scheme+  , _authority :: Authority+  , __path     :: Path+  , __query    :: Query+  , __fragment :: Fragment+  }+  deriving (Show, Read, Eq, Ord)++$(mkLabels [''Domain, ''Path, ''Host, ''Authority, ''Uri])++-- _parts    :: Domain :-> [String]+-- _domain   :: Host :-> Domain+-- _ipv4     :: Host :-> IPv4+-- _regname  :: Host :-> String+-- _host     :: Authority :-> Host+-- _port     :: Authority :-> Maybe Port+-- _userinfo :: Authority :-> UserInfo+-- _segments :: Path :-> [PathSegment]+-- _path     :: Uri :-> Path++-- | Access raw (URI-encoded) query.++-- _query :: Uri :-> Query++-- | Access authority part of the URI.++-- authority :: Uri :-> Authority++-- | Access domain part of the URI, returns `Nothing' when the host is a+-- regname or IP-address.++domain :: Uri :-> Maybe Domain+domain = (Bij f (Hostname . fromJust)) `iso` (_host . authority)+  where+    f (Hostname d) = Just d+    f _            = Nothing++-- | Access regname part of the URI, returns `Nothing' when the host is a+-- domain or IP-address.++regname :: Uri :-> Maybe RegName+regname = (Bij f (RegName . fromJust)) `iso` (_host . authority)+  where+    f (RegName r) = Just r+    f _           = Nothing++-- | Access IPv4-address part of the URI, returns `Nothing' when the host is a+-- domain or regname.++ipv4 :: Uri :-> Maybe IPv4+ipv4 = (Bij f (IP . fromJust)) `iso` (_host . authority)+  where+    f (IP i) = Just i+    f _      = Nothing++-- | Access raw (URI-encoded) fragment.++-- _fragment :: Uri :-> Fragment++-- | Access the port number part of the URI when available.++port :: Uri :-> Maybe Port+port = _port . authority++-- | Access the query part of the URI, the part that follows the ?. The query+-- will be properly decoded when reading and encoded when writing.++query :: Uri :-> Query+query = encoded `iso` _query++-- | Access the fragment part of the URI, the part that follows the #. The+-- fragment will be properly decoded when reading and encoded when writing.++fragment :: Uri :-> Fragment+fragment = encoded `iso` _fragment++-- | Is a URI relative?++-- relative :: Uri :-> Bool++-- | Access the scheme part of the URI. A scheme is probably the protocol+-- indicator like /http/, /ftp/, etc.++-- scheme :: Uri :-> Scheme++-- | Access the path part of the URI as a list of path segments. The segments+-- will still be URI-encoded.++segments :: Uri :-> [PathSegment]+segments = _segments . _path++-- | Access the userinfo part of the URI. The userinfo contains an optional+-- username and password or some other credentials.++userinfo :: Uri :-> String+userinfo = _userinfo . authority++-- | Constructors for making empty URI.++mkUri :: Uri+mkUri = Uri False mkScheme mkAuthority mkPath mkQuery mkFragment++-- | Constructors for making empty `Scheme`.++mkScheme :: Scheme+mkScheme = ""++-- | Constructors for making empty `Path`.++mkPath :: Path+mkPath = Path []++-- | Constructors for making empty `Authority`.++mkAuthority :: Authority+mkAuthority = Authority "" mkHost mkPort++-- | Constructors for making empty `Query`.++mkQuery :: Query+mkQuery = ""++-- | Constructors for making empty `Fragment`.++mkFragment :: Fragment+mkFragment = ""++-- | Constructors for making empty `UserInfo`.++mkUserinfo :: UserInfo+mkUserinfo = ""++-- | Constructors for making empty `Host`.++mkHost :: Host+mkHost = Hostname (Domain [])++-- | Constructors for making empty `Port`.++mkPort :: Maybe Port+mkPort = Nothing+

@@ -0,0 +1,66 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Uri.Encode where++import Data.Bits+import Data.Char+import Data.Maybe+import Data.Label+import Network.Protocol.Uri.Chars+import qualified Data.ByteString as B+import qualified Data.ByteString.UTF8 as U++-- | URI encode a string.++encode :: String -> String+encode = concatMap encodeChr+  where+    encodeChr c+      | unreserved c || genDelims c || subDelims c = [c]+      | otherwise = '%' :+          intToDigit (shiftR (ord c) 4) :+          intToDigit ((ord c) .&. 0x0F) : []++-- | URI decode a string.++decode :: String -> String+decode = U.toString . B.pack . map (fromIntegral . ord) . dec+  where+    dec [] = []+    dec ('%':d:e:ds) | isHexDigit d && isHexDigit e = (chr $ digs d * 16 + digs e) : dec ds +      where digs a = fromJust $ lookup (toLower a) $ zip "0123456789abcdef" [0..]+    dec (d:ds) = d : dec ds++-- | Decoding and encoding as a label.++encoded :: Bijection (->) String String+encoded = Bij decode encode+

@@ -0,0 +1,308 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE+    StandaloneDeriving+  , TypeOperators+  , FlexibleContexts+  , FlexibleInstances+  #-}+module Network.Protocol.Uri.Parser where++import Control.Applicative hiding (empty)+import Control.Category+import Data.Char+import Data.List +import Data.Maybe+import Data.Label+import Network.Protocol.Uri.Data+import Network.Protocol.Uri.Encode+import Network.Protocol.Uri.Printer+import Network.Protocol.Uri.Query+import Prelude hiding ((.), id, mod)+import Safe+import Text.ParserCombinators.Parsec hiding (many, (<|>))++-- | Access the host part of the URI.++host :: Uri :-> String+host = (Bij showHost ((either (const mkHost) id) . parseHost)) `iso` (_host . authority)++-- | Access the path part of the URI. The query will be properly decoded when+-- reading and encoded when writing.++path :: Uri :-> FilePath+path = (Bij (decode . showPath) (either (const mkPath) id . parsePath . encode)) `iso` _path++-- | Access the path and query parts of the URI as a single string. The string+-- will will be properly decoded when reading and encoded when writing.++pathAndQuery :: Uri :-> String+pathAndQuery = values "?" `osi` Lens ((\p q -> [p, q]) <$> idx 0 `for` path <*> idx 1 `for` query)+  where idx = flip (atDef "")+        osi (Bij a b) = iso (Bij b a)++-- | Parse string into a URI and ignore all failures by returning an empty URI+-- when parsing fails. Can be quite useful in situations that parse errors are+-- unlikely.++toUri :: String -> Uri+toUri = either (const mkUri) id . parseUri++-- | Parse string into a URI.++parseUri :: String -> Either ParseError Uri+parseUri = parse pUriReference ""++-- | Parse string into a URI and only accept absolute URIs.++parseAbsoluteUri :: String -> Either ParseError Uri+parseAbsoluteUri = parse pAbsoluteUri ""++-- | Parse string into an authority.++parseAuthority :: String -> Either ParseError Authority+parseAuthority = parse pAuthority ""++-- | Parse string into a path.++parsePath :: String -> Either ParseError Path+parsePath = parse pPath ""++-- | Parse string into a host.++parseHost :: String -> Either ParseError Host+parseHost = parse pHost ""++-- D.2.  Modifications++pAlpha, pDigit, pAlphanum :: CharParser st Char+pAlpha    = letter+pDigit    = digit+pAlphanum = alphaNum++-- 2.3.  Unreserved Characters++pUnreserved :: GenParser Char st Char+pUnreserved  = pAlphanum <|> oneOf "-._~"++pReserved :: GenParser Char st Char+pReserved  = pGenDelims <|> pSubDelims++pGenDelims :: CharParser st Char+pGenDelims = oneOf ":/?#[]@"++pSubDelims :: CharParser st Char+pSubDelims = oneOf "!$&'()*+,;="++-- 2.1.  Percent-Encoding++pPctEncoded :: GenParser Char st String+pPctEncoded = (:) <$> char '%' <*> pHex++pHex :: GenParser Char st String+pHex = (\a b -> a:b:[])+    <$> hexDigit+    <*> hexDigit++-- 3.  Syntax Components++-- With the hier-part integrated.++pUri :: GenParser Char st Uri+pUri = (\a (b,c) d e -> Uri False a b c d e)+  <$> (pScheme <* string ":")+  <*> (q <|> p)+  <*> option "" (string "?" *> pQuery)+  <*> option "" (string "#" *> pFragment)+  where+    q = (,) <$> (string "//" *> pAuthority) <*> pPathAbempty+    p = ((,) mkAuthority) <$> (pPathAbsolute <|> pPathRootless {-<|> pPathEmpty-})++-- 3.1.  Scheme++pScheme :: GenParser Char st String+pScheme = (:) <$> pAlpha <*> many (pAlphanum <|> oneOf "+_.")++-- 3.2.  Authority++pAuthority :: GenParser Char st Authority+pAuthority = Authority+  <$> option mkUserinfo (try (pUserinfo <* string "@"))+  <*> pHost+  <*> option Nothing (string ":" *> pPort)++-- 3.2.1.  User Information++pUserinfo :: GenParser Char st String+pUserinfo = concat <$> many (+      (pure <$> pUnreserved)+  <|> (         pPctEncoded)+  <|> (pure <$> pSubDelims)+  <|> (pure <$> oneOf ":")+  )++-- 3.2.2.  Host++pHost :: GenParser Char st Host+pHost = diff <$> pRegName -- <|> RegName <$> pRegName+  where+    diff  a = either (const (RegName a)) sep (parse pHostname "" a)+    sep   a = if hst a then Hostname (Domain a) else ipreg a+    ipreg a = if ip a then IP (toIP a) else RegName (intercalate "." a)+    hst     = not . all isDigit . headDef "" . dropWhile null . reverse+    ip    a = length a == 4 && length (mapMaybe (either (const Nothing) Just . parse pDecOctet "") a) == 4+    toIP [a, b, c, d] = IPv4 (read a) (read b) (read c) (read d)+    toIP _            = IPv4 0 0 0 0++{-+pfff, ipv6 is sooo not gonna make it..++pIPLiteral = "[" ( IPv6address <|> IPvFuture  ) "]"++pIPvFuture = "v" 1*HEXDIG "." 1*( unreserved <|> subDelims <|> ":" )++pIPv6address =+                                 6( h16 ":" ) ls32+  <|>                       "::" 5( h16 ":" ) ls32+  <|> [               h16 ] "::" 4( h16 ":" ) ls32+  <|> [ *1( h16 ":" ) h16 ] "::" 3( h16 ":" ) ls32+  <|> [ *2( h16 ":" ) h16 ] "::" 2( h16 ":" ) ls32+  <|> [ *3( h16 ":" ) h16 ] "::"    h16 ":"   ls32+  <|> [ *4( h16 ":" ) h16 ] "::"              ls32+  <|> [ *5( h16 ":" ) h16 ] "::"              h16+  <|> [ *6( h16 ":" ) h16 ] "::"++pH16           = 1*4HEXDIG+pLs32          = ( h16 ":" h16 ) <|> IPv4address+-}++pIPv4address :: GenParser Char st [Int]+pIPv4address = (:) <$> pDecOctet <*> (count 3 $ char '.' *> pDecOctet)++pDecOctet :: GenParser Char st Int+pDecOctet = read <$> choice [+    try ((\a b c -> [a,b,c]) <$> char '2' <*> char '5'      <*> oneOf "012345")+  , try ((\a b c -> [a,b,c]) <$> char '2' <*> oneOf "01234" <*> digit)+  , try ((\a b c -> [a,b,c]) <$> char '1' <*> digit         <*> digit)+  , try ((\a b   -> [a,b])   <$>              digit         <*> digit)+  ,     (pure                <$>                                digit)+  ]++pRegName :: GenParser Char st String+pRegName = concat <$> many1 (+      (pure <$> pUnreserved)+  <|>           pPctEncoded+  <|> (pure <$> pSubDelims))++-- Not actually part of the rfc3986, but comptability with the rfc2396.+-- This information can be useful, so why throw away.++pHostname :: GenParser Char st [String]+pHostname = sepBy (option "" pDomainlabel) (string ".")++pDomainlabel :: GenParser Char st String+pDomainlabel = intercalate "-" <$> sepBy1 (some pAlphanum) (string "-")++-- 3.2.3.  Port++pPort :: GenParser Char st (Maybe Port)+pPort = readMay <$> some pDigit++-- 3.4.  Query++pQuery :: GenParser Char st String+pQuery = concat <$> many (pPchar <|> pure <$> oneOf "/?")++-- 3.5.  Fragment++pFragment :: GenParser Char st String+pFragment = concat <$> many (pPchar <|> pure <$> oneOf "/?" )++-- 3.3.  Path++pPath, pPathAbempty, pPathAbsolute, pPathNoscheme, pPathRootless, pPathEmpty :: GenParser Char st Path++pPath =+      try pPathAbsolute -- begins with "/" but not "//"+  <|> try pPathNoscheme -- begins with a nonColon segment+  <|> try pPathRootless -- begins with a segment+  <|> pPathEmpty        -- zero characters++pPathAbempty  = Path . ("":) <$> _pSlashSegments+pPathAbsolute = (char '/' *>) $ Path . ("":) <$> (option [] $ (:) <$> pSegmentNz <*> _pSlashSegments)+pPathNoscheme = Path <$> ((:) <$> pSegmentNzNc <*> _pSlashSegments)+pPathRootless = Path <$> ((:) <$> pSegmentNz    <*> _pSlashSegments)+pPathEmpty    = Path [] <$ string ""++pSegment, pSegmentNz, pSegmentNzNc :: GenParser Char st String+pSegment     = concat <$> many pPchar+pSegmentNz   = concat <$> some pPchar+pSegmentNzNc = concat <$> some (+      (pure <$> pUnreserved)+  <|>           pPctEncoded+  <|> (pure <$> pSubDelims)+  <|> (pure <$> oneOf "@" ))++_pSlashSegments :: GenParser Char st [PathSegment]+_pSlashSegments = (many $ (:) <$> char '/' *> pSegment)+++pPchar :: GenParser Char st String+pPchar = choice+  [ pure <$> pUnreserved+  , pPctEncoded+  , pure <$> pSubDelims+  , pure <$> oneOf ":@"+  ]++-- 4.1.  URI Reference++pUriReference :: GenParser Char st Uri+pUriReference = try pAbsoluteUri <|> pRelativeRef++-- 4.2.  Relative Reference++-- With the relative-part integrated.++pRelativeRef :: GenParser Char st Uri+pRelativeRef = ($)+  <$> (try pRelativePart+  <|> ((Uri True mkScheme mkAuthority)+  <$> (pPathAbsolute <|> pPathRootless <|> pPathEmpty)))+  <*> option "" (string "?" *> pQuery)+  <*> option "" (string "#" *> pFragment)++pRelativePart :: GenParser Char st (Query -> Fragment -> Uri)+pRelativePart = Uri True mkScheme <$> (string "//" *> pAuthority) <*> pPathAbempty++-- 4.3.  Absolute URI++pAbsoluteUri :: GenParser Char st Uri+pAbsoluteUri = pUri

@@ -0,0 +1,102 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Uri.Path where++import Data.List+import Network.Protocol.Mime+import Data.Label++{- | Label to access the extension of a filename. -}++extension :: FilePath :-> Maybe String+extension = lens getExt setExt+  where+    splt     p = (\(a,b) -> (reverse a, reverse b)) $ break (=='.') $ reverse p+    isExt e  p = '/' `elem` e || not ('.' `elem` p)+    getExt   p = let (u, v) = splt p in+                 if isExt u v then Nothing else Just u+    setExt e p = let (u, v) = splt p in+                 (if isExt u v then p else init v) ++ maybe "" ('.':) e++{- |+Try to guess the correct mime type for the input file based on the file+extension.+-}++mimetype :: FilePath -> Maybe String+mimetype p = get extension p >>= mime++{- |+Normalize a path by removing or merging all dot or dot-dot segments and double+slashes. +-}++-- Todo: is this windows-safe?  is it really secure?++normalize :: FilePath -> FilePath+normalize p  = norm_rev (reverse p)+  where+    norm_rev ('/':t) = start_dir 0 "/" t+    norm_rev (    t) = start_dir 0 ""  t++    start_dir n q (".."           ) = rest_dir   n    q  ""+    start_dir n q ('/':t          ) = start_dir  n    q  t+    start_dir n q ('.':'/':t      ) = start_dir  n    q  t+    start_dir n q ('.':'.':'/': t ) = start_dir (n+1) q  t+    start_dir n q (t              ) = rest_dir   n    q  t++    rest_dir  n q  ""+        | n > 0      = foldr (++) q (replicate n "../")+        | null q     = "/"+        | otherwise  = q+    rest_dir  0 q ('/':t ) = start_dir  0   ('/':q)  t+    rest_dir  n q ('/':t ) = start_dir (n-1)     q   t+    rest_dir  0 q (h:t   ) = rest_dir   0   (  h:q)  t+    rest_dir  n q (_:t   ) = rest_dir   n        q   t++{- | Jail a filepath within a jail directory. -}++jail+  :: FilePath         -- ^ Jail directory.+  -> FilePath         -- ^ Filename to jail.+  -> Maybe FilePath+jail jailDir p =+  let nj = normalize jailDir+      np = normalize p in+  if nj `isPrefixOf` np -- && not (".." `isPrefixOf` np)+    then Just np+    else Nothing++{- | Concatenate and normalize two filepaths. -}++(/+) :: FilePath -> FilePath -> FilePath+a /+ b = normalize (a ++ "/" ++ b)+

@@ -0,0 +1,98 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+module Network.Protocol.Uri.Printer where++import Network.Protocol.Uri.Data++printPath :: Path -> ShowS+printPath (Path ("":xs)) = sc '/' . printPath (Path xs)+printPath (Path xs)      = intersperseS (sc '/') (map ss xs)++showPath :: Path -> String+showPath = flip printPath ""++-- instance Show Path where+--   showsPrec _ (Path ("":xs)) = sc '/' . shows (Path xs)+--   showsPrec _ (Path xs)      = intersperseS (sc '/') (map ss xs)++printIPv4 :: IPv4 -> ShowS+printIPv4 (IPv4 a b c d) = intersperseS (sc '.') (map shows [a, b, c, d])++-- instance Show IPv4 where+--   showsPrec _ (IPv4 a b c d) = intersperseS (sc '.') (map shows [a, b, c, d])++printDomain :: Domain -> ShowS+printDomain (Domain d) = intersperseS (sc '.') (map ss d)++-- instance Show Domain where+--   showsPrec _ (Domain d) = intersperseS (sc '.') (map ss d)++printHost :: Host -> ShowS+printHost (Hostname d) = printDomain d+printHost (IP i)       = printIPv4 i +printHost (RegName r)  = ss r++showHost :: Host -> String+showHost = flip printHost ""++printAuthority :: Authority -> ShowS+printAuthority (Authority u h p) =+    let u' = if null u then id else ss u . ss "@"+        p' = maybe id (\s -> sc ':' . shows s) p+    in u' . printHost h . p'++showAuthority :: Authority -> String+showAuthority = flip printAuthority ""++printUri :: Uri -> ShowS+printUri (Uri _ s a p q f) =+    let s' = if null s then id else ss s . sc ':'+        a' = printAuthority a ""+        p' = printPath p+        q' = if null q then id else sc '?' . ss q+        f' = if null f then id else sc '#' . ss f+        t' = if null a' then id else ss "//"+    in s' . t' . ss a' . p' . q' . f'++showUri :: Uri -> String+showUri = flip printUri ""++ss :: String -> ShowS+ss = showString++sc :: Char -> ShowS+sc = showChar++-- | ShowS version of intersperse.++intersperseS :: ShowS -> [ShowS] -> ShowS+intersperseS _ []     = id+intersperseS s (x:xs) = foldl (\a b -> a.s.b) x xs+

@@ -0,0 +1,82 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+{-# LANGUAGE TypeOperators #-}+module Network.Protocol.Uri.Query where++import Prelude hiding ((.), id)+import Control.Category+import Data.List+import Data.List.Split +import Data.Label+import Network.Protocol.Uri.Data+import Network.Protocol.Uri.Encode++type Parameters = [(String, String)]++-- | Fetch the query parameters form a URI.++queryParams :: Uri :-> Parameters+queryParams = params `iso` _query++-- | Generic lens to parse/print a string as query parameters.++params :: Bijection (->) String Parameters+params = keyValues "&" "=" . (Bij from to) . encoded+  where from = intercalate " " . splitOn "+"+        to   = intercalate "+" . splitOn " "++-- | Generic label for accessing key value pairs encoded in a string.++keyValues :: String -> String -> Bijection (->) String Parameters+keyValues sep eqs = Bij parser printer+  where parser =+            filter (\(a, b) -> not (null a))+          . map (f . splitOn eqs)+          . concat+          . map (splitOn sep)+          . lines+          where f []     = ("", "")+                f [x]    = (trim x, "")+                f (x:xs) = (trim x, trim $ intercalate eqs xs)+        printer = intercalate sep . map (\(a, b) -> a ++ eqs ++ b)++-- | Generic label for accessing lists of values encoded in a string.++values :: String -> Bijection (->) String [String]+values sep = Bij parser printer+  where parser = filter (not . null) . concat . map (map trim . splitOn sep) . lines+        printer = intercalate sep++-- Helper to trim all heading and trailing whitespace.++trim :: String -> String+trim = rev (dropWhile (`elem` " \t\n\r"))+  where rev f = reverse . f . reverse . f+

@@ -0,0 +1,74 @@+{-+Copyright (c) Sebastiaan Visser 2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. 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.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE REGENTS 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 AUTHORS 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.+-}+module Network.Protocol.Uri.Remap where++import Control.Category+import Data.List +import Data.Label+import Network.Protocol.Uri.Data+import Prelude hiding ((.), id, mod)++-- | Map one URI to another using a URI mapping scheme. A URI mapping scheme is+-- simply a pair of URIs of which only the host part, port number and path will+-- be taken into account when mapping.++remap :: (Uri, Uri) -> Uri -> Maybe Uri+remap (f, t) u =+  let+    ftu = [f, t, u]+    hst = _host . authority+    [h0, h1, h2] = map (get hst)      ftu+    [p0, p1, p2] = map (get port)     ftu+    [s0, s1, s2] = map (get segments) ftu+  in case+     ( remapHost h0 h1 h2+     , remapPort p0 p1 p2+     , remapPath s0 s1 s2+     ) of+    (Just h, Just p, Just s)+      -> Just (set hst h . set port p . set segments s $ u)+    _ -> Nothing+  where+  remapHost (Hostname (Domain a))+            (Hostname (Domain b))   (Hostname (Domain c))          = fmap (Hostname . Domain . (++b)) (a `stripPrefix` reverse c)+  remapHost (Hostname (Domain a)) b (Hostname (Domain c)) | a == c = Just b+  remapHost (RegName a)           b (RegName c)           | a == c = Just b+  remapHost (IP a)                b (IP c)                | a == c = Just b+  remapHost _                     _ _                              = Nothing+  remapPath xs ys zs = fmap (ys++) (xs `stripPrefix` zs)+  remapPort x y z = if x == z then Just y else Nothing++-- from = toUri "http://myhost:8080/ggl"+-- to   = toUri "http://google.com/gapp"+-- testRemap =+--   do let x = remap from to (toUri "http://images.myhost:8080/ggl/search?q=aapjes")+--      print x++

@@ -0,0 +1,129 @@+{-+ - Copyright (c) 2009-2010 Johnny Morrice+ -+ - Permission is hereby granted, free of charge, to any person+ - obtaining a copy of this software and associated documentation + - files (the "Software"), to deal in the Software without + - restriction, including without limitation the rights to use, copy, + - modify, merge, publish, distribute, sublicense, and/or sell copies + - of the Software, and to permit persons to whom the Software is + - furnished to do so, subject to the following conditions:+ -+ - The above copyright notice and this permission notice shall be + - included in all copies or substantial portions of the Software.+ -+ - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, + - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF+ - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND + - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS+ - BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN+ - ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN+ - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+ - SOFTWARE.+ -+ -}+module Network.Shpider.Forms +   (+   Form (..)+   , Method (..)+   , gatherForms+   , fillOutForm+   , allForms+   , toForm+   , mkForm+   )+   where++import Data.Maybe+import Data.Char+import Control.Arrow ( first )+import qualified Data.Map as M+import Text.HTML.TagSoup.Parsec++data Method = GET | POST+   deriving Show++-- | Plain old form: Method, action and inputs.+data Form = +   Form { method :: Method+        , action :: String +        , inputs :: M.Map String String+        }+   deriving Show++-- | Takes a form and fills out the inputs with the given [ ( String , String ) ].+-- It is convienent to use the `pairs` syntax here.+--+-- @+-- f : _ <- `getFormsByAction` \"http:\/\/whatever.com\"+-- `sendForm` $ `fillOutForm` f $ `pairs` $ do+--    \"author\" =: \"Johnny\"+--    \"message\" =: \"Nice syntax dewd.\"+-- @+fillOutForm :: Form -> [ ( String , String ) ] -> Form+fillOutForm = foldl ( \f (n,v) -> f { inputs = M.insert n v $ inputs f } )++-- | The first argument is the action attribute of the form, the second is the method attribute, and the third are the inputs.+mkForm :: String -> Method -> [ ( String , String ) ] -> Form+mkForm a m ps =+   Form { action = a+        , method = m+        , inputs = M.fromList ps+        }++-- | Gets all forms from a list of tags.+gatherForms :: [ Tag String ] -> [ Form ]+gatherForms =+   tParse allForms++-- | The `TagParser` which parses all forms.+allForms :: TagParser String [ Form ]+allForms = do+   fs <- allWholeTags "form"+   return $ mapMaybe toForm fs++-- | A case insensitive lookup for html attributes.+attrLookup :: String -> [ ( String , String ) ] -> Maybe String+attrLookup attr =+   lookup ( map toLower attr ) . map ( first (map toLower) )++-- | Turns a String lowercase.  <rant>In my humble opinion, and considering that a few different packages implement this meager code, this should be in the prelude.</rant>+lowercase :: String -> String +lowercase = map toLower+++toForm :: WholeTag String -> Maybe Form+toForm ( TagOpen _ attrs , innerTags , _ ) = do+   m <- methodLookup attrs+   a <- attrLookup "action" attrs+   let is = tParse ( allOpenTags "input" ) innerTags+       tas = tParse ( allWholeTags "textarea" ) innerTags+   Just $ Form { inputs = M.fromList $ mapMaybe inputNameValue is ++ mapMaybe textAreaNameValue tas+               , action = a+               , method = m+               }++methodLookup attrs = do+   m <- attrLookup "method" attrs+   case lowercase m of+      "get" ->+         Just GET+      "post" ->+         Just POST+      otherwise ->+         Nothing++inputNameValue ( TagOpen _ attrs ) = do+   v <- case attrLookup "value" attrs of+           Nothing ->+              Just ""+           j@(Just _ ) ->+              j+   n <- attrLookup "name" attrs+   Just ( n , v )++textAreaNameValue ( TagOpen _ attrs , inner , _ ) = do+   let v = innerText inner+   n <- attrLookup "name" attrs+   Just ( n , v )+

@@ -0,0 +1,16 @@+module Test.Api where++import Web.VKHS.Login+import Web.VKHS.Api+import Text.Printf++-- | Almost working example. Just set correct values for client_id/login/password+print_user_info = do+    let e = env "3213232" "user@example.com" "password" [Photos,Audio,Groups]+    (Right at) <- login e+    (Right ans) <- api e{verbose = Debug} at "users.get" [+          ("uids","911727")+        , ("fields","first_name,last_name,nickname,screen_name")+        , ("name_case","nom")+        ]+    putStrLn ans

@@ -0,0 +1,27 @@+module Test.Test where++import Data.Label+import Network.Protocol.Http+import Network.Protocol.Uri+import Network.Protocol.Uri.Query+import Network.Protocol.Cookie as C+import Network.Shpider.Forms++import Text.HTML.TagSoup++tryparse = gatherForms . parseTags ++test_cookies :: Cookies+test_cookies = get setCookies test_headers+++test_headers :: Http Response+test_headers = read "Http {_headline = Response {__status = Found}, _version = Version {_major = 1, _minor = 1}, _headers = Headers {unHeaders = [(\"Server\",\"nginx/1.2.1\"),(\"Date\",\"Wed, 29 Aug 2012 08:35:18 GMT\"),(\"Content-Type\",\"text/html; charset=windows-1251\"),(\"Content-Length\",\"0\"),(\"Connection\",\"keep-alive\"),(\"X-Powered-By\",\"PHP/5.3.3-7+squeeze3\"),(\"Set-Cookie\",\"remixlang=0; expires=Sat, 24-Aug-2013 14:23:04 GMT; path=/; domain=.vk.com\"),(\"Pragma\",\"no-cache\"),(\"Cache-control\",\"no-store\"),(\"Set-Cookie\",\"remixchk=5; expires=Tue, 20-Aug-2013 04:42:57 GMT; path=/; domain=.vk.com\"),(\"Location\",\"https://login.vk.com/?from_host=oauth.vk.com&from_protocol=http&ip_h=670993b49983a18c93&soft=1&to=aHR0cDovL29hdXRoLnZrLmNvbS9vYXV0aC9hdXRob3JpemU/Y2xpZW50X2lkPTMwODIyNjYmc2NvcGU9d2FsbCxncm91cCZyZWRpcmVjdF91cmk9aHR0cDovL29hdXRoLnZrLmNvbS9ibGFuay5odG1sJmRpc3BsYXk9d2FwJnJlc3BvbnNlX3R5cGU9dG9rZW4-\"),(\"Vary\",\"Accept-Encoding\")]}}"++test_body :: String+test_body = "<!DOCTYPE html PUBLIC \"-//WAPFORUM//DTD XHTML Mobile 1.0//EN\" \"http://www.wapforum.org/DTD/xhtml-mobile10.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\">\n<head>\n<meta http-equiv=\"content-type\" content=\"application/xhtml+xml; charset=UTF-8\" />\n<meta http-equiv=\"X-UA-Compatible\" content=\"IE=edge\" />\n<title>\208\159\208\190\208\187\209\131\209\135\208\181\208\189\208\184\208\181 \208\180\208\190\209\129\209\130\209\131\208\191\208\176 \208\186 \208\146\208\154\208\190\208\189\209\130\208\176\208\186\209\130\208\181</title>\n<style type=\"text/css\">\nhtml,body {\n  padding: 0px;\n  margin: 0px;\n  font-family: tahoma, arial, verdana, sans-serif, Lucida Sans;\n  text-align: center;\n  background: #f7f7f7;\n  font-size: 12px;\n}\nb {\n  color: #36638E;\n}\n.button_yes {\n  border: 1px solid #3B6798;\n  text-shadow: #45688E 0px 1px 0px;\n  display: inline-block;\n  width: 90px;\n  text-decoration: none;\n  padding: 0px;\n}\n.button_yes input {\n  background-color: #6D8FB3;\n  border: 1px solid #7E9CBC;\n  border-bottom-color: #5C82AB;\n  border-left-color: #5C82AB;\n  border-right-color: #5C82AB;\n  padding: 3px 3px 4px 3px;\n  color: #FFFFFF;\n  margin: 0px;\n  width: 90px;\n  cursor: pointer;\n  font-size: 12px;\n}\n.button_no {\n  border: 1px solid #B8B8B8;\n  border-top: 1px solid #9F9F9F;\n  text-shadow: #FFFFFF 0px 1px 0px;\n  display: inline-block;\n  width: 70px;\n  color: #000000;\n  text-decoration: none;\n}\n.button_no div {\n  background-color: #EAEAEA;\n  border: 1px solid #FFFFFF;\n  border-bottom-color: #DFDFDF;\n  border-left-color: #F4F4F4;\n  border-right-color: #F4F4F4;\n  padding: 3px 3px 4px 3px;\n}\na {\n  color: #2B587A;\n  text-decoration: none;\n}\n</style>\n<script type=\"text/javascript\" language=\"javascript\">\n// <![CDATA[\nif (parent && parent != window) {\n  location.href = 'http://vk.com';\n}\n// ]]>\n</script>\n</head>\n<body>\n<div style=\"background: #5b7fa6; padding: 2px 3px 3px 3px; border-bottom: 1px solid #6f91bb;\">\n<b style=\"color: #FFFFFF;\">\208\159\208\190\208\187\209\131\209\135\208\181\208\189\208\184\208\181 \208\180\208\190\209\129\209\130\209\131\208\191\208\176 \208\186 \208\146\208\154\208\190\208\189\209\130\208\176\208\186\209\130\208\181</b>\n</div>\n<div style=\"border-top: 1px solid #4a6a91; padding:10px;\">\n  <div style=\"background: #ffffff; border: 1px solid #adbbca; padding: 5px;'\">\n    <style>\ninput {\n  border: 1px solid #C0CAD5;\n}\n.label {\n  color: #777777;\n}\n</style>\n\n<form method=\"POST\" action=\"https://login.vk.com/?act=login&soft=1&utf8=1\">\n<input type=\"hidden\" name=\"q\" value=\"1\">\n<input type=\"hidden\" name=\"from_host\" value=\"oauth.vk.com\">\n<input type=\"hidden\" name=\"from_protocol\" value=\"http\">\n<input type=\"hidden\" name=\"ip_h\" value=\"670993b49983a18c93\" />\n<input type=\"hidden\" name=\"to\" value=\"aHR0cDovL29hdXRoLnZrLmNvbS9vYXV0aC9hdXRob3JpemU/Y2xpZW50X2lkPTMwODIyNjYmcmVkaXJlY3RfdXJpPWJsYW5rLmh0bWwmcmVzcG9uc2VfdHlwZT10b2tlbiZzY29wZT04MTkyJnN0YXRlPSZkaXNwbGF5PXdhcA--\">\n<span class=\"label\">\208\162\208\181\208\187\208\181\209\132\208\190\208\189 \208\184\208\187\208\184 e-mail:</span><br />\n<input type=\"text\" name=\"email\"><br />\n<span class=\"label\">\208\159\208\176\209\128\208\190\208\187\209\140:</span><br />\n<input type=\"password\" name=\"pass\">\n<div style=\"padding: 8px 0px 5px 0px\">\n<div class=\"button_yes\">\n  <input type=\"submit\" value=\"\208\146\208\190\208\185\209\130\208\184\" />\n</div>\n<a class=\"button_no\" href=\"https://oauth.vk.com/grant_access?hash=c3ebb24fc8c8def60f&client_id=3082266&settings=8192&redirect_uri=blank.html&cancel=1&state=&token_type=0\">\n  <div>\n  \208\158\209\130\208\188\208\181\208\189\208\176\n  </div>\n</a>\n</form>\n</div>\n  </div>\n  <div style=\"border-top: 1px solid #DDD; margin: 0 1px 7px 1px;\"></div>\n  \n  <a href=\"http://m.vkontakte.ru\">\208\191\208\181\209\128\208\181\208\185\209\130\208\184 \208\186 \209\129\208\176\208\185\209\130\209\131</a>\n</div>\n</body>"+++test_uri :: Uri+test_uri = Uri {_relative = False, _scheme = "http", _authority = Authority {__userinfo = "", __host = Hostname {__domain = Domain {__parts = ["oauth","vk","com"]}}, __port = Nothing}, __path = Path {__segments = ["","blank.html"]}, __query = "", __fragment = "access_token=ab266e7cfb6db4e5ab99513d4aab048f09aab2bab2ba713c89d4d95b37ad4f6&expires_in=86400&user_id=911727"} +

@@ -0,0 +1,20 @@+-- FIXME: in order debug to work+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE OverlappingInstances #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}++module Debug where++import Control.Monad+import Control.Monad.Trans++class Debug x where+    debug :: (MonadIO m) => x -> m ()++instance (Show x) => Debug x where+    debug = liftIO . putStrLn . show . show++instance Debug String where+    debug = liftIO . putStrLn . show+

@@ -0,0 +1,45 @@+{-# LANGUAGE ScopedTypeVariables #-}++module Web.VKHS.Curl (vk_curl) where++import Prelude hiding (catch)+import Control.Exception (catch,bracket)+import Control.Concurrent (threadDelay)+import Control.Monad.Writer+import Data.IORef (newIORef, readIORef, atomicModifyIORef)+import qualified Data.ByteString.UTF8 as U+import Network.Curlhs.Core++import Web.VKHS.Types++import qualified Data.ByteString.Char8 as BS++-- | Generic request sender. Uses delay to prevent application from being+-- blocked for flooding+vk_curl :: Env -> Writer [CURLoption] () -> IO (Either String String)+vk_curl e w = do+    let askE x = return (x e)+    v <- askE verbose+    a <- askE useragent+    d <- askE delay_ms+    do+        buff <- newIORef BS.empty+        bracket (curl_easy_init) (curl_easy_cleanup) $ \curl -> do {+            let +                memwrite n = atomicModifyIORef buff+                    (\o -> (BS.append o n, CURL_WRITEFUNC_OK))+            in+            curl_easy_setopt curl $+                [ CURLOPT_HEADER         True+                , CURLOPT_WRITEFUNCTION (Just $ memwrite)+                , CURLOPT_SSL_VERIFYPEER False+                , CURLOPT_USERAGENT $ BS.pack a+                , CURLOPT_VERBOSE (v == Debug )+                ] ++ (execWriter w);+            curl_easy_perform curl;+            threadDelay (1000 * d); -- delay in microseconds+            b <- readIORef buff ;+            return (Right $ U.toString b) ;+        } `catch`+            (\(e::CURLcode) -> return $ Left ("CURL error: " ++ (show e)))+