hpasteit-0.1.0.0: HPasteIt.hs

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

import Data.Char
import Data.Monoid
import System.Exit
import System.IO

import qualified Data.ByteString.Char8 as BS

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

data Options = Options
    { optTitle    :: String
    , optAuthor   :: String
    , optLanguage :: String
    , optChannel  :: String
    , optFile     :: FilePath
    }

optParser :: Parser Options
optParser = Options
        <$> nullOption (mconcat [ reader  Right
                                , value   "via HPasteIt"
                                , short   't'
                                , long    "title"
                                , metavar "TITLE"
                                , help    "The title of the paste; \
                                          \defaults to \"via HPasteIt\"."
                                ])

        <*> nullOption (mconcat [ reader  Right
                                , value   "Anonymous"
                                , short   'a'
                                , long    "author"
                                , metavar "AUTHOR"
                                , help    "The author of the paste; \
                                          \defaults to \"Anonymous\"."
                                ])

        <*> nullOption (mconcat [ reader  (readLanguage . map toLower)
                                , long    "language"
                                , short   'l'
                                , metavar "LANGUAGE"
                                , value   "haskell"
                                , help    "The language of the paste; \
                                          \defaults to Haskell."
                                ])

        <*> nullOption (mconcat [ reader  (readChannel . map toLower)
                                , long    "channel"
                                , short   'c'
                                , metavar "CHANNEL"
                                , value   ""
                                , help    "The IRC channel to notify."
                                ])

        <*> argument Just (mconcat [ metavar "FILE"
                                   , value   "-"
                                   , help    "The path of the file to paste; \
                                             \defaults to - for STDIN."
                                   ])
  where
    -- The string arguments of these functions are lower-case.

    readLanguage :: String -> Either ParseError String
    readLanguage lang
      | Just real_lang <- lookup lang suffixes = Right real_lang
      | lang `elem` langs = Right lang
      | otherwise         = Left (ErrorMsg err_msg)
      where
        suffixes = [ ("hs" , "haskell"        )
                   , ("lhs", "literatehaskell")
                   ]

        -- Not an exhaustive list.
        langs = ["haskell","agda","ocaml","lisp","erlang","literatehaskell"
                ]

        err_msg = "Invalid language. See hpaste.org for a full list of \
                  \supported languages."

    readChannel :: String -> Either ParseError String
    readChannel chan
        = if dropWhile (=='#') chan `elem` chans
            then Right chan
            else Left (ErrorMsg err_msg)
      where
        -- Not an exhaustive list.
        chans = ["haskell"]

        err_msg = "Invalid IRC channel. See hpaste.org for a full list of \
                  \valid IRC channels."


main :: IO ()
main = do
    options <- execParser $ info (helper <*> optParser) $
        mconcat [ fullDesc
                , header "hpasteit - command-line client for hpaste.org"
                ]

    paste <- case optFile options of
        "-"  -> BS.getContents
        file -> BS.readFile file

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

        -- In order to grab the URL of the paste we 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