magicbane (empty) → 0.1.0

raw patch · 9 files changed

+436/−0 lines, 9 filesdep +aesondep +aeson-qqdep +attoparsecsetup-changed

Dependencies added: aeson, aeson-qq, attoparsec, base, classy-prelude, conduit, conduit-combinators, data-default, data-has, either, ekg-core, ekg-wai, envy, errors, fast-logger, http-api-data, http-client, http-client-tls, http-conduit, http-date, http-link-header, http-media, http-types, lifted-async, mime-types, monad-control, monad-logger, monad-metrics, mtl, network, network-uri, raw-strings-qq, refined, servant, servant-server, split, string-conversions, text, transformers, unordered-containers, wai, wai-cli, wai-middleware-metrics

Files

• Setup.hs +2/−0
• library/Magicbane.hs +70/−0
• library/Magicbane/App.hs +45/−0
• library/Magicbane/HTTPClient.hs +73/−0
• library/Magicbane/Logging.hs +30/−0
• library/Magicbane/Metrics.hs +32/−0
• library/Magicbane/Util.hs +87/−0
• library/Magicbane/Validation.hs +22/−0
• magicbane.cabal +75/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,70 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-missing-signatures #-}+{-# LANGUAGE Trustworthy, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving, 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.+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.Trans.Control as X+import           Control.Monad.Trans.Either as X+import           Control.Monad.Trans.Maybe as X hiding (liftListen, liftPass, liftCallCC)+import qualified System.Envy+import           System.Envy as X hiding ((.=), (.!=), decode)+import qualified System.IO+import           Data.Default as X+import           Data.List.Split as X (splitOn)+import           Data.String.Conversions as X hiding ((<>))+import           Data.String.Conversions.Monomorphic as X+import           Data.Aeson as X+import           Data.Aeson.QQ as X+import           Text.RawString.QQ as X+import           Network.URI as X+import qualified Network.HTTP.Link+import           Network.HTTP.Link as X hiding (Link)+import           Network.HTTP.Types as X hiding (Header)+import           Network.Wai as X (Application, Middleware)+import           Network.Wai.Cli as X hiding (port)+import           Magicbane.App as X hiding (Or)+import           Magicbane.Logging as X+import           Magicbane.Metrics as X+import           Magicbane.Validation as X+import           Magicbane.HTTPClient as X+import           Magicbane.Util as X++type Host = Header "Host" Text+type Form = ReqBody '[FormUrlEncoded] [(Text, Text)]++type HTTPLink = Network.HTTP.Link.Link+type WithLink α = (Headers '[Header "Link" [HTTPLink]] α)++instance (Default α) ⇒ DefConfig α where+  defConfig = def++decodeEnvy = System.Envy.decode++-- | Reads an Envy configuration from the env variables and launches the given action if successful.+--   (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)+                                    Right c → a c++hPutStrLn h s = liftIO $ System.IO.hPutStrLn h s++type BasicContext = (ModHttpClient, ModLogger)+type BasicApp α = MagicbaneApp BasicContext α++newBasicContext ∷ IO BasicContext+newBasicContext = do+  http ← newHttpClient+  (_, logg) ← newLogger $ LogStdout defaultBufSize+  return (http, logg)

@@ -0,0 +1,45 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+{-# LANGUAGE NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances, GeneralizedNewtypeDeriving #-}++-- | Extends Servant with context.+--   Basically wrapping Servant in a ReaderT of your type.+--   Which should be a tuple of all your moudles and configs and stuff, so that the Data.Has module would let you access these items by type.+module Magicbane.App (+  module X+, module Magicbane.App+) where++import           ClassyPrelude+import           Control.Monad.Trans.Except as X+import           Control.Monad.Except as X (MonadError, throwError)+import           Data.Proxy as X+import           Data.Has as X+import           Servant as X++newtype MagicbaneApp β α = MagicbaneApp {+  unMagicbaneApp ∷ ReaderT β (ExceptT ServantErr IO) α+} deriving (Functor, Applicative, Monad, MonadIO, MonadBase IO,+            MonadThrow, MonadCatch, MonadError ServantErr, MonadReader β)++instance MonadBaseControl IO (MagicbaneApp β) where+  type StM (MagicbaneApp β) α = StM (ReaderT β (ExceptT ServantErr IO)) α+  liftBaseWith f = MagicbaneApp $ liftBaseWith $ \x → f $ x . unMagicbaneApp+  restoreM       = MagicbaneApp . restoreM++runMagicbaneExcept ∷ β → MagicbaneApp β α → ExceptT ServantErr IO α+runMagicbaneExcept ctx a = ExceptT $ liftIO $ runExceptT $ runReaderT (unMagicbaneApp a) ctx++magicbaneToExcept ∷ β → MagicbaneApp β :~> ExceptT ServantErr IO+magicbaneToExcept ctx = Nat $ runMagicbaneExcept ctx++-- | Constructs a WAI application from an API definition, a Servant context (used for auth mainly), the app context and the actual action handlers.+magicbaneApp api sctx ctx actions = serveWithContext api sctx $ srv ctx+  where srv c = enter (magicbaneToExcept c) actions++-- | Gets a value of any type from the context.+askObj ∷ (Has β α, MonadReader α μ) ⇒ μ β+askObj = asks getter++-- | Gets a thing from a value of any type from the context. (Useful for configuration fields.)+askOpt ∷ (Has β α, MonadReader α μ) ⇒ (β → ψ) → μ ψ+askOpt f = asks $ f . getter

@@ -0,0 +1,73 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NoImplicitPrelude, 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.+--   That lets you plug stream parsers (e.g. html-conduit: 'performWithFn ($$ sinkDoc)') directly into the reading of the response body.+module Magicbane.HTTPClient (+  module Magicbane.HTTPClient+, module X+) where++import           ClassyPrelude+import           Control.Monad.Trans.Either+import           Data.Has+import           Data.Conduit+import qualified Data.Conduit.Combinators as C+import           Data.String.Conversions+import           Network.URI as X+import           Network.HTTP.Types+import           Network.HTTP.Conduit as HC+import           Network.HTTP.Client.Conduit as HCC+import           Network.HTTP.Client.Internal (setUri) -- The fuck?+import           Network.HTTP.Client as X hiding (Proxy, path)+import           Network.HTTP.Client.TLS (newTlsManager)+import           Magicbane.Util (writeForm)++newtype ModHttpClient = ModHttpClient Manager++instance (Has ModHttpClient α) ⇒ HasHttpManager α where+  getHttpManager = (\(ModHttpClient m) → m) <$> getter++newHttpClient ∷ IO ModHttpClient+newHttpClient = ModHttpClient <$> newTlsManager++type MonadHTTP ψ μ = (HasHttpManager ψ, MonadReader ψ μ, MonadIO μ, MonadBaseControl IO μ)++runHTTP ∷ EitherT ε μ α → μ (Either ε α)+runHTTP = runEitherT++-- | Creates a request from a URI.+reqU ∷ (MonadHTTP ψ μ) ⇒ URI → EitherT Text μ Request+reqU uri = hoistEither $ bimap tshow id $ setUri defaultRequest uri++-- | Creates a request from a string of any type, parsing it into a URI.+reqS ∷ (MonadHTTP ψ μ, ConvertibleStrings σ String) ⇒ σ → EitherT Text μ Request+reqS uri = hoistEither $ bimap tshow id $ parseUrlThrow $ cs uri++-- | Configures the request to not throw errors on error status codes.+anyStatus ∷ (MonadHTTP ψ μ) ⇒ Request → EitherT Text μ Request+anyStatus req = return $ setRequestIgnoreStatus req++-- | Sets a x-www-form-urlencoded form as the request body (also sets the content-type).+postForm ∷ (MonadHTTP ψ μ) ⇒ [(Text, Text)] → Request → EitherT Text μ Request+postForm form req =+  return req { method = "POST"+             , requestHeaders = [ (hContentType, "application/x-www-form-urlencoded; charset=utf-8") ]+             , requestBody = RequestBodyBS $ writeForm form }++-- | Performs the request, using a given function to read the body. This is what all other performWith functions are based on.+performWithFn ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ (ConduitM ι ByteString μ () → μ ρ) → Request → EitherT Text μ (Response ρ)+performWithFn fn req = do+  res ← lift $ tryAny $ HCC.withResponse req $ \res → do+    body ← fn $ responseBody res+    return res { responseBody = body }+  hoistEither $ bimap tshow id res++-- | Performs the request, ignoring the body.+performWithVoid ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → EitherT Text μ (Response ())+performWithVoid = performWithFn (const $ return ())++-- | Performs the request, reading the body into a lazy ByteString.+performWithBytes ∷ (MonadHTTP ψ μ, MonadCatch μ) ⇒ Request → EitherT Text μ (Response LByteString)+performWithBytes = performWithFn ($$ C.sinkLazy)

@@ -0,0 +1,30 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}++-- | Provides logging via monad-logger/fast-logger in a Magicbane app context.+module Magicbane.Logging (+  module Magicbane.Logging+, module X+) where++import           ClassyPrelude+import           Data.Has+import           Control.Monad.Logger as X+import           System.Log.FastLogger+import           System.Log.FastLogger as X (LogType(..), defaultBufSize)++newtype ModLogger = ModLogger (Loc → LogSource → LogLevel → LogStr → IO ())++instance (Has ModLogger α, Monad μ, MonadIO μ, MonadReader α μ) ⇒ MonadLogger μ where+  monadLoggerLog loc src lvl msg = asks getter >>= \(ModLogger f) → liftIO (f loc src lvl $ toLogStr msg)++instance (Has ModLogger α, MonadIO μ, MonadReader α μ) ⇒ MonadLoggerIO μ where+  askLoggerIO = (\(ModLogger f) → f) <$> asks getter++-- | Creates a logger module. Also returns the logger itself for using outside of your Magicbane app (e.g. in some WAI middleware).+newLogger ∷ LogType → IO (TimedFastLogger, ModLogger)+newLogger logtype = do+  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))

@@ -0,0 +1,32 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, FlexibleInstances, FlexibleContexts, UndecidableInstances #-}++-- | Provides metrics via monad-metrics/EKG in a Magicbane app context.+--   Also reexports Wai metrics middleware.+module Magicbane.Metrics (+  module Magicbane.Metrics+, module X+) where++import           ClassyPrelude+import           Data.Has+import qualified Control.Monad.Metrics+import           Control.Monad.Metrics as X hiding (initialize, initializeWith, run, run')+import           System.Metrics as X (Store, registerGcMetrics)+import qualified System.Remote.Monitoring.Wai+import           System.Remote.Monitoring.Wai as X (serverMetricStore)+import           Network.Wai.Metrics as X++newtype ModMetrics = ModMetrics Metrics++instance (Has ModMetrics α, Monad μ, MonadReader α μ) ⇒ MonadMetrics μ where+  getMetrics = (\(ModMetrics m) → m) <$> asks getter++forkMetricsServer ∷ ByteString → Int → IO System.Remote.Monitoring.Wai.Server+forkMetricsServer = System.Remote.Monitoring.Wai.forkServer++-- | Creates a metrics module with a particular Store.+--   The Store should come from the backend you want to use for storing the metrics.+--   For development, a simple backend that shows metrics on a web page is ekg-wai, reexported here.+newMetricsWith ∷ Store → IO ModMetrics+newMetricsWith x = ModMetrics <$> Control.Monad.Metrics.initializeWith x

@@ -0,0 +1,87 @@+{-# LANGUAGE NoImplicitPrelude, OverloadedStrings, UnicodeSyntax, DataKinds, TypeOperators, MultiParamTypeClasses, TypeFamilies, FlexibleContexts, FlexibleInstances, UndecidableInstances #-}++-- | Various useful functions.+module Magicbane.Util where++import           ClassyPrelude+import           Control.Monad.Except (MonadError)+import           Control.Error (hush)+import qualified Data.HashMap.Strict as HMS+import qualified Data.Text as T+import           Data.Char (isSpace)+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+import           Network.HTTP.Types (hContentType)+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 = 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 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).+formList ∷ Form → [(Text, Text)]+formList = fromMaybe [] . hush . fromForm++-- | Converts a flat key-value form with keys in typical nesting syntax (e.g. "one[two][three]") to an Aeson Value with nesting (for use in FromForm instances).+formToObject ∷ [(Text, Text)] → Value+formToObject f = foldl' assignProp (object []) $ (map . first) parseKey f+  where parseKey x = fromMaybe [ x ] $ hush $ parseOnly formKey x+        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 v1+        concatJSON _ (Array v2) = Array v2+        concatJSON _ _ = Null++formKey ∷ Parser [Text]+formKey = do+  firstKey ← AP.takeWhile (/= '[')+  restKeys ← many' $ do+    void $ char '['+    s ← AP.takeWhile (/= ']')+    void $ char ']'+    return s+  void $ option '_' $ char '[' >> char ']'+  return $ firstKey : filter (not . null) restKeys++-- | Parses any string into a URI.+parseUri ∷ ConvertibleStrings α String ⇒ α → URI+parseUri = fromJust . parseURI . cs++-- | Prepares text for inclusion in a URL.+--+-- >>> :set -XOverloadedStrings+-- >>> slugify "Hello & World!"+-- "hello-and-world"+slugify ∷ Text → Text+slugify = filter (not . isSpace) . intercalate "-" . 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.toLower . T.strip++-- | Creates a simple text/plain ServantErr.+errText ∷ ServantErr → LByteString → 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 e t = throwError $ errText e t

@@ -0,0 +1,22 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE NoImplicitPrelude, 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++instance ToJSON α ⇒ ToJSON (Refined ρ α) where+  toJSON = toJSON . unrefine++instance (FromJSON α, Predicate ρ α) ⇒ FromJSON (Refined ρ α) where+  parseJSON x = do+    res ← parseJSON x+    case refine res of+      Right v → return v+      Left e → fail e

@@ -0,0 +1,75 @@+name:            magicbane+version:         0.1.0+synopsis:        A web framework that integrates Servant, ClassyPrelude, 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.+category:        Web+homepage:        https://github.com/myfreeweb/magicbane+author:          Greg V+copyright:       2017 Greg V <greg@unrelenting.technology>+maintainer:      greg@unrelenting.technology+license:         PublicDomain+build-type:      Simple+cabal-version:   >= 1.10+tested-with:+    GHC == 8.0.2++source-repository head+    type: git+    location: git://github.com/myfreeweb/magicbane.git++library+    build-depends:+        base >= 4.8.0.0 && < 5+      , classy-prelude+      , transformers+      , errors+      , split+      , either+      , mtl+      , refined+      , lifted-async+      , monad-control+      , monad-metrics+      , monad-logger+      , fast-logger+      , ekg-core+      , ekg-wai+      , data-default+      , data-has+      , string-conversions+      , unordered-containers+      , attoparsec+      , text+      , conduit+      , conduit-combinators+      , aeson+      , aeson-qq+      , raw-strings-qq+      , wai+      , wai-middleware-metrics+      , wai-cli+      , servant+      , servant-server+      , network-uri+      , network+      , http-types+      , http-media+      , http-client+      , http-client-tls+      , http-conduit+      , http-link-header+      , http-date+      , http-api-data+      , mime-types+      , envy+    default-language: Haskell2010+    exposed-modules:+        Magicbane+        Magicbane.App+        Magicbane.Logging+        Magicbane.Metrics+        Magicbane.Validation+        Magicbane.HTTPClient+        Magicbane.Util+    ghc-options: -Wall+    hs-source-dirs: library