{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE KindSignatures #-}
module Web.Giphy
(
Key(..)
, Query(..)
, Phrase(..)
, Tag(..)
, Pagination(..)
, GifId(..)
, Gif(..)
, Image(..)
, ImageMap()
, PaginationOffset(..)
, SearchResponse(..)
, SingleGifResponse(..)
, TranslateResponse(..)
, RandomResponse(..)
, GiphyConfig(..)
, Giphy()
, runGiphy
, runGiphy'
, gifId
, gifImages
, gifSlug
, gifUrl
, imageHeight
, imageUrl
, imageSize
, imageWidth
, imageMp4Url
, imageMp4Size
, imageWebpUrl
, imageWebpSize
, paginationCount
, paginationOffset
, paginationTotalCount
, searchItems
, searchPagination
, singleGifItem
, translateItem
, randomGifItem
, search
, searchOffset
, translate
, gif
, random
) where
import Control.Monad (MonadPlus (), forM, join, mzero)
import Control.Monad.Trans (MonadIO (), lift, liftIO)
import Data.Aeson ((.:), (.:?))
import Data.Functor ((<$>))
import Data.Monoid ((<>))
import GHC.Generics (Generic ())
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Servant.API ((:<|>) (..), (:>))
import qualified Control.Monad.Reader as Reader
import qualified Data.Aeson.Types as Aeson
import qualified Data.Map.Strict as Map
import qualified Data.Proxy as Proxy
import qualified Data.Text as T
import qualified Lens.Micro.TH as Lens
import qualified Network.HTTP.Client as HTTP
import qualified Network.URI as URI
import qualified Servant.API as Servant
import qualified Servant.Client as Servant
import qualified Text.Read as Read
import qualified Web.HttpApiData as Data
maybeParse :: MonadPlus m => (a -> Maybe b) -> m a -> m b
maybeParse f = (maybe mzero return . f =<<)
fromURI :: MonadPlus m => m String -> m Servant.URI
fromURI = maybeParse URI.parseURI
fromInt :: MonadPlus m => m String -> m Int
fromInt = maybeParse Read.readMaybe
newtype Key = Key T.Text
deriving (Data.ToHttpApiData, Data.FromHttpApiData, Show, Eq)
newtype Query = Query T.Text
deriving (Data.ToHttpApiData, Data.FromHttpApiData, Show, Eq)
newtype Phrase = Phrase T.Text
deriving (Data.ToHttpApiData, Data.FromHttpApiData, Show, Eq)
newtype Tag = Tag T.Text
deriving (Data.ToHttpApiData, Data.FromHttpApiData, Show, Eq)
newtype GifId = GifId T.Text
deriving (Data.ToHttpApiData, Data.FromHttpApiData, Show, Eq)
newtype PaginationOffset = PaginationOffset Int
deriving (Data.ToHttpApiData, Data.FromHttpApiData, Show, Eq)
data Image = Image {
_imageUrl :: Maybe URI.URI
, _imageSize :: Maybe Int
, _imageMp4Url :: Maybe URI.URI
, _imageMp4Size :: Maybe Int
, _imageWebpUrl :: Maybe URI.URI
, _imageWebpSize :: Maybe Int
, _imageWidth :: Maybe Int
, _imageHeight :: Maybe Int
} deriving (Show, Eq, Ord, Generic)
Lens.makeLenses ''Image
parseImageJSON :: T.Text -> Aeson.Object -> Aeson.Parser Image
parseImageJSON prefix o =
let p = if T.null prefix then "" else prefix <> "_"
in Image <$> (fromURI <$> (o .:? (p <> "url")))
<*> (fromInt <$> (o .:? (p <> "size")))
<*> (fromURI <$> (o .:? (p <> "mp4")))
<*> (fromInt <$> (o .:? (p <> "mp4_size")))
<*> (fromURI <$> (o .:? (p <> "webp")))
<*> (fromInt <$> (o .:? (p <> "webp_size")))
<*> (fromInt <$> (o .:? (p <> "width")))
<*> (fromInt <$> (o .:? (p <> "height")))
instance Aeson.FromJSON Image where
parseJSON (Aeson.Object o) = parseImageJSON "" o
parseJSON _ = error "Invalid image response."
type ImageMap = Map.Map T.Text Image
data Gif = Gif {
_gifId :: T.Text
, _gifSlug :: T.Text
, _gifUrl :: URI.URI
, _gifImages :: ImageMap
} deriving (Show, Eq, Ord, Generic)
Lens.makeLenses ''Gif
instance Aeson.FromJSON Gif where
parseJSON (Aeson.Object o) =
Gif <$> o .: "id"
<*> o .: "slug"
<*> fromURI (o .: "url")
<*> o .: "images"
parseJSON _ = error "Invalid GIF response."
data Pagination = Pagination {
_paginationTotalCount :: Int
, _paginationCount :: Int
, _paginationOffset :: Int
} deriving (Show, Eq, Ord, Generic)
Lens.makeLenses ''Pagination
instance Aeson.FromJSON Pagination where
parseJSON (Aeson.Object o) =
Pagination <$> o .: "total_count"
<*> o .: "count"
<*> o .: "offset"
parseJSON _ = error "Invalid pagination data."
data SearchResponse = SearchResponse {
_searchItems :: [Gif]
, _searchPagination :: Pagination
} deriving (Show, Eq, Ord, Generic)
Lens.makeLenses ''SearchResponse
instance Aeson.FromJSON SearchResponse where
parseJSON (Aeson.Object o) =
SearchResponse <$> o .: "data"
<*> o .: "pagination"
parseJSON _ = error "Invalid search response."
newtype TranslateResponse = TranslateResponse {
_translateItem :: Gif
} deriving (Show, Eq, Ord, Generic)
Lens.makeLenses ''TranslateResponse
instance Aeson.FromJSON TranslateResponse where
parseJSON (Aeson.Object o) =
TranslateResponse <$> o .: "data"
parseJSON _ = error "Invalid translate response."
newtype SingleGifResponse = SingleGifResponse {
_singleGifItem :: Gif
} deriving (Show, Eq, Ord, Generic)
Lens.makeLenses ''SingleGifResponse
instance Aeson.FromJSON SingleGifResponse where
parseJSON (Aeson.Object o) =
SingleGifResponse <$> o .: "data"
parseJSON _ = error "Invalid GIF response."
newtype RandomResponse = RandomResponse {
_randomGifItem :: Gif
} deriving (Show, Eq, Ord, Generic)
Lens.makeLenses ''RandomResponse
randomImageKeys :: [T.Text]
randomImageKeys = [ "fixed_height_downsampled"
, "fixed_height_small"
, "fixed_width_downsampled"
, "fixed_width_small"
, "fixed_width"
]
instance Aeson.FromJSON RandomResponse where
parseJSON (Aeson.Object o) =
RandomResponse <$> (mkGif =<< (o .: "data"))
where
mkGif :: Aeson.Object -> Aeson.Parser Gif
mkGif d =
Gif <$> d .: "id"
<*> pure ""
<*> fromURI (d .: "url")
<*> mkImageMap d
mkImageMap :: Aeson.Object -> Aeson.Parser ImageMap
mkImageMap = (Map.fromList <$>) . forM keys . uncurry . extractImage
where
dup = join (,)
keys = ("image", "original") : (dup <$> randomImageKeys)
extractImage :: Aeson.Object -> T.Text -> T.Text -> Aeson.Parser (T.Text, Image)
extractImage d key tag = (,) <$> pure tag <*> parseImageJSON key d
parseJSON _ = error "Invalid GIF response."
type GiphyAPI = "search"
:> Servant.QueryParam "api_key" Key
:> Servant.QueryParam "offset" PaginationOffset
:> Servant.QueryParam "q" Query
:> Servant.Get '[Servant.JSON] SearchResponse
:<|> "translate"
:> Servant.QueryParam "api_key" Key
:> Servant.QueryParam "s" Phrase
:> Servant.Get '[Servant.JSON] TranslateResponse
:<|> Servant.Capture "gif_id" GifId
:> Servant.QueryParam "api_key" Key
:> Servant.Get '[Servant.JSON] SingleGifResponse
:<|> "random"
:> Servant.QueryParam "api_key" Key
:> Servant.QueryParam "tag" Tag
:> Servant.Get '[Servant.JSON] RandomResponse
api :: Proxy.Proxy GiphyAPI
api = Proxy.Proxy
baseUrl :: Servant.BaseUrl
baseUrl = Servant.BaseUrl Servant.Https "api.giphy.com" 443 "/v1/gifs/"
search'
:: Maybe Key
-> Maybe PaginationOffset
-> Maybe Query
-> Servant.ClientM SearchResponse
translate'
:: Maybe Key
-> Maybe Phrase
-> Servant.ClientM TranslateResponse
gif'
:: GifId
-> Maybe Key
-> Servant.ClientM SingleGifResponse
random'
:: Maybe Key
-> Maybe Tag
-> Servant.ClientM RandomResponse
search' :<|> translate' :<|> gif' :<|> random' = Servant.client api
search
:: Query
-> Giphy SearchResponse
search query = do
key <- Reader.asks (configApiKey . ctxConfig)
lift $ search' (pure key) (pure $ PaginationOffset 0) (pure query)
searchOffset
:: Query
-> PaginationOffset
-> Giphy SearchResponse
searchOffset query offset = do
key <- Reader.asks (configApiKey . ctxConfig)
lift $ search' (pure key) (pure offset) (pure query)
gif
:: GifId
-> Giphy SingleGifResponse
gif gifid = do
key <- Reader.asks (configApiKey . ctxConfig)
lift $ gif' gifid (pure key)
translate
:: Phrase
-> Giphy TranslateResponse
translate phrase = do
key <- Reader.asks (configApiKey . ctxConfig)
lift $ translate' (pure key) (pure phrase)
random
:: Maybe Tag
-> Giphy RandomResponse
random tag = do
key <- Reader.asks (configApiKey . ctxConfig)
lift $ random' (pure key) tag
newtype GiphyConfig = GiphyConfig { configApiKey :: Key }
deriving (Show, Eq)
newtype GiphyContext = GiphyContext { ctxConfig :: GiphyConfig }
type Giphy = Reader.ReaderT GiphyContext Servant.ClientM
runGiphy :: MonadIO m => Giphy a -> GiphyConfig -> m (Either Servant.ClientError a)
runGiphy g conf = do
manager <- liftIO $ HTTP.newManager tlsManagerSettings
runGiphy' manager g conf
runGiphy'
:: MonadIO m
=> HTTP.Manager
-> Giphy a
-> GiphyConfig
-> m (Either Servant.ClientError a)
runGiphy' manager giphy conf =
let env = Servant.ClientEnv manager baseUrl Nothing
runClientM' = flip Servant.runClientM
in
liftIO . runClientM' env . Reader.runReaderT giphy $ GiphyContext conf