givegif-1.0.0.0: app/Main.hs

{-# LANGUAGE LambdaCase        #-}
{-# LANGUAGE OverloadedStrings #-}

module Main where

import qualified Control.Error.Util         as Err
import qualified Data.ByteString.Lazy       as BSL
import qualified Data.ByteString.Lazy.Char8 as BS8
import qualified Data.Text                  as T
import qualified Data.Text.IO               as TIO
import qualified Network.Wreq               as Wreq
import qualified Options.Applicative        as Opt
import qualified Options.Applicative.Text   as Opt
import qualified Web.Giphy                  as Giphy

import           Control.Applicative        (optional, (<**>), (<|>))
import           Control.Lens               (Getting (), preview)
import           Control.Lens.At            (at)
import           Control.Lens.Cons          (_head)
import           Control.Lens.Operators
import           Control.Lens.Prism         (_Left, _Right)
import           Control.Monad              (join, unless)
import           Data.Monoid                (First (), (<>))
import           Data.Version               (Version (), showVersion)
import           Paths_givegif              (version)
import           System.Environment         (getProgName)
import           System.IO                  (stderr)

import           Console

data Options = Options
  { optNoPreview :: Bool
  , optMode      :: SearchMode
  }

data SearchMode = OptSearch T.Text | OptTranslate T.Text | OptRandom (Maybe T.Text)

options :: Opt.Parser Options
options =
  Options <$> Opt.switch ( Opt.long "no-preview"
                        <> Opt.short 'n'
                        <> Opt.help "Don't render an inline image preview." )
          <*> ( ( OptSearch <$> Opt.textOption ( Opt.long "search"
                                          <> Opt.short 's'
                                          <> Opt.help "Use search to find a matching GIF." ) )
          <|> ( OptTranslate <$> Opt.textOption ( Opt.long "translate"
                                           <> Opt.short 't'
                                           <> Opt.help "Use translate to find a matching GIF." ) )
          <|> ( OptRandom <$> optional ( Opt.textArgument ( Opt.metavar "RANDOM_TAG" ) ) ) )

cliParser :: String -> Version -> Opt.ParserInfo Options
cliParser progName ver =
  Opt.info ( Opt.helper <*> options <**> versionInfo )
    ( Opt.fullDesc
   <> Opt.progDesc "Find GIFs on the command line."
   <> Opt.header progName )
  where
    versionInfo = Opt.infoOption ( unwords [progName, showVersion ver] )
      ( Opt.short 'V'
     <> Opt.long "version"
     <> Opt.hidden
     <> Opt.help "Show version information" )

apiKey :: Giphy.Key
apiKey = Giphy.Key "dc6zaTOxFJmzC"

taggedPreview
  :: t
  -> Getting (First a) s a
  -> s
  -> Either t a
taggedPreview tag l s = Err.note tag $ preview l s

main :: IO ()
main = do
  progName <- getProgName
  Opt.execParser (cliParser progName version) >>= run
  where
    run :: Options -> IO ()
    run opts = do
      let config = Giphy.GiphyConfig apiKey
      let app = getApp opts
      resp <- Giphy.runGiphy app config

      -- Get the first result and turn the left side into a String error
      let fstRes = resp & _Right %~ taggedPreview "No results found." _head
                        & _Left  %~ T.pack . show
                        & join

      -- Turn the right hand side into an Either.
      let fstUrl = fstRes & _Right %~ taggedPreview "No images attached."
                                      ( Giphy.gifImages
                                      . at "original"
                                      . traverse
                                      . Giphy.imageUrl
                                      . traverse )
                                    & join

      -- TODO: Understand lens actions and perform the fetch + tuple transform
      --       through it.
      let doReq uri = Wreq.get uri >>= (\resp' -> return (uri, resp'))
      resp' <- sequence $ doReq <$> (show <$> fstUrl)

      case resp' of
        Right r -> uncurry (printGif opts) r
        Left e -> TIO.hPutStrLn stderr $ "Error: " <> e

    getApp :: Options -> Giphy.Giphy [Giphy.Gif]
    getApp opts =
      case optMode opts of
        OptSearch s -> searchApp s
        OptTranslate t -> translateApp t
        OptRandom r -> randomApp r

    printGif :: Options -> String -> Wreq.Response BSL.ByteString -> IO ()
    printGif opts uri r = do
      unless (optNoPreview opts) $ do
        render <- getImageRenderer
        BS8.putStrLn . render $ consoleImage True (r ^. Wreq.responseBody)
      putStrLn uri

translateApp :: T.Text -> Giphy.Giphy [Giphy.Gif]
translateApp q = do
  resp <- Giphy.translate $ Giphy.Phrase q
  return . pure $ resp ^. Giphy.translateItem

searchApp :: T.Text -> Giphy.Giphy [Giphy.Gif]
searchApp q = do
  resp <- Giphy.search $ Giphy.Query q
  return $ resp ^. Giphy.searchItems

randomApp :: Maybe T.Text -> Giphy.Giphy [Giphy.Gif]
randomApp q = do
  resp <- Giphy.random $ Giphy.Tag <$> q
  return . pure $ resp ^. Giphy.randomGifItem