diff --git a/library/Magicbane.hs b/library/Magicbane.hs --- a/library/Magicbane.hs +++ b/library/Magicbane.hs @@ -1,19 +1,18 @@ {-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-signatures #-} -{-# LANGUAGE Trustworthy, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving, LambdaCase #-} +{-# LANGUAGE Trustworthy, NoMonomorphismRestriction, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances, LambdaCase #-} -- | A Dropwizard-inspired web framework that integrates -- Servant, monad-metrics/EKG, monad-logger/fast-logger, and other useful libraries -- to provide a smooth web service development experience. -- --- This module provides a ClassyPrelude based prelude with all the stuff you need reexported. +-- This module provides all the stuff you need. module Magicbane ( module X , module Magicbane ) where -import ClassyPrelude as X hiding (fromString, Handler, Concurrently, runConcurrently, concurrently, mapConcurrently, async, asyncWithUnmask, asyncBound, asyncOn, asyncOnWithUnmask, race, race_, withAsync, withAsyncBound, withAsyncOn, withAsyncOnWithUnmask, withAsyncWithUnmask, cancel, cancelWith) -import Control.Concurrent.Async.Lifted as X -- Classy reexports …Lifted.Safe which doesn't work with ExceptT import Control.Error.Util as X hiding (hoistEither, (??), tryIO, bool) +import Control.Monad.IO.Class import Control.Monad.Trans.Control as X import Control.Monad.Trans.Maybe as X hiding (liftListen, liftPass, liftCallCC) import qualified System.Envy @@ -25,6 +24,7 @@ import Data.String.Conversions.Monomorphic as X import Data.Aeson as X import Data.Aeson.QQ as X +import Data.Text (Text) import Text.RawString.QQ as X import Network.URI as X import qualified Network.HTTP.Link @@ -33,6 +33,7 @@ import Network.Wai as X (Application, Middleware) import Network.Wai.Cli as X hiding (port) import Magicbane.App as X hiding (Or) +import Magicbane.Async as X import Magicbane.Logging as X import Magicbane.Metrics as X import Magicbane.Validation as X @@ -54,7 +55,7 @@ -- (Does environment variable reading ever fail in practice? Probably not.) withEnvConfig ∷ FromEnv α ⇒ (α → IO ()) → IO () withEnvConfig a = decodeEnv >>= \case - Left e → hPutStrLn stderr ("error reading env: " ++ e) + Left e → hPutStrLn System.IO.stderr ("error reading env: " ++ e) Right c → a c hPutStrLn h s = liftIO $ System.IO.hPutStrLn h s diff --git a/library/Magicbane/App.hs b/library/Magicbane/App.hs --- a/library/Magicbane/App.hs +++ b/library/Magicbane/App.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-missing-signatures #-} -{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving, CPP #-} +{-# LANGUAGE NoMonomorphismRestriction, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving, CPP #-} -- | Extends Servant with context. -- Basically wrapping Servant in a ReaderT of your type. @@ -9,9 +9,13 @@ , module Magicbane.App ) where -import ClassyPrelude hiding (Handler) -import Control.Monad.Trans.Except as X +import Control.Exception.Safe hiding (Handler) +import Control.Monad.Base import Control.Monad.Error.Class as X (MonadError, throwError) +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Trans.Control +import Control.Monad.Trans.Except as X import Data.Proxy as X import Data.Has as X import Servant as X hiding (And) diff --git a/library/Magicbane/Async.hs b/library/Magicbane/Async.hs new file mode 100644 --- /dev/null +++ b/library/Magicbane/Async.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedStrings, UnicodeSyntax, FlexibleContexts #-} + +-- | 'Control.Monad.Except.ExceptT'-friendly concurrency +-- The selection of exposed functions matches "ClassyPrelude", but uses +-- "Control.Concurrent.Async.Lifted" instead of the 'Control.Monad.Except.ExceptT'-incompatible +-- "Control.Concurrent.Async.Lifted.Safe". +module Magicbane.Async ( + module Magicbane.Async +, module X +) where + +import Control.Concurrent.Lifted as X hiding (yield, throwTo) +import qualified Control.Concurrent.Lifted as Conc (yield) +import Control.Concurrent.Async as X (Async, waitSTM, pollSTM, waitCatchSTM) +import Control.Concurrent.Async.Lifted as X (async, asyncBound, asyncOn, asyncWithUnmask, asyncOnWithUnmask, withAsync, withAsyncBound, withAsyncOn, withAsyncWithUnmask, withAsyncOnWithUnmask, asyncThreadId, race, race_, concurrently, mapConcurrently, Concurrently (..)) +import Control.Monad.Base + +-- | Originally 'Conc.yield'. Renamed to avoid conflict with streaming libraries. +yieldThread :: MonadBase IO m => m () +yieldThread = Conc.yield +{-# INLINE yieldThread #-} diff --git a/library/Magicbane/HTTPClient.hs b/library/Magicbane/HTTPClient.hs --- a/library/Magicbane/HTTPClient.hs +++ b/library/Magicbane/HTTPClient.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, FlexibleContexts, FlexibleInstances, UndecidableInstances, ConstraintKinds #-} +{-# LANGUAGE OverloadedStrings, UnicodeSyntax, FlexibleContexts, FlexibleInstances, UndecidableInstances, ConstraintKinds #-} -- | Provides an HTTP(S) client via http-client(-tls) in a Magicbane app context. -- Also provides a simple composable interface for making arbitrary requests, based on http-client-conduit. @@ -9,12 +9,19 @@ , module X ) where -import ClassyPrelude +import Control.Exception.Safe +import Control.Monad.IO.Class +import Control.Monad.Reader +import Control.Monad.Trans.Control import Control.Monad.Trans.Except import Data.Has +import Data.Bifunctor +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as L (ByteString) import Data.Conduit import qualified Data.Conduit.Combinators as C import Data.String.Conversions +import Data.Text (Text, pack) import Network.URI as X import Network.HTTP.Types import Network.HTTP.Conduit as HC @@ -39,11 +46,11 @@ -- | Creates a request from a URI. reqU ∷ (MonadHTTP ψ μ) ⇒ URI → ExceptT Text μ Request -reqU uri = ExceptT $ return $ bimap tshow id $ setUri defaultRequest uri +reqU uri = ExceptT $ return $ bimap (pack.show) id $ setUri defaultRequest uri -- | Creates a request from a string of any type, parsing it into a URI. reqS ∷ (MonadHTTP ψ μ, ConvertibleStrings σ String) ⇒ σ → ExceptT Text μ Request -reqS uri = ExceptT $ return $ bimap tshow id $ parseUrlThrow $ cs uri +reqS uri = ExceptT $ return $ bimap (pack.show) id $ parseUrlThrow $ cs uri -- | Configures the request to not throw errors on error status codes. anyStatus ∷ (MonadHTTP ψ μ) ⇒ Request → ExceptT Text μ Request @@ -62,12 +69,12 @@ res ← lift $ tryAny $ HCC.withResponse req $ \res → do body ← fn $ responseBody res return res { responseBody = body } - ExceptT $ return $ bimap tshow id res + ExceptT $ return $ bimap (pack.show) id res -- | Performs the request, ignoring the body. performWithVoid ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → ExceptT Text μ (Response ()) performWithVoid = performWithFn (const $ return ()) -- | Performs the request, reading the body into a lazy ByteString. -performWithBytes ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → ExceptT Text μ (Response LByteString) +performWithBytes ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → ExceptT Text μ (Response L.ByteString) performWithBytes = performWithFn ($$ C.sinkLazy) diff --git a/library/Magicbane/Logging.hs b/library/Magicbane/Logging.hs --- a/library/Magicbane/Logging.hs +++ b/library/Magicbane/Logging.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings, UnicodeSyntax, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} -- | Provides logging via monad-logger/fast-logger in a Magicbane app context. module Magicbane.Logging ( @@ -7,9 +7,11 @@ , module X ) where -import ClassyPrelude import Data.Has +import Data.Monoid +import Control.Monad.IO.Class import Control.Monad.Logger as X +import Control.Monad.Reader import System.Log.FastLogger import System.Log.FastLogger as X (LogType(..), defaultBufSize) @@ -27,4 +29,4 @@ tc ← newTimeCache simpleTimeFormat' (fl, _) ← newTimedFastLogger tc logtype -- forget cleanup because the logger will exist for the lifetime of the (OS) process - return (fl, ModLogger $ \loc src lvl msg → fl (\t → toLogStr (t ++ " ") ++ defaultLogStr loc src lvl msg)) + return (fl, ModLogger $ \loc src lvl msg → fl (\t → toLogStr (t <> " ") <> defaultLogStr loc src lvl msg)) diff --git a/library/Magicbane/Metrics.hs b/library/Magicbane/Metrics.hs --- a/library/Magicbane/Metrics.hs +++ b/library/Magicbane/Metrics.hs @@ -1,5 +1,5 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings, UnicodeSyntax, FlexibleInstances, FlexibleContexts, UndecidableInstances #-} -- | Provides metrics via monad-metrics/EKG in a Magicbane app context. -- Also reexports Wai metrics middleware. @@ -8,7 +8,6 @@ , module X ) where -import ClassyPrelude import Data.Has import qualified Control.Monad.Metrics import Control.Monad.Metrics as X hiding (initialize, initializeWith, run, run') @@ -16,6 +15,9 @@ import qualified System.Remote.Monitoring.Wai import System.Remote.Monitoring.Wai as X (serverMetricStore) import Network.Wai.Metrics as X +-- replacing ClassyPrelude +import Control.Monad.Reader +import Data.ByteString (ByteString) newtype ModMetrics = ModMetrics Metrics diff --git a/library/Magicbane/Util.hs b/library/Magicbane/Util.hs --- a/library/Magicbane/Util.hs +++ b/library/Magicbane/Util.hs @@ -1,17 +1,24 @@ -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} +{-# LANGUAGE OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances #-} -- | Various useful functions. module Magicbane.Util where -import ClassyPrelude +import Control.Arrow +import Control.Monad import Control.Monad.Except (MonadError) import Control.Error (hush) +import qualified Data.ByteString.Lazy as L (ByteString) import qualified Data.HashMap.Strict as HMS +import qualified Data.Sequences as S import qualified Data.Text as T +import Data.Text (Text) import Data.Char (isSpace) +import Data.Foldable +import Data.HashMap.Strict (insertWith) +import Data.Maybe +import Data.MonoTraversable import Data.String.Conversions import Data.String.Conversions.Monomorphic -import Data.Maybe (fromJust) import Data.Attoparsec.Text as AP import Data.Aeson import Network.URI @@ -19,18 +26,17 @@ import Web.FormUrlEncoded hiding (parseMaybe) import Servant - -- | Merges two JSON objects recursively. When the values are not objects, just returns the left one. mergeVal ∷ Value → Value → Value mergeVal (Object x) (Object y) = Object $ HMS.unionWith mergeVal x y mergeVal x _ = x -- | Encodes key-value data as application/x-www-form-urlencoded. -writeForm ∷ (ConvertibleStrings α Text, ConvertibleStrings β Text, ConvertibleStrings LByteString γ) ⇒ [(α, β)] → γ +writeForm ∷ (ConvertibleStrings α Text, ConvertibleStrings β Text, ConvertibleStrings L.ByteString γ) ⇒ [(α, β)] → γ writeForm = fromLBS . mimeRender (Proxy ∷ Proxy FormUrlEncoded) . map (toST *** toST) -- | Decodes key-value data from application/x-www-form-urlencoded. -readForm ∷ (ConvertibleStrings Text α, ConvertibleStrings Text β, ConvertibleStrings γ LByteString) ⇒ γ → Maybe [(α, β)] +readForm ∷ (ConvertibleStrings Text α, ConvertibleStrings Text β, ConvertibleStrings γ L.ByteString) ⇒ γ → Maybe [(α, β)] readForm x = map (fromST *** fromST) <$> hush (mimeUnrender (Proxy ∷ Proxy FormUrlEncoded) $ toLBS x) -- | Reads a Servant incoming form as a list of key-value pairs (for use in FromForm instances). @@ -44,7 +50,7 @@ assignProp (Object o) ([k], v) = Object $ insertWith concatJSON k (toJSON [ v ]) o assignProp (Object o) (k : k' : ks, v) = Object $ insertWith (\_ o' → assignProp o' (k' : ks, v)) k (assignProp (object []) (k' : ks, v)) o assignProp x _ = x - concatJSON (Array v1) (Array v2) = Array $ v1 ++ v2 + concatJSON (Array v1) (Array v2) = Array $ v1 <> v2 concatJSON (Array v1) _ = Array v1 concatJSON _ (Array v2) = Array v2 concatJSON _ _ = Null @@ -58,7 +64,7 @@ void $ char ']' return s void $ option '_' $ char '[' >> char ']' - return $ firstKey : filter (not . null) restKeys + return $ firstKey : S.filter (not . T.null) restKeys -- | Parses any string into a URI. parseUri ∷ ConvertibleStrings α String ⇒ α → URI @@ -70,18 +76,18 @@ -- >>> slugify "Hello & World!" -- "hello-and-world" slugify ∷ Text → Text -slugify = filter (not . isSpace) . intercalate "-" . words . +slugify = T.filter (not . isSpace) . T.intercalate "-" . T.words . T.replace "&" "and" . T.replace "+" "plus" . T.replace "%" "percent" . T.replace "<" "lt" . T.replace ">" "gt" . T.replace "=" "eq" . T.replace "#" "hash" . T.replace "@" "at" . T.replace "$" "dollar" . - filter (`onotElem` asString "!^*?()[]{}`./\\'\"~|") . + T.filter (`onotElem` ("!^*?()[]{}`./\\'\"~|"::String)) . T.toLower . T.strip -- | Creates a simple text/plain ServantErr. -errText ∷ ServantErr → LByteString → ServantErr +errText ∷ ServantErr → L.ByteString → ServantErr errText e t = e { errHeaders = [ (hContentType, "text/plain; charset=utf-8") ] , errBody = t } -- | Creates and throws a simple text/plain ServantErr. -throwErrText ∷ MonadError ServantErr μ ⇒ ServantErr → LByteString → μ α +throwErrText ∷ MonadError ServantErr μ ⇒ ServantErr → L.ByteString → μ α throwErrText e t = throwError $ errText e t diff --git a/library/Magicbane/Validation.hs b/library/Magicbane/Validation.hs --- a/library/Magicbane/Validation.hs +++ b/library/Magicbane/Validation.hs @@ -1,13 +1,11 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax #-} +{-# LANGUAGE OverloadedStrings, UnicodeSyntax #-} -- | Integrates the refinement types from the refined library with aeson. module Magicbane.Validation ( module Refined ) where - -import ClassyPrelude import Refined import Data.Aeson diff --git a/magicbane.cabal b/magicbane.cabal --- a/magicbane.cabal +++ b/magicbane.cabal @@ -2,19 +2,19 @@ -- -- see: https://github.com/sol/hpack -- --- hash: d745301cacd1d82cdb20fad978024069617cdb814742a11f1fda1ea280068d7b +-- hash: 88e201dd0d795d1b2f734fac496dffd6df8421151ab0e9b88379490a2d4c5bfa name: magicbane -version: 0.1.4 -synopsis: A web framework that integrates Servant, ClassyPrelude, EKG, fast-logger, wai-cli… +version: 0.2.0 +synopsis: A web framework that integrates Servant, EKG, fast-logger, wai-cli… -description: Inspired by Dropwizard, Magicbane provides a packaged framework for developing web services using the best available libraries, including Servant, ClassyPrelude, Aeson, EKG/monad-metrics, fast-logger/monad-logger, wai-cli and others. +description: Inspired by Dropwizard, Magicbane provides a packaged framework for developing web services using the best available libraries, including Servant, Aeson, EKG/monad-metrics, fast-logger/monad-logger, wai-cli and others. category: Web homepage: https://github.com/myfreeweb/magicbane#readme bug-reports: https://github.com/myfreeweb/magicbane/issues author: Greg V maintainer: greg@unrelenting.technology -copyright: 2017 Greg V +copyright: 2017-2018 Greg V license: PublicDomain tested-with: GHC==8.2.1 build-type: Simple @@ -31,9 +31,10 @@ build-depends: aeson , aeson-qq + , async , attoparsec , base >=4.8.0.0 && <5 - , classy-prelude + , bytestring , conduit , conduit-combinators , data-default @@ -47,26 +48,25 @@ , http-client , http-client-tls , http-conduit - , http-date , http-link-header - , http-media , http-types , lifted-async - , mime-types + , lifted-base , monad-control , monad-logger , monad-metrics + , mono-traversable , mtl - , network , network-uri , raw-strings-qq , refined - , servant + , safe-exceptions , servant-server , split , string-conversions , text , transformers + , transformers-base , unordered-containers , wai , wai-cli @@ -80,5 +80,6 @@ Magicbane.HTTPClient Magicbane.Util other-modules: + Magicbane.Async Paths_magicbane default-language: Haskell2010