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 qualified Data.Text.Encoding 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)
apiRf :: (Aeson.FromJSON b, MonadAPI m x s)
=> MethodName
-> MethodArgs
-> (b -> Either String a)
-> API m x a
apiRf m0 args0 flt = 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 (Response _ b)) -> do
case flt b of
Right a -> return a
Left e -> do
recovery <- raise (CallFailure (m0, args0, j, e))
go recovery
(Left e) -> do
recovery <- raise (CallFailure (m0, args0, j, e))
go recovery
apiR :: (Aeson.FromJSON a, MonadAPI m x s)
=> MethodName
-> MethodArgs
-> API m x a
apiR m0 args0 = apiRf m0 args0 Right
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
(Left e1, Left e2) -> do
recovery <- raise (CallFailure (m0, args0, j, e1 <> ";" <> e2))
go recovery
(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
(Right _, Right (Response _ err)) -> do
ma <- (handler err)
case ma of
Just a -> return a
Nothing -> do
recovery <- raise (CallFailure (m0, args0, j,
"Response matches both error and result object"))
go recovery
(Right (Response _ a), _) -> do
return a
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))
jsonEncodeBS :: JSON -> ByteString
jsonEncodeBS JSON{..} = BS.concat $ toChunks $ Aeson.encode js_aeson
jsonEncode :: JSON -> Text
jsonEncode JSON{..} = Text.decodeUtf8 $ BS.concat $ toChunks $ Aeson.encode js_aeson
jsonEncodePrettyBS :: JSON -> ByteString
jsonEncodePrettyBS JSON{..} = BS.concat $ toChunks $ Aeson.encodePretty js_aeson
jsonEncodePretty :: JSON -> Text
jsonEncodePretty JSON{..} = Text.decodeUtf8 $ BS.concat $ toChunks $ Aeson.encodePretty js_aeson