module Web.VKHS.Login
( login
, Env(..)
, env
, AccessRight(..)
, Verbosity(..)
) 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
env cid email pwd ar = Env
Normal
"Mozilla/5.0 (X11; Linux x86_64; rv:12.0) Gecko/20120702 Firefox/12.0"
[ ("email",email) , ("pass",pwd) ]
cid
500
ar
vk_start_action :: ClientId -> [AccessRight] -> Action
vk_start_action cid ac = 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 (ErrorT String IO) a
runVK :: Env -> 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)
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
vk_fill_form :: Form -> VK FilledForm
vk_fill_form f = ask >>= \e -> do
let (bad,good,user) = split_inputs (formdata 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 :: (Page,Cookies) -> VK (Either AccessToken Action)
vk_analyze ((h,b),c)
| isJust a = return $ Left (fromJust a)
| isJust l = return $ Right $ OpenUrl (fromJust l) c
| (not . null) f = return $ Right $ SendForm (head f) c
| otherwise = fail "HTML processing failure (new design of VK login dialog?)"
where
l = get location h
f = parseTags >>> gatherForms $ b
a = uri_fragment h
vk_dump_page :: Int -> Uri -> Page -> IO ()
vk_dump_page n u (h,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)
login :: Env -> IO (Either String AccessToken)
login e = runVK e $ loop 0 (vk_start_action (clientId e) (ac_rights e)) where
loop n 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 ans
case a of
Right act' -> do
loop (n+1) act'
Left at -> do
return at