module Web.VKHS.API.Base where
import Data.Time
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Control.Monad.Writer
import Control.Monad.Cont
import Control.Exception (catch, SomeException)
import qualified Data.Text as Text
import Data.ByteString.Lazy (fromStrict,toChunks)
import qualified Data.ByteString.Char8 as BS
import Data.Aeson ((.=), (.:))
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Types as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import Text.Printf
import Text.Read (readMaybe)
import Web.VKHS.Imports
import Web.VKHS.Types
import Web.VKHS.Client hiding (Response(..))
import Web.VKHS.Monad
import Web.VKHS.Error
import Web.VKHS.API.Types
import Debug.Trace
data APIState = APIState {
api_access_token :: String
} deriving (Show)
defaultState = APIState {
api_access_token = ""
}
class ToGenericOptions s => ToAPIState s where
toAPIState :: s -> APIState
modifyAPIState :: (APIState -> APIState) -> (s -> s)
modifyAccessToken :: (MonadIO m, MonadState s m, ToAPIState s) => AccessToken -> m ()
modifyAccessToken at@AccessToken{..} = do
modify $ modifyAPIState (\as -> as{api_access_token = at_access_token})
GenericOptions{..} <- getGenericOptions
case l_access_token_file of
[] -> return ()
fl -> liftIO $ writeFile l_access_token_file (show at)
return ()
class (MonadIO (m (R m x)), MonadClient (m (R m x)) s, ToAPIState s, MonadVK (m (R m x)) (R m x)) =>
MonadAPI m x s | m -> s
type API m x a = m (R m x) a
decodeJSON :: (MonadAPI m x s)
=> ByteString
-> API m x JSON
decodeJSON bs = do
case Aeson.decode (fromStrict bs) of
Just js -> return (JSON js)
Nothing -> raise (JSONParseFailure bs)
apiJ :: (MonadAPI m x s)
=> String
-> [(String, Text)]
-> API m x JSON
apiJ mname (map (id *** tunpack) -> margs) = do
GenericOptions{..} <- gets toGenericOptions
APIState{..} <- gets toAPIState
let protocol = (case o_use_https of
True -> "https"
False -> "http")
url <- ensure $ pure
(urlCreate
(URL_Protocol protocol)
(URL_Host o_api_host)
(Just (URL_Port (show o_port)))
(URL_Path ("/method/" ++ mname))
(buildQuery (("access_token", api_access_token):margs)))
debug $ "> " <> (tshow url)
req <- ensure (requestCreateGet url (cookiesCreate ()))
(res, jar') <- requestExecute req
decodeJSON (responseBody res)
api :: (Aeson.FromJSON a, MonadAPI m x s)
=> String
-> [(String, Text)]
-> API m x a
api m args = do
j <- apiJ m args
case parseJSON j of
Right a -> return a
Left e -> terminate (JSONParseFailure' j e)
apiR :: (Aeson.FromJSON a, MonadAPI m x s)
=> MethodName
-> MethodArgs
-> API m x a
apiR m0 args0 = go (ReExec m0 args0) where
go action = do
j <- do
case action of
ReExec m args -> do
apiJ m args
ReParse j -> do
pure j
case parseJSON j of
(Right a) -> return a
(Left e) -> do
recovery <- raise (CallFailure (m0, args0, j, e))
go recovery
apiHM :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
=> MethodName
-> MethodArgs
-> (ErrorRecord -> API m x (Maybe a))
-> API m x a
apiHM m0 args0 handler = go (ReExec m0 args0) where
go action = do
j <- do
case action of
ReExec m args -> do
apiJ m args
ReParse j -> do
pure j
case (parseJSON j, parseJSON j) of
(Right (Response _ a), _) -> return a
(Left e, Right (Response _ err)) -> do
ma <- (handler err)
case ma of
Just a -> return a
Nothing -> do
recovery <- raise (CallFailure (m0, args0, j, e))
go recovery
(Left e1, Left e2) -> do
recovery <- raise (CallFailure (m0, args0, j, e1 <> ";" <> e2))
go recovery
apiH :: forall m x a s . (Aeson.FromJSON a, MonadAPI m x s)
=> MethodName
-> MethodArgs
-> (ErrorRecord -> Maybe a)
-> API m x a
apiH m args handler = apiHM m args (\e -> pure (handler e) :: API m x (Maybe a))
apiE :: (Aeson.FromJSON a, MonadAPI m x s)
=> String
-> [(String, Text)]
-> API m x (Either (Response ErrorRecord) a)
apiE m args = apiJ m args >>= convert where
convert j = do
err <- pure $ parseJSON j
ans <- pure $ parseJSON j
case (ans, err) of
(Right a, _) -> return (Right a)
(Left a, Right e) -> return (Left e)
(Left a, Left e) -> do
j' <- raise (JSONCovertionFailure
(j, "apiE: " <> Text.pack m <> ": expecting either known response or error"))
convert j'
apiD :: (Aeson.FromJSON a, MonadAPI m x s)
=> a
-> String
-> [(String, Text)]
-> API m x a
apiD def m args =
apiE m args >>= \case
Left err -> return def
Right x -> return x
api_S :: (Aeson.FromJSON a, MonadAPI m x s)
=> String -> [(String, String)] -> API m x a
api_S m args = api m (map (id *** tpack) args)
jsonEncode :: JSON -> ByteString
jsonEncode JSON{..} = BS.concat $ toChunks $ Aeson.encode js_aeson
jsonEncodePretty :: JSON -> ByteString
jsonEncodePretty JSON{..} = BS.concat $ toChunks $ Aeson.encodePretty js_aeson