diff --git a/hw-uri.cabal b/hw-uri.cabal --- a/hw-uri.cabal +++ b/hw-uri.cabal @@ -1,7 +1,7 @@ cabal-version: 2.4 name: hw-uri -version: 0.1.1.11 +version: 0.2.0.0 synopsis: Supports IO on URIs description: Supports IO on URIs. homepage: https://github.com/haskell-works/hw-uri @@ -24,10 +24,11 @@ common amazonka { build-depends: amazonka >= 1.6.1 && < 1.7 } common amazonka-core { build-depends: amazonka-core >= 1.6.1 && < 1.7 } common amazonka-s3 { build-depends: amazonka-s3 >= 1.6.1 && < 1.7 } -common antiope-core { build-depends: antiope-core >= 7.4.4 && < 8 } -common antiope-s3 { build-depends: antiope-s3 >= 7.4.4 && < 8 } +common antiope-core { build-depends: antiope-core >= 7.4.5 && < 8 } +common antiope-s3 { build-depends: antiope-s3 >= 7.4.5 && < 8 } common antiope-optparse-applicative { build-depends: antiope-optparse-applicative >= 7.0.1 && < 8 } common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.11 } +common deepseq { build-depends: deepseq >= 1.4 && < 1.5 } common directory { build-depends: directory >= 1.3.3.0 && < 1.4 } common dlist { build-depends: dlist >= 0.8.0.7 && < 0.9 } common exceptions { build-depends: exceptions >= 0.10.1 && < 0.11 } @@ -59,6 +60,7 @@ , antiope-core , antiope-s3 , bytestring + , deepseq , directory , dlist , exceptions @@ -85,6 +87,7 @@ HaskellWorks.Data.Uri.IO.Static HaskellWorks.Data.Uri.Location HaskellWorks.Data.Uri.Show + HaskellWorks.Data.Uri.Status HaskellWorks.Data.Uri.Text HaskellWorks.Data.Uri.UriError diff --git a/src/HaskellWorks/Data/Uri/IO/Lazy.hs b/src/HaskellWorks/Data/Uri/IO/Lazy.hs --- a/src/HaskellWorks/Data/Uri/IO/Lazy.hs +++ b/src/HaskellWorks/Data/Uri/IO/Lazy.hs @@ -32,6 +32,7 @@ import Data.Text (Text) import HaskellWorks.Data.Uri.Location (Location (..)) import HaskellWorks.Data.Uri.Show +import HaskellWorks.Data.Uri.Status import HaskellWorks.Data.Uri.UriError import qualified Antiope.S3 as AWS @@ -60,14 +61,14 @@ handleAwsError :: MonadCatch m => m a -> m (Either UriError a) handleAwsError f = catch (Right <$> f) $ \(e :: AWS.Error) -> case e of - (AWS.ServiceError (AWS.ServiceError' _ s _ _ _ _)) -> return (Left (AwsUriError s)) + (AWS.ServiceError (AWS.ServiceError' _ s _ _ _ _)) -> return (Left (AwsUriError (fromHttpStatus s))) _ -> throwM e handleHttpError :: MonadCatch m => m a -> m (Either UriError a) handleHttpError f = catch (Right <$> f) $ \(e :: HTTP.HttpException) -> case e of (HTTP.HttpExceptionRequest _ e') -> case e' of - HTTP.StatusCodeException resp _ -> return (Left (HttpUriError (resp & HTTP.responseStatus))) + HTTP.StatusCodeException resp _ -> return (Left (HttpUriError (fromHttpStatus (resp & HTTP.responseStatus)))) _ -> return (Left (GenericUriError (tshow e'))) _ -> throwM e diff --git a/src/HaskellWorks/Data/Uri/Location.hs b/src/HaskellWorks/Data/Uri/Location.hs --- a/src/HaskellWorks/Data/Uri/Location.hs +++ b/src/HaskellWorks/Data/Uri/Location.hs @@ -1,4 +1,5 @@ {-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -25,6 +26,7 @@ import Antiope.Core (ToText (..), fromText) import Antiope.S3 (ObjectKey (..), S3Uri (..)) import Control.Applicative +import Control.DeepSeq import Control.Lens ((%~), (&), (^.)) import Data.Aeson import Data.Generics.Product.Any @@ -53,7 +55,7 @@ = S3 S3Uri | Local FilePath | HttpUri Text - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, NFData) instance ToJSON Location where toJSON v = case v of diff --git a/src/HaskellWorks/Data/Uri/Status.hs b/src/HaskellWorks/Data/Uri/Status.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/Data/Uri/Status.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveAnyClass #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE TypeApplications #-} + +module HaskellWorks.Data.Uri.Status + ( Status(..) + , fromHttpStatus + ) where + +import Control.DeepSeq +import Data.ByteString (ByteString) +import Data.Typeable +import GHC.Generics + +import qualified Network.HTTP.Types.Status as HTTP + +data Status = Status + { statusCode :: Int + , statusMessage :: ByteString + } deriving (Show, Typeable, Generic, NFData) + +instance Eq Status where + Status { statusCode = a } == Status { statusCode = b } = a == b + +instance Ord Status where + compare Status { statusCode = a } Status { statusCode = b } = a `compare` b + +fromHttpStatus :: HTTP.Status -> Status +fromHttpStatus s = Status + { statusCode = HTTP.statusCode s + , statusMessage = HTTP.statusMessage s + } diff --git a/src/HaskellWorks/Data/Uri/UriError.hs b/src/HaskellWorks/Data/Uri/UriError.hs --- a/src/HaskellWorks/Data/Uri/UriError.hs +++ b/src/HaskellWorks/Data/Uri/UriError.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} @@ -7,27 +8,28 @@ , uriErrorStatus ) where -import Data.Semigroup ((<>)) +import Control.DeepSeq +import Data.Semigroup ((<>)) import Data.String -import Data.Text (Text) +import Data.Text (Text) import GHC.Generics import HaskellWorks.Data.Uri.Show +import HaskellWorks.Data.Uri.Status -import qualified Data.Text as T -import qualified Network.HTTP.Types as HTTP +import qualified Data.Text as T data UriError = AwsUriError - { status :: HTTP.Status + { status :: Status } | HttpUriError - { status :: HTTP.Status + { status :: Status } | RetriesFailedUriError | NotFound | DeleteFailed Text | GenericUriError Text - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance IsString UriError where fromString = GenericUriError . T.pack @@ -41,5 +43,5 @@ displayUriError (DeleteFailed msg) = "Delete failed: " <> msg uriErrorStatus :: UriError -> Maybe Int -uriErrorStatus (AwsUriError (HTTP.Status statusCode _)) = Just statusCode -uriErrorStatus _ = Nothing +uriErrorStatus (AwsUriError (Status statusCode _)) = Just statusCode +uriErrorStatus _ = Nothing diff --git a/test/HaskellWorks/Data/Uri/AwsSpec.hs b/test/HaskellWorks/Data/Uri/AwsSpec.hs --- a/test/HaskellWorks/Data/Uri/AwsSpec.hs +++ b/test/HaskellWorks/Data/Uri/AwsSpec.hs @@ -12,6 +12,7 @@ import Control.Monad.IO.Class import Data.Maybe (isJust) import HaskellWorks.Data.Uri.IO.Lazy +import HaskellWorks.Data.Uri.Status import HaskellWorks.Data.Uri.UriError import HaskellWorks.Hspec.Hedgehog import Hedgehog @@ -19,7 +20,6 @@ import qualified Antiope.S3.Types as AWS import qualified Data.ByteString.Lazy.Char8 as LBSC -import qualified Network.HTTP.Types as HTTP import qualified System.Environment as IO {-# ANN module ("HLint: ignore Redundant do" :: String) #-} @@ -34,5 +34,5 @@ envAws <- liftIO $ mkEnv Oregon (const LBSC.putStrLn) result <- liftIO $ runResourceT $ headS3Uri envAws $ AWS.S3Uri "jky-mayhem" "hjddhd" result === Left AwsUriError - { status = HTTP.Status { HTTP.statusCode = 404 , HTTP.statusMessage = "Not Found" } + { status = Status { statusCode = 404 , statusMessage = "Not Found" } }