summaryrefslogtreecommitdiff
path: root/src/Web/VKHS.hs
blob: 8425ffe9c8f3c13328e89f6a0b4c524dfc04982c (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
module Web.VKHS (
    module Web.VKHS
  , module Web.VKHS.Client
  , module Web.VKHS.Types
  , module Web.VKHS.Error
  , module Web.VKHS.Monad
  , module Web.VKHS.Login
  , module Web.VKHS.API
  ) where

import Data.Time
import Control.Applicative
import Control.Monad
import Control.Monad.Except
import Control.Monad.State (MonadState, execState, evalStateT, StateT(..), get, modify)
import Control.Monad.Cont
import Control.Monad.Reader
import Debug.Trace
import System.IO

import qualified Data.ByteString.Char8 as BS
import qualified Data.Text as Text

import Web.VKHS.Imports
import Web.VKHS.Error
import Web.VKHS.Types
import Web.VKHS.Client hiding (Error, Response, defaultState)
import qualified Web.VKHS.Client as Client
import Web.VKHS.Monad hiding (catch)
import qualified Web.VKHS.Monad as VKHS
import Web.VKHS.Login (MonadLogin, LoginState(..), ToLoginState(..), printForm, login)
import qualified Web.VKHS.Login as Login
import Web.VKHS.API
import qualified Web.VKHS.API as API

-- | Main state of the VK monad stack. Consists of lesser states plus a copy of
-- generic options provided by the caller.
data State = State {
    cs :: ClientState
  , ls :: LoginState
  , as :: APIState
  , go :: GenericOptions
  }

instance ToLoginState State where
  toLoginState = ls
  modifyLoginState f = \s -> s { ls = f (ls s) }
instance ToClientState State where
  toClientState = cs
  modifyClientState f = \s -> s { cs = f (cs s) }
instance API.ToAPIState State where
  toAPIState = as
  modifyAPIState f = \s -> s { as = f (as s) }
instance ToGenericOptions State where
  toGenericOptions = go

initialState :: (MonadIO m) => GenericOptions -> m State
initialState go = State
  <$> liftIO (Client.defaultState go)
  <*> pure (Login.defaultState go)
  <*> pure (API.defaultState)
  <*> pure go

type Guts x m r a = ReaderT (r -> x r r) (ContT r m) a

-- | Main VK monad able to track errors, track full state 'State', set
-- early exit by the means of continuation monad. VK encodes a coroutine which
-- has entry points defined by 'Result' datatype.
--
-- See also 'runVK' and 'defaultSupervisor`.
--
-- * FIXME Re-write using modern 'Monad.Free'
newtype VK r a = VK { unVK :: Guts VK (StateT State (ExceptT Text IO)) r a }
  deriving(MonadIO, Functor, Applicative, Monad, MonadState State, MonadReader (r -> VK r r) , MonadCont)

instance MonadClient (VK r) State
instance MonadVK (VK r) r
instance MonadLogin (VK r) r State
instance MonadAPI VK r State

-- | Run the VK coroutine till next return. Consider using 'runVK' for full
-- spinup.
stepVK :: VK r r -> StateT State (ExceptT Text IO) r
stepVK m = runContT (runReaderT (unVK (VKHS.catch m)) undefined) return

-- | Run VK monad @m@ and handle continuation requests using default
-- algorithm. @defaultSupervisor@ would relogin on invalid access token
-- condition, ask for missing form fields (typically - an email/password)
--
-- See also 'runVK'
--
-- * FIXME Store known answers in external DB (in file?) instead of LoginState
--   FIXME dictionary
-- * FIXME Handle capthas (offer running standalone apps)
defaultSupervisor :: (Show a) => VK (R VK a) (R VK a) -> StateT State (ExceptT Text IO) a
defaultSupervisor = go where
  go m = do
    GenericOptions{..} <- toGenericOptions <$> get
    res <- stepVK m
    res_desc <- pure (describeResult res)
    case res of
      Fine a -> do
        return a

      UnexpectedInt e k -> do
        alert "UnexpectedInt (ignoring)"
        go (k 0)

      UnexpectedFormField (Form tit f) i k -> do
        alert $ "While filling form " <> (printForm "" f)
        case o_allow_interactive of
          True -> do
            v <- do
              alert $ "Please, enter the value for input " <> tpack i <> " : "
              liftIO $ getLine
            go (k v)
          False -> do
            alert $ "Unable to query value for " <> tpack i <> " since interactive mode is disabled"
            lift $ throwError res_desc

      LogError text k -> do
        alert text
        go (k ())

      CallFailure (m, args, j, err) k -> do
        alert $    "Error calling API:\n\n\t" <> tshow m <> " " <> tshow args <> "\n"
              <> "\nResponse object:\n\n\t" <> tpack (ppShow j) <> "\n"
              <> "\nParser error was:" <> tshow err <> "\n"

        case parseJSON j of
          Left err -> do
            alert $ "Failed to parse JSON error object, message: " <> tshow err
            lift $ throwError res_desc

          Right (Response _ ErrorRecord{..}) -> do
            case er_code of
              NotLoggedIn -> do
                alert $ "Attempting to re-login"
                at <- defaultSupervisor (login >>= return . Fine)
                modifyAccessToken at
                go (k $ ReExec m args)
              TooManyRequestsPerSec -> do
                alert $ "Too many requests per second, consider changing options"
                go (k $ ReExec m args)
              ErrorCode ec -> do
                alert $  "Unhandled error code " <> tshow ec <> "\n"
                      <> "Consider improving 'defaultSupervisor' or applying \n"
                      <> "custom error filters using `apiH` ,`apiHS` or their \n"
                      <> "high-level wrappers `apiSimpleH` / `apiSimpleHM`"
                lift $ throwError res_desc

      RepeatedForm Form{..} k -> do
        alert  $ "Failed to complete login procedure. Last seen form is\n"
              <> "\n"
              <> printForm "\t" form
              <> "\n"
              <> "You may try to obtain more details by setting --verbose flag and/or checking the 'latest.html' file"
        lift $ throwError res_desc

      _ -> do
        alert $ "Unsupervised error: " <> res_desc
        lift $ throwError res_desc

-- | Run login procedure using 'defaultSupervisor'. Return 'AccessToken' on
-- success
runLogin :: GenericOptions -> ExceptT Text IO AccessToken
runLogin go = do
  s <- initialState go
  evalStateT (defaultSupervisor (login >>= return . Fine)) s

-- | Run the VK monad @m@ using generic options @go@ and 'defaultSupervisor'.
-- Perform login procedure if needed. This is an mid-layer runner, consider
-- using 'runVK' instead.
runAPI :: Show b => GenericOptions -> VK (R VK b) b -> ExceptT Text IO b
runAPI go@GenericOptions{..} m = do
  s <- initialState go
  flip evalStateT s $ do

    readInitialAccessToken >>= \case
      Nothing ->
        return ()
      Just at -> do
        modifyAccessToken at

    defaultSupervisor (m >>= return . Fine)

-- | Run the VK monad @m@ using generic options @go@ and 'defaultSupervisor'
runVK :: Show a => GenericOptions -> VK (R VK a) a -> IO (Either Text a)
runVK go = runExceptT . runAPI go

-- | A version of 'runVK' with unit return.
runVK_ :: Show a => GenericOptions -> VK (R VK a) a -> IO ()
runVK_ go = do
  runVK go >=> \case
    Left e -> fail (tunpack e)
    Right _ -> return ()