Reddit.hs

module Reddit.Types.Reddit
  ( Reddit
  , RedditT(..)
  , RedditF(..)
  , runRoute
  , receiveRoute
  , nest
  , failWith
  , withBaseURL
  , withHeaders
  , Modhash(..)
  , LoginDetails(..)
  , POSTWrapped(..)
  , ShouldRateLimit
  , RateLimits(RateLimits, should, info)
  , RateLimitInfo(..)
  , headersToRateLimitInfo
  , ClientParams(..)
  , mkClientParamsHeader
  , mainBaseURL
  , loginBaseURL
  , addAPIType
  ) where

import Reddit.Types.Error

import Control.Applicative
import Control.Monad.IO.Class
import Control.Monad.Trans.Free
import Control.Monad.Trans.Class
import Data.Aeson
import Data.ByteString.Lazy (ByteString)
import Data.Monoid
import Data.Text (Text)
import Data.Time.Clock
import Network.API.Builder hiding (runRoute)
import Network.HTTP.Client hiding (path)
import Network.HTTP.Types
import Prelude
import Text.Read (readMaybe)
import qualified Data.ByteString.Char8 as BS
import qualified Data.Text.Encoding as Text

type Reddit a = RedditT IO a

data RedditF m a where
  FailWith :: APIError RedditError -> RedditF m a
  Nest :: RedditT m b -> (Either (APIError RedditError) b -> a) -> RedditF m a
  NestResuming :: RedditT m b -> (Either (APIError RedditError, Maybe (RedditT m b)) b -> a) -> RedditF m a
  ReceiveRoute :: Receivable b => Route -> (b -> a) -> RedditF m a
  RunRoute :: FromJSON b => Route -> (b -> a) -> RedditF m a
  WithBaseURL :: Text -> RedditT m b -> (b -> a) -> RedditF m a
  WithHeaders :: ([Header] -> [Header]) -> RedditT m b -> (b -> a) -> RedditF m a

instance Functor (RedditF m) where
  fmap _ (FailWith x) = FailWith x
  fmap f (Nest a x) = Nest a (fmap f x)
  fmap f (NestResuming a x) = NestResuming a (fmap f x)
  fmap f (ReceiveRoute r x) = ReceiveRoute r (fmap f x)
  fmap f (RunRoute r x) = RunRoute r (fmap f x)
  fmap f (WithBaseURL u a x) = WithBaseURL u a (fmap f x)
  fmap f (WithHeaders hf a x) = WithHeaders hf a (fmap f x)

newtype RedditT m a = RedditT (FreeT (RedditF m) m a)
  deriving (Functor, Applicative, Monad)

instance MonadTrans RedditT where
  lift = RedditT . lift

instance MonadIO m => MonadIO (RedditT m) where
  liftIO = RedditT . liftIO

runRoute :: (FromJSON a, Monad m) => Route -> RedditT m a
runRoute r = RedditT $ liftF $ RunRoute r id

receiveRoute :: (Receivable a, Monad m) => Route -> RedditT m a
receiveRoute r = RedditT $ liftF $ ReceiveRoute r id

nest :: Monad m => RedditT m a -> RedditT m (Either (APIError RedditError) a)
nest f = RedditT $ liftF $ Nest f id

withBaseURL :: Monad m => Text -> RedditT m a -> RedditT m a
withBaseURL u f = RedditT $ liftF $ WithBaseURL u f id

withHeaders :: Monad m => ([Header] -> [Header]) -> RedditT m a -> RedditT m a
withHeaders u f = RedditT $ liftF $ WithHeaders u f id

failWith :: Monad m => APIError RedditError -> RedditT m a
failWith = RedditT . liftF . FailWith

newtype Modhash = Modhash Text
  deriving (Show, Read, Eq)

instance FromJSON Modhash where
  parseJSON (Object o) =
    Modhash <$> ((o .: "json") >>= (.: "data") >>= (.: "modhash"))
  parseJSON _ = mempty

data LoginDetails = LoginDetails Modhash CookieJar
  deriving (Show)

instance Receivable LoginDetails where
  receive x = do
    (resp, mh) <- receive x
    return $ LoginDetails (unwrapJSON mh) (responseCookieJar (resp :: Response ByteString))

newtype POSTWrapped a = POSTWrapped a
  deriving (Show, Read, Eq)

instance Functor POSTWrapped where
  fmap f (POSTWrapped a) = POSTWrapped (f a)

data RateLimits =
  RateLimits { should :: ShouldRateLimit
             , info :: Maybe RateLimitInfo }
  deriving (Show, Read, Eq)

type ShouldRateLimit = Bool

data RateLimitInfo = RateLimitInfo { used :: Integer
                                   , remaining :: Integer
                                   , resetTime :: UTCTime }
  deriving (Show, Read, Eq)

headersToRateLimitInfo :: ResponseHeaders -> UTCTime -> Maybe RateLimitInfo
headersToRateLimitInfo hs now =
  RateLimitInfo <$> rlUsed <*> rlRemaining <*> rlResetTime'
  where (rlUsed, rlRemaining, rlResetTime) =
          trimap extract ("x-ratelimit-used", "x-ratelimit-remaining", "x-ratelimit-reset")
        rlResetTime' = fmap (\s -> addUTCTime (fromIntegral s) now) rlResetTime
        extract s = lookup s hs >>= readMaybe . BS.unpack
        trimap f (a, b, c) = (f a, f b, f c)

data ClientParams = ClientParams Text Text
  deriving (Show, Read, Eq, Ord)

mkClientParamsHeader :: ClientParams -> (HeaderName, BS.ByteString)
mkClientParamsHeader (ClientParams i s) = ("Authorization", Text.encodeUtf8 $ i <> ":" <> s)

addAPIType :: Route -> Route
addAPIType (Route fs ps m) = Route fs ("api_type" =. ("json" :: Text) : ps) m

mainBaseURL :: Text
mainBaseURL = "https://api.reddit.com"

loginBaseURL :: Text
loginBaseURL = "https://ssl.reddit.com"