imagepaste-0.2.0.0: src/EngineImm.hs

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

import qualified Text.JSON as J

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 structures according to API: http://imm.io/api/
data ImmReply = ImmReply {
  irSuccess :: Bool,
  irPayload :: Maybe ImmReplyPayload
} deriving Show

data ImmReplyPayload = ImmReplyPayload {
  irpUid    :: String,
  irpUri    :: String,
  irpLink   :: String,
  irpName   :: String,
  irpFormat :: String,
  irpExt    :: String,
  irpWidth  :: Int,
  irpHeight :: Int,
  irpSize   :: String
} deriving Show

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

dummyReply = ImmReply False Nothing

instance J.JSON ImmReply where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f = lookRead as
        m id = maybe (J.Ok Nothing) (liftM Just . J.readJSON) (lookup id as)
        mList id = maybe (J.Ok []) J.readJSON (lookup id as)
        mBool id def = maybe (J.Ok def) J.readJSON (lookup id as)
    in ImmReply <$> f "success" <*> m "payload"
    
  readJSON _ = return dummyReply

dummyReplyPayload = ImmReplyPayload "" "" "" "" "" "" 0 0 ""

instance J.JSON ImmReplyPayload where
  showJSON _ = J.JSNull
  
  readJSON (J.JSObject obj) =
    let as = J.fromJSObject obj
        f id = lookRead as id
    in ImmReplyPayload
           <$> f "uid"
           <*> f "uri"
           <*> f "link"
           <*> f "name"
           <*> f "format"
           <*> f "ext"
           <*> f "width"
           <*> f "height"
           <*> f "size"
  
  readJSON _ = return dummyReplyPayload

immUploadUrl = "http://imm.io/store/"

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

handler :: Engine.PasteHandler ()
handler = upload

upload :: Engine.PasteHandler ()
upload = do
  context <- get
  response <- liftIO $ Engine.sendPostWithFile context

  let parseResult (J.Ok reply) = parseReply (irSuccess reply) (irPayload reply)
      parseResult _ = return ()

      parseReply False _ = return ()
      parseReply True (Just payload) = do
           put context { Engine.pcResultLink = Just $ irpUri payload }
           return () in
    parseResult ((J.decode $ rspBody response) :: J.Result ImmReply)