PastePipe-1.3: pastepipe.hs

{-# LANGUAGE DeriveDataTypeable #-}
-- pastepipe.hs
-- 
-- A CLI for Hpaste.org.
--
--  Authored by Rogan Creswick (creswick_at_googles_mail_service.)
--
-- Pastepipe reads from stdin, posting to hpaste, and prints out the 
-- resulting url (the last line of output).  Parameters control various 
-- hpaste form fields:
--
--   -u username  (defaults to $USER)
--   -l language  (defaults to haskell, of course)
--   -t title     (defaults to the empty string)
--
-- It will auto-detect your local username, but -u overrides this detection.
-- 
-- compile with: 
-- ghci --make -package HTTP pastepipe.hs -o pastepipe

module Main where

import Network.HTTP.Base
import Network.URI
import Network.Browser
import Data.Maybe
import System.Environment (getEnv)
import System.Console.CmdArgs

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/"

-- | The URI for posting new pastes to hpaste.
-- This isn't guaranteed to trigger a failure on all execution paths, as-is.
saveUri :: String -> URI
saveUri coreUri = buildURI coreUri "save"

-- | composes the core uri and a string to create a usable URI
buildURI :: String -> String -> URI
buildURI coreUri str = fromJust $ parseURI $ coreUri ++ str

-- | Posts the given content to hpaste.org, returning the new uri.
post :: Config -> String -> IO URI
post conf str = do 
  (url, _) <- Network.Browser.browse $ do
                  setOutHandler outHandler
                  setAllowRedirects True -- handle HTTP redirects
                  request $ buildRequest conf str
  return url

-- | Creates the request to post a chunk of content.
buildRequest :: Config -> String -> Request String
buildRequest conf str = formToRequest $ Form POST (saveUri $ uri conf)
                             [ ("title", title conf)
                             , ("author", userName conf)
                             , ("content", str)
                             , ("language", language conf)
                             , ("channel", "")]

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 $ fromJust $ parseURI $ uri conf