module Web.VKHS.Login
( login
, env
) where
import Prelude hiding ((.), id, catch)
import Control.Applicative
import Control.Category
import Control.Exception
import Control.Failure
import Control.Monad.Trans
import Control.Monad.Error
import Control.Monad.Reader
import Control.Monad.Writer
import qualified Control.Monad.State as S
import qualified Data.ByteString.Char8 as BS
import Data.List
import Data.String
import Data.Char
import Data.Monoid
import Data.Either
import Data.Label
import qualified Data.Map as M
import Data.Maybe
import Data.Typeable
import Network.Curlhs.Core
import Network.Protocol.Http
import Network.Protocol.Uri
import Network.Protocol.Uri.Query
import Network.Protocol.Cookie as C
import Network.Shpider.Forms
import Text.HTML.TagSoup
import Text.Printf
import System.IO
import Web.VKHS.Types
import Web.VKHS.Curl
type Url = String
type Email = String
type Uid = String
type Password = String
type Body = String
toarg :: [AccessRight] -> String
toarg = intercalate "," . map (map toLower . show)
env :: String
-> String
-> String
-> [AccessRight]
-> Env LoginEnv
env cid email pwd ar = mkEnv
(LoginEnv
[ ("email",email) , ("pass",pwd) ]
ar
cid
)
vk_start_action :: ClientId -> [AccessRight] -> ActionHist
vk_start_action cid ac = AH [] $ OpenUrl start_url mempty where
start_url = (\f -> f $ toUri "http://oauth.vk.com/authorize")
$ set query $ bw params
[ ("client_id", cid)
, ("scope", toarg ac)
, ("redirect_uri", "http://oauth.vk.com/blank.html")
, ("display", "wap")
, ("response_type", "token")
]
type FilledForm = Form
type VK a = ReaderT (Env LoginEnv) (ErrorT String IO) a
runVK :: Env LoginEnv -> VK a -> IO (Either String a)
runVK e vk = runErrorT (runReaderT vk e)
liftVK :: IO (Either String a) -> VK a
liftVK m = liftIO m >>= either fail return
dbgVK :: Verbosity -> IO () -> VK ()
dbgVK v act = ask >>= \e -> do
if v > (verbose e) then return ()
else liftIO $ act
when_debug = dbgVK Debug
when_trace = dbgVK Trace
type Page = (Http Response, Body)
type Hist = [[String]]
data ActionHist = AH Hist Action
deriving(Show)
data Action = OpenUrl Uri Cookies | SendForm Form Cookies
deriving (Show)
actionUri :: Action -> Uri
actionUri (OpenUrl u _) = u
actionUri (SendForm f _) = toUri . action $ f
liftEIO act = (liftIO act) >>= either fail return
vk_get :: Uri -> Cookies -> VK Page
vk_get u c = let
c' = (BS.pack $ bw cookie $ map toShort $ bw gather c )
u' = (BS.pack $ showUri u)
in do
e <- ask
s <- liftEIO $ vk_curl e $ do
when ((not . BS.null) c') $ do
tell [CURLOPT_COOKIE c']
when ((not . BS.null) u') $ do
tell [CURLOPT_URL u']
liftVK (return $ parseResponse s)
vk_post :: FilledForm -> Cookies -> VK Page
vk_post f c = let
c' = (BS.pack $ bw cookie $ map toShort $ bw gather c )
p' = (BS.pack $ bw params $ M.toList $ inputs f)
u' = (BS.pack $ action f)
in do
e <- ask
s <- liftEIO $ vk_curl e $ do
when ((not . BS.null) c') $ do
tell [CURLOPT_COOKIE c']
when ((not . BS.null) u') $ do
tell [CURLOPT_URL u']
tell [CURLOPT_POST True]
tell [CURLOPT_COPYPOSTFIELDS p']
liftVK (return $ parseResponse s)
split_inputs :: [(String,String)]
-> M.Map String String
-> (M.Map String (), M.Map String String, M.Map String String)
split_inputs d m =
let (b,g) = M.mapEitherWithKey (match_field d) m
in (b, M.map (either id id) g, snd (M.mapEither id g))
where
match_field d k a
| not (null a) = maybe ((Right . Left) a) (Right . Right) u
| otherwise = maybe (Left ()) (Right . Right) u
where u = lookup k d
inputs_to_fill :: Form -> [String]
inputs_to_fill f = let (inps,_,_) = split_inputs [] (inputs f) in M.keys inps
vk_fill_form :: Form -> VK FilledForm
vk_fill_form f = ask >>= \e -> do
let (bad,good,user) = split_inputs ((formdata . sub) e) (inputs f)
when (not $ M.null bad) (fail $ "Unmatched form parameters: " ++ (show bad))
return f { inputs = good }
vk_move :: Action -> VK (Page, Cookies)
vk_move (OpenUrl u c) = do
(h,b) <- (vk_get u c)
return ((h,b),c`mappend`(get setCookies h))
vk_move (SendForm f c) = do
f' <- vk_fill_form f
(h,b) <- (vk_post f' c)
return ((h,b),c`mappend`(get setCookies h))
uri_fragment :: Http Response -> Maybe AccessToken
uri_fragment = get location >=> pure . get fragment >=> pure . fw (keyValues "&" "=") >=> \f -> do
(\a b c -> (a,b,c)) <$> lookup "access_token" f <*> lookup "user_id" f <*> lookup "expires_in" f
vk_analyze :: Hist -> (Page,Cookies) -> VK (Either AccessToken (Action,Hist))
vk_analyze hist ((h,b),c)
| isJust a = return $ Left (fromJust a)
| isJust l = return $ Right (OpenUrl (fromJust l) c, hist)
| not (null fs) && not (is `elem` hist)
= return $ Right (SendForm f c, is:hist)
| not (null fs) && (is `elem` hist)
= fail $ "Invalid password/Form containig following inputs already seen: " ++ (show is)
| not gs = fail $ "HTTP error: status " ++ (show s)
| otherwise = fail $ "HTML processing failure (new design of VK login dialog?)"
where
gs = s`elem` [OK,Created,Found,SeeOther,Accepted,Continue]
s = get status h
l = get location h
fs = parseTags >>> gatherForms $ b
f = head fs
is = inputs_to_fill f
a = uri_fragment h
vk_dump_page :: Int -> Uri -> Page -> IO ()
vk_dump_page n u (h,b)
| (>0) . length . filter (isAlpha) $ b =
let name = printf "%02d-%s.html" n (showAuthority (get authority u))
in bracket (openFile name WriteMode) (hClose) $ \f -> do
hPutStrLn f b
hPutStrLn stderr $ "dumped: name " ++ (name) ++ " size " ++ (show $ length b)
| otherwise = return ()
login :: Env LoginEnv -> IO (Either String AccessToken)
login e@(Env (LoginEnv _ acr cid) _ _ _) =
runVK e $ loop [0..] (vk_start_action cid acr) where
loop (n:ns) (AH h act) = do
when_trace $ printf "VK => %02d %s" n (show act)
ans@(p,c) <- vk_move act
when_debug $ vk_dump_page n (actionUri act) p
a <- vk_analyze h ans
case a of
Right (act',h') -> do
loop ns (AH h' act')
Left at -> do
return at