{-# OPTIONS_GHC
  -fno-warn-deprecations
  -fno-warn-orphans
  #-}
{-# LANGUAGE
    CPP
  , DeriveFunctor
  , FlexibleContexts
  , FlexibleInstances
  , GeneralizedNewtypeDeriving
  , MultiParamTypeClasses
  , TypeFamilies
  , UndecidableInstances
  #-}
#if MIN_VERSION_base(4,9,0)
{-# OPTIONS_GHC -Wno-redundant-constraints #-}
#endif

module Rest.Client.Base
  ( ApiInfo(..)
  , ApiState(..)
  , ApiT(..)
  , Api
  , ApiStateC(..)
  , runT
  , run
  , runWithPort
  , ApiResponse(..)
  , responseToMaybe
  ) where

#if !MIN_VERSION_base(4,6,0)
import Prelude hiding (catch)
#endif

import Control.Monad.Base
import Control.Monad.Catch (MonadCatch (catch))
import Control.Monad.Cont hiding (mapM)
import Control.Monad.Error hiding (mapM)
import Control.Monad.List hiding (mapM)
import Control.Monad.RWS hiding (mapM)
import Control.Monad.Reader hiding (mapM)
import Control.Monad.State hiding (mapM)
import Control.Monad.Trans.Control
import Control.Monad.Trans.Except (ExceptT)
import Control.Monad.Trans.Resource
import Control.Monad.Writer hiding (mapM)
import Data.ByteString
import Data.CaseInsensitive
import Network.HTTP.Conduit hiding (method, responseBody)
import Network.HTTP.Client (defaultManagerSettings)

import Rest.Types.Error

data ApiInfo =
  ApiInfo
   { manager :: Manager
   , apiHost :: String
   , apiPort :: Int
   , headers :: [(String, String)]
   }

newtype ApiState = ApiState { cookies :: CookieJar }

newtype ApiT m a = ApiT { unApiT :: StateT ApiState (ReaderT ApiInfo (ResourceT m)) a }
  deriving ( Applicative
           , Functor
           , Monad
           , MonadIO
           )

type Api = ApiT IO

class (MonadResource m, MonadBaseControl IO m, Monad m, Functor m, MonadBase IO m) => ApiStateC m where
  getApiState     :: m ApiState
  putApiState     :: ApiState -> m ()
  askApiInfo      :: m ApiInfo

instance (MonadBaseControl IO m, Monad m, Functor m, MonadBase IO m, MonadIO m, MonadThrow m) => ApiStateC (ApiT m) where
  getApiState    = ApiT get
  putApiState    = ApiT . put
  askApiInfo     = ApiT (lift ask)

instance MonadTrans ApiT where
  lift = ApiT . lift . lift . lift

instance MonadBase b m => MonadBase b (ApiT m) where
  liftBase = liftBaseDefault

#if MIN_VERSION_monad_control(1,0,0)
instance MonadTransControl ApiT where
  type StT ApiT a = StT ResourceT (StT (ReaderT ApiInfo) (StT (StateT ApiState) a))
  liftWith f = ApiT (liftWith (\runs -> liftWith (\runrr -> liftWith (\runrs -> f (runrs . runrr . runs . unApiT)))))
  restoreT = ApiT . restoreT . restoreT . restoreT

instance MonadBaseControl v m => MonadBaseControl v (ApiT m) where
  type StM (ApiT m) a = ComposeSt ApiT m a
  liftBaseWith = defaultLiftBaseWith
  restoreM     = defaultRestoreM
#else
instance MonadTransControl ApiT where
  newtype StT ApiT a = StTApiT { unStTApiT :: StT ResourceT (StT (ReaderT ApiInfo) (StT (StateT ApiState) a)) }
  liftWith f = ApiT (liftWith (\runs -> liftWith (\runrr -> liftWith (\runrs -> f (fmap StTApiT . runrs . runrr . runs . unApiT)))))
  restoreT = ApiT . restoreT . restoreT . restoreT . fmap unStTApiT

instance MonadBaseControl v m => MonadBaseControl v (ApiT m) where
  newtype StM (ApiT m) a = StMApiT { unStMApiT :: ComposeSt ApiT m a }
  liftBaseWith = defaultLiftBaseWith StMApiT
  restoreM     = defaultRestoreM unStMApiT
#endif

instance MonadThrow m => MonadThrow (ApiT m) where throwM = ApiT . lift . lift . lift . throwM

instance MonadCatch m => MonadCatch (ApiT m) where catch c f = ApiT (unApiT c `catch` (unApiT . f))

instance (MonadIO m, MonadThrow m, MonadBase IO m, Functor m, Applicative m) => MonadResource (ApiT m) where
  liftResourceT = ApiT . lift . lift . transResourceT liftIO

instance ApiStateC m => ApiStateC (ExceptT e m) where
  getApiState = lift getApiState
  askApiInfo  = lift askApiInfo
  putApiState = lift . putApiState

instance (Error e, ApiStateC m) => ApiStateC (ErrorT e m) where
  getApiState = lift getApiState
  askApiInfo  = lift askApiInfo
  putApiState = lift . putApiState

instance (Monoid w, ApiStateC m) => ApiStateC (RWST r w s m) where
  getApiState = lift getApiState
  askApiInfo  = lift askApiInfo
  putApiState = lift . putApiState

instance (Monoid w, ApiStateC m) => ApiStateC (WriterT w m) where
  getApiState = lift getApiState
  askApiInfo  = lift askApiInfo
  putApiState = lift . putApiState

instance ApiStateC m => ApiStateC (ListT m) where
  getApiState = lift getApiState
  askApiInfo  = lift askApiInfo
  putApiState = lift . putApiState

instance ApiStateC m => ApiStateC (ReaderT r m) where
  getApiState = lift getApiState
  askApiInfo  = lift askApiInfo
  putApiState = lift . putApiState

instance ApiStateC m => ApiStateC (StateT s m) where
  getApiState = lift getApiState
  askApiInfo  = lift askApiInfo
  putApiState = lift . putApiState

runT :: MonadBaseControl IO m => ApiInfo -> ApiState -> ApiT m a -> ResourceT m a
runT inf st api = runReaderT (evalStateT (unApiT api) st) inf

run :: String -> ApiT IO a -> IO a
run = flip runWithPort 80

runWithPort :: String -> Int -> ApiT IO a -> IO a
runWithPort hst prt api = do
  m <- newManager defaultManagerSettings
  runResourceT $ do
    runT (ApiInfo m hst prt []) (ApiState (createCookieJar [])) api

data ApiResponse e a  =
  ApiResponse
    { statusCode      :: Int
    , statusMessage   :: ByteString
    , httpVersion     :: (Int, Int)
    , responseHeaders :: [(CI ByteString , ByteString)]
    , responseBody    :: Either (Reason e) a
    } deriving (Functor, Show)

responseToMaybe :: ApiResponse e a -> Maybe a
responseToMaybe = either (const Nothing) Just . responseBody