packages feed

imagepaste (empty) → 0.2.0.0

raw patch · 24 files changed

+1832/−0 lines, 24 filesdep +HTTPdep +basedep +containerssetup-changed

Dependencies added: HTTP, base, containers, json, mtl, network, regex-posix, tagsoup, template-haskell, transformers, vcs-revision

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c)2011, Yuri Bochkarev++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Yuri Bochkarev nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ imagepaste.cabal view
@@ -0,0 +1,63 @@+Name:                imagepaste+Version:             0.2.0.0+Synopsis:            Command-line image paste utility+Description:+    Command-line utility to paste images to image hosting sites.+    Image hosting sites are internally called engines. Some engines+    support pasting not just image files but any files so with+    some engines the program can be used as a file sharing client.+Homepage:            https://bitbucket.org/balta2ar/imagepaste+License:             BSD3+License-file:        LICENSE+Author:              Yuri Bochkarev+Maintainer:          baltazar.bz@gmail.com+Category:            Network+Build-type:          Simple+Cabal-version:       >= 1.6++Executable imagepaste+  Main-is:             Main.hs+  other-modules:       Configuration,+                       EngineFastpic,+                       EngineFlashtux,+                       Engine,+                       EngineImagebin,+                       EngineImgur,+                       EngineImm,+                       EngineIpicture,+                       EngineOmpldr,+                       EngineRadikal,+                       EngineRghost,+                       EngineScrin,+                       EngineScrnsht,+                       Log,+                       Processing,+                       Proxy,+                       Runner,+                       Tests,+                       Tools,+                       Version++  Build-depends:       base >= 3 && < 5,+                       containers,+                       network,+                       mtl,+                       transformers,+                       template-haskell,++                       regex-posix,+                       tagsoup,+                       HTTP,+                       json,++                       vcs-revision+  +  hs-source-dirs:      src++  Extensions:          CPP+  cpp-options:         -DCABAL++source-repository this+  type:     mercurial+  location: https://bitbucket.org/balta2ar/imagepaste+  tag:      0.2.0.0
+ src/Configuration.hs view
@@ -0,0 +1,187 @@+module Configuration (+  readConfigFiles,+  getEngineAuth,+  configFilePaths,+  dummyConf,+  +  Configuration(..),+  EngineAuth(..),+  HttpProxy(..),+  FileTypeMapping(..)+  +  ) where++import qualified Data.Maybe as May+import qualified Data.Map as Map+import qualified Text.JSON as J+import qualified Control.Exception as C++import System.Environment (getEnvironment)+import System.IO (withFile)+import System.IO.Error (isDoesNotExistError)+import Control.Monad (liftM)+import Control.Applicative ((<$>), (<*>))+import Data.List (find, intercalate)+import Data.Maybe (fromMaybe, catMaybes)++import qualified Tools+import Log (msgDebug, msgInfo)++data HttpProxy = HttpProxy {+  hpUrl      :: String,+  hpUsername :: Maybe String,+  hpPassword :: Maybe String+  } deriving (Eq, Ord, Show)++data EngineAuth = EngineAuth {+  eaEngine   :: EngineName,+  eaName     :: String,+  eaPassword :: String+  } deriving (Eq, Ord, Show)++data FileTypeMapping = FileTypeMapping {+  ftmEngine   :: EngineName,+  ftmTypes    :: [String]+  } deriving (Eq, Ord, Show)++type FileType        = String+type EngineName      = String++data Configuration = Configuration {+  cfgNetworkTimeout       :: Int,+  cfgHttpProxy            :: Maybe HttpProxy,+  cfgEngineAuths          :: [EngineAuth],+  cfgEnginePriority       :: [String],+  cfgFileTypeMapping      :: [FileTypeMapping],+  cfgTryNextEngineOnError :: Bool+  } deriving (Eq, Ord, Show)++--+-- | Returns list of config files to read+--+configFilePaths :: IO [String]+configFilePaths = do+  env <- getEnvironment+  let base = "imp.conf"+      pathPairs = [("USERPROFILE", ""),+                   ("XDG_CONFIG_HOME", ""),+                   ("HOME", ".config")]+      xdgConfigDirs = Tools.splitOn ':' $ fromMaybe "" $ lookup "XDG_CONFIG_DIRS" env+      join = intercalate "/"+      expandPair p = case lookup (fst p) env of+        Nothing -> ""+        Just x -> if null $ snd p+                  then x+                  else join [x, snd p]+      nonEmpty = filter (not . null)+      vars = nonEmpty $ map expandPair pathPairs ++ xdgConfigDirs+      varPaths = map (\x -> join [x, "imp", base]) vars+  +  return varPaths++--+-- | Helper functions+--+mLookup a as = maybe (fail $ "No such element: " ++ a) return (lookup a as)+lookRead as id = mLookup id as  >>= J.readJSON++--+-- | HttpProxy JSON reader+--+instance J.JSON HttpProxy 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)+    in HttpProxy <$> f "url" <*> m "username" <*> m "password"++  readJSON _ = return $ HttpProxy "<url>" Nothing Nothing++--+-- | EngineAuth JSON reader+--+instance J.JSON EngineAuth where+  showJSON _ = J.JSNull+  +  readJSON (J.JSObject obj) =+    let as = J.fromJSObject obj+        f = lookRead as+    in EngineAuth <$> f "engine" <*> f "username" <*> f "password"+  +  readJSON _ = return $ EngineAuth "" "" ""++--+-- | FileTypeMapping JSON reader+--+instance J.JSON FileTypeMapping where+  showJSON _ = J.JSNull+  +  readJSON (J.JSObject obj) =+    let as = J.fromJSObject obj+        f id = lookRead as id+    in FileTypeMapping <$> f "engine" <*> f "types"+  +  readJSON _ = return $ FileTypeMapping "" []++dummyHttpProxy = HttpProxy "<dummy url>" (Just "noname") (Just "nopass")+dummyNetworkTimeout = 10 * 10 ^ 6 -- 10s by default++--+-- | Configuration JSON reader+--+instance J.JSON Configuration where+  showJSON _ = J.JSNull+  +  readJSON (J.JSObject obj) =+    let as                  = J.fromJSObject obj+        mMaybe              = mDefFun Just Nothing+        mDef def            = mDefFun id def+        mDefFun fun def idx = maybe (J.Ok def) (liftM fun . J.readJSON) (lookup idx as)+    in Configuration+         <$> mDefFun (1000 *) dummyNetworkTimeout "network_timeout"+         <*> mMaybe         "http_proxy"+         <*> mDef    []     "engine_auth"+         <*> mDef    []     "engine_priority"+         <*> mDef    []     "file_type_mapping"+         <*> mDef    False  "try_next_engine_on_error"+    +  readJSON _ = return dummyConf++dummyConf = Configuration {+  cfgNetworkTimeout       = dummyNetworkTimeout,+  cfgHttpProxy            = Nothing,+  cfgEngineAuths          = [],+  cfgEnginePriority       = [],+  cfgFileTypeMapping      = [],+  cfgTryNextEngineOnError = True+  }++-- | Parse configuration or return dummy config if empty content is given+processConfig :: Maybe String -> Maybe Configuration+processConfig Nothing = Nothing+processConfig (Just "") = Just dummyConf+processConfig (Just contents) =+  case (J.decode contents :: J.Result Configuration) of+    J.Ok conf -> Just conf+    J.Error string -> Nothing++-- | Read given path and maybe return a string with file content+-- Empty path is a special backup case -- return empty string+readConfigFile :: FilePath -> IO (Maybe String)+readConfigFile "" = return $ Just ""+readConfigFile filename = do+  msgDebug $ "Reading config: " ++ show filename+  C.catch (liftM Just $ readFile filename) (\e -> let _ = e :: C.IOException+                                                  in return Nothing)++-- | Read files by given paths until valid config is read+-- Empty filepath will cause to return default dummy valid config+readConfigFiles :: [FilePath] -> IO Configuration+readConfigFiles xs = do+  configContents <- mapM readConfigFile xs+  return $ head $ May.mapMaybe processConfig configContents++getEngineAuth :: Configuration -> String -> Maybe EngineAuth+getEngineAuth config engineName = find (\auth -> eaEngine auth == engineName) $ cfgEngineAuths config
+ src/Engine.hs view
@@ -0,0 +1,313 @@+{-# LANGUAGE TypeSynonymInstances, GeneralizedNewtypeDeriving #-}++module Engine (+  runPasteHandler,++  fetch,+  engineNames,+  sendPostWithFile,+  sendPostWithoutFile,+  preparePostRequest,+  +  addFields,+  addCustomHeaders,+  +  cookiesRemoveSet,+  mergeCookies,++  uploadAndGrabHtml,+  fetchAndGrabHtml,++  saveFirstLink,+  saveFirstLinkExtended,++  grabLocationHeader,+  grabExtractLinks,++  PasteHandler,+  PasteContext(..),+  PasteContextMap,+  InputField(..),+  InputFields,+  EncodingType(..),+  LinkFilterType(..)+  +  ) where++import Control.Monad.Reader (+  ReaderT,+  MonadReader,+  runReaderT,+  ask)++import Control.Monad.State (+  StateT,+  MonadState,+  MonadIO,+  runStateT,+  get,+  put,+  gets,+  liftIO,+  modify)++import Data.Maybe+import Network.URI+import Network.HTTP+import Network.HTTP.Headers+import Text.Regex.Posix+import Text.HTML.TagSoup+import Network.Browser+import System.IO.Error++import Control.Monad (void)++import qualified Data.Maybe as May+import qualified Data.Map as Map+import qualified Data.List as List+import qualified Network.URI as URI+import qualified Control.Monad.Reader as R++import qualified Tools+import qualified Proxy+import qualified Processing+import qualified Configuration+import Log (msgDebug, msgInfo, dumpString)++-- | Interfaces++-- PasteContext                -- mutable context, ReaderT+-- Configuration.Configuration -- immutable configuration from file, StateT+newtype PasteHandler a = PasteHandlerA {+  runPasteHandlerA :: ReaderT Configuration.Configuration (StateT PasteContext IO) a+} deriving (Monad,+            MonadIO,+            MonadReader Configuration.Configuration,+            MonadState PasteContext,+            Functor)++instance Show (PasteHandler a) where+  show _ = "PasteHandler"++data PasteContext = PasteContext {+  pcUploadLink    :: String,                  -- initial request link+  pcFileTagName   :: String,                  -- tag name of file in POST form+  pcFileName      :: String,                  -- filename in the filesystem+  pcFields        :: InputFields,             -- mandatory POST fields+  pcEncodingType  :: EncodingType,            -- type of encoding: Multipart or UrlEncoded+  pcContents      :: String,                  -- file contents+  pcResultLink    :: Maybe String,            -- link to pasted file+  pcCustomFields  :: Map.Map String String,   -- custom engine fields to pass in a handler chain+  pcAllowRedirect :: Bool,                    -- allow HTTP redirects by HTTP lib+  pcCustomHeaders :: [Header]                 -- custom HTTP request header fields+  } deriving Show++-- | Map {engineName -> pasteContext}+type PasteContextMap a = Map.Map String (PasteContext, PasteHandler a)++-- | Interface for transformation to HTML form++data EncodingType = MultipartFormData | UrlEncoded deriving Show++type InputFields = [InputField]+data InputField = TextField String String+                | EmptyFilenameField Int+                | BinaryFileField String String String+                deriving Show++class Encodable a where+  toString :: a -> EncodingType -> String++-- | Interface implementation++instance Encodable InputField where+  toString (TextField key value) MultipartFormData =+    "Content-Disposition: form-data; name=\"" ++ key ++ "\"\r\n" +++    --"Content-Type: text/plain; charset=utf-8\r\n" +++    "\r\n" +++    value ++ "\r\n"+    +  toString (TextField key value) UrlEncoded = encodeUrl key ++ "=" ++ encodeUrl value where+    encodeUrl = URI.normalizeEscape . URI.escapeURIString (\_ -> False)+  toString (EmptyFilenameField _) UrlEncoded = "<undefined>"+  toString (BinaryFileField {}) UrlEncoded = "<undefined>"++  toString (EmptyFilenameField n) MultipartFormData =+    "Content-Disposition: form-data; name=\"file" ++ show n ++ "\"; filename=\"\"\r\n" +++    "Content-Type: text/plain\r\n" +++    "\r\n" +++    "\r\n"+    +  toString (BinaryFileField name filename payload) MultipartFormData =+    "Content-Disposition: form-data; name=\"" ++ name +++    "\"; filename=\"" ++ filename ++ "\"\r\n" +++    contentType filename +++    "\r\n" +++    payload ++ "\r\n"+    +    where+      contentType name | name =~ "\\.[jJ][pP][gG]" = "Content-Type: image/jpeg\r\n"+      contentType name | name =~ "\\.[pP][nN][gG]" = "Content-Type: image/png\r\n"+      contentType name = "Content-Type: unknown\r\n"++-- | Encoding++encodeInputField :: InputField -> String -> String+encodeInputField field boundary = "\r\n" ++ toString field MultipartFormData ++ "--" ++ boundary++encodeInputFields :: [InputField] -> String -> EncodingType -> String+encodeInputFields fields boundary MultipartFormData = concat t ++ h where+  encoded = map (`encodeInputField` boundary) fields+  h = head encoded ++ "--"+  t = tail encoded++encodeInputFields fields _ UrlEncoded = List.intercalate "&" $ map encodeField fields where+  encodeField field = toString field UrlEncoded++-- | Prepares request body for sending+encodeContentWithFile :: String -> String -> String -> InputFields -> FilePath -> String+encodeContentWithFile boundary content fileFieldName fields filename =+  "--" ++ boundary ++ +  encodeInputFields (BinaryFileField fileFieldName filename content : fields) boundary MultipartFormData +++  "\r\n"++encodeContentWithoutFile :: String -> InputFields -> EncodingType -> String+encodeContentWithoutFile boundary fields encType = compound encType where+  compound MultipartFormData = "--" ++ boundary ++ body ++ "\r\n"+  compound UrlEncoded = body+  body = encodeInputFields fields boundary encType++-- | Implementation++-- | Set "Cookie" header name and merge many SetCookie: headers into single Cookie:+cookiesRemoveSet :: Response String -> Header+cookiesRemoveSet response = mergeCookies headers "; " where+  headers = retrieveHeaders HdrSetCookie response++mergeCookies :: [Header] -> String -> Header+mergeCookies cookies separator = mkHeader HdrCookie $ List.intercalate separator $ map hdrValue cookies++addFields :: PasteContext -> InputFields -> PasteContext+addFields context newFields = context { Engine.pcFields = newFields ++ Engine.pcFields context }++addCustomHeaders :: PasteContext -> [Header] -> PasteContext+addCustomHeaders context newHeaders = context { Engine.pcCustomHeaders = newHeaders ++ Engine.pcCustomHeaders context }++fetch :: Request String -> Bool -> IO (Response String)+fetch req redirect = do+  proxyEnv <- Proxy.getProxyFromEnvironment+  let proxy = proxyEnv++  (uri, rsp) <- browse $ do+    setAllowRedirects redirect -- handle HTTP redirects+    setProxy proxy+    --setDebugLog Nothing+    setOutHandler $ const $ return ()+    request req+  return rsp++preparePostRequest :: Bool -> PasteContext -> Request String+preparePostRequest withFile context = request where+  boundary = "LYNX"+  +  contentType = properContentType (pcEncodingType context) +  properContentType MultipartFormData = "multipart/form-data; boundary=" ++ boundary+  properContentType UrlEncoded = "application/x-www-form-urlencoded"++  shortName = reverse . takeWhile (\x -> x /= '/' && x /= '\\') . reverse  +  fileContent = pcContents context+  filename = shortName $ pcFileName context+  fileTagName = shortName $ pcFileTagName context+  +  encodedContent = localEncode withFile+  localEncode True = encodeContentWithFile boundary fileContent fileTagName (pcFields context) filename+  localEncode False = encodeContentWithoutFile boundary (pcFields context) (pcEncodingType context)+  +  headers = [Header HdrContentType contentType,+             Header HdrContentLength (show (length encodedContent)),+             Header HdrUserAgent "Links (2.2)",+             Header HdrConnection "Close"]+  uri = fromJust $ parseURI (pcUploadLink context)+  request = Request {rqURI = uri,+                     rqMethod = POST,+                     rqHeaders = headers ++ pcCustomHeaders context,+                     rqBody = encodedContent}++-- | Send HTTP auth form using POST+sendPostWithoutFile :: PasteContext -> IO (Response String)+sendPostWithoutFile context = sendPost context $ preparePostRequest False++sendPostWithFile :: PasteContext -> IO (Response String)+sendPostWithFile context = sendPost context $ preparePostRequest True++sendPost :: PasteContext -> (PasteContext -> Request String) -> IO (Response String)+sendPost context preparator =+  do+    msgDebug "--- sendPost ---"+    let request = preparator context+    +    msgDebug $ "request body len = " ++ show (length (rqBody request))+    dumpString "request.body.dump.bin" $ rqBody request++    response <- fetch request $ pcAllowRedirect context+    dumpString "response.html" $ rspBody response++    return response++-- | List engine names in a single string+engineNames :: PasteContextMap a -> String+engineNames engines = List.intercalate ", " $ Map.keys engines++-- | Runs handler with given configuration and state+runPasteHandler :: FilePath+                -> Configuration.Configuration+                -> PasteContext+                -> PasteHandler a+                -> IO (Maybe String)+runPasteHandler filename config state handler = Tools.withFileContents filename $ \fileContent -> do+  let newState = state { pcContents = fileContent, pcFileName = filename }+  (_, resultContext) <- runStateT (runReaderT (runPasteHandlerA handler) config) newState+  return $ pcResultLink resultContext++-- | Useful built-in helpers which solve common paste problems++data LinkFilterType = FileName | FileExtension | FileEmpty++getFilter :: PasteContext -> LinkFilterType -> String+getFilter context FileName      = Tools.fileName (pcFileName context)+getFilter context FileExtension = Tools.fileExtension (pcFileName context) ++ "$"+getFilter context FileEmpty     = ""++type Grabber = PasteContext -> Response String -> [String]++grabLocationHeader :: Grabber+grabLocationHeader _ response = May.maybeToList $ lookupHeader HdrLocation $ rspHeaders response++grabExtractLinks :: String -> String -> LinkFilterType -> Grabber+grabExtractLinks attr value flt context response =+  Processing.extractLinks (rspBody response) attr value $ getFilter context flt++-- Grabs links from page according to given field names and regexp+uploadAndGrabHtml :: Grabber -> PasteHandler [String]+uploadAndGrabHtml grab = do+  context <- get+  response <- liftIO $ sendPostWithFile context+  return $ grab context response++fetchAndGrabHtml :: String -> Bool -> Grabber -> PasteHandler [String]+fetchAndGrabHtml url redirect grab = do+  context <- get+  response <- liftIO $ fetch (getRequest url) redirect+  return $ grab context response++-- Save first link of the input as it is+saveFirstLink :: [String] -> Engine.PasteHandler ()+saveFirstLink = saveFirstLinkExtended "" ""++-- Save first link with possible prefix and postfix+saveFirstLinkExtended :: String -> String -> [String] -> Engine.PasteHandler ()+saveFirstLinkExtended prefix postfix links = do+  context <- get+  case links of+    (link:_) -> void $ put context { Engine.pcResultLink = Just $ concat [prefix, link, postfix] }+    _        -> return ()
+ src/EngineFastpic.hs view
@@ -0,0 +1,55 @@+module EngineFastpic (config, handler) where++import Data.Maybe+import Network.HTTP.Headers+import Network.HTTP+import Control.Monad.State (modify, get, put)+import Control.Monad.IO.Class (liftIO)++import qualified Data.Map as Map++import qualified Engine++fastpicUploadUrl = "http://fastpic.ru/upload"++fastpicFields = [Engine.EmptyFilenameField n | n <- [2..6]] +++                [Engine.TextField "uploading" "1",+                 Engine.TextField "check_thumb" "size",+                 Engine.TextField "thumb_text" "Uvelichit'",+                 Engine.TextField "thumb_size" "170",+                 Engine.TextField "res_select" "500",+                 Engine.TextField "orig_resize" "500",+                 Engine.TextField "orig_rotate" "0",+                 Engine.TextField "jpeg_quality" "75",+                 Engine.TextField "submit" "Zagruzit'"]++config = Engine.PasteContext {+  Engine.pcUploadLink    = fastpicUploadUrl,+  Engine.pcFileTagName   = "file1",+  Engine.pcFileName      = "",+  Engine.pcFields        = fastpicFields,+  Engine.pcEncodingType  = Engine.MultipartFormData,+  Engine.pcContents      = "",+  Engine.pcResultLink    = Nothing,+  Engine.pcCustomFields  = Map.empty,+  Engine.pcAllowRedirect = False,+  Engine.pcCustomHeaders = []+  }++-- | Parses response, downloads refresh page and parses it too+handler :: Engine.PasteHandler ()+handler = do+  context <- get+  response <- liftIO $ Engine.sendPostWithFile context+  maybe (return ()) parseRefreshPage (getRefreshLink response)++parseRefreshPage :: String -> Engine.PasteHandler ()+parseRefreshPage url = Engine.fetchAndGrabHtml url False (Engine.grabExtractLinks "input" "value" Engine.FileExtension)+                         >>= Engine.saveFirstLink++-- | Returns Refresh URL from fastpic.ru upload response+getRefreshLink :: Response String -> Maybe String+getRefreshLink response = cut where+  refresh = HdrCustom "Refresh"+  headers = getHeaders response+  cut = fmap (drop 6) (lookupHeader refresh headers)
+ src/EngineFlashtux.hs view
@@ -0,0 +1,28 @@+module EngineFlashtux (config, handler) where++import qualified Data.Map as Map++import qualified Engine++flashtuxUploadUrl = "http://img.flashtux.org/index.php"++flashtuxFields = [Engine.TextField "MAX_FILE_SIZE" "5242880",+                  Engine.TextField "postimg" "1",+                  Engine.TextField "upload" "UPLOAD!"]++config = Engine.PasteContext {+  Engine.pcUploadLink    = flashtuxUploadUrl,+  Engine.pcFileTagName   = "filename",+  Engine.pcFileName      = "",+  Engine.pcFields        = flashtuxFields,+  Engine.pcEncodingType  = Engine.MultipartFormData,+  Engine.pcContents      = "",+  Engine.pcResultLink    = Nothing,+  Engine.pcCustomFields  = Map.empty,+  Engine.pcAllowRedirect = True,+  Engine.pcCustomHeaders = []+  }++handler :: Engine.PasteHandler ()+handler = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "a" "href" Engine.FileExtension)+            >>= Engine.saveFirstLink
+ src/EngineImagebin.hs view
@@ -0,0 +1,29 @@+module EngineImagebin (config, handler) where++import qualified Data.Map as Map++import qualified Engine++imagebinUploadUrl = "http://imagebin.org/index.php"++imagebinFields = [Engine.TextField "nickname" "imp",+                  Engine.TextField "disclaimer_agree" "Y",+                  Engine.TextField "Submit" "Submit",+                  Engine.TextField "mode" "add"]++config = Engine.PasteContext {+  Engine.pcUploadLink    = imagebinUploadUrl,+  Engine.pcFileTagName   = "image",+  Engine.pcFileName      = "",+  Engine.pcFields        = imagebinFields,+  Engine.pcEncodingType  = Engine.MultipartFormData,+  Engine.pcContents      = "",+  Engine.pcResultLink    = Nothing,+  Engine.pcCustomFields  = Map.empty,+  Engine.pcAllowRedirect = True,+  Engine.pcCustomHeaders = []+  }++handler :: Engine.PasteHandler ()+handler = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "img" "src" Engine.FileEmpty)+            >>= Engine.saveFirstLinkExtended "http://imagebin.org" ""
+ src/EngineImgur.hs view
@@ -0,0 +1,193 @@+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)
+ src/EngineImm.hs view
@@ -0,0 +1,110 @@+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)
+ src/EngineIpicture.hs view
@@ -0,0 +1,26 @@+module EngineIpicture (config, handler) where++import qualified Data.Map as Map++import qualified Engine+import qualified EngineFastpic++ipictureUploadUrl = "http://ipicture.ru/Upload/"++ipictureFields = [Engine.TextField "method" "file"]++config = Engine.PasteContext {+  Engine.pcUploadLink    = ipictureUploadUrl,+  Engine.pcFileTagName   = "userfile",+  Engine.pcFileName      = "",+  Engine.pcFields        = ipictureFields,+  Engine.pcEncodingType  = Engine.MultipartFormData,+  Engine.pcContents      = "",+  Engine.pcResultLink    = Nothing,+  Engine.pcCustomFields  = Map.empty,+  Engine.pcAllowRedirect = False,+  Engine.pcCustomHeaders = []+  }++handler :: Engine.PasteHandler ()+handler = EngineFastpic.handler
+ src/EngineOmpldr.hs view
@@ -0,0 +1,24 @@+module EngineOmpldr (config, handler) where++import qualified Data.Map as Map++import qualified Engine++ompldrUploadUrl = "http://ompldr.org/upload"++config = Engine.PasteContext {+  Engine.pcUploadLink    = ompldrUploadUrl,+  Engine.pcFileTagName   = "file1",+  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 = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "a" "href" Engine.FileName)+            >>= Engine.saveFirstLinkExtended "http://ompldr.org" ""
+ src/EngineRadikal.hs view
@@ -0,0 +1,121 @@+module EngineRadikal (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 Engine+import qualified Tools+import qualified Processing+import qualified Configuration+import Log (msgDebug, msgInfo)++radikalUploadUrl = "http://radikal.ru/action.aspx"+radikalAuthUrl = "http://radikal.ru/REGISTER/PageLogin.aspx"++radikalFields = [+  Engine.TextField "upload" "yes",+  Engine.TextField "GEO_POINT_ID" "",+  Engine.TextField "URLF" "",+  Engine.TextField "" "0",+  Engine.TextField "M" "640",+  Engine.TextField "JQ" "85",+  Engine.TextField "IM" "7",+  Engine.TextField "VM" "180",+  Engine.TextField "R" "0",+  Engine.TextField "VE" "yes",+  Engine.TextField "V" "Uvelishit'",+  Engine.TextField "X" "",+  Engine.TextField "FS" ""]++authFields = [+  Engine.TextField "postpass" "yes",+  Engine.TextField "rurl" "http://www.radikal.ru/default.aspx"]++config = Engine.PasteContext {+  Engine.pcUploadLink    = radikalUploadUrl,+  Engine.pcFileTagName   = "F",+  Engine.pcFileName      = "",+  Engine.pcFields        = radikalFields,+  Engine.pcEncodingType  = Engine.MultipartFormData,+  Engine.pcContents      = "",+  Engine.pcResultLink    = Nothing,+  Engine.pcCustomFields  = Map.empty,+  Engine.pcAllowRedirect = False,+  Engine.pcCustomHeaders = []+  }++authConfig = Engine.PasteContext {+  Engine.pcUploadLink    = radikalAuthUrl,+  Engine.pcFileTagName   = "",+  Engine.pcFileName      = "",+  Engine.pcFields        = authFields,+  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 "radikal") where+    returnHandler Nothing = getLoginPage >> sendFile+    returnHandler _       = getLoginPage >> auth >> sendFile++-- | Retrieves UID and SID from login page+getLoginPage :: Engine.PasteHandler ()+getLoginPage = do+  -- start login page+  context <- get+  liftIO $ msgDebug "Getting login page..."+  loginPage <- liftIO $ Engine.fetch (getRequest radikalAuthUrl) True+  let cookies = Engine.cookiesRemoveSet loginPage+  liftIO $ msgDebug $ "cookies: " ++ show cookies+  put $ Engine.addCustomHeaders context [cookies]++auth :: Engine.PasteHandler ()+auth = do+  config <- ask+  context <- get++  -- add username and password form fields to authConfig context+  -- add cookies (UID, SID) to authConfig from the context+  let +      auth = Configuration.getEngineAuth config "radikal"+      (name, password) = maybe ("", "") (Configuration.eaName Control.Arrow.&&& Configuration.eaPassword) auth+      withFields = Engine.addFields authConfig [Engine.TextField "username" name,+                                                Engine.TextField "upassword" password]+      withCookies = Engine.addCustomHeaders withFields $ Engine.pcCustomHeaders context+  +  liftIO $ msgDebug "Sending post without file"+  liftIO $ msgDebug $ "withFields: " ++ show withFields+  liftIO $ msgDebug $ "withCookies: " ++ show withCookies+  +  -- send login request+  liftIO $ msgDebug "Sending HTTP FORM POST..."+  response <- liftIO $ Engine.sendPostWithoutFile withCookies+  +  let cookies = Engine.cookiesRemoveSet response+      newHeaders = cookies : Engine.pcCustomHeaders withCookies+      mergedCookie = Engine.mergeCookies newHeaders "; "+      authorizedContext = context { Engine.pcCustomHeaders = [mergedCookie] }++  liftIO $ msgDebug $ "newHeaders: " ++ show newHeaders+  liftIO $ msgDebug $ "newCookies: " ++ show cookies+  liftIO $ msgDebug $ "mergedCookie: " ++ show mergedCookie++  put authorizedContext+  +sendFile :: Engine.PasteHandler ()+sendFile = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "input" "value" Engine.FileExtension)+             >>= Engine.saveFirstLink
+ src/EngineRghost.hs view
@@ -0,0 +1,148 @@+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
+ src/EngineScrin.hs view
@@ -0,0 +1,68 @@+module EngineScrin (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 Data.Map as Map+import qualified Data.List as List++import qualified Engine+import qualified Tools+import qualified Processing+import qualified Configuration+import Log (msgDebug, msgInfo)++scrinUploadUrl = "http://scrin.org/"++scrinFields = [+  Engine.TextField "resize_x" "",+  Engine.TextField "resize_y" "",+  Engine.TextField "thumb-sets" "none",+  Engine.TextField "thumb-size-h" "100",+  Engine.TextField "thumb-size-w" "100",+  Engine.TextField "x" "",+  Engine.TextField "y" ""]++config = Engine.PasteContext {+  Engine.pcUploadLink    = scrinUploadUrl,+  Engine.pcFileTagName   = "fileup[]",+  Engine.pcFileName      = "",+  Engine.pcFields        = scrinFields,+  Engine.pcEncodingType  = Engine.MultipartFormData,+  Engine.pcContents      = "",+  Engine.pcResultLink    = Nothing,+  Engine.pcCustomFields  = Map.empty,+  Engine.pcAllowRedirect = False,+  Engine.pcCustomHeaders = []+  }++handler :: Engine.PasteHandler ()+handler = getPostkeyAndCookies >> sendFile++-- | Retrieves Cookies and Postkey from login page+getPostkeyAndCookies :: Engine.PasteHandler ()+getPostkeyAndCookies = do+  -- start login page+  context <- get+  liftIO $ msgDebug "Getting start page..."+  startPage <- liftIO $ Engine.fetch (getRequest scrinUploadUrl) True+  let cookies = Engine.cookiesRemoveSet startPage+  liftIO $ msgDebug $ "cookies: " ++ show cookies+  put $ Engine.addCustomHeaders context [cookies]++  let mPostkey = Processing.extractLink (rspBody startPage) "input" "value" ""+  liftIO $ msgDebug $ "postkey: " ++ show mPostkey++  let postkey = fromMaybe "" mPostkey+      fields = Engine.pcFields context+      newContext = context { Engine.pcFields = Engine.TextField "postkey" postkey : fields }++  put newContext++sendFile :: Engine.PasteHandler ()+sendFile = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "input" "value" Engine.FileExtension)+             >>= (Engine.saveFirstLink . reverse)
+ src/EngineScrnsht.hs view
@@ -0,0 +1,98 @@+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 }+
+ src/Log.hs view
@@ -0,0 +1,30 @@+{-# LANGUAGE CPP #-}+module Log (msgDebug,+            msgInfo,+            msgError,+            dumpString) where++import System.IO++msgDebug :: String -> IO ()+#ifdef IMAGEPASTE_DEBUG+msgDebug msg = putStrLn $ "DEBUG: " ++ msg+#else+msgDebug _ = return ()+#endif++msgError :: String -> IO ()+msgError = hPutStrLn stderr++msgInfo :: String -> IO ()+msgInfo = putStrLn++dumpString :: FilePath -> String -> IO ()+#ifdef IMAGEPASTE_DEBUG+dumpString file str = do+  h1 <- openBinaryFile file WriteMode+  hPutStr h1 str+  hClose h1+#else+dumpString _ _ = return ()+#endif
+ src/Main.hs view
@@ -0,0 +1,20 @@+--+-- Simple image paster+-- Uploads given image file to image hosting site+--+-- (c) 2010, 2011 Yuri baltazar Bochkarev+--++import System.IO+import System.Exit+import System.Environment++import qualified Runner++main :: IO ()+main = do+  args <- getArgs+  result <- Runner.mainRunner args+  case result of+    Nothing -> exitFailure+    Just link -> putStrLn link >> exitSuccess
+ src/Processing.hs view
@@ -0,0 +1,32 @@+module Processing (getAttrs,+                   extractLink,+                   extractLinks) where++import Text.HTML.TagSoup+import Text.Regex.Posix+import Data.Maybe++-- | Implementation++getAttrs :: [Tag String] -> String -> String -> [String]+getAttrs tags tagName attrName = mapMaybe link tags+  where+    firstAttr [] = Nothing+    firstAttr ((n, v):as) | n == attrName = Just v+                          | otherwise = firstAttr as+    link (TagOpen tag attrs) | tag == tagName = firstAttr attrs+    link _ = Nothing++extractLinks :: String -> String -> String -> String -> [String]+extractLinks r tag attr regexp =+  let tags = parseTags r :: [Tag String]+      links = getAttrs tags tag attr+      isPicture x = (x =~ regexp) --(x =~ "\\.jpg$") || (x =~ "\\.png$")+      isPictureUrl x = (isPicture x) --(&&) (isURI x) (True) --(isPicture x)+      urls = filter isPictureUrl links+  in urls++extractLink :: String -> String -> String -> String -> Maybe String+extractLink r tag attr regexp = passUrl (extractLinks r tag attr regexp) where+  passUrl [] = Nothing+  passUrl (x:_) = Just x
+ src/Proxy.hs view
@@ -0,0 +1,27 @@+module Proxy (getProxyFromEnvironment,+              getProxyFromConfig) where++import System.Environment+import Network.Browser+import System.IO.Error+import Network.URI (parseURI, nullURI)+import Data.Maybe (fromMaybe)++import qualified Control.Exception as C+import qualified Configuration++getProxyFromEnvironment :: IO Proxy+getProxyFromEnvironment = do+  proxy <- C.try (getEnv "HTTP_PROXY") :: IO (Either C.IOException String)+  case proxy of+    Left _ -> return NoProxy+    Right p -> return $ Proxy p Nothing++getProxyFromConfig :: Configuration.Configuration -> Proxy+getProxyFromConfig config = case Configuration.cfgHttpProxy config of+  Nothing -> NoProxy+  Just proxy -> let address = Configuration.hpUrl proxy+                    name = fromMaybe "" $ Configuration.hpUsername proxy+                    pass = fromMaybe "" $ Configuration.hpPassword proxy+                    auth = AuthBasic "" name pass $ fromMaybe nullURI (parseURI address)+                in Proxy address (Just auth)
+ src/Runner.hs view
@@ -0,0 +1,137 @@+module Runner (mainRunner,+               runArgs,+               defaultPriority) where++import System.Timeout++import qualified Data.Map as Map+import qualified Data.List as List+import qualified Data.Maybe (maybe)++import qualified Version+import Log (msgDebug, msgInfo, msgError)++import qualified Configuration+import qualified Engine+import qualified EngineFastpic+import qualified EngineRghost+import qualified EngineRadikal+import qualified EngineIpicture+import qualified EngineOmpldr+import qualified EngineFlashtux+import qualified EngineImagebin+import qualified EngineImm+import qualified EngineScrin+import qualified EngineScrnsht+import qualified EngineImgur++engineConfigs = Map.fromList [+    ("fastpic",  (EngineFastpic.config,  EngineFastpic.handler)),+    ("rghost",   (EngineRghost.config,   EngineRghost.handler)),+    ("ipicture", (EngineIpicture.config, EngineIpicture.handler)),+    ("ompldr",   (EngineOmpldr.config,   EngineOmpldr.handler)),+    ("flashtux", (EngineFlashtux.config, EngineFlashtux.handler)),+    ("imagebin", (EngineImagebin.config, EngineImagebin.handler)),+    ("radikal",  (EngineRadikal.config,  EngineRadikal.handler)),+    ("scrnsht",  (EngineScrnsht.config,  EngineScrnsht.handler)),+    ("scrin",    (EngineScrin.config,    EngineScrin.handler)),+    ("imgur",    (EngineImgur.config,    EngineImgur.handler)),+    ("imm",      (EngineImm.config,      EngineImm.handler))]++usage :: String+usage = "imp v" ++ Version.fullVersion+        ++ "\r\nusage: program [engine] <image-file>\r\nengines: "+        ++ Engine.engineNames engineConfigs++-- | Check the config for inappropriate values and fill them with valid ones+fillConfig :: Configuration.Configuration -> Configuration.Configuration+fillConfig oldConfig = oldConfig { Configuration.cfgEnginePriority = priority } where+  priority = if Configuration.cfgEnginePriority oldConfig == []+             then Map.keys engineConfigs+             else Configuration.cfgEnginePriority oldConfig++-- | Run engine with given name+runEngine :: FilePath -> Configuration.Configuration -> String -> IO (Maybe String)+runEngine filename config name = do+  msgDebug $ "Trying engine: " ++ show name+  let (state, handler) = engineConfigs Map.! name+      runner           = Engine.runPasteHandler filename config state handler+      timeoutMus       = Configuration.cfgNetworkTimeout config+      timeoutMs        = timeoutMus `div` 1000+  result <- timeout timeoutMus runner+  case result of+    Nothing -> do+      msgError $ "error: Network timeout (" ++ name ++ ", " ++ show timeoutMs ++ "ms)"+      return Nothing   -- timeout+    Just x -> return x -- ok, but there might be internal errors++defaultPriority :: [String]+defaultPriority = Map.keys engineConfigs++-- | Mixes given engine names from priorities and file type mapping.+-- Names from the mapping are pushed to the head of the resulting list+buildPriority :: String -> [String] -> [Configuration.FileTypeMapping] -> [String]+buildPriority filename = foldl addPriority where+  addPriority priorities mapping =+    let engine = Configuration.ftmEngine mapping+        types  = Configuration.ftmTypes mapping+    in if any (`List.isSuffixOf` filename) types+       then engine : List.delete engine priorities+       else priorities++runArgs :: [String] -> Configuration.Configuration -> IO (Maybe String)++-- | Run all available engines in an order affected by+-- engine_priority and file_type_mapping properties+runArgs (filename:[]) config = runEngines priorities (Configuration.cfgTryNextEngineOnError config) where+  configPlusDefaultPriorities = List.nub $ Configuration.cfgEnginePriority config ++ defaultPriority++  priorities :: [String]+  priorities = buildPriority filename configPlusDefaultPriorities (Configuration.cfgFileTypeMapping config)++  runEngines :: [String] -> Bool -> IO (Maybe String)+  -- We were initially given an empty list of engine names+  runEngines [] _ = do+    mapM_ msgError ["error: Cannot select engine. Possible reasons:",+                    "- could not read any of config files",+                    "- engine priority in config file list is empty",+                    "- none of the file type mappings matches the filename suffix",+                    "- missing explicit engine name in commnad-line arguments"]+    return Nothing++  runEngines (name:_) False = runEngine filename config name -- run only first engine+  runEngines names tryNext  = runNextEngine names tryNext    -- run all the engines++  runNextEngine :: [String] -> Bool -> IO (Maybe String)+  runNextEngine [] _ = return Nothing+  runNextEngine (name:rest) tryNext = do+    result <- runEngine filename config name+    maybe (runNextEngine rest tryNext) (return . Just) result++-- | Run only specified engine and do not try others on error+runArgs (engine:filename:[]) config = selectAction names where+  names = Map.keys engines+  engines = Map.filterWithKey (\k _ -> engine `List.isPrefixOf` k) engineConfigs++  selectAction []     = do+    msgError $ "error: engine not found\r\nengines: " ++ Engine.engineNames engineConfigs+    return Nothing+  selectAction [name] = runEngine filename config name+  selectAction _      = do+    msgError $ "error: ambiguous engine name. can be: " ++ Engine.engineNames engines+    return Nothing++runArgs _ _ = msgError usage >> return Nothing++mainRunner :: [String] -> IO (Maybe String)+mainRunner args = do+  configPaths <- Configuration.configFilePaths+  msgDebug $ "configPaths: " ++ show configPaths+  -- "" will return dummy empty config if no configs will be found+  config <- Configuration.readConfigFiles $ configPaths ++ [""]+  let filledConfig = fillConfig config++  msgDebug "=== imp.conf ==="+  msgDebug $ show filledConfig++  runArgs args filledConfig
+ src/Tests.hs view
@@ -0,0 +1,31 @@+import Test.HUnit+import Data.Maybe++import qualified Runner+import qualified Configuration++samplesPath = "tests/samples/"++imageFiles = ["hello.jpg", "pixel.jpg", "cat.jpg", "cubes.png", "diablo.png"]+zipFiles = ["gtk3.zip"]++allEngines = Runner.defaultPriority+fileEngines = ["rghost", "ompldr"]++testEngineOnFile :: String -> String -> Configuration.Configuration -> IO ()+testEngineOnFile engine file config = do+  result <- Runner.runArgs [engine, samplesPath ++ file] config+  assertBool ("test_" ++ show engine ++ "_" ++ show file) (isJust result)++makeTestLabel file engine = TestLabel+                            ("test_" ++ engine ++ "_" ++ file)+                            (TestCase (testEngineOnFile engine file Configuration.dummyConf))++genLabels files engines = [makeTestLabel f e | f <- files, e <- engines]++tests = TestList $ genLabels imageFiles allEngines ++ genLabels zipFiles fileEngines++main :: IO ()+main = do+  foo <- runTestTT tests+  return ()
+ src/Tools.hs view
@@ -0,0 +1,27 @@+module Tools (fileName,+              fileExtension,+              splitOn,+              withFileContents) where++import System.IO++fileName :: String -> String+fileName = reverse . takeWhile (/= '/') . reverse++fileExtension :: String -> String+fileExtension = reverse . takeWhile (/= '.') . reverse . fileName++splitOn :: Char -> String -> [String]+splitOn delim s = case dropWhile (== delim) s of+  "" -> []+  s' -> w : splitOn delim s''+        where (w, s'') = break (== delim) s'++withFileContents :: FilePath -> (String -> IO a) -> IO a+withFileContents filename handler = do+  h1 <- openBinaryFile filename ReadMode+  fileContent <- hGetContents h1++  result <- handler fileContent+  hClose h1+  return result
+ src/Version.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE CPP #-}+module Version (fullVersion) where++#ifdef CABAL+-- cabal build++import Distribution.VcsRevision.Mercurial+import Language.Haskell.TH.Syntax+import Paths_imagepaste (version)+import Data.Version (showVersion)++main = showVersion version++showHgVersion :: String+showHgVersion = $(do+    v <- qRunIO getRevision+    lift $ case v of+        Nothing            -> "<none>"+        Just (hash, True)  -> hash ++ " (with local modifications)"+        Just (hash, False) -> hash)+++-- | Version++fullVersion = (showVersion version) ++ " " ++ showHgVersion++#else+-- Makefile (ghc --make) build++fullVersion = "0.2.0.0-alpha 119:86725ab7343e"++#endif+-- CABAL