{-# LANGUAGE OverloadedStrings #-}
module MyAnimeList.Export
( MediaType(..)
, exportLists
, MyAnimeListException(..)
) where
import Data.Function
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Catch (MonadThrow, Exception, throwM)
import Control.Concurrent.Async (Concurrently(Concurrently),
runConcurrently)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as B8
import Data.Text (Text)
import Data.Text.Encoding (encodeUtf8)
import Data.Conduit
import qualified Data.Conduit.List as C
import Text.HTML.TagStream.ByteString (Token, tokenStream)
import Text.HTML.TagStream (Token' (TagOpen, Text))
import Network.URI (URI, parseURIReference, uriPath,
relativeTo)
import Network.HTTP.Client (Manager, Request, BodyReader, CookieJar,
withResponse, parseRequest_,
urlEncodedBody, getUri, path, cookieJar,
responseBody, responseCookieJar, brRead)
import MemoizedTraverse (memoizedTraverse)
data MediaType = Anime | Manga
deriving (Read, Show, Eq, Ord, Enum)
data MyAnimeListException = InvalidCredentials
| TooManyAttempts
deriving (Read, Show, Eq, Ord)
instance Exception MyAnimeListException
newtype CSRF = CSRF { unCsrf :: ByteString }
malHomePage :: Request
malHomePage = parseRequest_ "https://myanimelist.net/"
malLoginPage :: Request
malLoginPage = malHomePage { path = "/login.php" }
malExportPage :: Request
malExportPage = malHomePage { path = "/panel.php?go=export" }
malExportPath :: String
malExportPath = "/export/download.php"
malErrorMap :: [(ByteString, MyAnimeListException)]
malErrorMap = [ ("Your username or password is incorrect.", InvalidCredentials)
, ("Too many failed login attempts, your IP address has been blocked for several hours.", TooManyAttempts)
]
lookupErrorMap :: ByteString -> Maybe MyAnimeListException
lookupErrorMap t = case filter (\(m,_) -> BS.isInfixOf m t) malErrorMap of
[] -> Nothing
((_, e):_) -> Just e
exportLists :: (Functor f, Foldable f)
=> Text
-> Text
-> Manager
-> f MediaType
-> IO (CookieJar, f URI)
exportLists username password manager mediaTypes = do
(cj, csrf) <- getCsrf manager
cj' <- login username password cj csrf manager
urls <- runConcurrently $ memoizedTraverse
(Concurrently . exportList cj' csrf manager) mediaTypes
pure (cj', urls)
login :: Text
-> Text
-> CookieJar
-> CSRF
-> Manager
-> IO CookieJar
login username password cj csrf manager = withResponse req manager $ \res -> do
runConduit $ sourceBodyReader (responseBody res)
.| tokenStream
.| awaitForever tagToLoginError
pure $ responseCookieJar res
where
req = urlEncodedBody [ ("user_name", encodeUtf8 username)
, ("password", encodeUtf8 password)
, ("sublogin", "Login")
, ("submit", "1")
, ("csrf_token", unCsrf csrf)
]
malLoginPage { cookieJar = Just cj }
getCsrf :: Manager
-> IO (CookieJar, CSRF)
getCsrf manager = withResponse malHomePage manager $ \res ->
runConduit $ sourceBodyReader (responseBody res)
.| tokenStream
.| C.mapMaybe tagToCsrf
.| (await >>= maybe
(fail $ moduleName ++ ".getCsrf: couldn't find csrf")
(pure . (,) (responseCookieJar res))
)
exportList :: CookieJar
-> CSRF
-> Manager
-> MediaType
-> IO URI
exportList cj csrf manager mediaType = withResponse req manager $ \res ->
runConduit $ sourceBodyReader (responseBody res)
.| tokenStream
.| C.mapMaybe tagToUri
.| C.filter ((malExportPath ==) . uriPath)
.| C.map (`relativeTo` getUri malHomePage)
.| (await >>= maybe
(fail $ moduleName ++ ".exportList: couldn't find uri")
pure
)
where
req = urlEncodedBody [ ("type", mediaTypeValue mediaType)
, ("subexport", "Export My List")
, ("csrf_token", unCsrf csrf)
]
malExportPage { cookieJar = Just cj }
sourceBodyReader :: MonadIO m => BodyReader -> ConduitM i ByteString m ()
sourceBodyReader br = fix $ \r -> do
x <- liftIO $ brRead br
unless (BS.null x) (yield x >> r)
tagToCsrf :: Token -> Maybe CSRF
tagToCsrf (TagOpen "meta" xs False) = case lookup "name" xs of
Just "csrf_token" -> CSRF <$> lookup "content" xs
_ -> Nothing
tagToCsrf _ = Nothing
tagToUri :: Token -> Maybe URI
tagToUri (TagOpen "a" xs False) =
parseURIReference . B8.unpack =<< lookup "href" xs
tagToUri _ = Nothing
tagToLoginError :: MonadThrow m => Token -> ConduitM Token o m ()
tagToLoginError (TagOpen "div" xs False)
| lookup "class" xs == Just "badresult" = do
nextTag <- await
case nextTag of
Just (Text t)
| Just e <- lookupErrorMap t -> throwM e
Just e -> failM $ moduleName ++ ".login: unknown error: " ++ show e
Nothing -> failM $ moduleName ++ ".login: unexpected end of stream"
tagToLoginError _ = pure ()
mediaTypeValue :: MediaType -> ByteString
mediaTypeValue Anime = "1"
mediaTypeValue Manga = "2"
moduleName :: String
moduleName = "MyAnimeList.Export"
failM :: MonadThrow m => String -> m a
failM = throwM . userError