VKHS 0.5.7 → 1.6.0
raw patch · 46 files changed
+1126/−5399 lines, 46 filesdep +EitherTdep +case-insensitivedep +clockdep −bimapdep −curlhsdep −failure
Dependencies added: EitherT, case-insensitive, clock, data-default-class, http-client, http-client-tls, http-types, network-uri, pipes, pipes-http
Dependencies removed: bimap, curlhs, failure, pretty-show, safe, template-haskell, transformers
Files
- VKHS.cabal +30/−60
- app/vkq/Main.hs +252/−0
- src/Data/Label.hs +0/−166
- src/Data/Label/Abstract.hs +0/−133
- src/Data/Label/Derive.hs +0/−214
- src/Data/Label/Maybe.hs +0/−75
- src/Data/Label/MaybeM.hs +0/−31
- src/Data/Label/Pure.hs +0/−46
- src/Data/Label/PureM.hs +0/−72
- src/Network/Protocol/Cookie.hs +0/−238
- src/Network/Protocol/Http.hs +0/−130
- src/Network/Protocol/Http/Data.hs +0/−176
- src/Network/Protocol/Http/Headers.hs +0/−153
- src/Network/Protocol/Http/Parser.hs +0/−174
- src/Network/Protocol/Http/Printer.hs +0/−88
- src/Network/Protocol/Http/Status.hs +0/−193
- src/Network/Protocol/Mime.hs +0/−695
- src/Network/Protocol/Uri.hs +0/−128
- src/Network/Protocol/Uri/Chars.hs +0/−48
- src/Network/Protocol/Uri/Data.hs +0/−214
- src/Network/Protocol/Uri/Encode.hs +0/−66
- src/Network/Protocol/Uri/Parser.hs +0/−308
- src/Network/Protocol/Uri/Path.hs +0/−102
- src/Network/Protocol/Uri/Printer.hs +0/−98
- src/Network/Protocol/Uri/Query.hs +0/−82
- src/Network/Protocol/Uri/Remap.hs +0/−74
- src/Network/Shpider/Forms.hs +0/−129
- src/Test/API.hs +0/−17
- src/Test/Data.hs +0/−27
- src/Test/Debug.hs +0/−19
- src/Text/HTML/TagSoup/Parsec.hs +0/−209
- src/Text/Namefilter.hs +0/−17
- src/Text/PFormat.hs +0/−24
- src/VKNews.hs +0/−134
- src/VKQ.hs +0/−291
- src/Web/VKHS.hs +100/−65
- src/Web/VKHS/API.hs +115/−4
- src/Web/VKHS/API/Aeson.hs +0/−93
- src/Web/VKHS/API/Base.hs +0/−45
- src/Web/VKHS/API/Monad.hs +0/−76
- src/Web/VKHS/API/Types.hs +0/−52
- src/Web/VKHS/Client.hs +271/−0
- src/Web/VKHS/Curl.hs +0/−177
- src/Web/VKHS/Login.hs +164/−217
- src/Web/VKHS/Monad.hs +96/−0
- src/Web/VKHS/Types.hs +98/−39
VKHS.cabal view
@@ -1,6 +1,6 @@ name: VKHS-version: 0.5.7+version: 1.6.0 synopsis: Provides access to Vkontakte social network via public API description: Provides access to Vkontakte API methods. Library requires no interaction@@ -16,78 +16,48 @@ cabal-version: >=1.6 homepage: http://github.com/grwlf/vkhs -source-repository head- type: git- location: https://github.com/grwlf/vkhs.git--executable vknews- extra-libraries: curl- hs-source-dirs: src- main-is: VKNews.hs- build-tools: hsc2hs- ghc-options: -Wall -fwarn-tabs--executable vkq- hs-source-dirs: src- main-is: VKQ.hs- 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, Text.Namefilter,- Text.PFormat,- Text.HTML.TagSoup.Parsec,- Data.Label.Abstract,- Data.Label.Derive,- Data.Label.Maybe,- Data.Label.MaybeM,- Data.Label.Pure,- Data.Label.PureM,- Data.Label-- -- maybe not elegant, but convenient during tests- -- if os(windows)- -- include-dirs: .\curl-7.25.0-devel-mingw32\include- -- extra-lib-dirs: .\curl-7.25.0-devel-mingw32\bin+ other-modules: - exposed-modules: Web.VKHS- Web.VKHS.API- Web.VKHS.API.Aeson- Web.VKHS.API.Base- Web.VKHS.API.Types- Web.VKHS.API.Monad- Web.VKHS.Curl- Web.VKHS.Login+ exposed-modules:+ Web.VKHS Web.VKHS.Types+ Web.VKHS.Monad+ Web.VKHS.Client+ Web.VKHS.Login+ Web.VKHS.API build-depends: base >=4.6 && <5, containers, mtl, bytestring,- tagsoup,- failure,- curlhs,- safe,+ http-client,+ http-client-tls,+ network-uri,+ pipes,+ pipes-http,+ time,+ data-default-class, parsec,+ tagsoup,+ case-insensitive,+ http-types, split, utf8-string,- bimap,- template-haskell,- transformers,+ clock, optparse-applicative, aeson,- filepath,- directory,- regexpr,- pretty-show,+ EitherT, vector,- text,- time+ filepath,+ directory+++executable vkq+ hs-source-dirs: app/vkq, app/aux, src+ main-is: Main.hs+ build-depends: regexpr,+ text+
+ app/vkq/Main.hs view
@@ -0,0 +1,252 @@+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++module Main where++import Control.Exception (SomeException(..),catch,bracket)+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Either+import Data.Maybe+import Data.List+import Data.Char+import Data.Text(Text(..),pack)+import qualified Data.Text as Text+import qualified Data.Text.IO as Text+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS+import Options.Applicative+import System.Environment+import System.Exit+import System.IO+import Text.RegexPR+import Text.Printf++import Web.VKHS+import Web.VKHS.Types+import Web.VKHS.Client as Client+import Web.VKHS.Monad hiding (catch)+import Web.VKHS.API as API+import Web.VKHS.API.Types as API++import Util++env_access_token = "VKQ_ACCESS_TOKEN"++data APIOptions = APIOptions {+ a_method :: String+ , a_args :: String+ } deriving(Show)++data LoginOptions = LoginOptions {+ l_eval :: Bool+ } deriving(Show)++data Options+ = Login GenericOptions LoginOptions+ | API GenericOptions APIOptions+ | Music GenericOptions MusicOptions+ | UserQ GenericOptions UserOptions+ | WallQ GenericOptions WallOptions+ | GroupQ GenericOptions GroupOptions+ deriving(Show)++toMaybe :: (Functor f) => f String -> f (Maybe String)+toMaybe = fmap (\s -> if s == "" then Nothing else Just s)++opts m =+ let++ -- genericOptions_ :: Parser GenericOptions+ genericOptions_ puser ppass = GenericOptions+ <$> (pure $ o_login_host defaultOptions)+ <*> (pure $ o_api_host defaultOptions)+ <*> (pure $ o_port defaultOptions)+ <*> flag False True (long "verbose" <> help "Be verbose")+ <*> (pure $ o_use_https defaultOptions)+ <*> fmap read (strOption (value (show $ o_max_request_rate_per_sec defaultOptions) <> long "req-per-sec" <> metavar "N" <> help "Max number of requests per second"))+ <*> flag True False (long "interactive" <> help "Allow interactive queries")++ <*> (AppID <$> strOption (long "appid" <> metavar "APPID" <> value "3128877" <> help "Application ID, defaults to VKHS" ))+ <*> puser+ <*> ppass+ <*> strOption (short 'a' <> m <> metavar "ACCESS_TOKEN" <>+ help ("Access token. Honores " ++ env_access_token ++ " environment variable"))++ genericOptions = genericOptions_+ (strOption (value "" <> long "user" <> metavar "USER" <> help "User name or email"))+ (strOption (value "" <> long "pass" <> metavar "PASS" <> help "User password"))++ genericOptions_login = genericOptions_+ (argument str (metavar "USER" <> help "User name or email"))+ (argument str (metavar "PASS" <> help "User password"))+++ api_cmd = (info (API <$> genericOptions <*> (APIOptions+ <$> argument str (metavar "METHOD" <> help "Method name")+ <*> argument str (metavar "PARAMS" <> help "Method arguments, KEY=VALUE[,KEY2=VALUE2[,,,]]")))+ ( progDesc "Call VK API method" ))++ in subparser (+ command "login" (info (Login <$> genericOptions_login <*> (LoginOptions+ <$> flag False True (long "eval" <> help "Print in shell-friendly format")+ ))+ ( progDesc "Login and print access token" ))+ <> command "call" api_cmd+ <> command "api" api_cmd+ <> command "music" (info ( Music <$> genericOptions <*> (MusicOptions+ <$> switch (long "list" <> short 'l' <> help "List music files")+ <*> strOption+ ( metavar "STR"+ <> long "query" <> short 'q' <> value [] <> help "Query string")+ <*> strOption+ ( metavar "FORMAT"+ <> short 'f'+ <> value "%o_%i %U\t%t"+ <> help "Listing format, supported tags: %i %o %a %t %d %u"+ )+ <*> strOption+ ( metavar "FORMAT"+ <> short 'F'+ <> value "%o_%i %U\t%t"+ <> help ("Output format, supported tags:" ++ (listTags mr_tags))+ )+ <*> toMaybe (strOption (metavar "DIR" <> short 'o' <> help "Output directory" <> value ""))+ <*> many (argument str (metavar "RECORD_ID" <> help "Download records"))+ <*> flag False True (long "skip-existing" <> help "Don't download existing files")+ ))+ ( progDesc "List or download music files"))++ <> command "user" (info ( UserQ <$> genericOptions <*> (UserOptions+ <$> strOption (long "query" <> short 'q' <> help "String to query")+ ))+ ( progDesc "Extract various user information"))++ <> command "wall" (info ( WallQ <$> genericOptions <*> (WallOptions+ <$> strOption (long "id" <> short 'i' <> help "Owner id")+ ))+ ( progDesc "Extract wall information"))++ <> command "group" (info ( GroupQ <$> genericOptions <*> (GroupOptions+ <$> strOption (long "query" <> short 'q' <> value [] <> help "Group search string")+ <*> strOption+ ( metavar "FORMAT"+ <> short 'F'+ <> value "%o_%i %U\t%t"+ <> help ("Output format, supported tags:" ++ (listTags gr_tags))+ )+ ))+ ( progDesc "Extract groups information"))+ )++main :: IO ()+main = ( do+ m <- maybe (value "") (value) <$> lookupEnv env_access_token+ o <- execParser (info (helper <*> opts m) (fullDesc <> header "VKontakte social network tool"))+ r <- runEitherT (cmd o)+ case r of+ Left err -> do+ hPutStrLn stderr err+ exitFailure+ Right _ -> do+ return ()+ )`catch` (\(e::SomeException) -> do+ putStrLn $ (show e)+ exitFailure+ )++{-+ ____ _ ___+ / ___| | |_ _|+| | | | | |+| |___| |___ | |+ \____|_____|___|++ -}++cmd :: Options -> EitherT String IO ()++-- Login+cmd (Login go LoginOptions{..}) = do+ AccessToken{..} <- runLogin go+ case l_eval of+ True -> liftIO $ putStrLn $ printf "export %s=%s\n" env_access_token at_access_token+ False -> liftIO $ putStrLn at_access_token++-- API+cmd (API go APIOptions{..}) = do+ runAPI go (apiJ a_method (splitFragments "," "=" a_args))+ return ()++cmd (Music go@GenericOptions{..} mo@MusicOptions{..})++ -- Query music files+ |not (null m_search_string) = do+ runAPI go $ do+ API.Response _ (SizedList len ms) <- api "audio.search" [("q",m_search_string)]+ forM_ ms $ \m -> do+ io $ printf "%s\n" (mr_format m_output_format m)+ io $ printf "total %d\n" len++ -- List music files+ |m_list_music = do+ runAPI go $ do+ (API.Response _ (ms :: [MusicRecord])) <- api "audio.get" [("q",m_search_string)]+ forM_ ms $ \m -> do+ io $ printf "%s\n" (mr_format m_output_format m)++ -- Download music files+ |not (null m_records_id) = do+ let out_dir = fromMaybe "." m_out_dir+ runAPI go $ do+ (API.Response _ (ms :: [MusicRecord])) <- api "audio.getById" [("audios", concat $ intersperse "," m_records_id)]+ forM_ ms $ \mr@MusicRecord{..} -> do+ (f, mh) <- liftIO $ openFileMR mo mr+ case mh of+ Just h -> do+ u <- ensure (pure $ Client.urlFromString mr_url_str)+ r <- Client.downloadFileWith u (BS.hPut h)+ io $ printf "%d_%d\n" mr_owner_id mr_id+ io $ printf "%s\n" mr_title+ io $ printf "%s\n" f+ Nothing -> do+ io $ hPutStrLn stderr ("File " ++ f ++ " already exist, skipping")+ return ()+++-- Download audio files+-- cmd (Options v (Music (MO act False [] _ ofmt odir rid sk))) = do+-- let e = (envcall act) { verbose = v }+-- Response (ms :: [MusicRecord]) <- api_ e "audio.getById" [("audios", concat $ intersperse "," rid)]+-- forM_ ms $ \m -> do+-- (fp, mh) <- openFileMR odir sk ofmt m+-- case mh of+-- Just h -> do+-- r <- vk_curl_file e (url m) $ \ bs -> do+-- BS.hPut h bs+-- checkRight r+-- printf "%d_%d\n" (owner_id m) (aid m)+-- printf "%s\n" (title m)+-- printf "%s\n" fp+-- Nothing -> do+-- hPutStrLn stderr (printf "File %s already exist, skipping" fp)+-- return ()++-- Query groups files+cmd (GroupQ go (GroupOptions{..}))++ |not (null g_search_string) = do++ runAPI go $ do++ API.Response _ (Many cnt (grs :: [GroupRecord])) <-+ api "groups.search"+ [("q",g_search_string),+ ("v","5.44"),+ ("fields", "can_post,members_count"),+ ("count", "1000")]++ forM_ grs $ \gr -> do+ liftIO $ printf "%s\n" (gr_format g_output_format gr)+
− src/Data/Label.hs
@@ -1,166 +0,0 @@-{-# 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---- * 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 bijections 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-
− src/Data/Label/Abstract.hs
@@ -1,133 +0,0 @@-{-# 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 arr f i o = Point- { _get :: f `arr` o- , _set :: (i, f) `arr` f- }---- | Modification as a compositon of a getter and setter. Unfortunately,--- `ArrowApply' is needed for this composition.--_modify :: ArrowApply arr => Point arr f i o -> (o `arr` i, f) `arr` 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 arr f a = Lens { unLens :: Point arr f a a }---- | Create a lens out of a getter and setter.--lens :: (f `arr` a) -> ((a, f) `arr` f) -> Lens arr f a-lens g s = Lens (Point g s)---- | Get the getter arrow from a lens.--get :: Arrow arr => Lens arr f a -> f `arr` a-get = _get . unLens---- | Get the setter arrow from a lens.--set :: Arrow arr => Lens arr f a -> (a, f) `arr` f-set = _set . unLens---- | Get the modifier arrow from a lens.--modify :: ArrowApply arr => Lens arr f o -> (o `arr` o, f) `arr` f-modify = _modify . unLens--instance ArrowApply arr => Category (Lens arr) 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 arr => Functor (Point arr f i) where- fmap f x = Point (arr f . _get x) (_set x)- {-# INLINE fmap #-}--instance Arrow arr => Applicative (Point arr 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 arr => (o' `arr` o) -> (i `arr` i') -> Point arr f i' o' -> Point arr f i o-bimap f g l = Point (f . _get l) (_set l . first g)--infix 8 `for`--for :: Arrow arr => (i `arr` o) -> Lens arr f o -> Point arr f i o-for p = bimap id p . unLens---- | The bijections datatype, an arrow that works in two directions. --infix 8 `Bij`--data Bijection arr a b = Bij { fw :: a `arr` b, bw :: b `arr` a }---- | Bijections as categories.--instance Category arr => Category (Bijection arr) where- id = Bij id id- Bij a b . Bij c d = a . c `Bij` d . b- {-# INLINE id #-}- {-# INLINE (.) #-}---- | Lifting 'Bijection's.--liftBij :: Functor f => Bijection (->) a b -> Bijection (->) (f a) (f b)-liftBij a = fmap (fw a) `Bij` fmap (bw a)---- | The isomorphism type class is like a `Functor' but works in two directions.--infixr 8 `iso`--class Iso arr f where- iso :: Bijection arr a b -> f a `arr` f b---- | Flipped isomorphism.--osi :: Iso arr f => Bijection arr b a -> f a `arr` f b-osi (Bij a b) = iso (Bij b a)---- | We can diverge 'Lens'es using an isomorphism.--instance Arrow arr => Iso arr (Lens arr 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 arr => Iso arr (Bijection arr a) where- iso = arr . (.)- {-# INLINE iso #-}-
− src/Data/Label/Derive.hs
@@ -1,214 +0,0 @@-{-# OPTIONS -fno-warn-orphans #-}-{-# LANGUAGE- TemplateHaskell- , OverloadedStrings- , FlexibleContexts- , FlexibleInstances- , TypeOperators- , CPP- #-}-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.- --- -- Type of InlineSpec removed in TH-2.8.0 (GHC 7.6)-#if MIN_VERSION_template_haskell(2,8,0)- inline = PragmaD (InlineP labelName Inline FunLike (FromPhase 0))-#else- inline = PragmaD (InlineP labelName (InlineSpec True True (Just (True, 0))))-#endif- 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 (KindedTV tv kind) = SigT (VarT tv) kind-- -- Prettify type variables.- arrow = varT (mkName "arr")- prettyVars = map prettyTyVar vars- forallVars = PlainTV (mkName "arr") : 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 prettyType 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---- 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-
− src/Data/Label/Maybe.hs
@@ -1,75 +0,0 @@-{-# LANGUAGE TypeOperators, TupleSections #-}-module Data.Label.Maybe-( (:~>)-, lens-, get-, set-, set'-, modify-, modify'-, embed-)-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)))-
− src/Data/Label/MaybeM.hs
@@ -1,31 +0,0 @@-{-# 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)-
− src/Data/Label/Pure.hs
@@ -1,46 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Data.Label.Pure-( (:->)-, lens-, get-, set-, modify-)-where--import qualified Data.Label.Abstract as A--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-
− src/Data/Label/PureM.hs
@@ -1,72 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Data.Label.PureM-(--- * 'MonadState' lens operations.- gets-, puts-, modify-, modifyAndGet-, (=:)-, (=.)---- * 'MonadReader' lens operations.-, asks-, local-)-where--import Control.Monad-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)---- | Modify a value with a function somewhere in the state, pointed to by the--- specified lens. Additionally return a separate value based on the--- modification.--modifyAndGet :: M.MonadState s m => (s :-> a) -> (a -> (b, a)) -> m b-modifyAndGet l f =- do (b, a) <- f `liftM` gets l- puts l a- return b-
− src/Network/Protocol/Cookie.hs
@@ -1,238 +0,0 @@-{--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-
− src/Network/Protocol/Http.hs
@@ -1,130 +0,0 @@-{--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-
− src/Network/Protocol/Http/Data.hs
@@ -1,176 +0,0 @@-{--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, KindSignatures #-}-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'-
− src/Network/Protocol/Http/Headers.hs
@@ -1,153 +0,0 @@-{--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"-
− src/Network/Protocol/Http/Parser.hs
@@ -1,174 +0,0 @@-{--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)-
− src/Network/Protocol/Http/Printer.hs
@@ -1,88 +0,0 @@-{--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-
− src/Network/Protocol/Http/Status.hs
@@ -1,193 +0,0 @@-{--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-
− src/Network/Protocol/Mime.hs
@@ -1,695 +0,0 @@-{--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")- ]-
− src/Network/Protocol/Uri.hs
@@ -1,128 +0,0 @@-{--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-
− src/Network/Protocol/Uri/Chars.hs
@@ -1,48 +0,0 @@-{--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 "!$&'()*+,;="-
− src/Network/Protocol/Uri/Data.hs
@@ -1,214 +0,0 @@-{--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-
− src/Network/Protocol/Uri/Encode.hs
@@ -1,66 +0,0 @@-{--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-
− src/Network/Protocol/Uri/Parser.hs
@@ -1,308 +0,0 @@-{--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
− src/Network/Protocol/Uri/Path.hs
@@ -1,102 +0,0 @@-{--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)-
− src/Network/Protocol/Uri/Printer.hs
@@ -1,98 +0,0 @@-{--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-
− src/Network/Protocol/Uri/Query.hs
@@ -1,82 +0,0 @@-{--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-
− src/Network/Protocol/Uri/Remap.hs
@@ -1,74 +0,0 @@-{--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--
− src/Network/Shpider/Forms.hs
@@ -1,129 +0,0 @@-{-- - Copyright (c) 2009-2010 Johnny Morrice- -- - Permission is hereby granted, free of charge, to any person- - obtaining a copy of this software and associated documentation - - files (the "Software"), to deal in the Software without - - restriction, including without limitation the rights to use, copy, - - modify, merge, publish, distribute, sublicense, and/or sell copies - - of the Software, and to permit persons to whom the Software is - - furnished to do so, subject to the following conditions:- -- - The above copyright notice and this permission notice shall be - - included in all copies or substantial portions of the Software.- -- - THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, - - EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF- - MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND - - NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS- - BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN- - ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN- - CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE- - SOFTWARE.- -- -}-module Network.Shpider.Forms - (- Form (..)- , Method (..)- , gatherForms- , fillOutForm- , allForms- , toForm- , mkForm- )- where--import Data.Maybe-import Data.Char-import Control.Arrow ( first )-import qualified Data.Map as M-import Text.HTML.TagSoup.Parsec--data Method = GET | POST- deriving Show---- | Plain old form: Method, action and inputs.-data Form = - Form { method :: Method- , action :: String - , inputs :: M.Map String String- }- deriving Show---- | Takes a form and fills out the inputs with the given [ ( String , String ) ].--- It is convienent to use the `pairs` syntax here.------ @--- f : _ <- `getFormsByAction` \"http:\/\/whatever.com\"--- `sendForm` $ `fillOutForm` f $ `pairs` $ do--- \"author\" =: \"Johnny\"--- \"message\" =: \"Nice syntax dewd.\"--- @-fillOutForm :: Form -> [ ( String , String ) ] -> Form-fillOutForm = foldl ( \f (n,v) -> f { inputs = M.insert n v $ inputs f } )---- | The first argument is the action attribute of the form, the second is the method attribute, and the third are the inputs.-mkForm :: String -> Method -> [ ( String , String ) ] -> Form-mkForm a m ps =- Form { action = a- , method = m- , inputs = M.fromList ps- }---- | Gets all forms from a list of tags.-gatherForms :: [ Tag String ] -> [ Form ]-gatherForms =- tParse allForms---- | The `TagParser` which parses all forms.-allForms :: TagParser String [ Form ]-allForms = do- fs <- allWholeTags "form"- return $ mapMaybe toForm fs---- | A case insensitive lookup for html attributes.-attrLookup :: String -> [ ( String , String ) ] -> Maybe String-attrLookup attr =- lookup ( map toLower attr ) . map ( first (map toLower) )---- | Turns a String lowercase. <rant>In my humble opinion, and considering that a few different packages implement this meager code, this should be in the prelude.</rant>-lowercase :: String -> String -lowercase = map toLower---toForm :: WholeTag String -> Maybe Form-toForm ( TagOpen _ attrs , innerTags , _ ) = do- m <- methodLookup attrs- a <- attrLookup "action" attrs- let is = tParse ( allOpenTags "input" ) innerTags- tas = tParse ( allWholeTags "textarea" ) innerTags- Just $ Form { inputs = M.fromList $ mapMaybe inputNameValue is ++ mapMaybe textAreaNameValue tas- , action = a- , method = m- }--methodLookup attrs = do- m <- attrLookup "method" attrs- case lowercase m of- "get" ->- Just GET- "post" ->- Just POST- otherwise ->- Nothing--inputNameValue ( TagOpen _ attrs ) = do- v <- case attrLookup "value" attrs of- Nothing ->- Just ""- j@(Just _ ) ->- j- n <- attrLookup "name" attrs- Just ( n , v )--textAreaNameValue ( TagOpen _ attrs , inner , _ ) = do- let v = innerText inner- n <- attrLookup "name" attrs- Just ( n , v )-
− src/Test/API.hs
@@ -1,17 +0,0 @@-module Test.API where--import Web.VKHS---- | Almost working example. Just set correct values for client_id/login/password-print_user_info :: IO ()-print_user_info = do- let e = env "3213232" "user@example.com" "password" [Photos,Audio,Groups]- r <- login e{verbose = Debug}- print r- let (Right (at,_,_)) = r- ans <- api (callEnv e{verbose = Debug} at) "users.get" [- ("uids","911727")- , ("fields","first_name,last_name,nickname,screen_name")- , ("name_case","nom")- ]- print ans
− src/Test/Data.hs
@@ -1,27 +0,0 @@-module Test.Data where--import Data.Label-import Network.Protocol.Http-import Network.Protocol.Uri-import Network.Protocol.Uri.Query-import Network.Protocol.Cookie as C-import Network.Shpider.Forms--import Text.HTML.TagSoup--tryparse = gatherForms . parseTags --test_cookies :: Cookies-test_cookies = get setCookies test_headers---test_headers :: Http Response-test_headers = read "Http {_headline = Response {__status = Found}, _version = Version {_major = 1, _minor = 1}, _headers = Headers {unHeaders = [(\"Server\",\"nginx/1.2.1\"),(\"Date\",\"Wed, 29 Aug 2012 08:35:18 GMT\"),(\"Content-Type\",\"text/html; charset=windows-1251\"),(\"Content-Length\",\"0\"),(\"Connection\",\"keep-alive\"),(\"X-Powered-By\",\"PHP/5.3.3-7+squeeze3\"),(\"Set-Cookie\",\"remixlang=0; expires=Sat, 24-Aug-2013 14:23:04 GMT; path=/; domain=.vk.com\"),(\"Pragma\",\"no-cache\"),(\"Cache-control\",\"no-store\"),(\"Set-Cookie\",\"remixchk=5; expires=Tue, 20-Aug-2013 04:42:57 GMT; path=/; domain=.vk.com\"),(\"Location\",\"https://login.vk.com/?from_host=oauth.vk.com&from_protocol=http&ip_h=670993b49983a18c93&soft=1&to=aHR0cDovL29hdXRoLnZrLmNvbS9vYXV0aC9hdXRob3JpemU/Y2xpZW50X2lkPTMwODIyNjYmc2NvcGU9d2FsbCxncm91cCZyZWRpcmVjdF91cmk9aHR0cDovL29hdXRoLnZrLmNvbS9ibGFuay5odG1sJmRpc3BsYXk9d2FwJnJlc3BvbnNlX3R5cGU9dG9rZW4-\"),(\"Vary\",\"Accept-Encoding\")]}}"--test_body :: String-test_body = "<!DOCTYPE html PUBLIC \"-//WAPFORUM//DTD XHTML Mobile 1.0//EN\" \"http://www.wapforum.org/DTD/xhtml-mobile10.dtd\">\n<html xmlns=\"http://www.w3.org/1999/xhtml\">\n<head>\n<meta http-equiv=\"content-type\" content=\"application/xhtml+xml; charset=UTF-8\" />\n<meta http-equiv=\"X-UA-Compatible\" content=\"IE=edge\" />\n<title>\208\159\208\190\208\187\209\131\209\135\208\181\208\189\208\184\208\181 \208\180\208\190\209\129\209\130\209\131\208\191\208\176 \208\186 \208\146\208\154\208\190\208\189\209\130\208\176\208\186\209\130\208\181</title>\n<style type=\"text/css\">\nhtml,body {\n padding: 0px;\n margin: 0px;\n font-family: tahoma, arial, verdana, sans-serif, Lucida Sans;\n text-align: center;\n background: #f7f7f7;\n font-size: 12px;\n}\nb {\n color: #36638E;\n}\n.button_yes {\n border: 1px solid #3B6798;\n text-shadow: #45688E 0px 1px 0px;\n display: inline-block;\n width: 90px;\n text-decoration: none;\n padding: 0px;\n}\n.button_yes input {\n background-color: #6D8FB3;\n border: 1px solid #7E9CBC;\n border-bottom-color: #5C82AB;\n border-left-color: #5C82AB;\n border-right-color: #5C82AB;\n padding: 3px 3px 4px 3px;\n color: #FFFFFF;\n margin: 0px;\n width: 90px;\n cursor: pointer;\n font-size: 12px;\n}\n.button_no {\n border: 1px solid #B8B8B8;\n border-top: 1px solid #9F9F9F;\n text-shadow: #FFFFFF 0px 1px 0px;\n display: inline-block;\n width: 70px;\n color: #000000;\n text-decoration: none;\n}\n.button_no div {\n background-color: #EAEAEA;\n border: 1px solid #FFFFFF;\n border-bottom-color: #DFDFDF;\n border-left-color: #F4F4F4;\n border-right-color: #F4F4F4;\n padding: 3px 3px 4px 3px;\n}\na {\n color: #2B587A;\n text-decoration: none;\n}\n</style>\n<script type=\"text/javascript\" language=\"javascript\">\n// <![CDATA[\nif (parent && parent != window) {\n location.href = 'http://vk.com';\n}\n// ]]>\n</script>\n</head>\n<body>\n<div style=\"background: #5b7fa6; padding: 2px 3px 3px 3px; border-bottom: 1px solid #6f91bb;\">\n<b style=\"color: #FFFFFF;\">\208\159\208\190\208\187\209\131\209\135\208\181\208\189\208\184\208\181 \208\180\208\190\209\129\209\130\209\131\208\191\208\176 \208\186 \208\146\208\154\208\190\208\189\209\130\208\176\208\186\209\130\208\181</b>\n</div>\n<div style=\"border-top: 1px solid #4a6a91; padding:10px;\">\n <div style=\"background: #ffffff; border: 1px solid #adbbca; padding: 5px;'\">\n <style>\ninput {\n border: 1px solid #C0CAD5;\n}\n.label {\n color: #777777;\n}\n</style>\n\n<form method=\"POST\" action=\"https://login.vk.com/?act=login&soft=1&utf8=1\">\n<input type=\"hidden\" name=\"q\" value=\"1\">\n<input type=\"hidden\" name=\"from_host\" value=\"oauth.vk.com\">\n<input type=\"hidden\" name=\"from_protocol\" value=\"http\">\n<input type=\"hidden\" name=\"ip_h\" value=\"670993b49983a18c93\" />\n<input type=\"hidden\" name=\"to\" value=\"aHR0cDovL29hdXRoLnZrLmNvbS9vYXV0aC9hdXRob3JpemU/Y2xpZW50X2lkPTMwODIyNjYmcmVkaXJlY3RfdXJpPWJsYW5rLmh0bWwmcmVzcG9uc2VfdHlwZT10b2tlbiZzY29wZT04MTkyJnN0YXRlPSZkaXNwbGF5PXdhcA--\">\n<span class=\"label\">\208\162\208\181\208\187\208\181\209\132\208\190\208\189 \208\184\208\187\208\184 e-mail:</span><br />\n<input type=\"text\" name=\"email\"><br />\n<span class=\"label\">\208\159\208\176\209\128\208\190\208\187\209\140:</span><br />\n<input type=\"password\" name=\"pass\">\n<div style=\"padding: 8px 0px 5px 0px\">\n<div class=\"button_yes\">\n <input type=\"submit\" value=\"\208\146\208\190\208\185\209\130\208\184\" />\n</div>\n<a class=\"button_no\" href=\"https://oauth.vk.com/grant_access?hash=c3ebb24fc8c8def60f&client_id=3082266&settings=8192&redirect_uri=blank.html&cancel=1&state=&token_type=0\">\n <div>\n \208\158\209\130\208\188\208\181\208\189\208\176\n </div>\n</a>\n</form>\n</div>\n </div>\n <div style=\"border-top: 1px solid #DDD; margin: 0 1px 7px 1px;\"></div>\n \n <a href=\"http://m.vkontakte.ru\">\208\191\208\181\209\128\208\181\208\185\209\130\208\184 \208\186 \209\129\208\176\208\185\209\130\209\131</a>\n</div>\n</body>"---test_uri :: Uri-test_uri = Uri {_relative = False, _scheme = "http", _authority = Authority {__userinfo = "", __host = Hostname {__domain = Domain {__parts = ["oauth","vk","com"]}}, __port = Nothing}, __path = Path {__segments = ["","blank.html"]}, __query = "", __fragment = "access_token=ab266e7cfb6db4e5ab99513d4aab048f09aab2bab2ba713c89d4d95b37ad4f6&expires_in=86400&user_id=911727"} -
− src/Test/Debug.hs
@@ -1,19 +0,0 @@--- FIXME: in order debug to work-{-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE TypeSynonymInstances #-}-{-# LANGUAGE FlexibleInstances #-}--module Test.Debug where--import Control.Monad-import Control.Monad.Trans--class Debug x where- debug :: (MonadIO m) => x -> m ()--instance {-# OVERLAPPABLE #-} (Show x) => Debug x where- debug = liftIO . putStrLn . show . show--instance {-# OVERLAPPING #-} Debug String where- debug = liftIO . putStrLn . show-
− src/Text/HTML/TagSoup/Parsec.hs
@@ -1,209 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Text.HTML.TagSoup.Parsec - ( module Text.HTML.TagSoup- , TagParser- , TagParserSt- , WholeTag - , tParse- , tStParse- , openTag - , maybeOpenTag- , eitherOpenTag- , notOpenTag- , allOpenTags- , wholeTag- , maybeWholeTag- , eitherWholeTag- , allWholeTags- , closeTag- , maybeCloseTag- , eitherCloseTag- , notCloseTag- , allCloseTags- , maybeP- , allP- , eitherP- )- where--import Text.ParserCombinators.Parsec-import Text.ParserCombinators.Parsec.Pos-import Text.HTML.TagSoup--import Text.StringLike--import Data.Maybe-import Data.Char---- | A type represent the TagOpen, any inner tags , and the TagClose.-type WholeTag str = (Tag str, [Tag str] , Tag str)---- | The Tag parser, using Tag as the token.-type TagParser str = GenParser (Tag str) ()---- | A stateful tag parser--- This is a new type alias to allow backwards compatibility with old code.-type TagParserSt str u = GenParser (Tag str) u---- | Used to invoke parsing of Tags.-tParse :: (StringLike str, Show str) => TagParser str a -> [ Tag str ] -> a-tParse p ts =- either ( error . show ) id $ parse p "tagsoup" ts---- | Simply run a stateful tag parser-tStParse :: (StringLike str, Show str) => TagParserSt str st a -> st -> [ Tag str ] -> a-tStParse p state tos =- either ( error . show ) id $ runParser p state "tagsoup" tos- ---- Tag eater is the basic tag matcher, it increments the line number for each tag parsed.-tagEater matcher =- tokenPrim show - ( \ oldSp _ _ -> do - setSourceLine oldSp ( 1 + sourceLine oldSp )- )- matcher---- make a string lowercase-lowercase :: StringLike s => s -> s-lowercase =- fromString . map toLower . toString----- | openTag matches a TagOpen with the given name. It is not case sensitive.-openTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)-openTag soughtName =- openTagMatch soughtName ( Just ) $ \ _ -> Nothing---- | notOpenTag will match any tag which is not a TagOpen with the given name. It is not case sensitive.-notOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)-notOpenTag avoidName =- openTagMatch avoidName ( \ _ -> Nothing ) Just---- openTagMatch is the higher order function which will receive a TagOpen, and call match if it matches the soughtName, and noMatch if it doesn't-openTagMatch soughtName match noMatch =- tagEater $ \ tag ->- case tag of- t@( TagOpen tname atrs ) ->- if lowercase tname == lowercase soughtName- then- match t- else- noMatch t- t ->- noMatch t---- closeTagMatch is the higher order function which will receive a TagClose, and call match if it matches the soughtName and noMatch if it doesn't.-closeTagMatch soughtName match noMatch =- tagEater $ \ tag ->- case tag of- t@( TagClose tname ) ->- if lowercase tname == lowercase soughtName- then- match t- else- noMatch t- t ->- noMatch t---- | wholeTag matches a TagOpen with the given name,--- then all intervening tags,--- until it reaches a TagClose with the given name.--- It is not case sensitive.-wholeTag :: (StringLike str, Show str) => str -> TagParserSt str st (WholeTag str)-wholeTag soughtName = do- open <- openTag soughtName- ts <- many $ notCloseTag soughtName- close <- closeTag soughtName- return ( open , ts , close )---- | closeTag matches a TagClose with the given name. It is not case sensitive.-closeTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)-closeTag soughtName =- closeTagMatch soughtName ( Just ) $ \ _ -> Nothing---- | notCloseTag will match any tag which is not a TagClose with the given name. It is not case sensitive.-notCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st (Tag str)-notCloseTag avoidName =- closeTagMatch avoidName ( \ _ -> Nothing ) Just---- | maybeOpenTag will return `Just` the tag if it gets a TagOpen with he given name,--- It will return `Nothing` otherwise.--- It is not case sensitive.-maybeOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (Tag str) )-maybeOpenTag =- maybeP . openTag---- | maybeCloseTag will return `Just` the tag if it gets a TagClose with he given name,--- It will return `Nothing` otherwise.--- It is not case sensitive.-maybeCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (Tag str) )-maybeCloseTag =- maybeP . closeTag---- | maybeWholeTag will return `Just` the tag if it gets a WholeTag with he given name,--- It will return `Nothing` otherwise.--- It is not case sensitive.-maybeWholeTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Maybe (WholeTag str) )-maybeWholeTag =- maybeP . wholeTag---- | allOpenTags will return all TagOpen with the given name.--- It is not case sensitive.-allOpenTags :: (StringLike str, Show str) => str -> TagParserSt str st [ Tag str ]-allOpenTags =- allP . maybeOpenTag---- | allCloseTags will return all TagClose with the given name.--- It is not case sensitive.-allCloseTags :: (StringLike str, Show str) => str -> TagParserSt str st [ Tag str ]-allCloseTags =- allP . maybeCloseTag---- | allWholeTags will return all WholeTag with the given name.--- It is not case sensitive.-allWholeTags :: (StringLike str, Show str) => str -> TagParserSt str st [ WholeTag str ]-allWholeTags =- allP . maybeWholeTag---- | eitherP takes a parser, and becomes its `Either` equivalent -- returning `Right` if it matches, and `Left` of anyToken if it doesn't.-eitherP :: Show tok => GenParser tok st a -> GenParser tok st ( Either tok a )-eitherP p = do- try ( do t <- p- return $ Right t- ) <|> ( do t <- anyToken- return $ Left t- )--- | either a Right TagOpen or a Left arbitary tag.-eitherOpenTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (Tag str) )-eitherOpenTag = - eitherP . openTag---- | either a Right TagClose or a Left arbitary tag.-eitherCloseTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (Tag str) )-eitherCloseTag =- eitherP . closeTag---- | either a Right WholeTag or a Left arbitary tag.-eitherWholeTag :: (StringLike str, Show str) => str -> TagParserSt str st ( Either (Tag str) (WholeTag str) )-eitherWholeTag = - eitherP . wholeTag---- | allP takes a parser which returns a `Maybe` value, and returns a list of matching tokens.-allP :: GenParser tok st ( Maybe a ) -> GenParser tok st [ a ]-allP p = do- ts <- many p- let ls = - catMaybes ts- return ls---- | maybeP takes a parser, and becomes its `Maybe` equivalent -- returning `Just` if it matches, and `Nothing` if it doesn't.-maybeP :: Show tok => GenParser tok st a -> GenParser tok st ( Maybe a )-maybeP p =- try ( do t <- p- return $ Just t- ) <|> ( do anyToken- return Nothing- )--
− src/Text/Namefilter.hs
@@ -1,17 +0,0 @@-module Text.Namefilter - ( namefilter- ) where--import Data.Char-import Data.List-import Text.RegexPR--trim_space = gsubRegexPR "^ +| +$" ""-one_space = gsubRegexPR " +" " "-normal_letters = filter (\c -> or [ isAlphaNum c , c=='-', c=='_', c==' ', c=='&'])-html_amp = gsubRegexPR "&" "&"-no_html = gsubRegexPR re "" where- re = concat $ intersperse "|" [ "&[a-z]+;" , "&#[0-9]+;" ]--namefilter :: String -> String-namefilter = trim_space . one_space . normal_letters . no_html . html_amp
− src/Text/PFormat.hs
@@ -1,24 +0,0 @@-module Text.PFormat - ( pformat - ) where--import Data.List-import Data.Maybe---- | Example: pformat '%' [('%',"%"), ('w',"world")] "hello %% %x %w"--- pformat' :: Char -> [(Char,String)] -> String -> String--- pformat' x d s = reverse $ scan [] s where--- scan h (c:m:cs)--- | c == x = scan ((reverse $ fromMaybe (c:m:[]) (lookup m d))++h) cs--- | otherwise = scan (c:h) (m:cs)--- scan h (c:[]) = c:h--- scan h [] = h--pformat :: Char -> [(Char,a->String)] -> String -> a -> String-pformat x d s a = reverse $ scan [] s where- scan h (c:m:cs)- | c == x = scan ((reverse $ fromMaybe (const $ c:m:[]) (lookup m d) $ a)++h) cs- | otherwise = scan (c:h) (m:cs)- scan h (c:[]) = c:h- scan h [] = h-
− src/VKNews.hs
@@ -1,134 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}--module Main where--import Control.Applicative-import Control.Concurrent (threadDelay)-import Control.Monad.Trans-import Control.Monad.Reader-import Control.Monad.State-import Control.Monad.Error-import Control.Monad-import Data.Aeson-import Data.Maybe-import Data.Either-import Data.Monoid-import Data.Time.Clock-import Options.Applicative-import System.Environment-import System.Exit-import System.IO-import Text.Printf-import Text.RegexPR-import Web.VKHS as VK hiding (api,api')-import Web.VKHS.API.Monad as VK-import Network.CURL730--data Options = Options- { verb :: Verbosity- , application_id :: String- , access_token :: String- , vk_poll_interval_sec :: Int- , username :: String- , password :: String- -- , vk_group_id :: String- } deriving(Show)--data Pirozhok = Pirozhok- { plines :: String- , pdate :: UTCTime- }--pprint p = liftIO $ do- -- putStrLn (show $ pdate p)- putStr (plines p)--type PState a = StateT UTCTime (VKAPI IO) a--instance Error (String,Maybe a) where- strMsg s = (s,Nothing)--pirozhok d' wr@(WR _ _ _ t _) = Pirozhok <$> poetry <*> date- where- poetry = txt >>= nonempty >>= four >>=- maxlet >>= (pure . unlines)- date = check (publishedAt wr) where- check d | d <= d' = oops $ "older than " ++ (show d')- | otherwise = pure d- txt = pure $ lines $ gsubRegexPR "<br>" "\n" $ takeWhile (/= '©') t- nonempty ls = pure $ filter (/=[]) ls- four ls | length ls >4 = oops "more than 4 lines"- | otherwise = pure ls- maxlet ls | (sum $ map length ls) > 250 = oops "more than 250 letters"- | otherwise = pure ls- oops s = throwError (s, Just wr)--env_var_name = "VKNEWS_ACCESS_TOKEN"--opts at = Options- <$> flag Normal Debug (long "verbose" <> help "Be verbose")- <*> strOption (long "application-id" <> short 'a' <> value vkhs_app_id <> help (printf "Application ID (can be set via %s)" env_var_name))- <*> strOption (long "access-token" <> short 't' <> value at <> help "Access token")- <*> option auto (long "poll-interval" <> short 'i' <> value 20 <> help "Poll interval [sec]")- <*> argument str (metavar "USERNAME" <> help "User name")- <*> strOption (metavar "STR" <> long "password" <> short 'p' <> value "-" <> help "Password")- -- <*> argument str (metavar "GROUPID" <> help "Vkontakte ID of the group to read the news from")- where- vkhs_app_id = "3128877"--pirozhki = do- Response (SL len ws) <- lift $ VK.api' "wall.get" [("owner_id",gid_piro)]- d <- get- e <- ask- let ps = map (pirozhok d) ws- let d' = maxtime d (map pdate $ rights ps)- forM (lefts ps) $ \(s,wr) -> do- when (verbose e >= Trace) $ do- liftIO $ hPutStrLn stderr $ printf "Rejecting record %s. Reason: %s" (maybe "?" (show . wid) wr) s- when (d' > d) $ do- when (verbose e >= Trace) $ do- liftIO $ hPutStrLn stderr $ printf "Updating time to %s" (show d')- (put d')- return (rights ps)- where- maxtime d [] = d- maxtime d ps = maximum ps- gid_piro = "-28122932"--cmd :: Options -> IO ()-cmd (Options v apid at pollint u pass) = run $ do- forever $ do- ps <- pirozhki- forM ps $ \p -> do- pprint p- pmsg []- sleep_sec pollint-- where-- run vk = do- t <- getCurrentTime- let e = (VK.env apid u pass VK.allAccess) { verbose = v }- let ma = runStateT vk t- r <- runVKAPI ma ([],[],[]) e- case r of- Left er -> do- perror (show er)- exitFailure- Right ((a,_),_) -> return a-- perror s = liftIO $ hPutStrLn stderr s-- pmsg s = liftIO $ putStrLn s-- sleep_sec s = liftIO $ threadDelay (1000 * 1000 * s)---main :: IO ()-main = withlib CURL730 $ do- hSetBuffering stdout NoBuffering- hSetBuffering stderr NoBuffering- at <- fromMaybe [] <$> lookupEnv env_var_name- execParser (info (opts at) idm) >>= cmd-
− src/VKQ.hs
@@ -1,291 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE DeriveDataTypeable #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE ScopedTypeVariables #-}--module Main where--import Control.Monad-import Control.Exception (SomeException(..),catch,bracket)-import Data.Aeson as A-import Data.Label.Abstract-import Data.List-import qualified Data.ByteString as BS-import qualified Data.ByteString.UTF8 as U-import Network.Protocol.Uri.Query-import Options.Applicative-import System.Directory-import System.Exit-import System.FilePath-import System.Environment-import System.IO-import Text.Printf-import Text.PFormat (pformat)-import Text.Namefilter (namefilter)-import Text.Show.Pretty as PP-import Web.VKHS-import Web.VKHS.Curl-import Web.VKHS.API.Aeson as A-import Web.VKHS.API.Base as STR-import Network.CURL730--data Options = Options- { verb :: Verbosity- , cmdOpts :: CmdOptions- } deriving(Show)--data CmdOptions- = Login LoginOptions- | Call CallOptions- | Music MusicOptions- | UserQ UserOptions- | WallQ WallOptions- deriving(Show)--data LoginOptions = LoginOptions- { appid :: String- , username :: String- , password :: String- } deriving(Show)--data CallOptions = CO- { accessToken :: String- , parse :: Bool- , method :: String- , args :: String- } deriving(Show)--data MusicOptions = MO- { accessToken_m :: String- , list_music :: Bool- , search_string :: String- , name_format :: String- , output_format :: String- , out_dir :: String- , records_id :: [String]- , skip_existing :: Bool- } deriving(Show)--data UserOptions = UO- { accessToken_u :: String- , queryString :: String- } deriving(Show)--data WallOptions = WO- { accessToken_w :: String- , woid :: String- } deriving(Show)--loginOptions :: Parser CmdOptions-loginOptions = Login <$> (LoginOptions- <$> strOption (metavar "APPID" <> short 'a' <> value "3128877" <> help "Application ID, defaults to VKHS" )- <*> argument str (metavar "USER" <> help "User name or email")- <*> argument str (metavar "PASS" <> help "User password"))--opts m =- let access_token_flag = strOption (short 'a' <> m <> metavar "ACCESS_TOKEN" <>- help "Access token. Honores VKQ_ACCESS_TOKEN environment variable")- in Options- <$> flag Normal Debug (long "verbose" <> help "Be verbose")- <*> subparser (- command "login" (info loginOptions- ( progDesc "Login and print access token (also prints user_id and expiration time)" ))- <> command "call" (info (Call <$> (CO- <$> access_token_flag- <*> switch (long "preparse" <> short 'p' <> help "Preparse into Aeson format")- <*> argument str (metavar "METHOD" <> help "Method name")- <*> argument str (metavar "PARAMS" <> help "Method arguments, KEY=VALUE[,KEY2=VALUE2[,,,]]")))- ( progDesc "Call VK API method" ))- <> command "music" (info ( Music <$> (MO- <$> access_token_flag- <*> switch (long "list" <> short 'l' <> help "List music files")- <*> strOption- ( metavar "STR"- <> long "query" <> short 'q' <> value [] <> help "Query string")- <*> strOption- ( metavar "FORMAT"- <> short 'f'- <> value "%o_%i %u\t%t"- <> help "Listing format, supported tags: %i %o %a %t %d %u"- )- <*> strOption- ( metavar "FORMAT"- <> short 'F'- <> value "%a - %t"- <> help "FileName format, supported tags: %i %o %a %t %d %u"- )- <*> strOption (metavar "DIR" <> short 'o' <> help "Output directory" <> value "")- <*> many (argument str (metavar "RECORD_ID" <> help "Download records"))- <*> flag False True (long "skip-existing" <> help "Don't download existing files")- ))- ( progDesc "List or download music files"))- <> command "user" (info ( UserQ <$> (UO- <$> access_token_flag- <*> strOption (long "query" <> short 'q' <> help "String to query")- ))- ( progDesc "Extract various user information"))- <> command "wall" (info ( WallQ <$> (WO- <$> access_token_flag- <*> strOption (long "id" <> short 'i' <> help "Owner id")- ))- ( progDesc "Extract wall information"))- )--api_ :: (A.FromJSON a) => Env CallEnv -> String -> [(String,String)] -> IO a-api_ a b c = do- r <- A.api' a b c- case r of- Right x -> return x- Left e -> hPutStrLn stderr (show e) >> exitFailure--api_str :: Env CallEnv -> String -> [(String,String)] -> IO String-api_str a b c = do- r <- STR.api a b c- case r of- Right x -> return (U.toString x)- Left e -> hPutStrLn stderr e >> exitFailure--mr_format :: String -> MusicRecord -> String-mr_format s mr = pformat '%'- [ ('i', show . aid)- , ('o', show . owner_id)- , ('a', namefilter . artist)- , ('t', namefilter . title)- , ('d', show . duration)- , ('u', url)- ] s mr--ifeither e fl fr = either fl fr e--errexit e = hPutStrLn stderr e >> exitFailure--checkRight (Left e) = hPutStrLn stderr e >> exitFailure-checkRight (Right a) = return a--main :: IO ()-main = withlib CURL730 $ do- m <- maybe (idm) (value) <$> lookupEnv "VKQ_ACCESS_TOKEN"- execParser (info (helper <*> opts m) (fullDesc <> header "Vkontakte social network tool")) >>= cmd- `catch` (\(e::SomeException) -> do- putStrLn $ (show e)- putStrLn $ "NOTE: make sure that libcurl.so is accessible (e.g. by setting LD_LIBRARY_PATH variable)" )--cmd :: Options -> IO ()---- Login-cmd (Options v (Login (LoginOptions a u p))) = do- let e = (env a u p allAccess) { verbose = v }- ea <- login e- ifeither ea errexit $ \(at,usrid,expin) -> do- printf "%s %s %s\n" at usrid expin---- Call user-specified API-cmd (Options v (Call (CO act pp mn as))) = do- let e = (envcall act) { verbose = v }- let s = fw (keyValues "," "=") as- case pp of- False -> do- ea <- api_str e mn s- putStrLn (show ea)- True -> do- (ea :: A.Value) <- api_ e mn s- putStrLn $ PP.ppShow ea---- Query audio files-cmd (Options v (Music (MO act _ q@(_:_) fmt _ _ _ _))) = do- let e = (envcall act) { verbose = v }- Response (SL len ms) <- api_ e "audio.search" [("q",q)]- forM_ ms $ \m -> do- printf "%s\n" (mr_format fmt m)- printf "total %d\n" len---- List audio files-cmd (Options v (Music (MO act True [] fmt _ _ _ _))) = do- let e = (envcall act) { verbose = v }- Response (ms :: [MusicRecord]) <- api_ e "audio.get" []- forM_ ms $ \m -> do- printf "%s\n" (mr_format fmt m)-cmd (Options _ (Music (MO _ False [] _ _ _ [] _))) = do- errexit "Music record ID is not specified (see --help)"---- Download audio files-cmd (Options v (Music (MO act False [] _ ofmt odir rid sk))) = do- let e = (envcall act) { verbose = v }- Response (ms :: [MusicRecord]) <- api_ e "audio.getById" [("audios", concat $ intersperse "," rid)]- forM_ ms $ \m -> do- (fp, mh) <- openFileMR odir sk ofmt m- case mh of- Just h -> do- r <- vk_curl_file e (url m) $ \ bs -> do- BS.hPut h bs- checkRight r- printf "%d_%d\n" (owner_id m) (aid m)- printf "%s\n" (title m)- printf "%s\n" fp- Nothing -> do- hPutStrLn stderr (printf "File %s already exist, skipping" fp)- return ()--cmd (Options v (UserQ (UO act qs))) = do- let e = (envcall act) { verbose = v }- print qs- ea <- A.api e "users.search" [("q",qs),("fields","uid,first_name,last_name,photo,education")]- putStrLn $ show ea- -- ae <- checkRight ea- -- processUQ uo ae---- List wall messages-cmd (Options v (WallQ (WO act oid))) = do- let e = (envcall act) { verbose = v }- (Response (SL len ws)) <- api_ e "wall.get" [("owner_id",oid)]- forM_ ws $ \w -> do- putStrLn (show $ wdate w)- putStrLn (wtext w)- printf "total %d\n" len--type NameFormat = String---- Open file. Return filename and handle. Don't open file if it exists-openFileMR :: FilePath -> Bool -> NameFormat -> MusicRecord -> IO (FilePath, Maybe Handle)-openFileMR [] _ _ m = do- let (_,ext) = splitExtension (url m)- temp <- getTemporaryDirectory- (fp,h) <- openBinaryTempFile temp ("vkqmusic"++ext)- return (fp, Just h)-openFileMR dir sk fmt m = do- let (_,ext) = splitExtension (url m)- let name = mr_format fmt m- let name' = replaceExtension name (takeWhile (/='?') ext)- let fp = (dir </> name')- e <- doesFileExist fp- case (e && sk) of- True -> do- return (fp,Nothing)- False -> do- h <- openBinaryFile fp WriteMode- return (fp,Just h)---- data Collection a = MC {--- response :: [a]--- } deriving (Show,Data,Typeable)---- processMC :: MusicOptions -> Collection MusicRecord -> IO ()--- processMC (MO _ _ _) (MC r) = do--- forM_ r $ \m -> do--- printf "%d_%d|%s|%s|%s\n" (owner_id m) (aid m) (artist m) (title m) (url m)---- processMC (MO _ rid False) (MC r) = do--- print r---- parseUsers :: JSValue -> Maybe [JSValue]--- parseUsers (JSObject (JSONObject [("response",(JSArray a))])) = Just a--- parseUsers _ = Nothing---- processUQ :: UserOptions -> JSValue -> IO ()--- processUQ (UO _ _) j = do- -- let (Just u) = parseUsers j- -- a <- fromJS (u !! 1)- -- print $ show (a :: UserRecord)- -- print $ show $ j--
src/Web/VKHS.hs view
@@ -1,85 +1,120 @@-{- |-Module : Web.VKHS-Copyright : (c) Sergey Mironov <ierton@gmail.com> 2012-License : BSD-style (see the file LICENSE)+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+module Web.VKHS where -Maintainer : ierton@gmail.com-Stability : experimental-Portability : non-portable (multi-parameter type classes)+import Data.List+import Data.Maybe+import Data.Time+import Data.Either+import Control.Applicative+import Control.Monad+import Control.Monad.State (MonadState, execState, evalStateT, StateT(..), get, modify)+import Control.Monad.Cont+import Control.Monad.Reader+import Control.Monad.Trans.Either -[@VKHS@]+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS -VKHS is written in Haskell and provides access to Vkontakte <http://vk.com>-social network, popular mainly in Russia. Library can be used to login into the-network as a standalone application (OAuth implicit flow as they call it).-Interaction with user is not required. For now, vkhs offers limited error-detection and no captcha support.+import System.IO -Following example illustrates basic usage (please fill client_id, email and-password with correct values):+import Web.VKHS.Error+import Web.VKHS.Types+import Web.VKHS.Client as Client+import Web.VKHS.Monad+import Web.VKHS.Login (MonadLogin, LoginState(..), ToLoginState(..), printForm, login)+import qualified Web.VKHS.Login as Login+import Web.VKHS.API (MonadAPI, APIState(..), ToAPIState(..), api)+import qualified Web.VKHS.API as API -> import Web.VKHS.Login-> import Web.VKHS.API->-> main = do-> let client_id = "111111"-> let e = env client_id "user@example.com" "password" [Photos,Audio,Groups]-> (Right at) <- login e->-> let user_of_interest = "222222"-> (Right ans) <- api e at "users.get" [-> ("uids",user_of_interest)-> , ("fields","first_name,last_name,nickname,screen_name")-> , ("name_case","nom")-> ]-> putStrLn ans+import Debug.Trace -client_id is an application identifier, provided by vk.com. Users receive it-after registering their applications after SMS confirmation. Registration form is -located here <http://vk.com/editapp?act=create>.+{- Test -} -Internally, library uses small curl-based HTTP automata and tagsoup for jumping-over relocations and submitting various \'Yes I agree\' forms. Curl .so library is-required for vkhs to work. I am using curl-7.26.0 on my system.+data State = State {+ cs :: ClientState+ , ls :: LoginState+ , as :: APIState+ , go :: GenericOptions+ } -[@Debugging@]+instance ToLoginState State where+ toLoginState = ls+ modifyLoginState f = \s -> s { ls = f (ls s) }+instance ToClientState State where+ toClientState = cs+ modifyClientState f = \s -> s { cs = f (cs s) }+instance API.ToAPIState State where+ toAPIState = as+ modifyAPIState f = \s -> s { as = f (as s) }+instance ToGenericOptions State where+ toGenericOptions = go -To authenticate the user, vkhs acts like a browser: it analyzes html but fills-all forms by itself instead of displaying pages. Of cause, would vk.com change-html design, things stop working.+initialState :: GenericOptions -> EitherT String IO State+initialState go = State+ <$> lift (Client.defaultState go)+ <*> pure (Login.defaultState go)+ <*> pure (API.defaultState)+ <*> pure go -To deal with that potential problem, I\'ve included some debugging facilities:-changing: -writing+newtype VK r a = VK { unVK :: Guts VK (StateT State (EitherT String IO)) r a }+ deriving(MonadIO, Functor, Applicative, Monad, MonadState State, MonadReader (r -> VK r r) , MonadCont) -> (Right at) <- login e { verbose = Debug }+instance MonadClient (VK r) State+instance MonadVK (VK r) r+instance MonadLogin (VK r) r State+instance API.MonadAPI (VK r) r State -will trigger curl output plus html dumping to the current directory. Please,-mail those .html to me if problem appears.+type Guts x m r a = ReaderT (r -> x r r) (ContT r m) a -[@Limitations@]+runVK :: VK r r -> StateT State (EitherT String IO) r+runVK m = runContT (runReaderT (unVK (catch m)) undefined) return - * Ignores \'Invalid password\' answers+defaultSuperviser :: (Show a) => VK (R VK a) (R VK a) -> StateT State (EitherT String IO) a+defaultSuperviser = go where+ go m = do+ GenericOptions{..} <- toGenericOptions <$> get+ res <- runVK m+ res_desc <- pure (describeResult res)+ case res of+ Fine a -> return a+ UnexpectedInt e k -> do+ alert "UnexpectedInt (ignoring)"+ go (k 0)+ UnexpectedFormField (Form tit f) i k -> do+ alert $ "While filling form " ++ (printForm "" f)+ case o_allow_interactive of+ True -> do+ v <- do+ alert $ "Please, enter the correct value for input " ++ i ++ " : "+ liftIO $ getLine+ go (k v)+ False -> do+ alert $ "Unable to query value for " ++ i ++ " since interactive mode is disabled"+ lift $ left res_desc+ _ -> do+ alert $ "Unsupervised error: " ++ res_desc+ lift $ left res_desc - * Captchas are treated as errors+runLogin go = do+ s <- initialState go+ evalStateT (defaultSuperviser (login >>= return . Fine)) s - * Implicit-flow authentication, see documentation in- Russian <http://vk.com/developers.php>- for details - * Probably, low speed due to restarting curl session on every request. But- anyway, vk.com limits request rate to 3 per second.---}--module Web.VKHS- ( module Web.VKHS.Login- , module Web.VKHS.Types- , module Web.VKHS.API- ) where+runAPI go@GenericOptions{..} m = do+ s <- initialState go+ flip evalStateT s $ do+ case (null l_access_token) of+ True -> do+ AccessToken{..} <- defaultSuperviser (login >>= return . Fine)+ modify $ modifyAPIState (\as -> as{api_access_token = at_access_token})+ False -> do+ modify $ modifyAPIState (\as -> as{api_access_token = l_access_token})+ defaultSuperviser (m >>= return . Fine) -import Web.VKHS.Types-import Web.VKHS.Login-import Web.VKHS.API
src/Web/VKHS/API.hs view
@@ -1,6 +1,117 @@-module Web.VKHS.API- ( module Web.VKHS.API.Aeson- ) where+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-} -import Web.VKHS.API.Aeson+module Web.VKHS.API where++import Data.List+import Data.Maybe+import Data.Time+import Data.Either+import Control.Category ((>>>))+import Control.Applicative+import Control.Monad+import Control.Monad.State+import Control.Monad.Writer+import Control.Monad.Cont++import Data.ByteString.Char8 (ByteString)+import Data.ByteString.Lazy (fromStrict)+import qualified Data.ByteString.Char8 as BS++import Data.Aeson ((.=), (.:))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson++import Text.Printf++import Web.VKHS.Types+import Web.VKHS.Client+import Web.VKHS.Monad+import Web.VKHS.Error++import Debug.Trace++data APIState = APIState {+ api_access_token :: String+ } deriving (Show)++defaultState = APIState {+ api_access_token = []+ }++class ToGenericOptions s => ToAPIState s where+ toAPIState :: s -> APIState+ modifyAPIState :: (APIState -> APIState) -> (s -> s)++class (MonadIO m, MonadClient m s, ToAPIState s, MonadVK m r) => MonadAPI m r s | m -> s++-- | Invoke the request. Return answer (normally, string representation of+-- JSON data). See documentation:+--+-- <http://vk.com/developers.php?oid=-1&p=%D0%9E%D0%BF%D0%B8%D1%81%D0%B0%D0%BD%D0%B8%D0%B5_%D0%BC%D0%B5%D1%82%D0%BE%D0%B4%D0%BE%D0%B2_API>+-- api :: Env CallEnv+-- -- ^ the VKHS environment+-- -> String+-- -- ^ API method name+-- -> [(String, String)]+-- -- ^ API method parameters (name-value pairs)+-- -> IO (Either String BS.ByteString)+-- api e mn mp =+-- let uri = showUri $ (\f -> f $ toUri $ printf "https://api.vk.com/method/%s" mn) $+-- set query $ bw params (("access_token",(access_token . sub) e):mp)+-- in vk_curl_payload e (tell [CURLOPT_URL uri])+++type API m x a = m (R m x) a++parseJSON :: (MonadAPI (m (R m x)) (R m x) s)+ => ByteString+ -> API m x JSON+parseJSON bs = do+ case Aeson.decode (fromStrict bs) of+ Just js -> return (JSON js)+ Nothing -> raise (JSONParseFailure bs)++apiJ :: (MonadAPI (m (R m x)) (R m x) s)+ => String+ -- ^ API method name+ -> [(String, String)]+ -- ^ API method arguments+ -> API m x JSON+apiJ mname margs = do+ GenericOptions{..} <- gets toGenericOptions+ APIState{..} <- gets toAPIState+ let protocol = (case o_use_https of+ True -> "https"+ False -> "http")+ url <- ensure $ pure+ (urlCreate+ (URL_Protocol protocol)+ (URL_Host o_api_host)+ (Just (URL_Port (show o_port)))+ (URL_Path ("/method/" ++ mname))+ (buildQuery (("access_token", api_access_token):margs)))++ debug $ "> " ++ (show url)++ req <- ensure (requestCreateGet url (cookiesCreate ()))+ (res, jar') <- requestExecute req+ parseJSON (responseBody res)+++api :: (Aeson.FromJSON a, MonadAPI (m (R m x)) (R m x) s)+ => String+ -- ^ API method name+ -> [(String, String)]+ -- ^ API method arguments+ -> API m x a+api m args = do+ j@JSON{..} <- apiJ m args+ case Aeson.parseEither Aeson.parseJSON js_aeson of+ Right a -> return a+ Left e -> terminate (JSONParseFailure' j e)
− src/Web/VKHS/API/Aeson.hs
@@ -1,93 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE OverloadedStrings #-}--module Web.VKHS.API.Aeson- ( api- , api'- , Base.envcall- , APIError(..)- , module Web.VKHS.API.Types- ) where--import Control.Applicative-import Control.Monad.Error--import Data.Aeson as A-import Data.Aeson.Types as A-import Data.Aeson.Parser as AG-import Data.ByteString.Lazy as BS-import Data.Data-import Data.Vector as V (head, tail)-import Text.Printf-import Web.VKHS.Types-import Web.VKHS.API.Types-import qualified Web.VKHS.API.Base as Base--parseJSON_obj_error :: String -> A.Value -> A.Parser a-parseJSON_obj_error name o = fail $- printf "parseJSON: %s expects object, got %s" (show name) (show o)--parseJSON_arr_error :: String -> A.Value -> A.Parser a-parseJSON_arr_error name o = fail $- printf "parseJSON: %s expects array, got %s" (show name) (show o)--instance (FromJSON a) => FromJSON (Response a) where- parseJSON (A.Object v) = do- a <- v .: "response"- x <- A.parseJSON a- return (Response x)- parseJSON o = parseJSON_obj_error "Response" o--parseGeneric :: (FromJSON a,Data a) => A.Value -> A.Parser a-parseGeneric val =- case A.fromJSON val of- A.Success a -> return a- A.Error s -> fail $ "parseGeneric fails:" ++ s--instance FromJSON MusicRecord where- parseJSON = parseGeneric--instance FromJSON WallRecord where- parseJSON (Object o) =- WR <$> (o .: "id")- <*> (o .: "to_id")- <*> (o .: "from_id")- <*> (o .: "text")- <*> (o .: "date")- parseJSON o = parseJSON_obj_error "WallRecord" o--instance (FromJSON a) => FromJSON (SizedList a) where- parseJSON (A.Array v) = do- n <- A.parseJSON (V.head v)- t <- A.parseJSON (A.Array (V.tail v))- return (SL n t)- parseJSON o = parseJSON_arr_error "SizedList" o--instance FromJSON RespError where- parseJSON (Object o) = do- (Object e) <- o .: "error"- ER <$> (e .: "error_code")- <*> (e .: "error_msg")- parseJSON o = parseJSON_obj_error "RespError" o--data APIError = APIE_resp RespError | APIE_other String | APIE_badAccessToken- deriving(Show)--instance Error APIError where- strMsg x = APIE_other x--api' :: (A.FromJSON a) => Env CallEnv -> String -> [(String,String)] -> IO (Either APIError a)-api' env mn mp- | Prelude.null ((access_token . sub) env) = return (Left APIE_badAccessToken)- | otherwise = runErrorT $ do- e <- BS.fromStrict <$> ErrorT (either (Left . APIE_other) (Right . id) <$> (Base.api env mn mp))- case (A.decode e) of- Just x -> return x- Nothing -> do- case (A.decode e) of- Just x -> throwError (APIE_resp x)- Nothing -> throwError $ APIE_other $ "AESON: error parsing JSON: " ++ show e--api :: Env CallEnv -> String -> [(String,String)] -> IO (Either APIError A.Value)-api = api'-
− src/Web/VKHS/API/Base.hs
@@ -1,45 +0,0 @@-module Web.VKHS.API.Base- ( api- , envcall- ) where--import Control.Monad ()-import Control.Monad.Error ()-import Control.Monad.Writer-import Control.Monad.Trans ()--import Data.Label-import qualified Data.ByteString.UTF8 as U-import qualified Data.ByteString as BS--import Network.CURL730--import Network.Protocol.Http ()-import Network.Protocol.Uri-import Network.Protocol.Uri.Query ()--import Text.Printf--import Web.VKHS.Types-import Web.VKHS.Curl--envcall :: String -> Env CallEnv-envcall at = mkEnv (CallEnv at)---- | Invoke the request. Return answer (normally, string representation of--- JSON data). See documentation:------ <http://vk.com/developers.php?oid=-1&p=%D0%9E%D0%BF%D0%B8%D1%81%D0%B0%D0%BD%D0%B8%D0%B5_%D0%BC%D0%B5%D1%82%D0%BE%D0%B4%D0%BE%D0%B2_API>-api :: Env CallEnv- -- ^ the VKHS environment- -> String- -- ^ API method name- -> [(String, String)]- -- ^ API method parameters (name-value pairs)- -> IO (Either String BS.ByteString)-api e mn mp =- let uri = showUri $ (\f -> f $ toUri $ printf "https://api.vk.com/method/%s" mn) $- set query $ bw params (("access_token",(access_token . sub) e):mp)- in vk_curl_payload e (tell [CURLOPT_URL uri])--
− src/Web/VKHS/API/Monad.hs
@@ -1,76 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GeneralizedNewtypeDeriving #-}--module Web.VKHS.API.Monad- ( api- , api'- , runVKAPI- , VKAPI(..)- , module Web.VKHS.API.Types- ) where--import Control.Applicative-import Control.Monad.Error-import Control.Monad.State-import Control.Monad.Reader-import Control.Concurrent (threadDelay)-import Data.Aeson as A--import Web.VKHS.API.Types-import qualified Web.VKHS.API.Aeson as VK-import qualified Web.VKHS.Login as VK-import Web.VKHS as VK (callEnv, Env(..), LoginEnv(..), AccessToken, APIError(..))--newtype VKAPI m a = VKAPI { unVKAPI :: ReaderT (Env LoginEnv) (StateT AccessToken (ErrorT APIError m)) a }- deriving(Monad, Applicative, Functor, MonadIO, MonadState AccessToken, MonadReader (Env LoginEnv), MonadError APIError)--runVKAPI :: (MonadIO m) => VKAPI m a -> VK.AccessToken -> Env LoginEnv -> m (Either VK.APIError (a,AccessToken))-runVKAPI m at e = runErrorT (runStateT (runReaderT (unVKAPI m) e) at)--shallTryRelogin :: APIError -> Bool-shallTryRelogin (APIE_other _) = False-shallTryRelogin _ = True---- TODO: report whole error stack-apiRetryWrapper :: (A.FromJSON a, MonadIO m) => Int -> String -> [(String,String)] -> VKAPI m a-apiRetryWrapper nr name args = do- e <- ask- (at,_,_) <- get- r <- liftIO $ VK.api' (callEnv e at) name args- case (nr,r) of- (0, Left er) -> throwError er- (x, Left er)- | shallTryRelogin er -> do- res <- liftIO $ VK.login e- case res of- Left err -> throwError (VK.APIE_other err)- Right at' -> do- put at' >> apiRetryWrapper (x-1) name args- | otherwise -> throwError er- (_, Right a) -> return a--apiForewerWrapper :: (A.FromJSON a, MonadIO m) => String -> [(String,String)] -> VKAPI m a-apiForewerWrapper name args = do- e <- ask- let call_api = do- (at,_,_) <- get- r <- liftIO $ VK.api' (callEnv e at) name args- case r of- (Left _) -> do_login- (Right a) -> return a- do_login = do- sleep 3- r <- liftIO $ VK.login e- case r of- Left _ -> do_login- Right at' -> put at' >> call_api- sleep x = - liftIO $ threadDelay (1000 * 1000 * x); -- convert sec to us- call_api--api' :: (A.FromJSON a, MonadIO m) => String -> [(String,String)] -> VKAPI m a-api' = apiForewerWrapper--api :: (MonadIO m) => String -> [(String,String)] -> VKAPI m A.Value-api = api'-
− src/Web/VKHS/API/Types.hs
@@ -1,52 +0,0 @@-{-# LANGUAGE DeriveDataTypeable #-}--module Web.VKHS.API.Types where--import Data.Typeable-import Data.Data-import Data.Time.Clock-import Data.Time.Clock.POSIX--newtype Response a = Response a- deriving (Show)--data SizedList a = SL Int [a]--data MusicRecord = MR- { aid :: Int- , owner_id :: Int- , artist :: String- , title :: String- , duration :: Int- , url :: String- } deriving (Show, Data, Typeable)---data UserRecord = UR- { uid :: Int- , first_name :: String- , last_name :: String- , photo :: String- , university :: Maybe Int- , university_name :: Maybe String- , faculty :: Maybe Int- , faculty_name :: Maybe String- , graduation :: Maybe Int- } deriving (Show, Data, Typeable)--data WallRecord = WR- { wid :: Int- , to_id :: Int- , from_id :: Int- , wtext :: String- , wdate :: Int- } deriving (Show)--publishedAt :: WallRecord -> UTCTime-publishedAt wr = posixSecondsToUTCTime $ fromIntegral $ wdate wr--data RespError = ER- { error_code :: Int- , error_msg :: String- } deriving (Show)-
+ src/Web/VKHS/Client.hs view
@@ -0,0 +1,271 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE ScopedTypeVariables #-}+module Web.VKHS.Client where++import Data.List+import Data.Maybe+import Data.Time+import Data.Either+import Control.Applicative+import Control.Arrow ((***))+import Control.Monad+import Control.Monad.State+import Control.Monad.Cont+import Data.Default.Class+import qualified Data.CaseInsensitive as CI+import Data.Map (Map)+import qualified Data.Map as Map+import Data.List.Split++import Control.Concurrent (threadDelay)++import System.IO as IO+import System.IO.Unsafe as IO+import System.Clock as Clock++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS++import Network.HTTP.Client ()+import Network.HTTP.Client.Internal (setUri)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import qualified Network.HTTP.Types as Client+import qualified Network.HTTP.Client as Client+import qualified Network.HTTP.Client.Internal as Client+import qualified Network.URI as Client+import qualified Network.Shpider.Forms as Shpider++import Pipes.Prelude as PP (foldM)+import qualified Pipes as Pipes (Producer(..), for, runEffect, (>->))+import qualified Pipes.HTTP as Pipes hiding (Request, Response)++import qualified Text.Parsec as Parsec++import Debug.Trace++import Web.VKHS.Types++data Error = ErrorParseURL { euri :: String, emsg :: String }+ | ErrorSetURL { eurl :: URL, emsg :: String }+ deriving(Show, Eq)++{-+ __ __ _+| \/ | ___ _ __ __ _ __| |+| |\/| |/ _ \| '_ \ / _` |/ _` |+| | | | (_) | | | | (_| | (_| |+|_| |_|\___/|_| |_|\__,_|\__,_|+-}++data ClientState = ClientState {+ cl_man :: Client.Manager+ , cl_last_execute :: TimeSpec+ , cl_minimum_interval_ns :: Integer+ }++defaultState :: GenericOptions -> IO ClientState+defaultState GenericOptions{..} = do+ cl_man <- Client.newManager+ (Client.managerSetProxy (Client.proxyEnvironment Nothing)+ (case o_use_https of+ True -> tlsManagerSettings+ False -> Client.defaultManagerSettings))+ cl_last_execute <- pure (TimeSpec 0 0)+ cl_minimum_interval_ns <- pure (round (10^9 / o_max_request_rate_per_sec))+ return ClientState{..}++class ToClientState s where+ toClientState :: s -> ClientState+ modifyClientState :: (ClientState -> ClientState) -> (s -> s)++class (MonadIO m, MonadState s m, ToClientState s) => MonadClient m s | m -> s++-- newtype ClientT m a = ClientT { unClient :: StateT ClientState m a }+-- deriving(Functor, Applicative, Monad, MonadState ClientState, MonadIO)++-- runClient :: (MonadIO m) => ClientT m a -> m a+-- runClient l = do+-- cl_man <- liftIO $ newManager defaultManagerSettings+-- evalStateT (unClient l) ClientState{..}++-- liftClient :: (Monad m) => m a -> ClientT m a+-- liftClient = ClientT . lift++{-+ _ _ ____ _+| | | | _ \| |+| | | | |_) | |+| |_| | _ <| |___+ \___/|_| \_\_____|+-}++newtype URL_Protocol = URL_Protocol { urlproto :: String }+ deriving(Show)+newtype URL_Query = URL_Query { urlq :: String }+ deriving(Show)+newtype URL_Host = URL_Host { urlh :: String }+ deriving(Show)+newtype URL_Port = URL_Port { urlp :: String }+ deriving(Show)+newtype URL_Path = URL_Path { urlpath :: String }+ deriving(Show)+newtype URL = URL { uri :: Client.URI }+ deriving(Show, Eq)++buildQuery :: [(String,String)] -> URL_Query+buildQuery qis = URL_Query ("?" ++ intercalate "&" (map (\(a,b) -> (esc a) ++ "=" ++ (esc b)) qis)) where+ esc x = Client.escapeURIString Client.isAllowedInURI x++urlCreate :: URL_Protocol -> URL_Host -> Maybe URL_Port -> URL_Path -> URL_Query -> Either Error URL+urlCreate URL_Protocol{..} URL_Host{..} port URL_Path{..} URL_Query{..} =+ pure $ URL $ Client.URI (urlproto ++ ":") (Just (Client.URIAuth "" urlh (maybe "" ((":"++).urlp) port))) urlpath urlq []++urlFromString :: String -> Either Error URL+urlFromString s =+ case Client.parseURI s of+ Nothing -> Left (ErrorParseURL s "Client.parseURI failed")+ Just u -> Right (URL u)++splitFragments :: String -> String -> String -> [(String,String)]+splitFragments sep eqs =+ 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)++ trim = rev (dropWhile (`elem` (" \t\n\r" :: String)))+ where rev f = reverse . f . reverse . f++urlFragments :: URL -> [(String,String)]+urlFragments URL{..} = splitFragments "&" "=" $ unsharp $ Client.uriFragment uri where+ unsharp ('#':x) = x+ unsharp y = y++{-+ ____ _ _+ / ___|___ ___ | | _(_) ___+| | / _ \ / _ \| |/ / |/ _ \+| |__| (_) | (_) | <| | __/+ \____\___/ \___/|_|\_\_|\___|+-}++data Cookies = Cookies { jar :: Client.CookieJar }+ deriving(Show,Eq)++cookiesCreate :: () -> Cookies+cookiesCreate () = Cookies (Client.createCookieJar [])++{-+ _ _ _____ _____ ____+| | | |_ _|_ _| _ \+| |_| | | | | | | |_) |+| _ | | | | | | __/+|_| |_| |_| |_| |_|+-}++data Request = Request {+ req :: Client.Request+ , req_jar :: Client.CookieJar+ }++requestCreateGet :: (MonadClient m s) => URL -> Cookies -> m (Either Error Request)+requestCreateGet URL{..} Cookies{..} = do+ case setUri def uri of+ Left exc -> do+ return $ Left $ ErrorSetURL (URL uri) (show exc)+ Right r -> do+ now <- liftIO getCurrentTime+ (r',_) <- pure $ Client.insertCookiesIntoRequest r jar now+ return $ Right $ Request {+ req = r'{+ Client.redirectCount = 0+ , Client.checkStatus = \_ _ _ -> Nothing+ },+ req_jar = jar+ }++requestCreatePost :: (MonadClient m s) => FilledForm -> Cookies -> m (Either Error Request)+requestCreatePost (FilledForm tit Shpider.Form{..}) c = do+ case Client.parseURI (Client.escapeURIString Client.isAllowedInURI action) of+ Nothing -> return (Left (ErrorParseURL action "parseURI failed"))+ Just action_uri -> do+ r <- requestCreateGet (URL action_uri) c+ case r of+ Left err -> do+ return $ Left err+ Right Request{..} -> do+ return $ Right $ Request (Client.urlEncodedBody (map (BS.pack *** BS.pack) $ Map.toList inputs) req) req_jar++data Response = Response {+ resp :: Client.Response (Pipes.Producer ByteString IO ())+ , resp_body :: ByteString+ }++responseBodyS :: Response -> String+responseBodyS Response{..} = BS.unpack $ resp_body++responseBody :: Response -> ByteString+responseBody Response{..} = resp_body++dumpResponseBody :: (MonadClient m s) => FilePath -> Response -> m ()+dumpResponseBody f Response{..} = liftIO $ BS.writeFile f resp_body++responseCookies :: Response -> Cookies+responseCookies Response{..} = Cookies (Client.responseCookieJar resp)++responseHeaders :: Response -> [(String,String)]+responseHeaders Response{..} =+ map (\(o,h) -> (BS.unpack (CI.original o), BS.unpack h)) $ Client.responseHeaders resp++responseCode :: Response -> Int+responseCode Response{..} = Client.statusCode $ Client.responseStatus resp++responseCodeMessage :: Response -> String+responseCodeMessage Response{..} = BS.unpack $ Client.statusMessage $ Client.responseStatus resp++responseRedirect :: Response -> Maybe URL+responseRedirect r =+ case lookup "Location" (responseHeaders r) of+ Just loc -> URL <$> Client.parseURI loc+ Nothing -> Nothing++responseOK :: Response -> Bool+responseOK r = c == 200 where+ c = responseCode r++requestExecute :: (MonadClient m s) => Request -> m (Response, Cookies)+requestExecute Request{..} = do+ jar <- pure req_jar+ ClientState{..} <- toClientState <$> get+ clk <- liftIO $ do+ clk <- Clock.getTime Clock.Realtime+ let interval_ns = timeSpecAsNanoSecs (clk `diffTimeSpec` cl_last_execute)+ when (interval_ns < cl_minimum_interval_ns) $ do+ threadDelay (fromInteger $ (cl_minimum_interval_ns - interval_ns) `div` 1000); -- convert ns to us+ return clk++ modify (modifyClientState (\s -> s{cl_last_execute = clk}))++ liftIO $ do+ Pipes.withHTTP req cl_man $ \resp -> do+ resp_body <- PP.foldM (\a b -> return $ BS.append a b) (return BS.empty) return (Client.responseBody resp)+ now <- getCurrentTime+ let (jar', resp') = Client.updateCookieJar resp req now jar+ return (Response resp resp_body, Cookies jar')++downloadFileWith :: (MonadClient m s) => URL -> (ByteString -> IO ()) -> m ()+downloadFileWith url h = do+ (ClientState{..}) <- toClientState <$> get+ (Right Request{..}) <- requestCreateGet url (cookiesCreate ())+ liftIO $ Pipes.withHTTP req cl_man $ \resp -> do+ PP.foldM (\() a -> h a) (return ()) (const (return ())) (Client.responseBody resp)+
− src/Web/VKHS/Curl.hs
@@ -1,177 +0,0 @@-{-# LANGUAGE ScopedTypeVariables #-}--module Web.VKHS.Curl- ( vk_curl- , vk_curl_file- , vk_curl_payload- , pack- , unpack- ) where--import Data.IORef (newIORef, readIORef, atomicModifyIORef)-import qualified Data.ByteString as BS-import qualified Data.ByteString.Internal as BS (c2w, w2c)--import Control.Applicative-import Control.Exception (catch,bracket)-import Control.Concurrent (threadDelay)-import Control.Monad.Writer--import Network.CURL730--import Prelude hiding (catch)--import System.IO--import Web.VKHS.Types---pack = BS.pack . map BS.c2w-unpack = map BS.w2c . BS.unpack---- | Generic request sender. Returns whole HTTP answer as a ByteString-vk_curl :: Env a -> Writer [CURLoption] () -> IO (Either String BS.ByteString)-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- do {- bracket (curl_easy_init) (curl_easy_cleanup) $ \curl ->- let- memwrite n = atomicModifyIORef buff- (\o -> (BS.append o n, CURL_WRITEFUNC_OK))- in do- curl_easy_setopt curl $- [ CURLOPT_HEADER True- , CURLOPT_WRITEFUNCTION (Just $ memwrite)- , CURLOPT_SSL_VERIFYPEER False- , CURLOPT_USERAGENT a- , CURLOPT_VERBOSE (v == Debug )- ] ++ (execWriter w);- curl_easy_perform curl;- threadDelay (1000 * d); -- convert ms to us- b <- readIORef buff ;- return (Right b) ;- } `catch`- (\(e::CURLE) -> return $ Left ("CURL error: " ++ (show e)))--scanPattern pat s =- let (_,o,x,n) = BS.foldl' check (False, BS.empty, BS.empty, BS.empty) s- in (BS.reverse o, x, BS.reverse n)- where- check (False, old, st, new) b- | BS.length st < BS.length pat = (False, old, st`BS.snoc`b, new)- | st == pat = (True, old, st, b`BS.cons`new)- | otherwise = (False, (BS.head st)`BS.cons`old, (BS.tail st)`BS.snoc`b, new)- check (True, old, st, new) b = (True, old, st, b`BS.cons`new)--cutheader :: BS.ByteString -> BS.ByteString -> Maybe (BS.ByteString, BS.ByteString)-cutheader buf new =- let- buf' = BS.append buf new- overfill = BS.length buf' >= 1024- (_,p,t) = scanPattern (BS.pack $ map BS.c2w "\r\n\r\n") buf'- in case (overfill, BS.null t) of- (True, True) -> Nothing- (False, True) -> Just (buf', t)- (_, False) -> Just (buf', t)--data State = Pending BS.ByteString | Working BS.ByteString | FailNoHeader--process :: State -> BS.ByteString -> State-process s@(Pending b) bs =- case cutheader b bs of- Nothing -> FailNoHeader- Just (b', t)- | BS.null t -> (Pending b')- | otherwise -> (Working t)-process s@(Working _) bs = (Working bs)-process s _ = s---- | Downloads the file and saves it on disk-vk_curl_file- :: Env a- -- ^ User environment- -> String- -- ^ URL- -> (BS.ByteString -> IO ())- -- ^ File write handler- -> IO (Either String ())-vk_curl_file e url cb = do- let askE x = return (x e)- v <- askE verbose- a <- askE useragent- d <- askE delay_ms- do- sr <- newIORef =<< (Pending <$> pure BS.empty)-- bracket (curl_easy_init) (curl_easy_cleanup) $ \curl -> do {- let- filewrite bs = do- s' <- atomicModifyIORef sr (\s -> let s' = process s bs in (s',s'))- case s' of- FailNoHeader -> return CURL_WRITEFUNC_FAIL- Pending b -> return CURL_WRITEFUNC_OK- Working t -> do- cb t- return CURL_WRITEFUNC_OK- in- curl_easy_setopt curl $- [ CURLOPT_HEADER True- , CURLOPT_WRITEFUNCTION (Just $ filewrite)- , CURLOPT_SSL_VERIFYPEER False- , CURLOPT_USERAGENT a- , CURLOPT_VERBOSE (v == Debug)- , CURLOPT_URL url- ];-- curl_easy_perform curl;- threadDelay (1000 * d); -- convert ms to us- s <- readIORef sr;- case s of- Working _ -> return $ Right ()- _ -> return $ Left "HTTP header detection failure"- } `catch`- (\(e::CURLE) -> return $ Left ("CURL error: " ++ (show e)))----- | Return HTTP payload, ignore headers-vk_curl_payload :: Env a -> Writer [CURLoption] () -> IO (Either String BS.ByteString)-vk_curl_payload e w = do- let askE x = return (x e)- v <- askE verbose- a <- askE useragent- d <- askE delay_ms- do- sr <- newIORef (BS.empty, Pending BS.empty)-- bracket (curl_easy_init) (curl_easy_cleanup) $ \curl -> do {- let- writer bs = do- atomicModifyIORef sr (\(buff,s) -> let s' = process s bs ; paired x =(x,x) in- case s' of- FailNoHeader -> paired (buff,s')- Pending b -> paired (buff,s')- Working t -> paired (BS.append buff t,s'))- return CURL_WRITEFUNC_OK-- in- curl_easy_setopt curl $- [ CURLOPT_HEADER True- , CURLOPT_WRITEFUNCTION (Just $ writer)- , CURLOPT_SSL_VERIFYPEER False- , CURLOPT_USERAGENT a- , CURLOPT_VERBOSE (v == Debug)- ] ++ (execWriter w);- curl_easy_perform curl;- threadDelay (1000 * d); -- convert ms to us- (buff,s) <- readIORef sr;- case s of- Working _ -> return $ Right buff- _ -> return $ Left "HTTP header detection failure"- } `catch`- (\(e::CURLE) -> return $ Left ("CURL error: " ++ (show e)))-
src/Web/VKHS/Login.hs view
@@ -1,243 +1,190 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-}--module Web.VKHS.Login- ( login- , env- ) where--import Prelude hiding ((.), id, catch)+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE FunctionalDependencies #-}+module Web.VKHS.Login where +import Data.List+import Data.Maybe+import Data.Time+import Data.Either+import Control.Category ((>>>)) import Control.Applicative-import Control.Category-import Control.Exception-import Control.Failure-import Control.Monad.Trans-import Control.Monad.Error-import Control.Monad.Reader+import Control.Monad+import Control.Monad.State import Control.Monad.Writer-import qualified Control.Monad.State as S+import Control.Monad.Cont -import qualified Data.ByteString as BS-import Data.List-import Data.String-import Data.Char-import Data.Monoid-import Data.Either-import Data.Label-import qualified Data.Map as M-import Data.Maybe-import Data.Typeable+import Data.Map (Map)+import qualified Data.Map as Map -import Network.CURL730-import Network.Protocol.Http-import Network.Protocol.Uri-import Network.Protocol.Uri.Query-import Network.Protocol.Cookie as C-import Network.Shpider.Forms+import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS -import Text.HTML.TagSoup-import Text.Printf-import System.IO+import qualified Text.HTML.TagSoup.Parsec as Tagsoup+import qualified Network.Shpider.Forms as Shpider import Web.VKHS.Types-import Web.VKHS.Curl as VKHS---- Test applications:------ pirocheck--- ID 3115622--- Key IOmaB10C1v7RoMiM6Lnu------ pirofetch--- ID 3082266--- Key <lost>--type Url = String-type Email = String-type Uid = String-type Password = String-type Body = String--toarg :: [AccessRight] -> String-toarg = intercalate "," . map (map toLower . show)---- | Gathers login information into Env data set.-env :: String- -- ^ Client ID (provided by VKontakte, also known as application ID)- -> String- -- ^ User email, able to authenticate the user- -> String- -- ^ User password- -> [AccessRight]- -- ^ Access rights to request- -> Env LoginEnv-env cid email pwd ar = mkEnv- (LoginEnv- [ ("email",email) , ("pass",pwd) ]- ar- cid- )--vk_start_action :: ClientId -> [AccessRight] -> ActionHist-vk_start_action cid ac = AH [] $ OpenUrl start_url mempty where- start_url = (\f -> f $ toUri "https://oauth.vk.com/authorize")- $ set query $ bw params- [ ("client_id", cid)- , ("scope", toarg ac)- , ("redirect_uri", "https://oauth.vk.com/blank.html")- , ("display", "wap")- , ("response_type", "token")- ]--type FilledForm = Form--type VK a = ReaderT (Env LoginEnv) (ErrorT String IO) a--runVK :: Env LoginEnv -> VK a -> IO (Either String a)-runVK e vk = runErrorT (runReaderT vk e)--liftVK :: IO (Either String a) -> VK a-liftVK m = liftIO m >>= either fail return+import Web.VKHS.Client+import Web.VKHS.Monad+import Web.VKHS.Error -dbgVK :: Verbosity -> IO () -> VK ()-dbgVK v act = ask >>= \e -> do- if v > (verbose e) then return ()- else liftIO $ act+import Debug.Trace+import System.IO -when_debug = dbgVK Debug-when_trace = dbgVK Trace+data LoginState = LoginState {+ ls_rights :: [AccessRight]+ -- ^ Access rights to be requested+ , ls_appid :: AppID+ -- ^ Application ID provided by vk.com+ , ls_formdata :: [(String,String)]+ -- ^ Dictionary containig inputID/value map for filling forms+ , ls_input_sets :: [[String]]+ } -type Page = (Http Response, Body)+defaultState :: GenericOptions -> LoginState+defaultState go@GenericOptions{..} =+ LoginState {+ ls_rights = allAccess+ , ls_appid = l_appid+ , ls_formdata = (if not (null l_username) then [("email", l_username)] else [])+ ++ (if not (null l_password) then [("pass", l_password)] else [])+ , ls_input_sets = []+ } --- | Browser action+class (ToGenericOptions s) => ToLoginState s where+ toLoginState :: s -> LoginState+ modifyLoginState :: (LoginState -> LoginState) -> (s -> s) -type Hist = [[String]]+class (MonadIO m, MonadClient m s, ToLoginState s, MonadVK m r) => MonadLogin m r s | m -> s -data ActionHist = AH Hist Action+-- | Login robot action+data RobotAction = DoGET URL Cookies | DoPOST FilledForm Cookies deriving(Show) -data Action = OpenUrl Uri Cookies | SendForm Form Cookies- deriving (Show)---- | Url assotiated with Action-actionUri :: Action -> Uri-actionUri (OpenUrl u _) = u-actionUri (SendForm f _) = toUri . action $ f--liftEIO act = (liftIO act) >>= either fail return---- | Send a get-request to the server-vk_get :: Uri -> Cookies -> VK Page-vk_get u c = let- c' = (bw cookie $ map toShort $ bw gather c )- u' = (showUri u)- in do- e <- ask- s <- liftEIO $ vk_curl e $ do- when ((not . null) c') $ do- tell [CURLOPT_COOKIE c']- when ((not . null) u') $ do- tell [CURLOPT_URL u']- liftVK (return $ parseResponse $ VKHS.unpack s)---- | Send a form to the server.-vk_post :: FilledForm -> Cookies -> VK Page-vk_post f c = let- c' = (bw cookie $ map toShort $ bw gather c )- p' = (bw params $ M.toList $ inputs f)- u' = (action f)- in do- e <- ask- s <- liftEIO $ vk_curl e $ do- when ((not . null) c') $ do- tell [CURLOPT_COOKIE c']- when ((not . null) u') $ do- tell [CURLOPT_URL u']- tell [CURLOPT_POST True]- tell [CURLOPT_COPYPOSTFIELDS p']- liftVK (return $ parseResponse $ VKHS.unpack s)+printAction :: String -> RobotAction -> String+printAction prefix (DoGET url jar) = prefix ++ " GET " ++ (show url)+printAction prefix (DoPOST FilledForm{..} jar) = printForm prefix fform --- | Splits parameters into 3 categories:--- 1)without a value, 2)filled from user dictionary, 3)with default values-split_inputs :: [(String,String)]- -- ^ User dictionary- -> M.Map String String- -- ^ Fields with default values (default doesn't exist if zero string)- -> (M.Map String (), M.Map String String, M.Map String String)-split_inputs d m =- let (b,g) = M.mapEitherWithKey (match_field d) m- in (b, M.map (either id id) g, snd (M.mapEither id g))- where- match_field d k a- | not (null a) = maybe ((Right . Left) a) (Right . Right) u- | otherwise = maybe (Left ()) (Right . Right) u- where u = lookup k d+type Login m x a = m (R m x) a -inputs_to_fill :: Form -> [String]-inputs_to_fill f = let (inps,_,_) = split_inputs [] (inputs f) in M.keys inps+initialAction :: (MonadLogin (m (R m x)) (R m x) s) => Login m x RobotAction+initialAction = do+ LoginState{..} <- gets toLoginState+ GenericOptions{..} <- gets toGenericOptions+ let+ protocol = (case o_use_https of+ True -> "https"+ False -> "http")+ u <- ensure $ pure+ (urlCreate+ (URL_Protocol protocol)+ (URL_Host o_login_host)+ (Just (URL_Port (show o_port)))+ (URL_Path "/authorize")+ (buildQuery [+ ("client_id", aid_string ls_appid)+ , ("scope", toUrlArg ls_rights)+ , ("redirect_url", protocol ++ "://oauth.vk.com/blank.html")+ , ("display", "wap")+ , ("response_type", "token")+ ]))+ return (DoGET u (cookiesCreate ())) -vk_fill_form :: Form -> VK FilledForm-vk_fill_form f = ask >>= \e -> do- let (bad,good,user) = split_inputs ((formdata . sub) e) (inputs f)- when (not $ M.null bad) (fail $ "Unmatched form parameters: " ++ (show bad))- return f { inputs = good }+printForm :: String -> Shpider.Form -> String+printForm prefix Shpider.Form{..} =+ let+ telln x = tell (x ++ "\n")+ in+ execWriter $ do+ telln $ prefix ++ "Form #" ++ " (" ++ (show method) ++ ") Action " ++ action+ forM_ (Map.toList inputs) $ \(input,value) -> do+ telln $ prefix ++ "\t" ++ input ++ ":" ++ (if null value then "<empty>" else value) --- | Execute an action, return Web-server's answer and adjusted cookies. Cookie--- management is very primitive: it's no more than merging old and new ones-vk_move :: Action -> VK (Page, Cookies)-vk_move (OpenUrl u c) = do- (h,b) <- (vk_get u c)- return ((h,b),c`mappend`(get setCookies h))-vk_move (SendForm f c) = do- f' <- vk_fill_form f- (h,b) <- (vk_post f' c)- return ((h,b),c`mappend`(get setCookies h))+fillForm :: (MonadLogin (m (R m x)) (R m x) s) => Form -> Login m x FilledForm+fillForm f@(Form{..}) = do+ LoginState{..} <- toLoginState <$> get+ GenericOptions{..} <- gets toGenericOptions+ let empty_inputs = Shpider.emptyInputs form+ case empty_inputs `elem` ls_input_sets of+ False -> do+ modify $ modifyLoginState (\s -> s{ls_input_sets = empty_inputs:ls_input_sets})+ True -> do+ raise (\k -> RepeatedForm f k)+ return ()+ fis <- forM (Map.toList (Shpider.inputs form)) $ \(input,value) -> do+ case lookup input ls_formdata of+ Just value' -> do+ -- trace $ "Overwriting default value for " ++ input ++ "( " ++ value ++ ") with " ++ value' $ do+ return (input, value')+ Nothing -> do+ case null value of+ False -> do+ -- trace "Using default value for " ++ input ++ " (" ++ value ++ ")" $ do+ return (input, value)+ True -> do+ value' <- raise (\k -> UnexpectedFormField f input k)+ return (input, value')+ -- Replace HTTPS with HTTP if not using TLS+ let action' = (if o_use_https == False && isPrefixOf "https" (Shpider.action form) then+ "http" ++ (fromJust $ stripPrefix "https" (Shpider.action form))+ else+ Shpider.action form)+ return $ FilledForm form_title form{Shpider.inputs = Map.fromList fis, Shpider.action = action'} -uri_fragment :: Http Response -> Maybe AccessToken-uri_fragment = get location >=> pure . get fragment >=> pure . fw (keyValues "&" "=") >=> \f -> do- (\a b c -> (a,b,c)) <$> lookup "access_token" f <*> lookup "user_id" f <*> lookup "expires_in" f+actionRequest :: (MonadLogin (m (R m x)) (R m x) s) => RobotAction -> Login m x (Response, Cookies)+actionRequest a@(DoGET url jar) = do+ debug (printAction "> " a)+ req <- ensure $ requestCreateGet url jar+ (res, jar') <- requestExecute req+ return (res, jar')+actionRequest a@(DoPOST form jar) = do+ debug (printAction "> " a)+ req <- ensure $ requestCreatePost form jar+ (res, jar') <- requestExecute req+ return (res, jar') --- | Suggest new action-vk_analyze :: Hist -> (Page,Cookies) -> VK (Either AccessToken (Action,Hist))-vk_analyze hist ((h,b),c)- | isJust a = return $ Left (fromJust a)- | isJust l = return $ Right (OpenUrl (fromJust l) c, hist)- | not (null fs) && not (is `elem` hist)- = return $ Right (SendForm f c, is:hist)- | not (null fs) && (is `elem` hist)- = fail $ "Invalid password/Form containig following inputs already seen: " ++ (show is)- | not gs = fail $ "HTTP error: status " ++ (show s)- | otherwise = fail $ "HTML processing failure (new design of VK login dialog?)"- where- gs = s`elem` [OK,Created,Found,SeeOther,Accepted,Continue]- s = get status h- l = get location h- fs = parseTags >>> gatherForms $ b- f = head fs- is = inputs_to_fill f- a = uri_fragment h+analyzeResponse :: (MonadLogin (m (R m x)) (R m x) s) => (Response, Cookies) -> Login m x (Either RobotAction AccessToken)+analyzeResponse (res, jar) = do+ LoginState{..} <- toLoginState <$> get+ let tags = Tagsoup.parseTags (responseBodyS res)+ title = Shpider.gatherTitle tags+ forms = map (Form title) (Shpider.gatherForms tags)+ dumpResponseBody "latest.html" res+ debug ("< 0 Title: " ++ title) -vk_dump_page :: Int -> Uri -> Page -> IO ()-vk_dump_page n u (h,b)- | (>0) . length . filter (isAlpha) $ b =- let name = printf "%02d-%s.html" n (showAuthority (get authority u))- in bracket (openFile name WriteMode) (hClose) $ \f -> do- hPutStrLn f b- hPutStrLn stderr $ "dumped: name " ++ (name) ++ " size " ++ (show $ length b)- | otherwise = return ()+ case (responseRedirect res) of+ Just url -> do+ debug $ "< 0 Fragments: " ++ show (urlFragments url)+ maybe (return $ Left $ DoGET url jar) (\x -> return $ Right x) $ do+ at_access_token <- lookup "access_token" (urlFragments url)+ at_user_id <- lookup "user_id" (urlFragments url)+ at_expires_in <- lookup "expires_in" (urlFragments url)+ return AccessToken{..}+ Nothing -> do+ case forms of+ [] -> do+ terminate LoginActionsExhausted+ (f:[]) -> do+ debug $ printForm "< 0 " $ form f+ ff <- fillForm f+ return $ Left (DoPOST ff jar)+ fs -> do+ forM_ (fs`zip`[0..]) $ \(f,n) -> do+ ff <- fillForm f+ debug $ printForm ("< " ++ (show n) ++ " ") $ fform ff+ terminate LoginActionsExhausted --- | Execute login procedure, return (Right AccessToken) on success-login :: Env LoginEnv -> IO (Either String AccessToken)-login e@(Env (LoginEnv _ acr cid) _ _ _) =- runVK e $ loop [0..] (vk_start_action cid acr) where- loop (n:ns) (AH h act) = do- when_trace $ printf "VK => %02d %s" n (show act)- ans@(p,c) <- vk_move act- when_debug $ vk_dump_page n (actionUri act) p- a <- vk_analyze h ans- case a of- Right (act',h') -> do- loop ns (AH h' act')- Left at -> do- return at+login :: (MonadLogin (m (R m x)) (R m x) s) => Login m x AccessToken+login = initialAction >>= go where+ go a = do+ req <- actionRequest a+ res <- analyzeResponse req+ -- trace (show res) $ do+ case res of+ Left a' -> go a'+ Right at -> return at
+ src/Web/VKHS/Monad.hs view
@@ -0,0 +1,96 @@+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE FunctionalDependencies #-}+module Web.VKHS.Monad where++import Data.List+import Data.Maybe+import Data.Time+import Data.Either+import Control.Applicative+import Control.Monad+import Control.Monad.State+import Control.Monad.Reader+import Control.Monad.Cont+import Data.Default.Class+import System.IO++import Data.ByteString.Char8 (ByteString)+import qualified Data.ByteString.Char8 as BS++import Web.VKHS.Error+import Web.VKHS.Types+import Web.VKHS.Client hiding(Error)+import qualified Web.VKHS.Client as Client+++-- newtype VKT m r a = VKT { unVKT :: StateT (r -> VKT m r r) (ContT r m) a }+-- deriving(Functor, Applicative, Monad, MonadState (r -> VKT m r r), MonadCont, MonadIO)++class (MonadCont m, MonadReader (r -> m r) m) => MonadVK m r++-- instance (Monad m) => MonadVK (VKT m r) r++catch :: (MonadVK m r) => m r -> m r+catch m = do+ callCC $ \k -> do+ local (const k) m++raise :: (MonadVK m r) => ((a -> m b) -> r) -> m a+raise z = callCC $ \k -> do+ err <- ask+ err (z k)+ undefined++terminate :: (MonadVK m r) => r -> m a+terminate r = do+ err <- ask+ err r+ undefined++class MonadVK (t r) r => EnsureVK t r c a | c -> a where+ ensure :: t r c -> t r a++instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Error Request) Request where+ ensure m = m >>= \x ->+ case x of+ (Right u) -> return u+ (Left e) -> raise (\k -> UnexpectedRequest e k)++instance (MonadVK (t (R t x)) (R t x)) => EnsureVK t (R t x) (Either Client.Error URL) URL where+ ensure m = m >>= \x ->+ case x of+ (Right u) -> return u+ (Left e) -> raise (\k -> UnexpectedURL e k)++-- instance EnsureVK (Either Client.Error Request) Request where+-- ensure m = m >>= \x ->+-- case x of+-- (Right u) -> return u+-- (Left e) -> raiseError (\k -> UnexpectedRequest e k)++-- instance EnsureVK (Either Client.Error URL) URL where+-- ensure m = m >>= \x ->+-- case x of+-- (Right u) -> return u+-- (Left e) -> raiseError (\k -> UnexpectedURL e k)+++debug :: (ToGenericOptions s, MonadState s m, MonadIO m) => String -> m ()+debug str = do+ GenericOptions{..} <- gets toGenericOptions+ when o_verbose $ do+ liftIO $ hPutStrLn stderr str++alert :: (ToGenericOptions s, MonadState s m, MonadIO m) => String -> m ()+alert str = do+ liftIO $ hPutStrLn stderr str+
src/Web/VKHS/Types.hs view
@@ -1,14 +1,31 @@+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FunctionalDependencies #-} module Web.VKHS.Types where +import Data.List+import Data.Char++import Data.Aeson (FromJSON(..), ToJSON(..), (.=), (.:))+import qualified Data.Aeson as Aeson+import qualified Data.Aeson.Types as Aeson++import qualified Network.Shpider.Forms as Shpider+ -- | AccessToken is a authentication data, required by all VK API -- functions. It is a tuple of access_token, user_id, expires_in fields, -- returned by login procedure.--- +-- -- See http://vk.com/developers.php?oid=-1&p=Авторизация_клиентских_приложений -- (in Russian) for more details-type AccessToken = (String,String,String)+data AccessToken = AccessToken {+ at_access_token :: String+ , at_user_id :: String+ , at_expires_in :: String+ } deriving(Show, Eq, Ord) -- | Access rigth to request from VK.+-- See API docs http://vk.com/developers.php?oid=-1&p=Права_доступа_приложений (in+-- Russian) for details data AccessRight = Notify -- Пользователь разрешил отправлять ему уведомления. | Friends -- Доступ к друзьям.@@ -28,12 +45,16 @@ | Notifications -- Доступ к оповещениям об ответах пользователю. | Stats -- Доступ к статистике групп и приложений пользователя, администратором которых он является. | Ads -- Доступ к расширенным методам работы с рекламным API.- | Offline -- Доступ к API в любое время со стороннего сервера. - deriving(Show)+ | Offline -- Доступ к API в любое время со стороннего сервера.+ deriving(Show, Eq, Ord, Enum) +toUrlArg :: [AccessRight] -> String+toUrlArg = intercalate "," . map (map toLower . show)++ allAccess :: [AccessRight] allAccess =- [ + [ -- Notify Friends , Photos@@ -54,48 +75,86 @@ -- , Offline ] --- See API docs http://vk.com/developers.php?oid=-1&p=Права_доступа_приложений (in--- Russian) for details+newtype AppID = AppID { aid_string :: String }+ deriving(Show, Eq, Ord) --- | Verbosity level. Debug will dump *html and output curl log++data JSON = JSON { js_aeson :: Aeson.Value }+ deriving(Show)++data Form = Form {+ form_title :: String+ , form :: Shpider.Form+ } deriving(Show)++data FilledForm = FilledForm {+ fform_title :: String+ , fform :: Shpider.Form+ } deriving(Show)+++data GenericOptions = GenericOptions {+ o_login_host :: String+ , o_api_host :: String+ , o_port :: Int+ , o_verbose :: Bool+ , o_use_https :: Bool+ , o_max_request_rate_per_sec :: Rational+ -- ^ How many requests per second is allowed+ , o_allow_interactive :: Bool++ , l_appid :: AppID+ , l_username :: String+ -- ^ Empty string means no value is given+ , l_password :: String+ -- ^ Empty string means no value is given+ , l_access_token :: String+ } deriving(Show)++defaultOptions = GenericOptions {+ o_login_host = "oauth.vk.com"+ , o_api_host = "api.vk.com"+ , o_port = 443+ , o_verbose = False+ , o_use_https = True+ , o_max_request_rate_per_sec = 3+ , o_allow_interactive = True++ , l_appid = AppID "3128877"+ , l_username = ""+ -- ^ Empty string means no value is given+ , l_password = ""+ -- ^ Empty string means no value is given+ , l_access_token = ""+ }++class ToGenericOptions s where+ toGenericOptions :: s -> GenericOptions+ data Verbosity = Normal | Trace | Debug deriving(Enum,Eq,Ord,Show) -type ClientId = String -data LoginEnv = LoginEnv- { formdata :: [(String,String)]- -- ^ Dictionary containig forms input/value- , ac_rights :: [AccessRight]- -- ^ Access rights, required by later API calls- , clientId :: ClientId- -- ^ Application ID provided by vk.com+data MusicOptions = MusicOptions {+ m_list_music :: Bool+ , m_search_string :: String+ , m_name_format :: String+ , m_output_format :: String+ , m_out_dir :: Maybe String+ , m_records_id :: [String]+ , m_skip_existing :: Bool } deriving(Show) -data CallEnv = CallEnv- { access_token :: String- -- ^ Access token, the result of login operation+data UserOptions = UserOptions {+ u_queryString :: String } deriving(Show) --- | VKHS environment-data Env subenv = Env- { sub :: subenv- , verbose :: Verbosity- -- ^ Verbosity level- , useragent :: String- -- ^ User agent identifier, defaults to Mozilla Firefox- , delay_ms :: Int- -- ^ Delay after each transaction, in milliseconds. Library uses it for- -- preventing application from being banned for flooding.- } deriving (Show)--mkEnv :: s -> Env s-mkEnv x = Env- x- Normal- "Mozilla/5.0 (X11; Linux x86_64; rv:12.0) Gecko/20120702 Firefox/12.0"- 500+data WallOptions = WallOptions {+ w_woid :: String+ } deriving(Show) -callEnv :: Env a -> String -> Env CallEnv-callEnv (Env _ a b c) at = Env (CallEnv at) a b c+data GroupOptions = GroupOptions {+ g_search_string :: String+ , g_output_format :: String+ } deriving(Show)