1. Yuri Bochkarev
  2. imagepaste

Commits

Yuri Bochkarev  committed 02256b0

[+] add network_timeout option, ms. default value is 10000ms

  • Participants
  • Parent commits 78b1152
  • Branches default

Comments (0)

Files changed (10)

File Makefile

View file
  • Ignore whitespace
 DEBUG_TARGET=imp.debug
 RELEASE_TARGET=imp.release
 TEST_TARGET=imp.tests
-DEFINES=-DGHC
+DEFINES=
 GHC_OPTIONS=-odir ${O_DIR} -hidir ${HI_DIR} -i${SRC_DIR} -cpp ${DEFINES}
 DEBUG_OPTIONS=-prof -auto-all -rtsopts=all -DIMAGEPASTE_DEBUG
 

File README.md

View file
  • Ignore whitespace
 
 ### Configuration
 
+`network_timeout` - timeout for network operations, ms. Default value
+is 10000ms.
+
 `engine_auth` - authentication info for engines. Specify your
 name and password for the account here.
 
 Sample configuration:
 
     {
+      "network_timeout": 5000,
+
       "engine_auth": [{"engine": "rghost",
                        "username": "Peter",
                        "password": "D83FJ9z"},
 
 ### About
 
-(c) 2010, 2011 Yuri Bochkarev
+(c) 2010, 2011, 2012 Yuri Bochkarev
 

File conf/imp.conf

View file
  • Ignore whitespace
 {
+  "network_timeout": 5000,
   "http_proxy": {"url": "http://192.168.10.50:8080",
                  "username": "ivanov",
                  "password": "D3VBllp"

File imagepaste.cabal

View file
  • Ignore whitespace
   hs-source-dirs:      src
 
   Extensions:          CPP
+  cpp-options:         -DCABAL
 
 source-repository head
   type:     mercurial

File notes/features.txt

View file
  • Ignore whitespace
     [+] engine may return error (e.g. when trying to paste zip file to fastpic)
     [+] implement "try next engine on error" behavior
     [+] use System.Exit.exitWith to exit the program with error code
-    [_] handle network timeouts
+    [+] handle network timeouts
+        network_timeout option added: value in ms, default is 10000ms
     [_] add command-line options
         [_] -c config
     [+] logging
     [_] add oauth support
 
 [_] engines
-    [+] add uploadscreenshot.com (apikey=1c7688a8199888584473517828)
-    [+] add imm.io
     [_] add imageshack.us
     [_] add yfrog.com
     [-] add tinypic.com (seems to be old (2009), full of flash and with captcha)
-    [+] add imgur.com (auth, apikey=420de151712e1f55f03221c4939c2080)
-    [+] add scrin.org
     [-] add minus.com (http://minus.com/pages/api, no anonymous API access)
     [_] add yandex.fotki
     [_] add twitpic.com (http://dev.twitpic.com, apikey=a1a5b6fe0ab2f61cbf88c7cb4fc4728b)
     [_] add thumbsnap.com (http://thumbsnap.com/api/docs)
     [_] add ipic.su
 
+    [+] imgur.com (auth, apikey=420de151712e1f55f03221c4939c2080)
+    [+] scrin.org
+    [+] uploadscreenshot.com (apikey=1c7688a8199888584473517828)
+    [+] imm.io
     [+] fastpic
     [+] flashtux
     [+] imagebin
     [_] write man page
     [_] add yaourt package
     [+] add cabal package
-    [_] insert changeset to Version.hs automatically on project build
+    [+] insert changeset to Version.hs automatically on project build
         consider: $ hg id -i
+        in cabal build only (see vcs-revision package)
 
 [+] versioning policy: http://www.haskell.org/haskellwiki/Package_versioning_policy
     the project uses four digit versioing policy: A.B.C.D

File src/Configuration.hs

View file
  • Ignore whitespace
 type EngineName      = String
 
 data Configuration = Configuration {
+  cfgNetworkTimeout       :: Int,
   cfgHttpProxy            :: Maybe HttpProxy,
   cfgEngineAuths          :: [EngineAuth],
-  cfgTryNextEngineOnError :: Bool,
   cfgEnginePriority       :: [String],
-  cfgFileTypeMapping      :: [FileTypeMapping]
+  cfgFileTypeMapping      :: [FileTypeMapping],
+  cfgTryNextEngineOnError :: Bool
   } deriving (Eq, Ord, Show)
 
 --
   readJSON _ = return $ FileTypeMapping "" []
 
 dummyHttpProxy = HttpProxy "<dummy url>" (Just "noname") (Just "nopass")
+dummyNetworkTimeout = 10 * 10 ^ 6 -- 10s by default
 
 --
 -- | Configuration JSON reader
   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)
+    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 do
       Configuration
-        <$> m "http_proxy"
-        <*> mList "engine_auth"
-        <*> mBool "try_next_engine_on_error" False
-        <*> mList "engine_priority"
-        <*> mList "file_type_mapping"
+        <$> 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          = [],
-  cfgTryNextEngineOnError = True,
   cfgEnginePriority       = [],
-  cfgFileTypeMapping      = []
+  cfgFileTypeMapping      = [],
+  cfgTryNextEngineOnError = True
   }
 
 -- | Parse configuration or return dummy config if empty content is given

File src/Engine.hs

View file
  • Ignore whitespace
 import Text.HTML.TagSoup
 import Network.Browser
 import System.IO.Error
---import System.IO
 
 import qualified Data.Map as Map
 import qualified Data.List as List
 addCustomHeaders :: PasteContext -> [Header] -> PasteContext
 addCustomHeaders context newHeaders = context { Engine.pcCustomHeaders = newHeaders ++ Engine.pcCustomHeaders context }
 
---fetch :: Request String -> Bool -> Configuration.Configuration -> IO (Response String)
 fetch :: Request String -> Bool -> IO (Response String)
---fetch req redirect config = do
 fetch req redirect = do
   proxyEnv <- Proxy.getProxyFromEnvironment
   let proxy = proxyEnv
-  --let proxy = case proxy of
-  --              NoProxy -> Proxy.getProxyFromConfig config
-  --              p -> p
 
   (uri, rsp) <- browse $ do
     setAllowRedirects redirect -- handle HTTP redirects
     setOutHandler $ const (return ())
     request $ req
   return rsp
-  --getResponseBody $ Right rsp
 
 preparePostRequest :: Bool -> PasteContext -> Request String
 preparePostRequest withFile context = request where

File src/Log.hs

View file
  • Ignore whitespace
+{-# LANGUAGE CPP #-}
 module Log (msgDebug,
             msgInfo,
+            msgError,
             dumpString) where
 
 import System.IO
 msgDebug _ = return ()
 #endif
 
+msgError :: String -> IO ()
+msgError = hPutStrLn stderr
+
 msgInfo :: String -> IO ()
-msgInfo msg = putStrLn msg
+msgInfo = putStrLn
 
 dumpString :: FilePath -> String -> IO ()
 #ifdef IMAGEPASTE_DEBUG

File src/Runner.hs

View file
  • Ignore whitespace
                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)
+import Log (msgDebug, msgInfo, msgError)
 
 import qualified Configuration
 import qualified Engine
 -- | 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)
-  msgDebug $ "Trying engine: " ++ show name
-  Engine.runPasteHandler filename config state handler
+      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
 buildPriority filename priorities mappings = foldl addPriority priorities mappings where
   addPriority prs mapping =
     let engine = Configuration.ftmEngine mapping
-        types = Configuration.ftmTypes mapping
+        types  = Configuration.ftmTypes mapping
     in if any (flip List.isSuffixOf $ filename) types
        then engine:(List.delete engine prs)
        else prs
   runEngines :: [String] -> Bool -> IO (Maybe String)
   -- We were initially given an empty list of engine names
   runEngines [] _ = do
-    mapM_ msgInfo ["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"]
+    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
   engines = Map.filterWithKey (\k _ -> engine `List.isPrefixOf` k) engineConfigs
 
   selectAction []     = do
-    msgInfo $ "error: engine not found\r\nengines: " ++ Engine.engineNames engineConfigs
+    msgError $ "error: engine not found\r\nengines: " ++ Engine.engineNames engineConfigs
     return Nothing
   selectAction [name] = runEngine filename config name
   selectAction _      = do
-    msgInfo $ "error: ambiguous engine name. can be: " ++ Engine.engineNames engines
+    msgError $ "error: ambiguous engine name. can be: " ++ Engine.engineNames engines
     return Nothing
 
-runArgs _ _ = msgInfo usage >> return Nothing
+runArgs _ _ = msgError usage >> return Nothing
 
 mainRunner :: [String] -> IO (Maybe String)
 mainRunner args = do

File src/Version.hs

View file
  • Ignore whitespace
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TemplateHaskell, CPP #-}
 module Version (fullVersion) where
 
-#ifdef GHC
--- Makefile (ghc --make) build
-
-fullVersion = "0.2.0.0-alpha 119:86725ab7343e"
-
-#else
+#ifdef CABAL
 -- cabal build
 
 import Distribution.VcsRevision.Mercurial
 import Language.Haskell.TH.Syntax
 import Paths_imagepaste (version)
-import Data.Version  (showVersion)
+import Data.Version (showVersion)
 
 main = showVersion version
 
 
 fullVersion = (showVersion version) ++ " " ++ showHgVersion
 
+#else
+-- Makefile (ghc --make) build
+
+fullVersion = "0.2.0.0-alpha 119:86725ab7343e"
+
 #endif
--- GHC
+-- CABAL