diff --git a/HPasteIt.hs b/HPasteIt.hs new file mode 100644 --- /dev/null +++ b/HPasteIt.hs @@ -0,0 +1,142 @@ +{-# 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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Patrick Palka + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Patrick Palka nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/hpasteit.cabal b/hpasteit.cabal new file mode 100644 --- /dev/null +++ b/hpasteit.cabal @@ -0,0 +1,34 @@ +name: hpasteit +version: 0.1.0.0 +synopsis: A command-line client for hpaste.org +-- description: +license: BSD3 +license-file: LICENSE +author: Patrick Palka +maintainer: patrick@parcs.ath.cx +copyright: Copyright (C) 2012 Patrick Palka +category: Web +build-type: Simple +cabal-version: >=1.8 +tested-with: GHC == 7.6.1 +stability: provisional +homepage: http://github.com/parcs/hpasteit +bug-reports: http://github.com/parcs/hpasteit/issues + +source-repository head + type: git + location: git://github.com/parcs/hpasteit.git + +executable hpasteit + main-is: HPasteIt.hs + + build-depends: base ==4.6.* + , bytestring ==0.10.* + , lifted-base ==0.2.* + , http-conduit ==1.8.* + , http-types ==0.7.* + , optparse-applicative ==0.5.* + + ghc-options: -Wall + + extensions: PatternGuards