diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,2 @@ -import Distribution.Simple -main = defaultMain +import Distribution.Simple +main = defaultMain diff --git a/VKHS.cabal b/VKHS.cabal --- a/VKHS.cabal +++ b/VKHS.cabal @@ -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.*, diff --git a/src/Data/Label.hs b/src/Data/Label.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label.hs @@ -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 + diff --git a/src/Data/Label/Abstract.hs b/src/Data/Label/Abstract.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Abstract.hs @@ -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 #-} + diff --git a/src/Data/Label/Derive.hs b/src/Data/Label/Derive.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Derive.hs @@ -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 + diff --git a/src/Data/Label/Maybe.hs b/src/Data/Label/Maybe.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Maybe.hs @@ -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)) + + + diff --git a/src/Data/Label/MaybeM.hs b/src/Data/Label/MaybeM.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/MaybeM.hs @@ -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) + diff --git a/src/Data/Label/Pure.hs b/src/Data/Label/Pure.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/Pure.hs @@ -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 + diff --git a/src/Data/Label/PureM.hs b/src/Data/Label/PureM.hs new file mode 100644 --- /dev/null +++ b/src/Data/Label/PureM.hs @@ -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) + diff --git a/src/Network/Protocol/Cookie.hs b/src/Network/Protocol/Cookie.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Cookie.hs @@ -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 + diff --git a/src/Network/Protocol/Http.hs b/src/Network/Protocol/Http.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http.hs @@ -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 + diff --git a/src/Network/Protocol/Http/Data.hs b/src/Network/Protocol/Http/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Data.hs @@ -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' + diff --git a/src/Network/Protocol/Http/Headers.hs b/src/Network/Protocol/Http/Headers.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Headers.hs @@ -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" + diff --git a/src/Network/Protocol/Http/Parser.hs b/src/Network/Protocol/Http/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Parser.hs @@ -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) + diff --git a/src/Network/Protocol/Http/Printer.hs b/src/Network/Protocol/Http/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Printer.hs @@ -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 + diff --git a/src/Network/Protocol/Http/Status.hs b/src/Network/Protocol/Http/Status.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Http/Status.hs @@ -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 + diff --git a/src/Network/Protocol/Mime.hs b/src/Network/Protocol/Mime.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Mime.hs @@ -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") + ] + diff --git a/src/Network/Protocol/Uri.hs b/src/Network/Protocol/Uri.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Chars.hs b/src/Network/Protocol/Uri/Chars.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Chars.hs @@ -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 "!$&'()*+,;=" + diff --git a/src/Network/Protocol/Uri/Data.hs b/src/Network/Protocol/Uri/Data.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Data.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Encode.hs b/src/Network/Protocol/Uri/Encode.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Encode.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Parser.hs b/src/Network/Protocol/Uri/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Parser.hs @@ -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 diff --git a/src/Network/Protocol/Uri/Path.hs b/src/Network/Protocol/Uri/Path.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Path.hs @@ -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) + diff --git a/src/Network/Protocol/Uri/Printer.hs b/src/Network/Protocol/Uri/Printer.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Printer.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Query.hs b/src/Network/Protocol/Uri/Query.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Query.hs @@ -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 + diff --git a/src/Network/Protocol/Uri/Remap.hs b/src/Network/Protocol/Uri/Remap.hs new file mode 100644 --- /dev/null +++ b/src/Network/Protocol/Uri/Remap.hs @@ -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 + + diff --git a/src/Network/Shpider/Forms.hs b/src/Network/Shpider/Forms.hs new file mode 100644 --- /dev/null +++ b/src/Network/Shpider/Forms.hs @@ -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. In my humble opinion, and considering that a few different packages implement this meager code, this should be in the prelude. +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 ) + diff --git a/src/Test/Api.hs b/src/Test/Api.hs new file mode 100644 --- /dev/null +++ b/src/Test/Api.hs @@ -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 diff --git a/src/Test/Data.hs b/src/Test/Data.hs new file mode 100644 --- /dev/null +++ b/src/Test/Data.hs @@ -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 = "\n\n\n\n\n\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\n\n\n\n\n
\n\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\n
\n
\n
\n \n\n
\n\n\n\n\n\n\208\162\208\181\208\187\208\181\209\132\208\190\208\189 \208\184\208\187\208\184 e-mail:
\n
\n\208\159\208\176\209\128\208\190\208\187\209\140:
\n\n
\n
\n \n
\n\n
\n \208\158\209\130\208\188\208\181\208\189\208\176\n
\n\n\n
\n
\n
\n \n \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\n
\n" + + +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"} + diff --git a/src/Test/Debug.hs b/src/Test/Debug.hs new file mode 100644 --- /dev/null +++ b/src/Test/Debug.hs @@ -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 + diff --git a/src/Web/VKHS/Curl.hs b/src/Web/VKHS/Curl.hs new file mode 100644 --- /dev/null +++ b/src/Web/VKHS/Curl.hs @@ -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))) +