imagepaste-0.2.0.0: src/EngineRghost.hs

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 -> "<no cookies>"
  
  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 "<could not get previous host>"
        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