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
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 (x1) 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);
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'