-- 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
coreUri :: String 
coreUri = "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 :: URI
saveUri = buildURI "save"

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

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

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

fakePost ::  String -> String -> String -> String -> IO URI
fakePost usr lang title str = do 
  putStrLn $ "user: "++usr
  putStrLn $ "lang: "++lang
  putStrLn $ "title: "++title
  putStrLn $ "content: "++str
  return saveUri

main :: IO () 
main = do
  args <- getArgs
  content <- getContents
  realUser <- getEnv "USER"
  let usr = getArgVal "-u" realUser args
      lang = getLang args
      title = getTitle args
  uri <- post 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" ""

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