http-trace (empty) → 0.1.0.0

raw patch · 5 files changed

+171/−0 lines, 5 filesdep +MissingHdep +basedep +curlsetup-changed

Dependencies added: MissingH, base, curl, http-trace, pcre-heavy, safe, template-haskell, text, transformers

Files

• LICENSE +21/−0
• Setup.hs +2/−0
• app/Main.hs +17/−0
• http-trace.cabal +38/−0
• src/Http/Trace.hs +93/−0

@@ -0,0 +1,21 @@+The MIT License (MIT)++Copyright (c) 2016 Sergey Bushnyak++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,17 @@+module Main where++import System.Environment+import Http.Trace++--------------------------------------------------------------------------------++main :: IO ()+main = do+  args <- getArgs+  case null args of+    True  -> putStrLn $ "no url supplied!"+    False ->+      do +        rdrs <- traceRedirects' (args!!0) True+        putStrLn $ "Redirects:"+        mapM_ (\x -> putStrLn $ "- " ++ x) rdrs

@@ -0,0 +1,38 @@+name:                http-trace+version:             0.1.0.0+synopsis:            Tracking http redirects +description:         Please see README.md+homepage:            https://github.com/sigrlami/http-trace#readme+license:             MIT+license-file:        LICENSE+author:              Sergey Bushnyak+maintainer:          sergey.bushnyak@sigrlami.eu+copyright:           Copyright: (c) 2016 Sergey Bushnyak+category:            Web+build-type:          Simple+cabal-version:       >=1.10+++library+  hs-source-dirs:      src+  exposed-modules:     Http.Trace+  build-depends:       base >= 4.7 && < 5+               ,       curl >= 1.3.8+               ,       pcre-heavy >= 1.0.0.0+               ,       template-haskell +               ,       text +               ,       safe >= 0.3.9+               ,       transformers+               ,       MissingH+  default-language:    Haskell2010++executable http-trace+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010+  build-depends:       base >= 4.7 && < 5+               ,       http-trace++  default-extensions:  OverloadedStrings+                    ,  TemplateHaskell

@@ -0,0 +1,93 @@+{-# LANGUAGE QuasiQuotes #-}++module Http.Trace+       ( traceRedirects+       , traceRedirects'  +       , isReachable+       ) where++import           Control.Monad.IO.Class+import qualified System.IO as IO+import           System.IO.Unsafe+import           Control.Applicative+import qualified Data.Text as T+import           Data.Maybe+import           Data.String.Utils+import           Network.Curl+import           Text.Regex.PCRE.Heavy+import           Safe++--------------------------------------------------------------------------------++-- | Regex for getting web links from text+-- +fullUrlRegex :: Regex+fullUrlRegex = [re|(http|ftp|https)://([\w_-]+(?:(?:\.[\w_-]+)+))([\w.,@?^=%&:/~+#-]*[\w@?^=%&/~+#-])?|]++shortUrlRegex :: Regex+shortUrlRegex = [re|(http|https)?:\/\/(www\.)?[-a-zA-Z0-9@:%._\+~#=]{2,256}\.[a-z]{2,6}|]++userAgent = ""++-- | Function to get all redirects for+--   provided url+traceRedirects :: String -> IO [String]+traceRedirects start =+  traceAux start+     where+       traceAux :: String -> IO [String]+       traceAux ""   = return $ []+       traceAux curr = do+         newLink  <- getNewLink (strip curr)+         newTrace <- traceAux (strip newLink)+         return $ curr : newTrace  +           where+             getNewLink :: String -> IO String+             getNewLink curr = do+               hds <- curlHead curr []+               let headMetas = snd hds+                   newLinkM  = lookup "LOCATION" headMetas+               case newLinkM of+                 Just link -> return $ link+                 Nothing   ->+                   do +                     str <- curlGetString curr [CurlTimeout 60]+                     --putStrLn $ curr+                     --putStrLn $ "--->" ++ (show $ fst str) ++ snd str+                     let  urlFromBodyM = headMay $ scan fullUrlRegex $ snd str      +                     case urlFromBodyM of+                       Nothing    -> return $ ""+                       Just link  -> return $ fst link++-- | Version that returns top-level domain names+--   without full url path                     +traceRedirects' :: String -> Bool -> IO [String]+traceRedirects' start compress = do+  rdrs <- traceRedirects start+  let rdrs' = map (\x -> fst $ head $ scan shortUrlRegex x) rdrs+  -- TODO: 1. apply shortUrlRegex+  --       2. remove same name+      rdrs'' = case compress of+                 True  -> removeDuplicates rdrs' +                 False -> rdrs' +  return $ rdrs''++-- traceRedirectsWithType -- usually click/jump/track/badlink++-- | Check if we redirects paths lead to destination url+--                        +isReachable :: String -> String -> IO Bool+isReachable start dest =+  do+    redirects <- traceRedirects start+    case null redirects of+      True  -> return $ False+      False -> return $ last redirects == dest+++removeDuplicates :: Eq a => [a] -> [a]+removeDuplicates = rdHelper []+    where rdHelper seen [] = seen+          rdHelper seen (x:xs)+              | x `elem` seen = rdHelper seen xs+              | otherwise = rdHelper (seen ++ [x]) xs