packages feed

hlongurl (empty) → 0.9.1

raw patch · 7 files changed

+291/−0 lines, 7 filesdep +basedep +bytestringdep +curlsetup-changed

Dependencies added: base, bytestring, curl, json, regex-base, regex-posix

Files

+ Data/List/Replace.hs view
@@ -0,0 +1,56 @@+module Data.List.Replace+    ( replace+    , substAllM+    )+    where++import Control.Applicative ((<$>))+import Data.List (intercalate, isPrefixOf, mapAccumR)+import Data.Monoid (Monoid(..))+import Text.Regex.Base.RegexLike (Extract(..))++-- Based on a function by Joseph+-- | Replace a substring with a replacement string throughout a list+replace :: Eq a => [a] -> [a] -> [a] -> [a]+replace []     newSub = intercalate newSub . map (:[])+replace oldSub newSub = _replace+    where+      _replace list@(h:ts)+          | isPrefixOf oldSub list = newSub ++ _replace (drop len list)+          | otherwise              = h : _replace ts+      _replace [] = []+      len = length oldSub++-- | Specifies a range of indexes within a list. Invariant: fst >= 0 && snd >= 0+type IndexRange = (Int, Int)++eSplitAt :: Extract a => Int -> a -> (a, a)+eSplitAt i x = (before i x, after i x)++-- | Gets (before start, (matched, after end))+splitAtIR :: Extract a => IndexRange -> a -> (a, (a, a))+splitAtIR ir = (eSplitAt (snd ir) <$>) . eSplitAt (fst ir)++isBefore :: IndexRange -> IndexRange -> Bool+isBefore (s1, l1) (s2, _) = s1 + l1 <= s2++sortedBy :: (a -> a -> Bool) -> [a] -> Bool+sortedBy _ [] = True+sortedBy r (h:t) = impl h t+  where+    impl _ [] = True+    impl h' (h2:t2) = r h' h2 && impl h2 t2++-- | Gets all the unmatched and matched segments, in order+-- Precondition: The IndexRange list must be in ascending order+unweave :: Extract a => [IndexRange] -> a -> (a, [(a, a)])+unweave irs | sortedBy isBefore irs = flip (mapAccumR $ flip splitAtIR) irs+            | otherwise = error $ "unweave: Non-ascending input: " ++ show irs++-- | Substitutes all ranges using the values returned by the function provided.+-- Precondition: The IndexRange list must be in ascending order+substAllM :: (Functor m, Monad m, Extract a, Monoid a) => (a -> m a) -> a -> [IndexRange] -> m a+substAllM f l irs = mconcat . (beforeFirst :) <$> mapM process matches+    where+      (beforeFirst, matches) = unweave irs l+      process (matched, unmatched) = (`mappend` unmatched) <$> f matched
+ Hlongurl.hs view
@@ -0,0 +1,41 @@+import Data.List.Replace (replace, substAllM)+import Network.Curl.Easy (curl_global_init, initialize)+import Network.LongURL (CurlInstance(..), domains, longURL, supportedSites)++import Control.Applicative ((<$>), (<*>))+import Data.ByteString.Lazy.Char8 (ByteString, pack, splitWith, unpack)+import qualified Data.ByteString.Lazy.Char8 as B+import Data.List (intercalate)+import Text.Regex.Base.Context ()+import Text.Regex.Base.RegexLike (getAllMatches, makeRegexM, match)+import Text.Regex.Posix.ByteString.Lazy (Regex)+import Text.Regex.Posix.String ()++-- FIXME: Make this lazy again+bsLines :: ByteString -> [ByteString]+bsLines = postProcess . splitWith (== '\n')+    where+      postProcess []           = []+      postProcess result+        | B.null (last result) = init result+        | otherwise            = result++-- | Split input into lines, in order to do incremental processing, and to try to limit memory usage+mapMLines_ :: Monad m => (ByteString -> m ()) -> ByteString -> m ()+mapMLines_ f = mapM_ f . bsLines++main :: IO ()+main = do+  curl_global_init 2  -- Initialise just win32sock (if applicable)+  curl' <- initialize+  let ci = CurlInstance { curl = curl', userAgent = "hlongurl 0.9.1; Haskell" }+  supportedDomains <- (domains =<<) <$> supportedSites ci+  urlRegex <- (makeRegexM+               $ "http://(" ++ intercalate "|" (replace "." "\\." <$> supportedDomains)+                    ++ ")/([-a-zA-Z0-9_\\'/\\\\\\+&%\\$#\\=~])*") :: IO Regex+  let substURLs :: ByteString -> IO ()+      substURLs =+         (B.putStrLn =<<)+         . (substAllM (((pack . show) <$>) . longURL ci . unpack)+                          <*> getAllMatches . match urlRegex)+  mapMLines_ substURLs =<< B.getContents
+ LICENSE view
@@ -0,0 +1,30 @@++Copyright (c) 2008 Robin Green, Sigbjorn Finne++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 Robin Green 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.
+ Network/LongURL.hs view
@@ -0,0 +1,71 @@+module Network.LongURL +    ( CurlInstance(..)+    , longURL+    , SupportedSite(..)+    , supportedSites+    , URLInfo(..)+    ) where++import Network.Curl (Curl, CurlResponse(..), do_curl, method_GET)+import Network.Curl.Code (CurlCode(..))+import Network.Curl.Opts (CurlOption(..))+import Network.Curl.Types (URLString)+import Text.JSON.String (readJSObject, runGetJSON)+import Text.JSON.Types (fromJSObject, fromJSString, JSObject, JSValue(..))+import Util.Codec.Percent (getEncodedString)++import Control.Applicative ((<$>))++data CurlInstance = CurlInstance { curl :: Curl+                                 , userAgent :: String+                                 }++data SupportedSite = SupportedSite { siteName :: String+                                   , domains :: [String]+                                   }++data URLInfo = URLInfo { longURL' :: String+                       , pageTitle :: Maybe String+                       }++simple_get :: CurlInstance -> URLString -> IO String+simple_get ci url = handleResponse =<< do_curl (curl ci) url+                    (CurlUserAgent (userAgent ci) : CurlVerbose False : CurlNoProgress True : method_GET)+    where+      handleResponse :: CurlResponse -> IO String+      handleResponse r = do { (CurlResponse { respCurlCode = CurlOK, respBody = b }) <- return r; return b }++getJSArray :: Monad m => JSValue -> m [JSValue]+getJSArray v = do { (JSArray a) <- return v; return a }++getJSString :: Monad m => JSValue -> m String+getJSString v = do { (JSString jss) <- return v; return $ fromJSString jss }++apiSite :: String+apiSite = "http://api.longurl.org"++apiVersion :: String+apiVersion = "v1"++-- | Makes a call to the JSON web API+apiCall :: CurlInstance -> String -> IO [(String, JSValue)]+apiCall ci query = do+  (Right (JSObject jso)) <- (runGetJSON readJSObject <$>) . simple_get ci+                            $ apiSite ++ "/" ++ apiVersion ++ "/" ++ query+  return $ fromJSObject jso++supportedSites :: CurlInstance -> IO [SupportedSite]+supportedSites ci =+    mapM (\(n, ds) -> SupportedSite n <$> (mapM getJSString =<< getJSArray ds)) =<< apiCall ci "services?format=json"++longURL :: CurlInstance -> String -> IO URLInfo+longURL ci url = do+  rec <- apiCall ci $ "expand?url=" ++ getEncodedString url ++ "&format=json"+  (Just jsURL) <- return $ lookup "long_url" rec+  url' <- getJSString jsURL+  title <- maybe (return Nothing) ((return <$>) . getJSString) $ lookup "title" rec+  return $ URLInfo { longURL' = url', pageTitle = title }++instance Show URLInfo where+    show (URLInfo { longURL' = url', pageTitle = Nothing })    = url'+    show (URLInfo { longURL' = url', pageTitle = Just title }) = url' ++ " [\"" ++ title ++ "\"]"
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Util/Codec/Percent.hs view
@@ -0,0 +1,57 @@+{- |+ +  Module      :  Util.Codec.Percent+  Copyright   :  (c) 2008++  Maintainer  : sof@forkIO.com++  License     : See the file LICENSE++  Status      : Coded++  Codec for de/encoding URI strings via percent encodings+ (cf. RFC 3986.)+-}+module Util.Codec.Percent where++import Data.Char ( chr, isAlphaNum )+import Numeric   ( readHex, showHex )++getEncodedString :: String -> String+getEncodedString "" = ""+getEncodedString (x:xs) = +  case getEncodedChar x of+    Nothing -> x : getEncodedString xs+    Just ss -> ss ++ getEncodedString xs++getDecodedString :: String -> String+getDecodedString "" = ""+getDecodedString ls@(x:xs) = +  case getDecodedChar ls of+    Nothing -> x : getDecodedString xs+    Just (ch,xs1) -> ch : getDecodedString xs1++getEncodedChar :: Char -> Maybe String+getEncodedChar x+ | isAlphaNum x || +   x `elem` "-_.~" = Nothing+ | xi < 0xff       = Just ('%':showHex (xi `div` 16) (showHex (xi `mod` 16) ""))+ | otherwise       = -- ToDo: import utf8 lib+   error "getEncodedChar: can only handle 8-bit chars right now."+ where+  xi :: Int+  xi = fromEnum x++getDecodedChar :: String -> Maybe (Char, String)+getDecodedChar str =+ case str of+   ""          -> Nothing+   (x:xs) +    | x /= '%'  -> Nothing+    | otherwise -> do+       case xs of+         (b1:b2:bs) -> +	    case readHex [b1,b2] of+	      ((v,_):_) -> Just (Data.Char.chr v, bs)+	      _ -> Nothing+	 _ -> Nothing
+ hlongurl.cabal view
@@ -0,0 +1,33 @@+name:                hlongurl+version:             0.9.1+Cabal-Version:	     >= 1.2+synopsis:            Library and utility interfacing to longurl.org+description:         The library provides a Haskell binding to the longurl.org API.+		     The utility finds all URLs in its input that longurl says it can expand,+		     and then tries to expand each of them in-place.+category:            Network+license:             BSD3+license-file:        LICENSE+copyright:	     Copyright (C) Robin Green 2008+author:              Robin Green+maintainer:          Robin Green <greenrd@greenrd.org>+build-type:	     Simple+stability:	     experimental+bug-reports:	     mailto:greenrd@greenrd.org+category:	     Web+tested-with:	     GHC == 6.10.1++source-repository head+  type:     darcs+  location: http://code.haskell.org/hlongurl/++Library+  build-Depends:	base, curl, json+  exposed-modules:      Network.LongURL, Util.Codec.Percent+  ghc-options:          -Wall++Executable hlongurl+  build-Depends:	base, bytestring, curl, regex-base >= 0.93.1, regex-posix >= 0.93.2+  main-is:	Hlongurl.hs+  Other-Modules:	Network.LongURL, Util.Codec.Percent, Data.List.Replace+  ghc-options:          -Wall