imagepaste-0.2.0.0: src/EngineImgur.hs

module EngineImgur (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 Control.Applicative ((<$>), (<*>))
import Control.Monad (void)

import qualified Control.Arrow
import qualified Data.Map as Map
import qualified Data.List as List
import qualified Text.JSON as J

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

-- | Data structures according to API: http://api.imgur.com/resources_anon
data ImgurReply = ImgurReply {
  irUpload :: ImgurUpload
} deriving Show

data ImgurUpload = ImgurUpload {
  iuImage :: ImgurReplyImage,
  iuLinks :: ImgurReplyLinks
} deriving Show

data ImgurReplyImage = ImgurReplyImage {
--  iriName       :: String,
--  iriTitle      :: String,
--  iriCaption    :: String,
  iriHash       :: String,
  iriDeletehash :: String,
  iriDatetime   :: String,
  iriType       :: String,
  iriAnimated   :: String,
  iriWidth      :: Int,
  iriHeight     :: Int,
  iriSize       :: Int,
  iriViews      :: Int,
  iriBandwidth  :: Int
} deriving Show

data ImgurReplyLinks = ImgurReplyLinks {
  irlOriginal   :: String,
  irlImgur      :: String,
  irlDelete     :: String,
  irlSmall      :: String,
  irlLarge      :: String
} deriving Show

mLookup a as = maybe (fail $ "No such element: " ++ a) return (lookup a as)
lookRead as id = mLookup id as  >>= J.readJSON

--dummyImage = ImgurReplyImage "" "" "" "" "" "" "" "" 0 0 0 0 0
dummyImage = ImgurReplyImage "" "" "" "" "" 0 0 0 0 0
dummyLinks = ImgurReplyLinks "" "" "" "" ""
dummyUpload = ImgurUpload dummyImage dummyLinks
dummyReply = ImgurReply dummyUpload

instance J.JSON ImgurReply where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f = lookRead as
    in ImgurReply <$> f "upload"
    
  readJSON _ = return dummyReply

instance J.JSON ImgurUpload where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f id = lookRead as id
    in ImgurUpload <$> f "image" <*> f "links"
    
  readJSON _ = return dummyUpload

instance J.JSON ImgurReplyImage where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f id = lookRead as id
    in ImgurReplyImage
           <$> f "hash"
           <*> f "deletehash"
           <*> f "datetime"
           <*> f "type"
           <*> f "animated"
           <*> f "width"
           <*> f "height"
           <*> f "size"
           <*> f "views"
           <*> f "bandwidth"
  
  readJSON _ = return dummyImage

instance J.JSON ImgurReplyLinks where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f = lookRead as
    in ImgurReplyLinks
           <$> f "original"
           <*> f "imgur_page"
           <*> f "delete_page"
           <*> f "small_square"
           <*> f "large_thumbnail"
  
  readJSON _ = return dummyLinks

imgurUploadUrl = "http://api.imgur.com/2/upload.json"
imgurSigninUrl = "http://api.imgur.com/2/signin"

imgurFields = [Engine.TextField "key" "420de151712e1f55f03221c4939c2080"]

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

signinConfig = Engine.PasteContext {
  Engine.pcUploadLink    = imgurSigninUrl,
  Engine.pcFileTagName   = "",
  Engine.pcFileName      = "",
  Engine.pcFields        = [],
  Engine.pcEncodingType  = Engine.UrlEncoded,
  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 "imgur") where
    returnHandler Nothing = upload
    returnHandler _       = signin >> upload

-- | Retrieves cookies
signin :: Engine.PasteHandler ()
signin = do
  -- start login page
  context <- get
  config <- ask

  let loginContext = signinConfig { Engine.pcFields = Engine.pcFields context ++ completeLoginFields }
      auth = Configuration.getEngineAuth config "imgur"
      (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth
      completeLoginFields = [Engine.TextField "username" name,
                             Engine.TextField "password" password]

  response <- liftIO $ Engine.sendPostWithoutFile loginContext

  let cookies = Engine.cookiesRemoveSet response
      authorizedContext = context { Engine.pcCustomHeaders = [cookies] }
  liftIO $ msgDebug $ "cookies: " ++ show cookies

  put authorizedContext

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

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

  response <- liftIO $ Engine.sendPostWithFile context

  let link reply = irlOriginal $ iuLinks $ irUpload reply
      parseResult (J.Ok reply) = void $ put context { Engine.pcResultLink = Just $ link reply }
      parseResult _            = return ()

  parseResult ((J.decode $ rspBody response) :: J.Result ImgurReply)