Haskell Twitter

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards   #-}

module Main where

import           Control.Applicative
import           Control.Monad
import           Data.ByteString       (ByteString)
import qualified Data.ByteString.Char8 as BS
import qualified Data.HashMap.Lazy     as HM
import           Data.Maybe            (fromMaybe)
import           Data.Text
import           Data.Text.Encoding    (encodeUtf8)
import qualified Data.Text.IO          as TIO
import           Data.Yaml
import           Network.HTTP.Req
import qualified Options.Applicative   as O
import           System.Directory      (getHomeDirectory)

data Account = Account { consumerKey    :: ByteString
                       , consumerSecret :: ByteString
                       , accessToken    :: ByteString
                       , accessSecret   :: ByteString
                       } deriving (Eq, Show)

data Setting = Setting { defaultAccount :: Text
                       , accounts       :: HM.HashMap Text Account
                       } deriving (Eq, Show)

instance FromJSON Account where
  parseJSON = withObject "Account" $ \o -> do
    consumerKey     <- encodeUtf8 <$> o .: "consumer-key"
    consumerSecret  <- encodeUtf8 <$> o .: "consumer-secret"
    accessToken     <- encodeUtf8 <$> o .: "access-token"
    accessSecret    <- encodeUtf8 <$> o .: "access-secret"
    return Account {..}

instance FromJSON Setting where
  parseJSON = withObject "Setting" $ \o -> do
    defaultAccount  <- o .: "default"
    accounts        <- o .: "accounts"
    return Setting {..}

loadSetting :: IO Setting
loadSetting = (<> "/.config/t/config.yaml") <$> getHomeDirectory
              >>= decodeFileEither
              >>= either (error . prettyPrintParseException) return

oauthOption :: Account -> Option scheme
oauthOption (Account ck cs at as) = oAuth1 ck cs at as

tweet :: Account -> Text -> IO ()
tweet account status = do
  let query = "status" =: status
  r <- runReq defaultHttpConfig $ req POST
    (https "api.twitter.com" /: "1.1" /: "statuses" /: "update.json")
    (ReqBodyUrlEnc query)
    jsonResponse
    (oauthOption account)
  BS.putStrLn $ encode (responseBody r :: Value)

listAccounts :: Setting -> IO ()
listAccounts s = TIO.putStrLn "accounts:" >> forM_ (HM.keys $ accounts s)
  (\k -> TIO.putStrLn $ (if k == defaultAccount s then "  *" else "   ") <> k)

data Options = Options { account    :: Maybe Text
                       , subCommand :: SubCommand
                       } deriving (Eq, Show)

data SubCommand = ListAccount
                | Update Text
                | UpdateFromSTDIN
                deriving (Eq, Show)

options :: O.Parser Options
options = Options
    <$> O.optional
          (O.strOption (O.long "account" <> O.metavar "NAME" <> O.help "Select the account"))
    <*> subCmdParser

subCmdParser :: O.Parser SubCommand
subCmdParser = O.subparser $
       O.command "list"   (pure ListAccount `withInfo` "List acconts")
    <> O.command "update" (updateOption     `withInfo` "Post a Tweet")
  where
    withInfo opts = O.info (O.helper <*> opts) . O.progDesc
    updateOption  = Update <$> O.strArgument (O.metavar "TEXT" <> O.help "Message")
                <|> pure UpdateFromSTDIN

run :: Options -> IO ()
run opts = loadSetting >>= run' (subCommand opts)
  where
    run' ListAccount   s   = listAccounts s
    run' (Update text) s   = join $ tweet <$> selectAccount s <*> pure text
    run' UpdateFromSTDIN s = join $ tweet <$> selectAccount s <*> TIO.getContents

    selectAccount s =
      let an = fromMaybe (defaultAccount s) (account opts)
      in  case HM.lookup an $ accounts s of
               Just a  -> return a
               Nothing -> error $ "Invalid account name: " <> unpack an

main :: IO ()
main = run =<< O.execParser opts
  where
    opts = O.info (options <**> O.helper)
         $ O.fullDesc
        <> O.header "t - CLI Twitter client"

package.yaml

name: t
ghc-options:
  - -Werror
  - -Wall
  - -O2
dependencies:
  - base >=4.7 && <5
  - bytestring
  - data-default-class
  - directory
  - optparse-applicative
  - req
  - text
  - unordered-containers
  - yaml
executables:
  t:
    main: Main.hs

stack.yaml

packages:
  - .
resolver: lts-16.9