PastePipe 1.2 → 1.3
raw patch · 2 files changed
+67/−86 lines, 2 filesdep +cmdargs
Dependencies added: cmdargs
Files
- PastePipe.cabal +2/−2
- pastepipe.hs +65/−84
PastePipe.cabal view
@@ -1,7 +1,7 @@ -- cabal configure --prefix=$HOME --user -- cabal build name: PastePipe-version: 1.2+version: 1.3 synopsis: CLI for pasting to hpaste.org description: PastePipe reads from standard in and posts to hpaste.org. It will auto-detect your username, but that can be @@ -20,5 +20,5 @@ Executable pastepipe Main-is: pastepipe.hs- Build-Depends: base >= 4 && < 5, HTTP, network+ Build-Depends: base >= 4 && < 5, HTTP, network, cmdargs ghc-options: -Wall
pastepipe.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} -- pastepipe.hs -- -- A CLI for Hpaste.org.@@ -19,18 +20,59 @@ module Main where ---import Data.Char (intToDigit)---import Network.HTTP import Network.HTTP.Base import Network.URI import Network.Browser import Data.Maybe-import System.Environment (getArgs, getEnv)---import System.IO ()+import System.Environment (getEnv)+import System.Console.CmdArgs --- The hpaste API help can be found here: --- http://hpaste.org/fastcgi/hpaste.fcgi/help+main :: IO () +main = do+ realUser <- getEnv "USER"+ conf <- cmdArgs "PastePipe v1.3, (C) Rogan Creswick 2009" [config realUser]+ content <- getContents+ let postFn = if test conf then fakePost else post+ resultUrl <- postFn conf content+ putStrLn $ show resultUrl+ +-- | Configuration type for PastePipe:+data Config = Config { userName :: String+ , language :: String+ , title :: String+ , uri :: String+ , test :: Bool }+ deriving (Show, Data, Typeable) +-- | Default config.+-- The string passed in is the current user's username.+config :: String -> Mode Config+config realUser = mode $ Config { + userName = realUser &= text + "Your user name"+ & typ "USER"+ & explicit & flag "user" & flag "u"+ , language = "haskell" &= text + "The language used for syntax highlighting"+ & typ "LANGUAGE"+ , title = "" &= text + "The title of the snippet"+ & typ "TITLE"+ & explicit & flag "title" & flag "t"+ , uri = defaultUri &= text + "The URI of the hpaste instance to post to"+ & typ "URL"+ , test = False &= text + "Prevents PastePipe from actually posting content, just echos the configuration and input"+ }+++-- | Define an output handler based on the user-specified verbosity.+outHandler :: String -> IO ()+outHandler str = do+ loud <- isLoud -- are we running in verbose mode?+ if loud then (putStr str) else (const (return()) str)+ -- | The "root" uri for hpaste.org defaultUri :: String defaultUri = "http://hpaste.org/fastcgi/hpaste.fcgi/"@@ -45,89 +87,28 @@ buildURI coreUri str = fromJust $ parseURI $ coreUri ++ str -- | Posts the given content to hpaste.org, returning the new uri.-post :: (String -> IO ()) -> URI -> String -> String -> String -> String -> IO URI-post outHandler posturi usr lang title str = do - (uri, _) <- Network.Browser.browse $ do+post :: Config -> String -> IO URI+post conf str = do + (url, _) <- Network.Browser.browse $ do setOutHandler outHandler setAllowRedirects True -- handle HTTP redirects- request $ buildRequest posturi usr lang title str- return uri+ request $ buildRequest conf str+ return url -- | Creates the request to post a chunk of content.-buildRequest :: URI -> String -> String -> String -> String -> Request String-buildRequest uri usr lang title str = formToRequest $ Form POST uri - [ ("title", title)- , ("author", usr)+buildRequest :: Config -> String -> Request String+buildRequest conf str = formToRequest $ Form POST (saveUri $ uri conf)+ [ ("title", title conf)+ , ("author", userName conf) , ("content", str)- , ("language", lang)+ , ("language", language conf) , ("channel", "")] -fakePost :: (String -> IO ()) -> URI -> String -> String -> String -> String -> IO URI-fakePost _ uri usr lang title str = do - putStrLn $ "uri: "++show uri- putStrLn $ "user: "++usr- putStrLn $ "lang: "++lang- putStrLn $ "title: "++title+fakePost :: Config -> String -> IO URI+fakePost conf str = do + putStrLn $ "uri: "++uri conf+ putStrLn $ "user: "++userName conf+ putStrLn $ "lang: "++language conf+ putStrLn $ "title: "++title conf putStrLn $ "content: "++str- return uri--main :: IO () -main = do- args <- getArgs- case (elem "--help" args) of - True -> printHelp- False -> do- content <- getContents- realUser <- getEnv "USER"- let usr = getArgVal "-u" realUser args- lang = getLang args- title = getTitle args- coreUri = getCoreUri args- postFn = getPostFn args- outHandler = getOutHandler args- uri <- postFn outHandler (saveUri coreUri) usr lang title content- putStrLn $ show uri---- | Determines the language from the list of arguments.-getLang :: [String] -> String-getLang = getArgVal "-l" "haskell"--getTitle :: [String] -> String-getTitle = getArgVal "-t" ""--getCoreUri :: [String] -> String-getCoreUri = getArgVal "--uri" defaultUri--getPostFn :: [String] -> (String -> IO ()) -> URI -> String -> String -> String -> String -> IO URI-getPostFn args = case (elem "--test" args) of- True -> fakePost- False -> post--getOutHandler :: [String] -> (String -> IO ())-getOutHandler args = case (elem "--verbose" args) of - True -> putStr- False -> const (return ()) --squelch output.- --- | Prints the usage information.-printHelp :: IO ()-printHelp = do- putStrLn "Usage: pastepipe --uri <url> -u <user> -t <title> -l <language> --test"- putStrLn ""- putStrLn " eg: pastepipe --uri \"http://hpaste.org/fastcgi/hpaste.fcgi/\" -t \"new post\""- putStrLn ""- putStrLn " -t <title> Defaults to \"\""- putStrLn " -u <username> Defaults to ${USER}"- putStrLn " -l <language> Defaults to haskell"- putStrLn $ " --uri <hpaste_uri> Defaults to "++ defaultUri- putStrLn " --test Fake the post--does not send anything to the server (used for testing)"- putStrLn " --verbose Print the web chatter from Network.Browse"----- | given a flag and a default value, returns the first --- argument following the first instance fo flag, or the default--- if no argument matches.-getArgVal :: String -> String -> [String] -> String-getArgVal _ def [] = def-getArgVal _ def (_:[]) = def-getArgVal flag def (x:xs) | flag == x = head xs- | otherwise = getArgVal flag def xs+ return $ fromJust $ parseURI $ uri conf