imagepaste-0.2.0.0: src/EngineScrnsht.hs

module EngineScrnsht (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 qualified Control.Arrow
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Text.HTML.TagSoup as TS

import qualified Engine
import qualified Configuration
import Log (msgDebug, msgInfo)

-- | Data structures according to API: http://www.uploadscreenshot.com/api-documentation
data ScrnshtReply = ScrnshtReply {
  srId        :: Int,
  srUrl       :: String,
  srShortUrl  :: String,
  srStatsUrl  :: String,
  srDeleteUrl :: String,
  srSmall     :: String,
  srLarge     :: String,
  srOriginal  :: String
} deriving Show

scrnshtUploadUrl = "http://img1.uploadscreenshot.com/api-upload.php"

scrnshtFields = [Engine.TextField "apiKey" "1c7688a8199888584473517828",
                 Engine.TextField "xmlOutput" "1"]

config = Engine.PasteContext {
  Engine.pcUploadLink    = scrnshtUploadUrl,
  Engine.pcFileTagName   = "userfile",
  Engine.pcFileName      = "",
  Engine.pcFields        = scrnshtFields,
  Engine.pcEncodingType  = Engine.MultipartFormData,
  Engine.pcContents      = "",
  Engine.pcResultLink    = Nothing,
  Engine.pcCustomFields  = Map.empty,
  Engine.pcAllowRedirect = False,
  Engine.pcCustomHeaders = []
  }

handler :: Engine.PasteHandler ()
handler = do
  config <- ask
  returnHandler (Configuration.getEngineAuth config "scrnsht") where
    returnHandler Nothing = upload
    returnHandler _       = signin >> upload

signin :: Engine.PasteHandler ()
signin = do
  context <- get
  config <- ask

  let auth = Configuration.getEngineAuth config "scrnsht"
      (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth
      credentials = [Engine.TextField "username" name,
                     Engine.TextField "userPasswordMD5" password]

  liftIO $ msgDebug $ "putting credentials: " ++ show credentials
  put $ Engine.addFields context credentials

tagsToInfo :: [TS.Tag String] -> Maybe ScrnshtReply
tagsToInfo tags = result where
  pairs = [(no, v) | TS.TagOpen no _:TS.TagText v:TS.TagClose nc:_ <- List.tails tags, no == nc]
  l v = fromMaybe "" (lookup v pairs)
  result = maybe Nothing (\_ -> Just info) $ lookup "success" pairs
  info = ScrnshtReply (read (l "id") :: Int)
                      (l "url")
                      (l "shorturl")
                      (l "statsurl")
                      (l "deleteurl")
                      (l "small")
                      (l "large")
                      (l "original")

upload :: Engine.PasteHandler ()
upload = do
  context <- get

  liftIO $ msgDebug "Sending post with file"
  liftIO $ msgDebug $ show context

  response <- liftIO $ Engine.sendPostWithFile context

  let text = rspBody response
      tags = TS.parseTags text :: [TS.Tag String]
      info = tagsToInfo tags
      link = fmap srOriginal info

  put context { Engine.pcResultLink = link }