diff --git a/integration/Main.hs b/integration/Main.hs --- a/integration/Main.hs +++ b/integration/Main.hs @@ -1,11 +1,10 @@ module Main where -import Test.Tasty (TestTree, defaultMain, testGroup) - import Polysemy.Http.CookieTest (test_cookies) import Polysemy.Http.RequestTest (test_request) import Polysemy.Http.StreamTest (test_httpStream) import Polysemy.Http.Test (unitTest) +import Test.Tasty (TestTree, defaultMain, testGroup) tests :: TestTree tests = diff --git a/integration/Polysemy/Http/CookieTest.hs b/integration/Polysemy/Http/CookieTest.hs --- a/integration/Polysemy/Http/CookieTest.hs +++ b/integration/Polysemy/Http/CookieTest.hs @@ -3,6 +3,8 @@ import Control.Lens ((.~)) import Hedgehog (evalEither, (===)) import Polysemy (embedToFinal, runFinal) +import Polysemy.Log (interpretLogNull) +import Polysemy.Resource (resourceToIOFinal) import qualified Polysemy.Http.Data.Http as Http import Polysemy.Http.Data.HttpError (HttpError) @@ -10,13 +12,11 @@ import Polysemy.Http.Data.Request (Port(Port), Tls(Tls)) import qualified Polysemy.Http.Data.Response as Response import Polysemy.Http.Data.Response (Response) -import Polysemy.Http.Log (interpretLogNull) import Polysemy.Http.Native (interpretHttpNative) import qualified Polysemy.Http.Request as Request import Polysemy.Http.Request (addCookie) import Polysemy.Http.Server (withServer) import Polysemy.Http.Test (UnitTest) -import Polysemy.Resource (resourceToIOFinal) c1, c1v, c2, c2v :: Text c1 = "c1" diff --git a/integration/Polysemy/Http/RequestTest.hs b/integration/Polysemy/Http/RequestTest.hs --- a/integration/Polysemy/Http/RequestTest.hs +++ b/integration/Polysemy/Http/RequestTest.hs @@ -4,6 +4,8 @@ import qualified Data.Aeson as Aeson import Hedgehog (evalEither, (===)) import Polysemy (embedToFinal, runFinal) +import Polysemy.Log (interpretLogNull) +import Polysemy.Resource (resourceToIOFinal) import qualified Polysemy.Http.Data.Http as Http import Polysemy.Http.Data.HttpError (HttpError) @@ -12,12 +14,10 @@ import qualified Polysemy.Http.Data.Response as Response import Polysemy.Http.Data.Response (Response) import Polysemy.Http.Json (jsonContentType) -import Polysemy.Http.Log (interpretLogNull) import Polysemy.Http.Native (interpretHttpNative) import qualified Polysemy.Http.Request as Request import Polysemy.Http.Server (Payload(Payload), withServer) import Polysemy.Http.Test (UnitTest) -import Polysemy.Resource (resourceToIOFinal) runRequest :: Int -> diff --git a/integration/Polysemy/Http/StreamTest.hs b/integration/Polysemy/Http/StreamTest.hs --- a/integration/Polysemy/Http/StreamTest.hs +++ b/integration/Polysemy/Http/StreamTest.hs @@ -4,7 +4,7 @@ import qualified Data.ByteString as ByteString import Hedgehog (assert, evalEither, (===)) import Polysemy (embedToFinal, runFinal) -import Polysemy.Http.Log (interpretLogStdout) +import Polysemy.Log (interpretLogNull) import Polysemy.Resource (resourceToIOFinal) import Polysemy.State (runState) @@ -49,7 +49,7 @@ embedToFinal $ runError @HttpError $ runState empty $ - interpretLogStdout $ + interpretLogNull $ interpretHttpNative $ Http.streamResponse (req port) handle diff --git a/lib/Polysemy/Http.hs b/lib/Polysemy/Http.hs --- a/lib/Polysemy/Http.hs +++ b/lib/Polysemy/Http.hs @@ -44,11 +44,10 @@ -- * Utilities -- ** Connection Pool module Polysemy.Http.Data.Manager, - -- ** Logging - module Polysemy.Http.Data.Log, - module Polysemy.Http.Log, ) where +import Prelude hiding (get, put) + import Polysemy.Http.AesonEntity (interpretEntityDecodeAeson, interpretEntityEncodeAeson) import Polysemy.Http.Data.Entity ( Decode, @@ -67,7 +66,6 @@ import Polysemy.Http.Data.Header (Header(..), HeaderName(..), HeaderValue(..)) import Polysemy.Http.Data.Http (Http, request, response, stream) import Polysemy.Http.Data.HttpError (HttpError(..)) -import Polysemy.Http.Data.Log (Log) import Polysemy.Http.Data.Manager (Manager) import Polysemy.Http.Data.Request ( Body(..), @@ -90,7 +88,6 @@ ) import Polysemy.Http.Data.StreamEvent (StreamEvent(..)) import Polysemy.Http.Http (streamResponse) -import Polysemy.Http.Log (interpretLogNull, interpretLogStdout) import Polysemy.Http.Native (interpretHttpNative) import Polysemy.Http.Request ( addCookie, @@ -110,13 +107,13 @@ withTls, ) import Polysemy.Http.Strict (interpretHttpStrict) -import Prelude hiding (get, put) -- $intro -- A basic 'Polysemy' effect abstracting HTTP requests: -- -- @ -- import Polysemy (resourceToIO, runM) +-- import Polysemy.Log.Colog (interpretLogStdout) -- import qualified Polysemy.Http as Http -- import Polysemy.Http (interpretHttpNative, interpretLogStdout) -- diff --git a/lib/Polysemy/Http/Data/Log.hs b/lib/Polysemy/Http/Data/Log.hs deleted file mode 100644 --- a/lib/Polysemy/Http/Data/Log.hs +++ /dev/null @@ -1,54 +0,0 @@ -module Polysemy.Http.Data.Log where - -import Polysemy.Internal (send) - --- |An effect that wraps 'Colog.Polysemy.Log' for less boilerplate. --- Constructors are manual because 'HasCallStack' is always in scope. -data Log :: Effect where - Debug :: HasCallStack => Text -> Log m () - Info :: HasCallStack => Text -> Log m () - Warn :: HasCallStack => Text -> Log m () - Error :: HasCallStack => Text -> Log m () - ErrorPlus :: (HasCallStack, Traversable t) => Text -> t Text -> Log m () - -debug :: - HasCallStack => - Member Log r => - Text -> - Sem r () -debug = - send . Debug - -info :: - HasCallStack => - Member Log r => - Text -> - Sem r () -info = - send . Info - -warn :: - HasCallStack => - Member Log r => - Text -> - Sem r () -warn = - send . Warn - -error :: - HasCallStack => - Member Log r => - Text -> - Sem r () -error = - send . Error - -errorPlus :: - HasCallStack => - Traversable t => - Member Log r => - Text -> - t Text -> - Sem r () -errorPlus = - send .: ErrorPlus diff --git a/lib/Polysemy/Http/Log.hs b/lib/Polysemy/Http/Log.hs deleted file mode 100644 --- a/lib/Polysemy/Http/Log.hs +++ /dev/null @@ -1,122 +0,0 @@ -module Polysemy.Http.Log where - -import Colog.Core (LogAction(LogAction), Severity, cmapM) -import qualified Colog.Core as Severity (Severity(Error, Info, Debug, Warning)) -import qualified Colog.Polysemy as Colog (Log, log) -import Colog.Polysemy.Effect (runLogAction) -import qualified Data.ByteString.Char8 as BS8 -import GHC.Stack (SrcLoc(SrcLoc), popCallStack, srcLocModule, srcLocStartLine) -import System.Console.ANSI (Color (..), ColorIntensity (Vivid), ConsoleLayer (Foreground), SGR (..), setSGRCode) - -import Polysemy.Http.Data.Log (Log(..)) - -data Message = - Message { - msgSeverity :: !Severity, - msgStack :: !CallStack, - msgText :: !Text - } - -showSeverity :: Severity -> Text -showSeverity = \case - Severity.Debug -> color Green "[Debug] " - Severity.Info -> color Blue "[Info] " - Severity.Warning -> color Yellow "[Warning] " - Severity.Error -> color Red "[Error] " - where - color :: Color -> Text -> Text - color c txt = - toText (setSGRCode [SetColor Foreground Vivid c]) <> - txt <> - toText (setSGRCode [Reset]) - -showSourceLoc :: CallStack -> Text -showSourceLoc cs = - square showCallStack - where - showCallStack :: Text - showCallStack = case getCallStack cs of - [] -> "" - [(name, loc)] -> showLoc name loc - (_, loc) : (callerName, _) : _ -> showLoc callerName loc - square t = "[" <> t <> "] " - showLoc :: String -> SrcLoc -> Text - showLoc name SrcLoc{..} = - toText srcLocModule <> "." <> toText name <> "#" <> show srcLocStartLine - -fmtRichMessageDefault :: Message -> IO Text -fmtRichMessageDefault = - pure . formatRichMessage - where - formatRichMessage :: Message -> Text - formatRichMessage Message{..} = - showSeverity msgSeverity - <> showSourceLoc msgStack - <> msgText - -logByteStringStdout :: LogAction IO ByteString -logByteStringStdout = LogAction BS8.putStrLn - -richMessageAction :: LogAction IO Message -richMessageAction = - cmapM (fmap encodeUtf8 . fmtRichMessageDefault) logByteStringStdout -{-# INLINE richMessageAction #-} - -log :: - HasCallStack => - Member (Colog.Log Message) r => - Severity -> - Text -> - Sem r () -log severity text = - Colog.log (Message severity stack text) - where - stack = - popCallStack (popCallStack callStack) - --- |No-op interpreter for 'Log' -interpretLogNull :: - InterpreterFor Log r -interpretLogNull = - interpret \case - Debug _ -> unit - Info _ -> unit - Warn _ -> unit - Error _ -> unit - ErrorPlus _ _ -> unit -{-# INLINE interpretLogNull #-} - -runCologStdout :: - Member (Embed IO) r => - InterpreterFor (Colog.Log Message) r -runCologStdout = - runLogAction @IO richMessageAction -{-# INLINE runCologStdout #-} - -toColog :: - HasCallStack => - Member (Colog.Log Message) r => - Sem (Log : r) a -> - Sem r a -toColog = - interpret \case - Debug msg -> - log Severity.Debug msg - Info msg -> - log Severity.Info msg - Warn msg -> - log Severity.Warning msg - Error msg -> - log Severity.Error msg - ErrorPlus msg detailed -> - log Severity.Error msg *> traverse_ (log Severity.Debug) detailed -{-# INLINE toColog #-} - --- |Default interpreter for 'Log' that uses 'Colog.Log' to print to stdout -interpretLogStdout :: - Member (Embed IO) r => - Sem (Log : r) a -> - Sem r a -interpretLogStdout = - runCologStdout . toColog . raiseUnder -{-# INLINE interpretLogStdout #-} diff --git a/lib/Polysemy/Http/Native.hs b/lib/Polysemy/Http/Native.hs --- a/lib/Polysemy/Http/Native.hs +++ b/lib/Polysemy/Http/Native.hs @@ -6,8 +6,8 @@ import Network.HTTP.Client (BodyReader, httpLbs, responseClose, responseOpen) import Network.HTTP.Client.Internal (CookieJar(CJ)) import Polysemy (getInitialStateT, interpretH, runTSimple) -import qualified Polysemy.Http.Data.Log as Log -import Polysemy.Http.Data.Log (Log) +import qualified Polysemy.Log as Log +import Polysemy.Log (Log) import Polysemy.Resource (Resource, bracket) import Polysemy.Http.Data.Header (Header(Header), unHeaderName, unHeaderValue) diff --git a/polysemy-http.cabal b/polysemy-http.cabal --- a/polysemy-http.cabal +++ b/polysemy-http.cabal @@ -1,11 +1,11 @@ cabal-version: 2.2 --- This file has been generated from package.yaml by hpack version 0.34.2. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack name: polysemy-http -version: 0.4.0.0 +version: 0.4.0.1 synopsis: Polysemy effect for http-client description: Please see the README on Github at category: Network @@ -33,7 +33,6 @@ Polysemy.Http.Data.Header Polysemy.Http.Data.Http Polysemy.Http.Data.HttpError - Polysemy.Http.Data.Log Polysemy.Http.Data.Manager Polysemy.Http.Data.Request Polysemy.Http.Data.Response @@ -41,7 +40,6 @@ Polysemy.Http.Data.StreamEvent Polysemy.Http.Http Polysemy.Http.Json - Polysemy.Http.Log Polysemy.Http.Manager Polysemy.Http.Native Polysemy.Http.Prelude @@ -54,12 +52,63 @@ Paths_polysemy_http hs-source-dirs: lib - default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + UnicodeSyntax + ViewPatterns ghc-options: -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively -Wall -O2 build-depends: aeson >=1.4.4.0 , ansi-terminal >=0.9.1 - , base >=4 && <5 + , base ==4.* , bytestring , case-insensitive >=1.2 , co-log-core >=0.2.1 @@ -73,7 +122,8 @@ , http-types >=0.12.3 , lens >=4 , polysemy >=1.3.0 - , polysemy-plugin >=0.2.5.1 && <0.3 + , polysemy-log + , polysemy-plugin >=0.2.5.1 , relude >=0.5 && <0.8 , string-interpolate >=0.2.1 , template-haskell >=2.14.0 @@ -95,12 +145,63 @@ Paths_polysemy_http hs-source-dirs: integration - default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + UnicodeSyntax + ViewPatterns ghc-options: -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively -Wall -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=1.4.4.0 , ansi-terminal >=0.9.1 - , base >=4 && <5 + , base ==4.* , bytestring , case-insensitive >=1.2 , co-log-core >=0.2.1 @@ -117,7 +218,8 @@ , network , polysemy >=1.3.0 , polysemy-http - , polysemy-plugin >=0.2.5.1 && <0.3 + , polysemy-log + , polysemy-plugin >=0.2.5.1 , relude >=0.5 && <0.8 , servant , servant-client @@ -145,12 +247,63 @@ Paths_polysemy_http hs-source-dirs: test - default-extensions: AllowAmbiguousTypes ApplicativeDo BangPatterns BinaryLiterals BlockArguments ConstraintKinds DataKinds DefaultSignatures DeriveAnyClass DeriveDataTypeable DeriveFoldable DeriveFunctor DeriveGeneric DeriveTraversable DerivingVia DoAndIfThenElse EmptyDataDecls ExistentialQuantification FlexibleContexts FlexibleInstances FunctionalDependencies GADTs GeneralizedNewtypeDeriving InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns OverloadedStrings PackageImports PartialTypeSignatures PatternGuards PatternSynonyms PolyKinds QuantifiedConstraints QuasiQuotes RankNTypes RecordWildCards RecursiveDo ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeOperators TypeSynonymInstances UndecidableInstances UnicodeSyntax ViewPatterns + default-extensions: + AllowAmbiguousTypes + ApplicativeDo + BangPatterns + BinaryLiterals + BlockArguments + ConstraintKinds + DataKinds + DefaultSignatures + DeriveAnyClass + DeriveDataTypeable + DeriveFoldable + DeriveFunctor + DeriveGeneric + DeriveTraversable + DerivingVia + DoAndIfThenElse + EmptyDataDecls + ExistentialQuantification + FlexibleContexts + FlexibleInstances + FunctionalDependencies + GADTs + GeneralizedNewtypeDeriving + InstanceSigs + KindSignatures + LambdaCase + MultiParamTypeClasses + MultiWayIf + NamedFieldPuns + OverloadedStrings + PackageImports + PartialTypeSignatures + PatternGuards + PatternSynonyms + PolyKinds + QuantifiedConstraints + QuasiQuotes + RankNTypes + RecordWildCards + RecursiveDo + ScopedTypeVariables + StandaloneDeriving + TemplateHaskell + TupleSections + TypeApplications + TypeFamilies + TypeOperators + TypeSynonymInstances + UndecidableInstances + UnicodeSyntax + ViewPatterns ghc-options: -fplugin=Polysemy.Plugin -flate-specialise -fspecialise-aggressively -Wall -O2 -threaded -rtsopts -with-rtsopts=-N build-depends: aeson >=1.4.4.0 , ansi-terminal >=0.9.1 - , base >=4 && <5 + , base ==4.* , bytestring , case-insensitive >=1.2 , co-log-core >=0.2.1 @@ -166,7 +319,8 @@ , lens >=4 , polysemy >=1.3.0 , polysemy-http - , polysemy-plugin >=0.2.5.1 && <0.3 + , polysemy-log + , polysemy-plugin >=0.2.5.1 , relude >=0.5 && <0.8 , string-interpolate >=0.2.1 , tasty