-- Copyright (C) 2017 Matthew Harm Bekkema
--
-- This file is part of myanimelist-export.
--
-- myanimelist-export is free software: you can redistribute it and/or modify
-- it under the terms of the GNU General Public License as published by
-- the Free Software Foundation, either version 3 of the License, or
-- (at your option) any later version.
--
-- myanimelist-export is distributed in the hope that it will be useful,
-- but WITHOUT ANY WARRANTY; without even the implied warranty of
-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-- GNU General Public License for more details.
--
-- You should have received a copy of the GNU General Public License
-- along with this program. If not, see <https://www.gnu.org/licenses/>.
-----------------------------------------------------------------------------
-- |
-- Module : MyAnimeList.Export
-- Copyright : Matthew Harm Bekkema 2017
-- License : GPL-3
-- Maintainer : mbekkema97@gmail.com
-- Stability : experimental
-----------------------------------------------------------------------------
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# 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
import MemoizedTraverse (memoizedTraverse)
-- | Represents a media type supported by MyAnimeList
data MediaType = Anime | Manga
deriving (Read, Show, Eq, Ord, Enum)
-- | Possible exceptions that could be raised by `exportLists`
data MyAnimeListException = InvalidCredentials -- ^ Wrong username/password
| TooManyAttempts -- ^ Too many failed logins
deriving (Read, Show, Eq, Ord)
instance Exception MyAnimeListException
newtype CSRF = CSRF { unCsrf :: ByteString }
malHomePage :: Request
malHomePage = "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"
-- | Known MyAnimeList error messages with the corresponding exceptions
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
-- | Export list(s) and return URL(s) to gzipped XML
exportLists :: (Functor f, Foldable f)
=> Text -- ^ Username
-> Text -- ^ Password
-> Manager -- ^ Manager (must support TLS)
-> f MediaType -- ^ Which list(s) to export
-> IO (f URI)
exportLists username password manager mediaTypes = do
(cj, csrf) <- getCsrf manager
cj' <- login username password cj csrf manager
runConcurrently $ memoizedTraverse
(Concurrently . exportList cj' csrf manager) mediaTypes
login :: Text -- ^ Username
-> Text -- ^ Password
-> 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