hpasteit-0.2.0.0: HPasteIt.hs

{-# LANGUAGE OverloadedStrings #-}
module Main (main) where

import ProgOpts (ProgOpts(..), parseOpts)

import Data.Maybe
import System.Directory
import System.Environment
import System.Exit
import System.IO

import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS

import Control.Exception.Lifted
import Network.HTTP.Conduit
import Network.HTTP.Types
import Options.Applicative
import System.Cmd

main :: IO ()
main = parseOpts >>= realMain

realMain :: ProgOpts -> IO ()
realMain PasteOpts
    { optFile     = opt_file
    , optTitle    = opt_title
    , optAuthor   = opt_author
    , optLanguage = opt_language
    , optChannel  = opt_channel
    }
  = do
    paste <- case opt_file of
        "-"  -> BS.getContents
        file -> BS.readFile file

    res <- withManager $ \man -> try $ do
        rq <- parseUrl "http://hpaste.org/new"
        let rq' = urlEncodedBody
                [ ("title"   , BS.pack opt_title   )
                , ("author"  , BS.pack opt_author  )
                , ("language", BS.pack opt_language)
                , ("channel" , BS.pack opt_channel )
                , ("paste"   , paste               )
                , ("email"   , ""                  )
                ] rq

        -- hpaste.org redirects us to the URL of the paste if pasting succeeds.
        -- In order to grab the URL we explicitly don't follow redirects.
        httpLbs (rq' { redirectCount = 0 }) man

    case res of
        -- An exception is thrown if the server issues a redirect.
        Left (StatusCodeException (Status 302 _) hdrs)
          | Just loc <- lookup "Location" hdrs -> do

            putStrLn ("http://hpaste.org" ++ BS.unpack loc)
            exitSuccess

        Left exc -> do

            hPutStrLn stderr "Encountered unexpected HttpException:\n"
            hPutStrLn stderr (show exc)
            exitFailure

        Right resp -> do

            hPutStrLn stderr "Encountered unexpected response:\n"
            hPutStrLn stderr (show resp)
            exitFailure

realMain ViewOpts
    { optPasteID = opt_paste_id }
  = do
    res <- withManager $ \man -> try $ do
        rq <- parseUrl ("http://hpaste.org/raw/" ++ show opt_paste_id)

        httpLbs (rq { redirectCount = 0}) man

    case res of
        Left (StatusCodeException (Status 302 _) hdrs)
          | Just "/" <- lookup "Location" hdrs -> do

            hPutStrLn stderr $
                "Paste #" ++ show opt_paste_id ++ " does not exist"
            exitFailure

        Left exc -> do

            hPutStrLn stderr "Encountered unexpected HttpException:\n"
            hPutStrLn stderr (show (exc :: HttpException))
            exitFailure

        Right resp -> do
            tmp_dir <- getTemporaryDirectory
            withTempFile tmp_dir "hpasteit" $ \hdl file -> do

                LBS.hPutStrLn hdl (responseBody resp)
                hFlush hdl

                editor <- fromMaybe "vi" <$> lookupEnv "EDITOR"
                exit_code <- rawSystem editor [file]

                exitWith exit_code

  where
    withTempFile :: FilePath -> String
                 -> (Handle -> FilePath -> IO a)
                 -> IO a
    withTempFile tmp_dir prefix thing = do
        (file,hdl) <- openTempFile tmp_dir prefix
        thing hdl file `finally` (hClose hdl `finally` removeFile file)