module EngineRghost (config, handler) where import Data.Maybe import Network.HTTP.Headers import Network.HTTP import Control.Monad.State (modify, get, put) import Control.Monad.Reader (ask) import Control.Monad.IO.Class (liftIO) import Text.JSON import qualified Control.Arrow import qualified Data.Map as Map import qualified Data.List as List import qualified Engine import qualified Processing import qualified Tools import qualified Configuration import Log (msgDebug, msgInfo) data RghostPair = RghostPair { rpAuth :: String, rpUrl :: String } deriving Show instance JSON RghostPair where showJSON _ = JSNull readJSON (JSObject obj) = return RghostPair { rpAuth = auth, rpUrl = url } where auth = getResult (valFromObj "authenticity_token" obj :: Result String) url = getResult (valFromObj "upload_host" obj :: Result String) getResult (Ok x) = x readJSON _ = return RghostPair { rpAuth = "", rpUrl = "" } rghostUploadUrl = "http://phonon.rghost.net/files" rghostLoginUrl = "http://rghost.net/profile/login" config = Engine.PasteContext { Engine.pcUploadLink = rghostUploadUrl, Engine.pcFileTagName = "file", Engine.pcFileName = "", Engine.pcFields = [], Engine.pcEncodingType = Engine.MultipartFormData, Engine.pcContents = "", Engine.pcResultLink = Nothing, Engine.pcCustomFields = Map.empty, Engine.pcAllowRedirect = False, Engine.pcCustomHeaders = [] } loginConfig = Engine.PasteContext { Engine.pcUploadLink = rghostLoginUrl, Engine.pcFileTagName = "", Engine.pcFileName = "", Engine.pcFields = [], Engine.pcEncodingType = Engine.UrlEncoded, Engine.pcContents = "", Engine.pcResultLink = Nothing, Engine.pcCustomFields = Map.empty, Engine.pcAllowRedirect = False, Engine.pcCustomHeaders = [] } -- login fields -- -- utf8=%E2%9C%93 -- + authenticity_token=ycIaQnwARIsBDoOkCbX0z9T0jBP0CunIafmYIdzwYWw%3D -- + email=imp.imagepaste%40gmail.com -- + password=imp_test_password -- remember_me=1 -- commit=Sign+in handler :: Engine.PasteHandler () handler = do config <- ask returnHandler (Configuration.getEngineAuth config "rghost") where returnHandler Nothing = getAuthToken >> upload returnHandler _ = getAuthToken >> login >> upload --getAuthToken >> upload --rghostHandler context = return context >>= rghostGetAuthToken >>= rghostUpload -- | Parses response, downloads refresh page and parses it too getAuthToken :: Engine.PasteHandler () getAuthToken = do respStartPage <- liftIO $ Engine.fetch (getRequest "http://rghost.net/multiple/upload_host") True let text = rspBody respStartPage result = decode text :: Result RghostPair pair = (\(Ok x) -> x) result let cookie = case lookupHeader HdrSetCookie $ rspHeaders respStartPage of Just h -> takeWhile (/= ';') h Nothing -> "" liftIO $ msgDebug "=== cookies ===" liftIO $ msgDebug $ show cookie context <- get liftIO $ msgDebug $ "filename = " ++ show (Engine.pcFileName context) let newContext = context { Engine.pcFields = Engine.TextField "authenticity_token" (rpAuth pair) : fields, Engine.pcCustomHeaders = customHeaders ++ headers, Engine.pcUploadLink = "http://" ++ rpUrl pair ++ "/files" } customHeaders = [Header HdrCookie cookie, Header HdrHost (rpUrl pair)] fields = Engine.pcFields context headers = Engine.pcCustomHeaders context put newContext login :: Engine.PasteHandler () login = do -- in order to login we need: -- 1. authenticity_token -- 2. cookies -- 3. HdrHost rghost.net config <- ask context <- get let loginContext = loginConfig { Engine.pcFields = Engine.pcFields context ++ completeLoginFields, Engine.pcCustomHeaders = prevCookie : mainHost } auth = Configuration.getEngineAuth config "rghost" (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth completeLoginFields = [Engine.TextField "email" name, Engine.TextField "password" password] -- save original host - it might me muon or phonon prevHost = case lookupHeader HdrHost $ Engine.pcCustomHeaders context of Nothing -> mkHeader HdrHost "" Just h -> mkHeader HdrHost h prevCookie = Engine.mergeCookies (filter isCookie $ Engine.pcCustomHeaders context) "; " isCookie (Header HdrCookie _) = True isCookie _ = False mainHost = [mkHeader HdrHost "rghost.net"] response <- liftIO $ Engine.sendPostWithoutFile loginContext let cookies = Engine.cookiesRemoveSet response newHeaders = [cookies, prevHost] -- : Engine.pcCustomHeaders context authorizedContext = context { Engine.pcCustomHeaders = newHeaders } put authorizedContext upload :: Engine.PasteHandler () upload = Engine.uploadAndGrabHtml Engine.grabLocationHeader >>= Engine.saveFirstLink