1. Yuri Bochkarev
  2. imagepaste

Commits

Yuri Bochkarev  committed 763778d

* more code refactoring

  • Participants
  • Parent commits 3342ef5
  • Branches default

Comments (0)

Files changed (10)

File notes/features.txt

View file
     [_] insert changeset to Version.hs automatically on project build
         consider: $ hg id -i
 
-[_] versioning policy: http://www.haskell.org/haskellwiki/Package_versioning_policy
+[+] versioning policy: http://www.haskell.org/haskellwiki/Package_versioning_policy
     the project uses four digit versioing policy: A.B.C.D
     A - branch number, increase upon huge architectural changes or
         next stable release with lots of features

File src/Engine.hs

View file
   mergeCookies,
 
   uploadAndGrabHtml,
+  fetchAndGrabHtml,
+
   saveFirstLink,
   saveFirstLinkExtended,
 
+  grabLocationHeader,
+  grabExtractLinks,
+
   PasteHandler,
   PasteContext(..),
   PasteContextMap,
 sendPost :: PasteContext -> (PasteContext -> Request String) -> IO (Response String)
 sendPost context preparator =
   do
-    --let h = pcHandler context
-    --return context >>= h
     msgDebug "--- sendPost ---"
-    --msgDebug $ show request
-    --msgDebug encodedContent
     let request = preparator context
-    --msgDebug ">>>>> request >>>>>"
-    --msgDebug $ show request
     
-    --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
-    
-    --msgDebug "<<<<< response body <<<<<"
-    --msgDebug $ show $ rspBody response
-    --msgDebug $ show response
+    response <- fetch request $ pcAllowRedirect context
+    dumpString "response.html" $ rspBody response
 
-    dumpString "response.html" $ rspBody response
-    
-    --picUrl <- (ecHandler config) response filename
-    --msgDebug picUrl
     return response
 
 -- | List engine names in a single string
 getFilter context FileExtension = Tools.fileExtension (pcFileName context) ++ "$"
 getFilter context FileEmpty     = ""
 
+type Grabber = PasteContext -> Response String -> [String]
+
+grabLocationHeader :: Grabber
+grabLocationHeader _ response = maybe [] (:[]) $ 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 :: String
-                  -> String
-                  -> LinkFilterType
-                  -> PasteHandler [String]
-uploadAndGrabHtml attr value flt = do
+uploadAndGrabHtml :: Grabber -> PasteHandler [String]
+uploadAndGrabHtml grab = do
   context <- get
   response <- liftIO $ sendPostWithFile context
-  return $ Processing.extractLinks (rspBody response) attr value $ getFilter context flt
+  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 ()

File src/EngineFastpic.hs

View file
 import qualified Data.Map as Map
 
 import qualified Engine
-import qualified Tools
-import qualified Processing
 
 fastpicUploadUrl = "http://fastpic.ru/upload"
 
   maybe (return ()) parseRefreshPage (getRefreshLink response)
 
 parseRefreshPage :: String -> Engine.PasteHandler ()
-parseRefreshPage url = do
-  context <- get
-  -- download Refresh page and parse it
-  refreshResponse <- liftIO $ Engine.fetch (getRequest url) False
-  let link = Processing.extractLink (rspBody refreshResponse) "input" "value" $ Tools.fileExtension (Engine.pcFileName context) ++ "$"
-  case link of
-    Nothing -> return ()
-    Just x -> put context { Engine.pcResultLink = link } >> return ()
-  
+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

File src/EngineFlashtux.hs

View file
   }
 
 handler :: Engine.PasteHandler ()
-handler = Engine.uploadAndGrabHtml
-            "a" "href"
-            Engine.FileExtension
+handler = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "a" "href" Engine.FileExtension)
             >>= Engine.saveFirstLink

File src/EngineImagebin.hs

View file
   }
 
 handler :: Engine.PasteHandler ()
-handler = Engine.uploadAndGrabHtml
-            "img" "src"
-            Engine.FileEmpty
+handler = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "img" "src" Engine.FileEmpty)
             >>= Engine.saveFirstLinkExtended "http://imagebin.org" ""

File src/EngineOmpldr.hs

View file
   }
 
 handler :: Engine.PasteHandler ()
-handler = Engine.uploadAndGrabHtml
-            "a" "href"
-            Engine.FileName
+handler = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "a" "href" Engine.FileName)
             >>= Engine.saveFirstLinkExtended "http://ompldr.org" ""

File src/EngineRadikal.hs

View file
   put authorizedContext
   
 sendFile :: Engine.PasteHandler ()
-sendFile = 
-  Engine.uploadAndGrabHtml
-    "input" "value"
-    Engine.FileExtension
-    >>= Engine.saveFirstLink
+sendFile = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "input" "value" Engine.FileExtension)
+             >>= Engine.saveFirstLink

File src/EngineRghost.hs

View file
 getAuthToken :: Engine.PasteHandler ()
 getAuthToken = do
   respStartPage <- liftIO $ Engine.fetch (getRequest "http://rghost.net/multiple/upload_host") True
-  --msgDebug "<<<<< response start page <<<<<"
-  --msgDebug $ show respStartPage
-  
-  --msgDebug "<<<<< response body <<<<<<"
-  --msgDebug $ show $ rspBody respStartPage
   
   let text = rspBody respStartPage
       result = ((decode text) :: Result RghostPair)
       pair = (\(Ok x) -> x) result
-  --msgDebug $ show pair
   
   let cookie = case lookupHeader HdrSetCookie $ rspHeaders respStartPage of
         Just h -> takeWhile (/= ';') h
   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),
-  --                       Engine.pcCustomHeaders = customHeaders ++ (Engine.pcCustomHeaders ctx),
-  --                       Engine.pcUploadLink = "http://" ++ (rpUrl pair) ++ "/files"
-  --                     }
-
   context <- get
 
   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,
       headers = Engine.pcCustomHeaders context
 
   put newContext
-
-  --msgDebug "=== getAuthToken: newContext ==="
-  --msgDebug $ show newContext
-  
-  --return newContext
   
 login :: Engine.PasteHandler ()
 login = do
-  --loginResult <- Engine.sendPostWithoutFile context
-  -- grab cookies and 
-  
-  -- loginContext: uname,pass fields, prevCookies, host: rghost.net
-  
   -- in order to login we need:
   -- 1. authenticity_token
   -- 2. cookies
       isCookie (Header HdrCookie _) = True
       isCookie _ = False
       mainHost = [mkHeader HdrHost "rghost.net"]
-        --lookupHeader HdrHost $ Engine.pcCustomHeaders context
-
-  --liftIO $ msgDebug "=== loginContext ==="
-  --liftIO $ msgDebug $ show loginContext
   
   response <- liftIO $ Engine.sendPostWithoutFile loginContext
   
   let cookies = Engine.cookiesRemoveSet response
       newHeaders = [cookies, prevHost] -- : Engine.pcCustomHeaders context
-      --mergedCookie = Engine.mergeCookies newHeaders "; "
-      --authorizedContext = context { Engine.pcCustomHeaders = [mergedCookie] }
       authorizedContext = context { Engine.pcCustomHeaders = newHeaders }
       
-  liftIO $ msgDebug "=== prevHost ==="
-  liftIO $ msgDebug $ show prevHost
-
-  liftIO $ msgDebug "=== prevCookies ==="
-  liftIO $ msgDebug $ show prevCookie
-  
-  liftIO $ msgDebug "=== login cookies ==="
-  liftIO $ msgDebug $ show cookies
-  
-  liftIO $ msgDebug "=== newHeaders ==="
-  liftIO $ msgDebug $ show newHeaders
-  
-  --liftIO $ msgDebug "=== authorizedContext ==="
-  --liftIO $ msgDebug $ show authorizedContext
-
   put authorizedContext
-  --return authorizedContext
 
 upload :: Engine.PasteHandler ()
-upload = do
-  --msgDebug "=== Fields ==="
-  --msgDebug $ show $ Engine.pcFields context
-
-  context <- get
-  response <- liftIO $ Engine.sendPostWithFile context
-
-  liftIO $ msgDebug $ "filename = " ++ (show $ Engine.pcFileName context)
-  --liftIO $ msgDebug $ "contents = " ++ (show $ Engine.pcContents context)
-  
-  --msgDebug "<<<<< response <<<<<"
-  --msgDebug $ show response
-  
-  --msgDebug $ show $ lookupHeader HdrLocation $ rspHeaders response
-
-  let link = lookupHeader HdrLocation $ rspHeaders response
-  case link of
-    Nothing -> return ()
-    Just x -> put context { Engine.pcResultLink = link } >> return ()
+upload = Engine.uploadAndGrabHtml Engine.grabLocationHeader >>= Engine.saveFirstLink

File src/EngineScrin.hs

View file
   put newContext
 
 sendFile :: Engine.PasteHandler ()
-sendFile = Engine.uploadAndGrabHtml
-             "input" "value"
-             Engine.FileExtension
+sendFile = Engine.uploadAndGrabHtml (Engine.grabExtractLinks "input" "value" Engine.FileExtension)
              >>= (Engine.saveFirstLink . reverse)

File src/Tools.hs

View file
   h1 <- openBinaryFile filename ReadMode
   fileContent <- hGetContents h1
 
-  --msgDebug $ "=== contents === of " ++ show filename
-  --msgDebug $ show fileContent
-
   result <- handler fileContent
   hClose h1
   return result