Commits

Yuri Bochkarev committed 071a348

+ added imm.io engine support

Comments (0)

Files changed (4)

notes/features.txt

         [+] add Log module with msgDebug, msgInfo functions
 
 [_] engines
-    [_] add imm.io
+    [+] add imm.io
     [_] add imageshack.us
     [_] add yfrog.com
     [_] add tinypic.com
     [_] write man page
     [_] add yaourt package
     [+] add cabal package
+    [_] insert changeset to Version.hs automatically on project build
+        consider: $ hg id -i
 
+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.HTML.TagSoup as TS
+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 id = lookRead as id
+        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 do
+      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)
 import qualified EngineOmpldr
 import qualified EngineFlashtux
 import qualified EngineImagebin
+import qualified EngineImm
 
 engineConfigs = Map.fromList [("fastpic",  (EngineFastpic.config,  EngineFastpic.handler)),
                               ("rghost",   (EngineRghost.config,   EngineRghost.handler)),
                               ("ompldr",   (EngineOmpldr.config,   EngineOmpldr.handler)),
                               ("flashtux", (EngineFlashtux.config, EngineFlashtux.handler)),
                               ("imagebin", (EngineImagebin.config, EngineImagebin.handler)),
-                              ("radikal",  (EngineRadikal.config,  EngineRadikal.handler))]
+                              ("radikal",  (EngineRadikal.config,  EngineRadikal.handler)),
+                              ("imm",      (EngineImm.config,      EngineImm.handler))]
 
 usage :: String
 usage = "imp v" ++ Version.version ++ " (changeset " ++ Version.changeset ++ ")"
 
 -- | Version
 
-version = "0.1.0"
+version = "0.2.0-alpha"
 changeset = "76a1f42e28a4+"