hpasteit-0.3.2: HPasteIt.hs

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

import ProgOpts (ProgOpts(..), parseOpts)

import Control.Applicative
import Control.Monad
import Data.Maybe
import System.Directory
import System.Environment
import System.FilePath
import System.Exit
import System.IO

import qualified Data.ByteString.UTF8 as UTF8
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 System.Cmd

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

realMain :: ProgOpts -> IO ()
realMain PasteOpts
    { optFile     = opt_file
    , optTitle    = m_opt_title
    , optAuthor   = m_opt_author
    , optLanguage = m_opt_language
    , optChannel  = opt_channel
    , optDebug    = opt_debug
    }
  = do
    paste <- case opt_file of
        "-"  -> UTF8.fromString <$> getContents
        file -> UTF8.fromString <$> readFile file

    -- An incomplete map from file extensions to language
    let ext_map = [ ("hs"  , "haskell"        )
                  , ("hsc" , "haskell"        )
                  , ("lhs" , "literatehaskell")
                  , ("c"   , "c"              )
                  , ("h"   , "c"              )
                  , ("agda", "agda"           )
                  , ("sh"  , "bash"           )
                  ]

        m_ext        = lookup (takeExtension opt_file) ext_map
        opt_language = fromMaybe "haskell" (m_opt_language <|> m_ext)

    opt_author <- do
        env_author <- try (getEnv "HPASTE_AUTHOR")

        let m_author = case env_author :: Either IOException String of
                Right author | not (null author) -> Just author
                _otherwise -> Nothing

        return $ fromMaybe "Anonymous" (m_opt_author <|> m_author)

    let def_title = if opt_file /= "-" then takeBaseName opt_file
                                       else "(no title)"

        opt_title = fromMaybe def_title m_opt_title

    when opt_debug $ do
        hPutStrLn stderr $ unlines
            [ "Title    : " ++ show opt_title
            , "Author   : " ++ show opt_author
            , "Language : " ++ show opt_language
            , "Channel  : " ++ show opt_channel
            , "Debug    : " ++ show opt_debug
            ]

        exitSuccess

    res <- withManager $ \man -> try $ do
        rq <- parseUrl "http://hpaste.org/new"
        let rq' = urlEncodedBody
                [ ("title"   , UTF8.fromString opt_title   )
                , ("author"  , UTF8.fromString opt_author  )
                , ("language", UTF8.fromString opt_language)
                , ("channel" , UTF8.fromString 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, responseTimeout = Just 60000000 }) 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, responseTimeout = Just 60000000 }) 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 <- do
                    m_editor <- try (getEnv "EDITOR")
                    case m_editor :: Either IOException String of
                        Right editor | not (null editor) -> return editor
                        _otherwise -> do
                            hPutStrLn stderr "$EDITOR not defined. Using 'vi'"
                            return "vi"

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