yam 0.5.5 → 0.5.6
raw patch · 10 files changed
+111/−87 lines, 10 filesdep +base16-bytestringdep +binarydep +mwc-randomdep −aesondep −random
Dependencies added: base16-bytestring, binary, mwc-random
Dependencies removed: aeson, random
Files
- src/Data/Opentracing/Tracer.hs +4/−13
- src/Data/Opentracing/Types.hs +4/−3
- src/Yam/Internal.hs +4/−4
- src/Yam/Logger.hs +18/−16
- src/Yam/Middleware/Trace.hs +13/−13
- src/Yam/Swagger.hs +7/−7
- src/Yam/Types/Env.hs +6/−6
- src/Yam/Types/Prelude.hs +45/−17
- test/Spec.hs +3/−3
- yam.cabal +7/−5
src/Data/Opentracing/Tracer.hs view
@@ -17,11 +17,8 @@ import Control.Monad.IO.Class import qualified Data.HashMap.Lazy as HM import Data.Opentracing.Types-import Data.Text (Text, justifyRight, pack) import Data.Time.Clock.POSIX-import Data.Word-import Numeric-import System.Random+import Yam.Types.Prelude type SpanName = Text @@ -31,12 +28,6 @@ class MonadTracer m => MonadTracing m where runInSpan :: SpanName -> (Span -> m ()) -> (Span -> m a) -> m a -{-# INLINE newId #-}-newId :: MonadIO m => m Text-newId = liftIO $ do- c <- randomIO :: IO Word64- return $ justifyRight 16 '0' $ pack $ showHex c ""- newSpan :: MonadTracer m => SpanName -> m Span newSpan name = do context <- askSpanContext@@ -44,11 +35,11 @@ getNow :: MonadIO m => m Int-getNow = liftIO $ (round . (* 1000)) <$> getPOSIXTime+getNow = liftIO $ round . (* 1000) <$> getPOSIXTime newSpan' :: MonadTracer m => SpanName -> SpanContext -> [SpanReference] -> m Span newSpan' name context references = do- spanId <- if null references then return (traceId context) else newId+ spanId <- if null references then return (traceId context) else liftIO randomString startTime <- getNow let finishTime = Nothing tags = HM.empty@@ -82,6 +73,6 @@ newContext :: MonadIO m => m SpanContext newContext = do- traceId <- newId+ traceId <- liftIO randomString let baggage = HM.empty return SpanContext{..}
src/Data/Opentracing/Types.hs view
@@ -1,5 +1,6 @@ module Data.Opentracing.Types where +import Data.ByteString (ByteString) import qualified Data.HashMap.Lazy as HM import Data.Scientific import Data.Text (Text)@@ -11,7 +12,7 @@ deriving (Eq, Show) data SpanContext = SpanContext- { traceId :: Text+ { traceId :: ByteString , baggage :: HM.HashMap Text (Maybe Text) } deriving (Eq, Show) @@ -22,11 +23,11 @@ data SpanReference = SpanReference { referenceType :: SpanReferenceType- , parentId :: Text+ , parentId :: ByteString } deriving (Eq, Show) data Span = Span- { spanId :: Text+ { spanId :: ByteString , name :: Text , startTime :: Int , finishTime :: Maybe Int
src/Yam/Internal.hs view
@@ -74,7 +74,7 @@ -> ServerT api App -> IO () start p = startYam- (readConfig "yam.application" p)- (readConfig "yam.swagger" p)- (readConfig "yam.logging" p)- (readConfig "yam.trace" p)+ (p .>> "yam.application")+ (p .>> "yam.swagger" )+ (p .>> "yam.logging" )+ (p .>> "yam.trace" )
src/Yam/Logger.hs view
@@ -18,15 +18,17 @@ import Yam.Types.Env import Yam.Types.Prelude -instance FromJSON LogLevel where- parseJSON v = go . T.toLower <$> parseJSON v+instance FromProperties LogLevel where+ fromProperties = fromProperties >=> go where- go :: Text -> LogLevel- go "debug" = LevelDebug- go "info" = LevelInfo- go "warn" = LevelWarn- go "error" = LevelError- go level = LevelOther level+ go :: Property -> Return LogLevel+ go (PStr t) = OK (gt $ T.toLower t)+ go _ = Fail "loglevel shoudbe string"+ gt "debug" = LevelDebug+ gt "info" = LevelInfo+ gt "warn" = LevelWarn+ gt "error" = LevelError+ gt _ = LevelOther "fatal" {-# INLINE toStr #-} toStr :: LogLevel -> LogStr@@ -45,15 +47,15 @@ } deriving (Eq, Show) instance Default LogConfig where- def = defJson+ def = LogConfig 4096 "" 10485760 256 LevelInfo -instance FromJSON LogConfig where- parseJSON = withObject "LogConfig" $ \v -> LogConfig- <$> v .:? "buffer-size" .!= 4096- <*> v .:? "file" .!= ""- <*> v .:? "max-size" .!= 10485760- <*> v .:? "max-history" .!= 256- <*> v .:? "level" .!= LevelInfo+instance FromProperties LogConfig where+ fromProperties p = LogConfig+ <$> p .?> "buffer-size" .?= bufferSize def+ <*> p .?> "file" .?= file def+ <*> p .?> "max-size" .?= maxSize def+ <*> p .?> "max-history" .?= rotateHistory def+ <*> p .?> "level" .?= level def newLogger :: Text -> LogConfig -> IO (LogFunc, IO ()) newLogger name LogConfig{..} = do
src/Yam/Middleware/Trace.hs view
@@ -27,16 +27,16 @@ = NoTracer deriving (Eq, Show) -instance FromJSON TraceNotifyType where- parseJSON v = go . T.toLower <$> parseJSON v+instance FromProperties TraceNotifyType where+ fromProperties = fromProperties >=> go where- go :: Text -> TraceNotifyType- go _ = NoTracer+ go :: Property -> Return TraceNotifyType+ go _ = OK NoTracer -instance FromJSON TraceConfig where- parseJSON = withObject "TraceConfig" $ \v -> TraceConfig- <$> v .:? "enabled" .!= True- <*> v .:? "type" .!= NoTracer+instance FromProperties TraceConfig where+ fromProperties p = TraceConfig+ <$> p .?> "enabled" .?= enabled def+ <*> p .?> "type" .?= method def instance Default TraceConfig where def = TraceConfig True NoTracer@@ -82,10 +82,10 @@ parseSpan headers env = let sc = fromMaybe (SpanContext "" HM.empty) $ getAttr spanContextKey env in case lookup hTraceId headers of- Just tid -> let sc' = sc { traceId = decodeUtf8 tid }+ Just tid -> let sc' = sc { traceId = tid } in return $ env & setAttr spanContextKey sc'- & go (maybe (traceId sc') decodeUtf8 $ lookup hSpanId headers) sc'+ & go (fromMaybe (traceId sc') $ lookup hSpanId headers) sc' _ -> do c <- newContext return $ setAttr spanContextKey c env@@ -103,13 +103,13 @@ traceMw env' notify app req resH = do env <- parseSpan (requestHeaders req) env' runApp env $- runInSpan ((decodeUtf8 $ requestMethod req) <> " /" <> T.intercalate "/" (pathInfo req)) notify $ \s@Span{..} -> do+ runInSpan (decodeUtf8 (requestMethod req) <> " /" <> T.intercalate "/" (pathInfo req)) notify $ \s@Span{..} -> do let SpanContext{..} = context- tid = traceId <> "," <> spanId+ tid = decodeUtf8 $ traceId <> "," <> spanId v = L.insert extensionLogKey tid (vault req) v' = L.insert spanKey s v liftIO $ app req {vault = v'}- $ resH . mapResponseHeaders (\hs -> (hTraceId,encodeUtf8 traceId):(hSpanId, encodeUtf8 spanId):hs)+ $ resH . mapResponseHeaders (\hs -> (hTraceId, traceId):(hSpanId, spanId):hs) traceMiddleware :: TraceConfig -> AppMiddleware traceMiddleware TraceConfig{..}
src/Yam/Swagger.hs view
@@ -5,7 +5,7 @@ , module Control.Lens ) where -import Control.Lens hiding (Context, allOf, (.=))+import Control.Lens hiding (Context, Empty, allOf, (.=)) import Data.Reflection import Data.Swagger hiding (name, port) import qualified Data.Swagger as S@@ -23,13 +23,13 @@ } deriving (Eq, Show) instance Default SwaggerConfig where- def = defJson+ def = SwaggerConfig "swagger-ui" "swagger-ui.json" True -instance FromJSON SwaggerConfig where- parseJSON = withObject "SwaggerConfig" $ \v -> SwaggerConfig- <$> v .:? "dir" .!= "swagger-ui"- <*> v .:? "schema" .!= "swagger-ui.json"- <*> v .:? "enabled" .!= True+instance FromProperties SwaggerConfig where+ fromProperties p = SwaggerConfig+ <$> p .?> "dir" .?= urlDir def+ <*> p .?> "schema" .?= urlSchema def+ <*> p .?> "enabled" .?= enabled def type SAPI dir schema api = SwaggerSchemaUI dir schema :<|> api
src/Yam/Types/Env.hs view
@@ -14,13 +14,13 @@ , port :: Int } deriving (Eq, Show) -instance FromJSON AppConfig where- parseJSON = withObject "AppConfig" $ \v -> AppConfig- <$> v .:? "name" .!= "application"- <*> v .:? "port" .!= 8888+instance FromProperties AppConfig where+ fromProperties p = AppConfig+ <$> p .?> "name" .?= name def+ <*> p .?> "port" .?= port def instance Default AppConfig where- def = defJson+ def = AppConfig "application" 8888 data Env = Env { attributes :: Vault@@ -32,7 +32,7 @@ def = Env L.empty Nothing def getAttr :: Key a -> Env -> Maybe a-getAttr k Env{..} = listToMaybe $ catMaybes $ L.lookup k <$> catMaybes [reqAttributes, Just attributes]+getAttr k Env{..} = (reqAttributes >>= L.lookup k) <|> L.lookup k attributes reqAttr :: Default a => Key a -> Env -> a reqAttr k = fromMaybe def . getAttr k
src/Yam/Types/Prelude.hs view
@@ -1,8 +1,10 @@ module Yam.Types.Prelude(- defJson- , randomString+ randomString , showText- , readConfig+ , (.>>)+ , (.?>)+ , (.?=)+ , (.|=) , LogFunc , Default(..) , Text@@ -18,12 +20,12 @@ , module Data.Proxy , module Data.Vault.Lazy , module Data.Maybe- , module Data.Aeson , module Data.Word , module Data.Text.Encoding , module Data.Function , module Data.Salak , module Data.Version+ , module Control.Applicative , module Control.Monad , module Control.Monad.Reader , module Control.Monad.Logger.CallStack@@ -31,13 +33,17 @@ , module Network.HTTP.Types ) where +import Control.Applicative import Control.Exception hiding (Handler) import Control.Monad import Control.Monad.Except import Control.Monad.IO.Unlift import Control.Monad.Logger.CallStack import Control.Monad.Reader-import Data.Aeson+import qualified Data.Binary as B+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16.Lazy as B16+import qualified Data.ByteString.Lazy as L import Data.Default import Data.Function import Data.Maybe@@ -45,10 +51,12 @@ import Data.Salak ( FromProperties (..) , Properties+ , Property (..)+ , Return (..) , defaultPropertiesWithFile ) import qualified Data.Salak as S-import Data.Text (Text, justifyRight, pack)+import Data.Text (Text, pack, unpack) import Data.Text.Encoding (decodeUtf8, encodeUtf8) import Data.Vault.Lazy (Key, Vault, newKey) import Data.Version@@ -56,24 +64,44 @@ import GHC.Stack import Network.HTTP.Types import Network.Wai-import Numeric-import System.Random+import System.IO.Unsafe (unsafePerformIO)+import System.Random.MWC +infixl 5 .?>+(.?>) :: FromProperties a => Properties -> Text -> Return a+(.?>) = flip S.lookup'++infixl 5 .|=+(.|=) :: Return a -> a -> a+(.|=) (OK a) _ = a+(.|=) (Fail e) _ = error e+(.|=) _ d = d++infixl 5 .?=+(.?=) :: Return a -> a -> Return a+(.?=) a b = OK (a .|= b)++infixl 5 .>>+(.>>) :: FromProperties a => Properties -> Text -> a+(.>>) p k = case p .?> k of+ OK v -> v+ Empty -> case fromProperties S.empty of+ (OK a) -> a+ (Fail e) -> error e+ _ -> error $ "Config " <> unpack k <> " not found"+ Fail e -> error e+ type LogFunc = Loc -> LogSource -> LogLevel -> LogStr -> IO () -defJson :: FromJSON a => a-defJson = fromJust $ decode "{}"+{-# NOINLINE randomGen #-}+randomGen :: GenIO+randomGen = unsafePerformIO create -- | Utility-{-# INLINE randomString #-}-randomString :: Int -> IO Text-randomString n = do- c <- randomIO :: IO Word64- return $ justifyRight n '0' $ pack $ take n $ showHex c ""+randomString :: IO ByteString+randomString = L.toStrict . B16.encode . B.encode <$> (uniform randomGen :: IO Word64) {-# INLINE showText #-} showText :: Show a => a -> Text showText = pack . show -readConfig :: (Default a, FromProperties a) => Text -> Properties -> a-readConfig k p = fromMaybe def $ S.lookup k p
test/Spec.hs view
@@ -4,7 +4,7 @@ module Main where -import qualified Data.Text as T+import qualified Data.ByteString as B import Test.Hspec import Test.QuickCheck.Monadic import Yam@@ -19,5 +19,5 @@ context "randomTest" $ do it "random" $ do monadicIO $ do- s <- run $ randomString 14- assert (T.length s == 14)+ s <- run $ randomString+ assert (B.length s == 16)
yam.cabal view
@@ -1,6 +1,6 @@ cabal-version: 1.12 name: yam-version: 0.5.5+version: 0.5.6 license: BSD3 license-file: LICENSE copyright: (c) 2018 Daniel YU@@ -49,8 +49,9 @@ -Wincomplete-uni-patterns -Wredundant-constraints -fno-warn-orphans -fno-warn-missing-signatures build-depends:- aeson >=1.4.2.0 && <1.5, base >=4.11 && <5,+ base16-bytestring >=0.1.1.6 && <0.2,+ binary >=0.8.6.0 && <0.9, bytestring >=0.10.8.2 && <0.11, data-default >=0.7.1.1 && <0.8, fast-logger >=2.4.13 && <2.5,@@ -58,7 +59,7 @@ lens ==4.17.*, monad-logger >=0.3.30 && <0.4, mtl >=2.2.2 && <2.3,- random ==1.1.*,+ mwc-random >=0.14.0.0 && <0.15, reflection >=2.1.4 && <2.2, salak >=0.1.4 && <0.3, scientific >=0.3.6.2 && <0.4,@@ -112,8 +113,9 @@ -fno-warn-missing-signatures build-depends: QuickCheck >=2.12.6.1 && <2.13,- aeson >=1.4.2.0 && <1.5, base >=4.11 && <5,+ base16-bytestring >=0.1.1.6 && <0.2,+ binary >=0.8.6.0 && <0.9, bytestring >=0.10.8.2 && <0.11, data-default >=0.7.1.1 && <0.8, fast-logger >=2.4.13 && <2.5,@@ -122,7 +124,7 @@ lens ==4.17.*, monad-logger >=0.3.30 && <0.4, mtl >=2.2.2 && <2.3,- random ==1.1.*,+ mwc-random >=0.14.0.0 && <0.15, reflection >=2.1.4 && <2.2, salak >=0.1.4 && <0.3, scientific >=0.3.6.2 && <0.4,