packages feed

VKHS 0.3.3 → 0.5.0

raw patch · 15 files changed

+1114/−136 lines, 15 filesdep −fclabelsdep ~aesondep ~basedep ~bytestringnew-component:exe:vknews

Dependencies removed: fclabels

Dependency ranges changed: aeson, base, bytestring, containers, mtl, optparse-applicative, template-haskell

Files

VKHS.cabal view
@@ -1,6 +1,6 @@  name:                VKHS-version:             0.3.3+version:             0.5.0 synopsis:            Provides access to Vkontakte social network via public API description:     Provides access to Vkontakte API methods. Library requires no interaction@@ -20,6 +20,20 @@     type:     git     location: https://github.com/ierton/vkhs.git +executable vknews+  extra-libraries: curl+  hs-source-dirs:    src+  main-is:           VKNews.hs+  build-tools:     hsc2hs+  ghc-options:     -Wall -fwarn-tabs+  other-modules:+    Network.Curlhs.Base,+    Network.Curlhs.Core,+    Network.Curlhs.Easy,+    Network.Curlhs.Setopt,+    Network.Curlhs.Errors,+    Network.Curlhs.Types+ executable vkq   extra-libraries: curl   hs-source-dirs:    src@@ -36,7 +50,7 @@   library-  extra-libraries: curl+  --extra-libraries: curl   build-tools:     hsc2hs   ghc-options:     -Wall -fwarn-tabs   hs-source-dirs:    src@@ -55,7 +69,14 @@     Network.Curlhs.Easy,     Network.Curlhs.Setopt,     Network.Curlhs.Errors,-    Network.Curlhs.Types+    Network.Curlhs.Types,+    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)@@ -66,27 +87,27 @@                      Web.VKHS.API                      Web.VKHS.API.Aeson                      Web.VKHS.API.Types+                     Web.VKHS.API.Monad                      Web.VKHS.Curl                      Web.VKHS.Login                      Web.VKHS.Types -  build-depends:     base >=4.5 && <5,-                     containers ==0.5.*,+  build-depends:     base >=4.6 && <5,+                     containers,+                     mtl,+                     bytestring,                      tagsoup-parsec ==0.0.*,                      tagsoup ==0.12.*,-                     mtl ==2.1.*,                      failure ==0.2.*,-                     bytestring >=0.10 && <0.11,                      safe ==0.3.*,                      parsec ==3.1.*,                      split ==0.2.*,                      utf8-string ==0.3.*,                      bimap ==0.2.*,-                     template-haskell ==2.8.*,+                     template-haskell,                      transformers ==0.3.*,-                     fclabels >=1.1.4 && <1.1.6,-                     optparse-applicative >=0.4 && <0.6,-                     aeson >= 0.6 && < 0.7,+                     optparse-applicative,+                     aeson,                      filepath,                      directory,                      regexpr,@@ -94,4 +115,4 @@                      vector,                      text,                      time-  +
+ src/Data/Label.hs view
@@ -0,0 +1,166 @@+{-# 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 view
@@ -0,0 +1,133 @@+{-# 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 view
@@ -0,0 +1,218 @@+{-# 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 prettyPred cx) (prettyType ty)+prettyType (VarT nm         ) = VarT (prettyName nm)+prettyType (AppT ty tx      ) = AppT (prettyType ty) (prettyType tx)+prettyType (SigT ty ki      ) = SigT (prettyType ty) ki+prettyType ty                 = ty++prettyPred :: Pred -> Pred+prettyPred (ClassP nm tys) = ClassP (prettyName nm) (map prettyType tys)+prettyPred (EqualP ty tx ) = EqualP (prettyType ty) (prettyType tx)++-- IsString instances for TH types.++instance IsString Exp where+  fromString = VarE . mkName++instance IsString (Q Pat) where+  fromString = varP . mkName++instance IsString (Q Exp) where+  fromString = varE . mkName+
+ src/Data/Label/Maybe.hs view
@@ -0,0 +1,75 @@+{-# 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 view
@@ -0,0 +1,31 @@+{-# 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 view
@@ -0,0 +1,46 @@+{-# 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 view
@@ -0,0 +1,72 @@+{-# 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/Test/API.hs view
@@ -1,9 +1,9 @@ module Test.API where  import Web.VKHS-import Text.Printf  -- | 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}
+ src/VKNews.hs view
@@ -0,0 +1,133 @@+{-# 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++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 (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 = do+  hSetBuffering stdout NoBuffering+  hSetBuffering stderr NoBuffering+  at <- fromMaybe [] <$> lookupEnv env_var_name+  execParser (info (opts at) idm) >>= cmd+
src/VKQ.hs view
@@ -6,13 +6,9 @@ module Main where  import Control.Monad-import Control.Monad.Error import Data.Aeson as A import Data.Label.Abstract-import Data.Typeable-import Data.Data import Data.List-import Data.Maybe import qualified Data.ByteString as BS import qualified Data.ByteString.UTF8 as U import Network.Protocol.Uri.Query@@ -29,7 +25,7 @@ import Web.VKHS import Web.VKHS.Curl import Web.VKHS.API.Aeson as A-import Web.VKHS.API as STR+import Web.VKHS.API.Base as STR  data Options = Options   { verb :: Verbosity@@ -65,6 +61,7 @@   , output_format :: String   , out_dir :: String   , records_id :: [String]+  , skip_existing :: Bool   } deriving(Show)  data UserOptions = UO@@ -74,59 +71,60 @@  data WallOptions = WO   { accessToken_w :: String-  , oid :: 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"))+  <$> 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" &+  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")+  <$> flag Normal Debug (long "verbose" <> help "Be verbose")   <*> subparser (     command "login" (info loginOptions-      ( progDesc "Login and print access token (also prints user_id and expiriration time)" ))-    & command "call" (info (Call <$> (CO+      ( 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[,,,]]")))+      <*> 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+    <> command "music" (info ( Music <$> (MO       <$> access_token_flag-      <*> switch (long "list" & short 'l' & help "List music files")+      <*> switch (long "list" <> short 'l' <> help "List music files")       <*> strOption         ( metavar "STR"-        & long "query" & short 'q' & value [] & help "Query string")+        <> 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"+        <> 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"+        <> 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 "")-      <*> arguments str (metavar "RECORD_ID" & help "Download records")+      <*> strOption (metavar "DIR" <> short 'o' <> help "Output directory" <> value "")+      <*> arguments 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+    <> command "user" (info ( UserQ <$> (UO       <$> access_token_flag-      <*> strOption (long "query" & short 'q' & help "String to query")+      <*> strOption (long "query" <> short 'q' <> help "String to query")       ))       ( progDesc "Extract various user information"))-    & command "wall" (info ( WallQ <$> (WO+    <> command "wall" (info ( WallQ <$> (WO       <$> access_token_flag-      <*> strOption (long "id" & short 'i' & help "Owner id")+      <*> strOption (long "id" <> short 'i' <> help "Owner id")       ))       ( progDesc "Extract wall information"))     )@@ -136,7 +134,7 @@   r <- A.api' a b c   case r of     Right x -> return x-    Left e -> hPutStrLn stderr e >> exitFailure+    Left e -> hPutStrLn stderr (show e) >> exitFailure  api_str :: Env CallEnv -> String -> [(String,String)] -> IO String api_str a b c = do@@ -165,7 +163,7 @@ main :: IO () main = do   m <- maybe (idm) (value) <$> lookupEnv "VKQ_ACCESS_TOKEN"-  execParser (info (opts m) idm) >>= cmd+  execParser (info (helper <*> opts m) (fullDesc <> header "Vkontakte social network tool")) >>= cmd  cmd :: Options -> IO () @@ -173,13 +171,13 @@ 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,uid,expin) -> do-    printf "%s %s %s\n" at uid expin+  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 args))) = do+cmd (Options v (Call (CO act pp mn as))) = do   let e = (envcall act) { verbose = v }-  let s = fw (keyValues "," "=") args+  let s = fw (keyValues "," "=") as   case pp of     False -> do       ea <- api_str e mn s@@ -189,7 +187,7 @@       putStrLn $ PP.ppShow ea  -- Query audio files-cmd (Options v (Music mo@(MO act _ q@(_:_) fmt _ _ _))) = do+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@@ -197,28 +195,33 @@   printf "total %d\n" len  -- List audio files -cmd (Options v (Music mo@(MO act True [] fmt _ _ _))) = do+cmd (Options v (Music (MO act True [] fmt _ _ _ _))) = do   let e = (envcall act) { verbose = v }   (Response ms) <- api_ e "audio.get" []   forM_ ms $ \m -> do     printf "%s\n" (mr_format fmt m)-cmd (Options v (Music mo@(MO act False [] _ ofmt odir []))) = do+cmd (Options _ (Music (MO _ False [] _ _ _ [] _))) = do   errexit "Music record ID is not specified (see --help)"  -- Download audio files-cmd (Options v (Music mo@(MO act False [] _ ofmt odir rid))) = do+cmd (Options v (Music (MO act False [] _ ofmt odir rid sk))) = do   let e = (envcall act) { verbose = v }   Response ms <- api_ e "audio.getById" [("audios", concat $ intersperse "," rid)]   forM_ ms $ \m -> do-    (fp, h) <- openFileMR odir ofmt m-    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+    (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@(UO act qs))) = do+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")]@@ -227,9 +230,9 @@   -- processUQ uo ae  -- List wall messages-cmd (Options v (WallQ mo@(WO act wid))) = do+cmd (Options v (WallQ (WO act oid))) = do   let e = (envcall act) { verbose = v }-  (Response (SL len ws)) <- api_ e "wall.get" [("owner_id",wid)]+  (Response (SL len ws)) <- api_ e "wall.get" [("owner_id",oid)]   forM_ ws $ \w -> do     putStrLn (show $ wdate w)     putStrLn (wtext w)@@ -237,19 +240,25 @@  type NameFormat = String -openFileMR :: FilePath -> NameFormat -> MusicRecord -> IO (FilePath, Handle)-openFileMR [] _ m = do+-- 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,h)-openFileMR dir fmt m = do+  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 ext+  let name' = replaceExtension name (takeWhile (/='?') ext)   let fp =  (dir </> name') -  h <- openBinaryFile fp WriteMode-  return (fp,h)+  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]
src/Web/VKHS/API.hs view
@@ -1,44 +1,6 @@ module Web.VKHS.API-    ( api-    , envcall-    )  where--import Control.Monad-import Control.Monad.Trans-import Control.Monad.Writer-import Control.Monad.Error--import Data.Label-import qualified Data.ByteString.UTF8 as U-import qualified Data.ByteString as BS--import Network.Curlhs.Core--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)+    ( module Web.VKHS.API.Aeson+    ) where --- | 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 $ U.fromString uri])+import Web.VKHS.API.Aeson
src/Web/VKHS/API/Aeson.hs view
@@ -2,38 +2,45 @@ {-# LANGUAGE OverloadedStrings #-}  module Web.VKHS.API.Aeson-    ( api-    , api'-    , module Web.VKHS.API.Types-    ) where+  ( api+  , api'+  , Base.envcall+  , APIError(..)+  , module Web.VKHS.API.Types+  ) where  import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Writer import Control.Monad.Error  import Data.Aeson as A-import qualified Data.Aeson.Types as A-import Data.Aeson (FromJSON, (.:), (.:?))+import Data.Aeson.Types as A import Data.Aeson.Generic as AG import Data.ByteString.Lazy as BS-import Data.Typeable import Data.Data-import Data.Vector as V (head, tail, toList)-+import Data.Vector as V (head, tail)+import Text.Printf import Web.VKHS.Types import Web.VKHS.API.Types-import qualified Web.VKHS.API as Base+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 a =-  case AG.fromJSON a of+parseGeneric :: (Data a) => A.Value -> A.Parser a+parseGeneric val =+  case AG.fromJSON val of     A.Success a -> return a     A.Error s -> fail $ "parseGeneric fails:" ++ s @@ -47,20 +54,40 @@        <*> (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 -api' :: (A.FromJSON a) => Env CallEnv -> String -> [(String,String)] -> IO (Either String a)-api' e mn mp = runErrorT $ do-  e <- ErrorT (Base.api e mn mp)-  let check (Just x) = return x-      check (Nothing) = fail $ "AESON: error parsing JSON: " ++ show e-  check $ A.decode $ BS.fromStrict e+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 -api :: Env CallEnv -> String -> [(String,String)] -> IO (Either String A.Value)+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/Monad.hs view
@@ -0,0 +1,76 @@+{-# 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 view
@@ -4,7 +4,8 @@  import Data.Typeable import Data.Data-import Data.Text+import Data.Time.Clock+import Data.Time.Clock.POSIX  data Response a = Response a   deriving(Show)@@ -33,13 +34,21 @@   , 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)