PastePipe-1.2: pastepipe.hs

-- 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 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 ()

-- The hpaste API help can be found here: 
--   http://hpaste.org/fastcgi/hpaste.fcgi/help

-- | 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 :: (String -> IO ()) -> URI -> String -> String -> String -> String -> IO URI
post outHandler posturi usr lang title str = do 
  (uri, _) <- Network.Browser.browse $ do
                  setOutHandler outHandler
                  setAllowRedirects True -- handle HTTP redirects
                  request $ buildRequest posturi usr lang title str
  return uri

-- | 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)
                             , ("content", str)
                             , ("language", lang)
                             , ("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
  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