diff --git a/VKHS.cabal b/VKHS.cabal
--- a/VKHS.cabal
+++ b/VKHS.cabal
@@ -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
-
+
diff --git a/src/Data/Label.hs b/src/Data/Label.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Label.hs
@@ -0,0 +1,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
+
diff --git a/src/Data/Label/Abstract.hs b/src/Data/Label/Abstract.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Label/Abstract.hs
@@ -0,0 +1,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 #-}
+
diff --git a/src/Data/Label/Derive.hs b/src/Data/Label/Derive.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Label/Derive.hs
@@ -0,0 +1,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
+
diff --git a/src/Data/Label/Maybe.hs b/src/Data/Label/Maybe.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Label/Maybe.hs
@@ -0,0 +1,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)))
+
diff --git a/src/Data/Label/MaybeM.hs b/src/Data/Label/MaybeM.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Label/MaybeM.hs
@@ -0,0 +1,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)
+
diff --git a/src/Data/Label/Pure.hs b/src/Data/Label/Pure.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Label/Pure.hs
@@ -0,0 +1,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
+
diff --git a/src/Data/Label/PureM.hs b/src/Data/Label/PureM.hs
new file mode 100644
--- /dev/null
+++ b/src/Data/Label/PureM.hs
@@ -0,0 +1,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
+
diff --git a/src/Test/API.hs b/src/Test/API.hs
--- a/src/Test/API.hs
+++ b/src/Test/API.hs
@@ -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}
diff --git a/src/VKNews.hs b/src/VKNews.hs
new file mode 100644
--- /dev/null
+++ b/src/VKNews.hs
@@ -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 "
" "\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
+
diff --git a/src/VKQ.hs b/src/VKQ.hs
--- a/src/VKQ.hs
+++ b/src/VKQ.hs
@@ -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]
diff --git a/src/Web/VKHS/API.hs b/src/Web/VKHS/API.hs
--- a/src/Web/VKHS/API.hs
+++ b/src/Web/VKHS/API.hs
@@ -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:
---
---
-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
diff --git a/src/Web/VKHS/API/Aeson.hs b/src/Web/VKHS/API/Aeson.hs
--- a/src/Web/VKHS/API/Aeson.hs
+++ b/src/Web/VKHS/API/Aeson.hs
@@ -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'
diff --git a/src/Web/VKHS/API/Monad.hs b/src/Web/VKHS/API/Monad.hs
new file mode 100644
--- /dev/null
+++ b/src/Web/VKHS/API/Monad.hs
@@ -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'
+
diff --git a/src/Web/VKHS/API/Types.hs b/src/Web/VKHS/API/Types.hs
--- a/src/Web/VKHS/API/Types.hs
+++ b/src/Web/VKHS/API/Types.hs
@@ -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)