Commits

Yuri Bochkarev committed 3c3bbb0

+ added release target to Makefile
+ added logging facilities: msgDebug, msgInfo, dumpString
+ added conditional compilation: debug messages won't appear in release build

Comments (0)

Files changed (11)

 O_DIR=obj
 SRC_DIR=src
 BIN_DIR=bin
-TARGET=timp
+DEBUG_TARGET=imp.debug
+RELEASE_TARGET=imp.release
 TEST_TARGET=tests
-GHC_OPTIONS=-odir ${O_DIR} -hidir ${HI_DIR} -i${SRC_DIR}
-DEBUG_OPTIONS=-prof -auto-all -rtsopts=all
+GHC_OPTIONS=-odir ${O_DIR} -hidir ${HI_DIR} -i${SRC_DIR} -cpp
+DEBUG_OPTIONS=-prof -auto-all -rtsopts=all -DIMAGEPASTE_DEBUG
 
-all: debug
+all: debug release
 
 debug:
-	ghc --make ${DEBUG_OPTIONS} ${GHC_OPTIONS} ${SRC_DIR}/Main.hs -o ${BIN_DIR}/${TARGET}
+	ghc --make ${DEBUG_OPTIONS} ${GHC_OPTIONS} ${SRC_DIR}/Main.hs -o ${BIN_DIR}/${DEBUG_TARGET}
+
+release:
+	ghc --make ${GHC_OPTIONS} ${SRC_DIR}/Main.hs -o ${BIN_DIR}/${RELEASE_TARGET}
 
 clean:
 	rm -f ${HI_DIR}/*.hi
 	rm -f ${O_DIR}/*.o
-	rm -f ${BIN_DIR}/${TARGET}
+	rm -f ${BIN_DIR}/${DEBUG_TARGET}
+	rm -f ${BIN_DIR}/${RELEASE_TARGET}
+	rm -f ${BIN_DIR}/${TEST_TARGET}
 
 check:
 	#cd src
 Synopsis:            Command-line image paste utility
 
 -- A longer description of the package.
--- Description:         
+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.
 
 -- URL for the project homepage or repository.
 Homepage:            https://bitbucket.org/balta2ar/imagepaste
   -- Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.
   -- Build-tools:         
   
+  Extensions:          CPP

notes/features.txt

     [_] handle network timeouts
     [_] add command-line options
         [_] -c config
+    [+] logging
+        [+] add Log module with msgDebug, msgInfo functions
 
 [_] engines
     [_] add imm.io
     [_] add imageshack.us
     [_] add yfrog.com
     [_] add tinypic.com
+    [_] add imgur.com
 
 [+] configuration
     [_] read HTTP proxy info from config

src/Configuration.hs

 import Data.Maybe (fromMaybe, catMaybes)
 
 import qualified Tools
+import Log (msgDebug, msgInfo)
 
 data HttpProxy = HttpProxy {
   hpUrl      :: String,
 readConfigFile :: FilePath -> IO (Maybe String)
 readConfigFile "" = return $ Just ""
 readConfigFile filename = do
-  putStrLn $ "Reading config: " ++ show filename
+  msgDebug $ "Reading config: " ++ show filename
   catch (liftM Just $ readFile filename) (\_ -> return Nothing)
 
 -- | Read files by given paths until valid config is read
 import Text.HTML.TagSoup
 import Network.Browser
 import System.IO.Error
-import System.IO
+--import System.IO
 
 import qualified Data.Map as Map
 import qualified Data.List as List
 import qualified Tools
 import qualified Proxy
 import qualified Configuration
+import Log (msgDebug, msgInfo, dumpString)
 
 -- | Interfaces
 
   do
     --let h = pcHandler context
     --return context >>= h
-    putStrLn "--- sendPost ---"
-    --putStrLn $ show request
-    --putStrLn encodedContent
+    msgDebug "--- sendPost ---"
+    --msgDebug $ show request
+    --msgDebug encodedContent
     let request = preparator context
-    --putStrLn ">>>>> request >>>>>"
-    --putStrLn $ show request
+    --msgDebug ">>>>> request >>>>>"
+    --msgDebug $ show request
     
-    --putStrLn ">>>>> request body >>>>>"
-    --putStrLn $ show $ rqBody request
-    putStrLn $ "request body len = " ++ (show (length (rqBody request)))
-    
-    h1 <- openBinaryFile "request.body.dump.bin" WriteMode
-    hPutStr h1 $ rqBody request
-    hClose h1
+    --msgDebug ">>>>> request body >>>>>"
+    --msgDebug $ show $ rqBody request
+    msgDebug $ "request body len = " ++ (show (length (rqBody request)))
+    dumpString "request.body.dump.bin" $ rqBody request
 
     response <- fetch request $ pcAllowRedirect context -- simpleHTTP request
     
-    --putStrLn "<<<<< response body <<<<<"
-    --putStrLn $ show $ rspBody response
-    --putStrLn $ show response
-    
-    h2 <- openBinaryFile "response.html" WriteMode
-    hPutStr h2 $ rspBody response
-    hClose h2
+    --msgDebug "<<<<< response body <<<<<"
+    --msgDebug $ show $ rspBody response
+    --msgDebug $ show response
+
+    dumpString "response.html" $ rspBody response
     
     --picUrl <- (ecHandler config) response filename
-    --putStrLn picUrl
+    --msgDebug picUrl
     return response
 
 -- | List engine names in a single string
 engineNames :: PasteContextMap a -> String
 engineNames engines = List.intercalate ", " $ Map.keys engines
 
-withFileContents :: FilePath -> (String -> IO a) -> IO a
-withFileContents filename handler = do
-  h1 <- openBinaryFile filename ReadMode
-  fileContent <- hGetContents h1
-
-  --putStrLn $ "=== contents === of " ++ show filename
-  --putStrLn $ show fileContent
-
-  result <- handler fileContent
-  hClose h1
-  return result
-
 -- | Runs handler with given configuration and state
 runPasteHandler :: FilePath
                 -> Configuration.Configuration
                 -> PasteContext
                 -> PasteHandler a
                 -> IO (Maybe String)
-runPasteHandler filename config state handler = withFileContents filename $ \fileContent -> do
+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

src/EngineRadikal.hs

 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"
 getLoginPage = do
   -- start login page
   context <- get
-  liftIO $ putStrLn "Getting login page..."
+  liftIO $ msgDebug "Getting login page..."
   loginPage <- liftIO $ Engine.fetch (getRequest radikalAuthUrl) True
   let cookies = Engine.cookiesRemoveSet loginPage
-  liftIO $ putStrLn $ "cookies: " ++ show cookies
+  liftIO $ msgDebug $ "cookies: " ++ show cookies
   put $ Engine.addCustomHeaders context [cookies]
 
 auth :: Engine.PasteHandler ()
                                                 (Engine.TextField "upassword" password)]
       withCookies = Engine.addCustomHeaders withFields $ Engine.pcCustomHeaders context
   
-  liftIO $ putStrLn "Sending post without file"
-  liftIO $ putStrLn $ "withFields: " ++ show withFields
-  liftIO $ putStrLn $ "withCookies: " ++ show withCookies
+  liftIO $ msgDebug "Sending post without file"
+  liftIO $ msgDebug $ "withFields: " ++ show withFields
+  liftIO $ msgDebug $ "withCookies: " ++ show withCookies
   
   -- send login request
-  liftIO $ putStrLn "Sending HTTP FORM POST..."
+  liftIO $ msgDebug "Sending HTTP FORM POST..."
   response <- liftIO $ Engine.sendPostWithoutFile withCookies
   
   let cookies = Engine.cookiesRemoveSet response
       mergedCookie = Engine.mergeCookies newHeaders "; "
       authorizedContext = context { Engine.pcCustomHeaders = [mergedCookie] }
 
-  liftIO $ putStrLn $ "newHeaders: " ++ show newHeaders
-  liftIO $ putStrLn $ "newCookies: " ++ show cookies
-  liftIO $ putStrLn $ "mergedCookie: " ++ show mergedCookie
+  liftIO $ msgDebug $ "newHeaders: " ++ show newHeaders
+  liftIO $ msgDebug $ "newCookies: " ++ show cookies
+  liftIO $ msgDebug $ "mergedCookie: " ++ show mergedCookie
 
   put authorizedContext
   
 sendFile = do
   context <- get
 
-  liftIO $ putStrLn "Sending post with file"
-  liftIO $ putStrLn $ show context
+  liftIO $ msgDebug "Sending post with file"
+  liftIO $ msgDebug $ show context
 
   response <- liftIO $ Engine.sendPostWithFile context
   link <- liftIO $ Processing.extractLinks response "img" "src" $ Tools.fileExtension (Engine.pcFileName context) ++ "$"

src/EngineRghost.hs

 import qualified Processing
 import qualified Tools
 import qualified Configuration
+import Log (msgDebug, msgInfo)
 
 data RghostPair = RghostPair {
   rpAuth :: String,
   readJSON _ = return RghostPair { rpAuth = "", rpUrl = "" }
 
 rghostUploadUrl = "http://phonon.rghost.net/files"
---rghostUploadUrl = "http://rghost.net/multiple/upload_host"
 rghostLoginUrl = "http://rghost.net/profile/login"
 
 config = Engine.PasteContext {
 getAuthToken :: Engine.PasteHandler ()
 getAuthToken = do
   respStartPage <- liftIO $ Engine.fetch (getRequest "http://rghost.net/multiple/upload_host") True
-  --putStrLn "<<<<< response start page <<<<<"
-  --putStrLn $ show respStartPage
+  --msgDebug "<<<<< response start page <<<<<"
+  --msgDebug $ show respStartPage
   
-  --putStrLn "<<<<< response body <<<<<<"
-  --putStrLn $ show $ rspBody respStartPage
+  --msgDebug "<<<<< response body <<<<<<"
+  --msgDebug $ show $ rspBody respStartPage
   
   let text = rspBody respStartPage
       result = ((decode text) :: Result RghostPair)
       pair = (\(Ok x) -> x) result
-  --putStrLn $ show pair
+  --msgDebug $ show pair
   
   let cookie = case lookupHeader HdrSetCookie $ rspHeaders respStartPage of
         Just h -> takeWhile (/= ';') h
         Nothing -> "<no cookies>"
   
-  liftIO $ putStrLn "=== cookies ==="
-  liftIO $ putStrLn $ show cookie
+  liftIO $ msgDebug "=== cookies ==="
+  liftIO $ msgDebug $ show cookie
       
   --let customHeaders = [Header HdrCookie cookie, Header HdrHost (rpUrl pair)]
   --modify $ \ctx -> ctx { Engine.pcFields = (Engine.TextField "authenticity_token" (rpAuth pair)) : (Engine.pcFields ctx),
 
   context <- get
 
-  liftIO $ putStrLn $ "filename = " ++ (show $ Engine.pcFileName context)
-  --liftIO $ putStrLn $ "contents = " ++ (show $ Engine.pcContents context)
+  liftIO $ msgDebug $ "filename = " ++ (show $ Engine.pcFileName context)
+  --liftIO $ msgDebug $ "contents = " ++ (show $ Engine.pcContents context)
 
   let newContext = context { Engine.pcFields = (Engine.TextField "authenticity_token" (rpAuth pair)) : fields,
                              Engine.pcCustomHeaders = customHeaders ++ headers,
 
   put newContext
 
-  --putStrLn "=== getAuthToken: newContext ==="
-  --putStrLn $ show newContext
+  --msgDebug "=== getAuthToken: newContext ==="
+  --msgDebug $ show newContext
   
   --return newContext
   
       mainHost = [mkHeader HdrHost "rghost.net"]
         --lookupHeader HdrHost $ Engine.pcCustomHeaders context
 
-  --liftIO $ putStrLn "=== loginContext ==="
-  --liftIO $ putStrLn $ show loginContext
+  --liftIO $ msgDebug "=== loginContext ==="
+  --liftIO $ msgDebug $ show loginContext
   
   response <- liftIO $ Engine.sendPostWithoutFile loginContext
   
       --authorizedContext = context { Engine.pcCustomHeaders = [mergedCookie] }
       authorizedContext = context { Engine.pcCustomHeaders = newHeaders }
       
-  liftIO $ putStrLn "=== prevHost ==="
-  liftIO $ putStrLn $ show prevHost
+  liftIO $ msgDebug "=== prevHost ==="
+  liftIO $ msgDebug $ show prevHost
 
-  liftIO $ putStrLn "=== prevCookies ==="
-  liftIO $ putStrLn $ show prevCookie
+  liftIO $ msgDebug "=== prevCookies ==="
+  liftIO $ msgDebug $ show prevCookie
   
-  liftIO $ putStrLn "=== login cookies ==="
-  liftIO $ putStrLn $ show cookies
+  liftIO $ msgDebug "=== login cookies ==="
+  liftIO $ msgDebug $ show cookies
   
-  liftIO $ putStrLn "=== newHeaders ==="
-  liftIO $ putStrLn $ show newHeaders
+  liftIO $ msgDebug "=== newHeaders ==="
+  liftIO $ msgDebug $ show newHeaders
   
-  --liftIO $ putStrLn "=== authorizedContext ==="
-  --liftIO $ putStrLn $ show authorizedContext
+  --liftIO $ msgDebug "=== authorizedContext ==="
+  --liftIO $ msgDebug $ show authorizedContext
 
   put authorizedContext
   --return authorizedContext
 
 upload :: Engine.PasteHandler ()
 upload = do
-  --putStrLn "=== Fields ==="
-  --putStrLn $ show $ Engine.pcFields context
+  --msgDebug "=== Fields ==="
+  --msgDebug $ show $ Engine.pcFields context
 
   context <- get
   response <- liftIO $ Engine.sendPostWithFile context
 
-  liftIO $ putStrLn $ "filename = " ++ (show $ Engine.pcFileName context)
-  --liftIO $ putStrLn $ "contents = " ++ (show $ Engine.pcContents context)
+  liftIO $ msgDebug $ "filename = " ++ (show $ Engine.pcFileName context)
+  --liftIO $ msgDebug $ "contents = " ++ (show $ Engine.pcContents context)
   
-  --putStrLn "<<<<< response <<<<<"
-  --putStrLn $ show response
+  --msgDebug "<<<<< response <<<<<"
+  --msgDebug $ show response
   
-  --putStrLn $ show $ lookupHeader HdrLocation $ rspHeaders response
+  --msgDebug $ show $ lookupHeader HdrLocation $ rspHeaders response
 
   let link = lookupHeader HdrLocation $ rspHeaders response
   case link of
+module Log (msgDebug,
+            msgInfo,
+            dumpString) where
+
+import System.IO
+
+msgDebug :: String -> IO ()
+#ifdef IMAGEPASTE_DEBUG
+msgDebug msg = putStrLn $ "DEBUG: " ++ msg
+#else
+msgDebug _ = return ()
+#endif
+
+msgInfo :: String -> IO ()
+msgInfo msg = putStrLn msg
+
+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/Processing.hs

 
 extractLinks :: Response String -> String -> String -> String -> IO (Maybe String)
 extractLinks r tag attr regexp = do
-  --putStrLn $ rspBody r
   let tags = parseTags (rspBody r) :: [Tag String]
       links = getAttrs tags tag attr
       isPicture x = (x =~ regexp) --(x =~ "\\.jpg$") || (x =~ "\\.png$")
 import qualified Maybe (maybe)
 
 import qualified Version
+import Log (msgDebug, msgInfo)
 
 import qualified Configuration
 import qualified Engine
 runEngine :: FilePath -> Configuration.Configuration -> String -> IO (Maybe String)
 runEngine filename config name = do
   let (state, handler) = (engineConfigs Map.! name)
-  putStrLn $ "Trying engine: " ++ show name
+  msgDebug $ "Trying engine: " ++ show name
   Engine.runPasteHandler filename config state handler
 
 defaultPriority :: [String]
   runEngines :: [String] -> Bool -> IO (Maybe String)
   -- We were initially given an empty list of engine names
   runEngines [] _ = do
-    mapM_ putStrLn ["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_ 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"]
     return Nothing
 
   runEngines (name:_) False = runEngine filename config name -- run only first engine
   engines = Map.filterWithKey (\k _ -> engine `List.isInfixOf` k) engineConfigs
 
   selectAction []     = do
-    putStrLn $ "error: engine not found\r\nengines: " ++ Engine.engineNames engineConfigs
+    msgInfo $ "error: engine not found\r\nengines: " ++ Engine.engineNames engineConfigs
     return Nothing
   selectAction [name] = runEngine filename config name
   selectAction _      = do
-    putStrLn $ "error: ambiguous engine name. can be: " ++ Engine.engineNames engines
+    msgInfo $ "error: ambiguous engine name. can be: " ++ Engine.engineNames engines
     return Nothing
 
-runArgs _ _ = putStrLn usage >> return Nothing
+runArgs _ _ = msgInfo usage >> return Nothing
 
 mainRunner :: [String] -> IO (Maybe String)
 mainRunner args = do
   configPaths <- Configuration.configFilePaths
-  putStrLn $ "configPaths: " ++ show configPaths
+  msgDebug $ "configPaths: " ++ show configPaths
   -- "" will return dummy empty config if no configs will be found
   config <- Configuration.readConfigFiles $ configPaths ++ [""]
   let filledConfig = fillConfig config
 
-  putStrLn "=== imp.conf ==="
-  putStrLn $ show filledConfig
+  msgDebug "=== imp.conf ==="
+  msgDebug $ show filledConfig
 
   runArgs args filledConfig
 module Tools (fileName,
               fileExtension,
-              splitOn) where
+              splitOn,
+              withFileContents) where
+
+import System.IO
 
 fileName :: String -> String
 fileName = reverse . (takeWhile (/= '/')) . reverse
   "" -> []
   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
+
+  --msgDebug $ "=== contents === of " ++ show filename
+  --msgDebug $ show fileContent
+
+  result <- handler fileContent
+  hClose h1
+  return result
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.