Error.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Pinboard.Error
-- Copyright   : (c) Jon Schoning, 2015
-- Maintainer  : jonschoning@gmail.com
-- Stability   : experimental
-- Portability : POSIX
module Pinboard.Error
  ( MonadErrorPinboard
  , defaultPinboardError
  , pinboardExceptionToEither
  , pinboardExceptionToMonadError
  , exceptionToMonadErrorPinboard
  , tryMonadError
  , eitherToMonadError
  , eitherToMonadThrow
  , PinboardErrorHTTPCode(..)
  , PinboardErrorType(..)
  , PinboardErrorCode(..)
  , PinboardError(..)
  ) where

import Data.Text (Text, pack)

import Data.Monoid
import Prelude

import Control.Exception.Safe
import Control.Monad.Error.Class (MonadError, throwError)

------------------------------------------------------------------------------
data PinboardErrorHTTPCode
  = BadRequest -- ^ 400
  | UnAuthorized -- ^ 401
  | RequestFailed -- ^ 402
  | Forbidden -- ^ 403
  | NotFound -- ^ 404
  | TooManyRequests -- ^ 429
  | PinboardServerError -- ^ (>=500)
  | UnknownHTTPCode -- ^ All other codes
  deriving (Show)

------------------------------------------------------------------------------
data PinboardErrorType
  = ConnectionFailure
  | HttpStatusFailure
  | ParseFailure
  | UnknownErrorType
  deriving (Eq, Show)

------------------------------------------------------------------------------
data PinboardErrorCode =
  UnknownError
  deriving (Show)

------------------------------------------------------------------------------
data PinboardError = PinboardError
  { errorType :: PinboardErrorType
  , errorMsg :: !Text
  , errorCode :: Maybe PinboardErrorCode
  , errorParam :: Maybe Text
  , errorHTTP :: Maybe PinboardErrorHTTPCode
  } deriving (Show)

instance Exception PinboardError

type MonadErrorPinboard m = MonadError PinboardError m

defaultPinboardError :: PinboardError
defaultPinboardError = PinboardError UnknownErrorType mempty Nothing Nothing Nothing

pinboardExceptionToEither
  :: MonadCatch m
  => m (Either PinboardError a) -> m (Either PinboardError a)
pinboardExceptionToEither = handle (\(e :: PinboardError) -> return (Left e))

tryMonadError
  :: (Exception e, MonadCatch m, MonadError e r)
  => m a -> m (r a)
tryMonadError a = eitherToMonadError <$> try a

pinboardExceptionToMonadError
  :: (MonadCatch m, MonadErrorPinboard e)
  => m (e a) -> m (e a)
pinboardExceptionToMonadError =
  handle (\(e :: PinboardError) -> return (throwError e))

exceptionToMonadErrorPinboard
  :: (MonadCatch m, MonadErrorPinboard e)
  => m (e a) -> m (e a)
exceptionToMonadErrorPinboard =
  handle
    (\(e :: SomeException) ->
        return $
        throwError $
        defaultPinboardError
        { errorMsg = (pack . show) e
        })

eitherToMonadError
  :: MonadError e m
  => Either e a -> m a
eitherToMonadError = either throwError return

eitherToMonadThrow
  :: (Exception e, MonadThrow m)
  => Either e a -> m a
eitherToMonadThrow = either throw return