diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/benchmarks/Main.hs b/benchmarks/Main.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Main.hs @@ -0,0 +1,44 @@ +import Prometheus + +import Control.Monad +import Criterion.Main +import System.Random + + +main :: IO () +main = defaultMain [ + bgroup "incCounter" $ expandBenches incCounterThenCollect + , bgroup "withLabelIncCounter" $ expandBenches withLabelIncCounter + , bgroup "addGauge" $ expandBenches $ withGaugeThenCollect (addGauge 47.0) + , bgroup "subGauge" $ expandBenches $ withGaugeThenCollect (subGauge 47.0) + , bgroup "setGauge" $ expandBenches $ withGaugeThenCollect (setGauge 47.0) + , bgroup "observe" $ expandBenches observeThenCollect + ] + +expandBenches :: (Int -> IO a) -> [Benchmark] +expandBenches = flip expand [1, 10, 100, 1000, 10000] + where expand b = map (\i -> bench (show i) (whnfIO (b i))) + +incCounterThenCollect :: Int -> IO [SampleGroup] +incCounterThenCollect i = do + c <- counter (Info "name" "help") + replicateM_ i (incCounter c) + collect c + +withLabelIncCounter :: Int -> IO [SampleGroup] +withLabelIncCounter i = do + v <- vector ("a", "b") $ counter (Info "name" "help") + replicateM_ i (withLabel ("c", "d") incCounter v) + collect v + +withGaugeThenCollect :: (Metric Gauge -> IO ()) -> Int -> IO [SampleGroup] +withGaugeThenCollect a i = do + g <- gauge (Info "name" "help") + replicateM_ i (a g) + collect g + +observeThenCollect :: Int -> IO [SampleGroup] +observeThenCollect i = do + s <- summary (Info "name" "help") defaultQuantiles + replicateM_ i (randomIO >>= flip observe s) + collect s diff --git a/prometheus-client.cabal b/prometheus-client.cabal new file mode 100644 --- /dev/null +++ b/prometheus-client.cabal @@ -0,0 +1,90 @@ +name: prometheus-client +version: 0.1.0.0 +synopsis: Haskell client library for http://prometheus.io. +description: Haskell client library for http://prometheus.io. +homepage: https://github.com/fimad/prometheus-haskell +license: Apache-2.0 +license-file: LICENSE +author: Will Coster +maintainer: willcoster@gmail.com +copyright: 2015 Will Coster +category: Network +build-type: Simple +cabal-version: >=1.10 + +source-repository head + type: git + location: https://github.com/fimad/prometheus-haskell + +library + hs-source-dirs: src/ + default-language: Haskell2010 + exposed-modules: + Prometheus + other-modules: + Prometheus.Info + , Prometheus.Label + , Prometheus.Export.Text + , Prometheus.Metric + , Prometheus.Metric.Counter + , Prometheus.Metric.Gauge + , Prometheus.Metric.Summary + , Prometheus.Metric.Vector + , Prometheus.MonadMonitor + , Prometheus.Registry + build-depends: + atomic-primops >=0.4 + , base >=4.6 && <4.8 + , bytestring >=0.9 + , containers + , mtl >=2 + , stm >=2.3 + , transformers + , time + , utf8-string + ghc-options: -Wall + +test-suite doctest + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: tests + ghc-options: -Wall + main-is: doctest.hs + build-depends: + base + , doctest + , prometheus-client + +test-suite spec + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: src, tests + main-is: Spec.hs + build-depends: + QuickCheck + , atomic-primops + , base >=4.6 && <4.8 + , bytestring + , containers + , hspec + , mtl + , random-shuffle + , stm + , time + , transformers + , utf8-string + ghc-options: -Wall + +benchmark bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: benchmarks + main-is: Main.hs + build-depends: + base >=4.6 && <4.8 + , bytestring + , criterion >=1.1 + , prometheus-client + , random + , utf8-string + ghc-options: -Wall diff --git a/src/Prometheus.hs b/src/Prometheus.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus.hs @@ -0,0 +1,226 @@ +-- | This module provides the basics for instrumenting Haskell executables for +-- use with the monitoring system. +module Prometheus ( + +-- * Registry + + registerIO +, register +, unsafeRegisterIO +, unsafeRegister +, unregisterAll +, collectMetrics + +-- * Exporting + +, exportMetricsAsText + +-- * Metrics +-- +-- | A metric represents a single value that is being monitored. For example +-- a metric could be the number of open files, the current CPU temperature, the +-- elapsed time of execution, and the latency of HTTP requests. +-- +-- This module provides 4 built-in metric types: counters, gauges, summaries, +-- and metric vectors. These types of metrics should cover most typical use +-- cases. However, for more specialized use cases it is also possible to write +-- custom metrics. + +-- ** Counter +-- +-- | A counter models a monotonically increasing integer value. It is the +-- simplest type of metric provided by this library. +-- +-- >>> myCounter <- counter (Info "my_counter" "An example counter") +-- >>> replicateM_ 47 (incCounter myCounter) +-- >>> getCounter myCounter +-- 47 + +, Counter +, counter +, incCounter +, getCounter + +-- ** Gauge +-- +-- | A gauge models an arbitrary floating point value. There are operations to +-- set the value of a gauge as well as add and subtract arbitrary values. +-- +-- >>> myGauge <- gauge (Info "my_gauge" "An example gauge") +-- >>> setGauge 100 myGauge +-- >>> addGauge 50 myGauge +-- >>> subGauge 25 myGauge +-- >>> getGauge myGauge +-- 125.0 + +, Gauge +, gauge +, incGauge +, decGauge +, addGauge +, subGauge +, setGauge +, setGaugeToDuration +, getGauge + +-- ** Summary +-- +-- | A summary captures observations of a floating point value over time and +-- summarizes the observations as a count, sum, and rank estimations. A typical +-- use case for summaries is measuring HTTP request latency. +-- +-- >>> mySummary <- summary (Info "my_summary" "") defaultQuantiles +-- >>> observe 0 mySummary +-- >>> getSummary mySummary +-- [(1 % 2,0.0),(9 % 10,0.0),(99 % 100,0.0)] + +, Summary +, Quantile +, summary +, defaultQuantiles +, observe +, observeDuration +, getSummary + +-- ** Vector +-- +-- | A vector models a collection of metrics that share the same name but are +-- partitioned across a set of dimensions. +-- +-- >>> myVector <- vector ("method", "code") $ counter (Info "http_requests" "") +-- >>> register myVector +-- >>> withLabel ("GET", "200") incCounter myVector +-- >>> withLabel ("GET", "200") incCounter myVector +-- >>> withLabel ("GET", "404") incCounter myVector +-- >>> withLabel ("POST", "200") incCounter myVector +-- >>> getVectorWith getCounter myVector +-- [(("GET","200"),2),(("GET","404"),1),(("POST","200"),1)] +-- >>> exportMetricsAsText >>= Data.ByteString.putStr +-- # HELP http_requests +-- # TYPE http_requests counter +-- http_requests{method="GET",code="200"} 2 +-- http_requests{method="GET",code="404"} 1 +-- http_requests{method="POST",code="200"} 1 + +, Vector +, vector +, withLabel +, removeLabel +, clearLabels +, getVectorWith + +-- *** Labels +-- +-- | The labels of a vector metric are types of the class Label. This module +-- defines all n-tupes of Strings for n <= 9 to be Labels. Additionally, the +-- type aliases LabelN is defined for each of these tuple types to make +-- specifying the types of vectors more concise. +-- +-- >>> :{ +-- >>> let myVector :: IO (Metric (Vector Label3 Counter)); +-- >>> myVector = vector ("a", "b", "c") $ counter (Info "some_counter" "") +-- >>> :} + +, Label (..) +, LabelPairs +, Label0 +, Label1 +, Label2 +, Label3 +, Label4 +, Label5 +, Label6 +, Label7 +, Label8 +, Label9 + +-- ** Custom metrics +-- +-- | Custom metrics can be created by directly creating a new 'Metric' type. There +-- are two parts of any metric, the handle and the collect method. +-- +-- The handle is a value embedded in the metric that is intended to allow for +-- communication with the metric from instrumented code. For example, all of the +-- metrics provided by this library use a newtype wrapped TVar of some +-- underlying data type as their handle. When defining a new metric, it is +-- recommended that you use a newtype wrapper around your handle type as it will +-- allow users of your metric to succinctly identify your metric in type +-- signatures. +-- +-- The collect method is responsible for serializing the current value of +-- a metric into a list of 'SampleGroup's. +-- +-- The following is an example of a custom metric that models the current CPU +-- time. It uses a newtype wrapped unit as the handler type since it doesn't +-- need to maintain any state. +-- +-- >>> :m +System.CPUTime +-- >>> :m +Data.ByteString.UTF8 +-- >>> newtype CPUTime = MkCPUTime () +-- >>> let info = Info "cpu_time" "The current CPU time" +-- >>> let toValue = Data.ByteString.UTF8.fromString . show +-- >>> let toSample = Sample "cpu_time" [] . toValue +-- >>> let toSampleGroup = (:[]) . SampleGroup info GaugeType . (:[]) . toSample +-- >>> let collectCPUTime = fmap toSampleGroup getCPUTime +-- >>> let cpuTimeMetric = Metric (MkCPUTime ()) collectCPUTime +-- >>> register cpuTimeMetric +-- >>> exportMetricsAsText >>= Data.ByteString.putStr +-- # HELP cpu_time The current CPU time +-- # TYPE cpu_time gauge +-- cpu_time ... + +-- * Instrumenting pure code +-- +-- | Pure code can be instrumented through the use of the 'Monitor' monad and +-- 'MonitorT' monad transformer. These constructs work by queueing all +-- operations on metrics. In order for the operations to actually be performed, +-- the queue must be evaluated within the IO monad. +-- +-- The following is a contrived example that defines an add function that +-- records the number of times it was invoked. +-- +-- > add :: Int -> Int -> Monitor Int +-- +-- Note that the changes to numAdds are not reflected until the updateMetrics +-- value has been evaluated in the IO monad. +-- +-- >>> numAdds <- counter (Info "num_adds" "The number of additions") +-- >>> let add x y = incCounter numAdds >> return (x + y) +-- >>> let (3, updateMetrics) = runMonitor $ (add 1 1) >>= (add 1) +-- >>> getCounter numAdds +-- 0 +-- >>> updateMetrics +-- >>> getCounter numAdds +-- 2 + +, MonadMonitor (..) +, Monitor +, runMonitor +, MonitorT +, runMonitorT + +-- * Base data types + +, Info (..) +, Metric (..) +, Sample (..) +, SampleGroup (..) +, SampleType (..) +) where + +import Prometheus.Export.Text +import Prometheus.Info +import Prometheus.Label +import Prometheus.Metric +import Prometheus.Metric.Counter +import Prometheus.Metric.Gauge +import Prometheus.Metric.Summary +import Prometheus.Metric.Vector +import Prometheus.MonadMonitor +import Prometheus.Registry + + +-- $setup +-- >>> :module +Prometheus +-- >>> :module +Control.Monad +-- >>> unregisterAll diff --git a/src/Prometheus/Export/Text.hs b/src/Prometheus/Export/Text.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Export/Text.hs @@ -0,0 +1,74 @@ +module Prometheus.Export.Text ( + exportMetricsAsText +) where + +import Prometheus.Info +import Prometheus.Label +import Prometheus.Metric +import Prometheus.Registry + +import Data.List (intersperse, intercalate) +import qualified Data.ByteString as BS +import qualified Data.ByteString.UTF8 as BS + + +-- $setup +-- >>> :module +Prometheus +-- >>> unregisterAll + +-- | Export all registered metrics in the Prometheus 0.0.4 text exposition +-- format. +-- +-- For the full specification of the format, see the official Prometheus +-- . +-- +-- >>> :m +Data.ByteString +-- >>> myCounter <- registerIO $ counter (Info "my_counter" "Example counter") +-- >>> incCounter myCounter +-- >>> exportMetricsAsText >>= Data.ByteString.putStr +-- # HELP my_counter Example counter +-- # TYPE my_counter counter +-- my_counter 1 +exportMetricsAsText :: IO BS.ByteString +exportMetricsAsText = do + samples <- collectMetrics + let exportedSamples = map exportSampleGroup samples ++ [BS.empty] + return $ BS.concat $ intersperse (BS.fromString "\n") exportedSamples + +exportSampleGroup :: SampleGroup -> BS.ByteString +exportSampleGroup (SampleGroup info ty samples) = + if BS.null exportedSamples + then BS.empty + else prefix `BS.append` exportedSamples + where + exportedSamples = exportSamples samples + name = metricName info + help = metricHelp info + prefix = BS.fromString $ unlines [ + "# HELP " ++ name ++ " " ++ escape help + , "# TYPE " ++ name ++ " " ++ show ty + ] + escape [] = [] + escape ('\n':xs) = '\\' : 'n' : escape xs + escape ('\\':xs) = '\\' : '\\' : escape xs + escape (x:xs) = x : escape xs + +exportSamples :: [Sample] -> BS.ByteString +exportSamples = BS.intercalate (BS.fromString "\n") . map exportSample + +exportSample :: Sample -> BS.ByteString +exportSample (Sample name [] value) = BS.concat [ + BS.fromString name, BS.fromString " ", value + ] +exportSample (Sample name labels value) = BS.concat [ + BS.fromString name + , BS.fromString "{", exportLabels labels, BS.fromString "} " + , value + ] + +exportLabels :: LabelPairs -> BS.ByteString +exportLabels labels = BS.fromString $ intercalate "," $ map exportLabel labels + +exportLabel :: (String, String) -> String +exportLabel (key, value) = key ++ "=" ++ show value + diff --git a/src/Prometheus/Info.hs b/src/Prometheus/Info.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Info.hs @@ -0,0 +1,43 @@ +module Prometheus.Info ( + Info (..) +, checkInfo +) where + + +-- | Meta data about a metric including its name and a help string that +-- describes the value that the metric is measuring. +data Info = Info { + metricName :: String +, metricHelp :: String +} deriving (Read, Show, Eq, Ord) + +checkInfo :: Info -> a -> a +checkInfo info a + | (x:_) <- name, not $ validStart x = errorInvalid + | (_:xs) <- name, not $ all validRest xs = errorInvalid + | ('_':'_':_) <- name = errorPrefix + | [] <- name = errorEmpty + | otherwise = a + where + name = metricName info + + errorInvalid = error $ concat [ + "The metric '", name, "' contains invalid characters." + ] + + errorPrefix = error $ concat [ + "The metric '", name, "' cannot start with '__'." + ] + + errorEmpty = error "Empty metric names are not allowed." + + validStart c = ('a' <= c && c <= 'z') + || ('A' <= c && c <= 'Z') + || c == '_' + || c == ':' + + validRest c = ('a' <= c && c <= 'z') + || ('A' <= c && c <= 'Z') + || ('0' <= c && c <= '9') + || c == '_' + || c == ':' diff --git a/src/Prometheus/Label.hs b/src/Prometheus/Label.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Label.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE FlexibleInstances #-} +module Prometheus.Label ( + Label (..) +, LabelPairs +, Label0 +, Label1 +, Label2 +, Label3 +, Label4 +, Label5 +, Label6 +, Label7 +, Label8 +, Label9 +) where + + +-- | A list of tuples where the first value is the label and the second is the +-- value of that label. +type LabelPairs = [(String, String)] + +-- | Label describes a class of types that can be used to as the label of +-- a vector. +class Ord l => Label l where + labelPairs :: l -> l -> LabelPairs + +type Label0 = () + +instance Label () where + labelPairs () () = [] + +type Label1 = String + +instance Label String where + labelPairs key value = [(key, value)] + +type Label2 = (String, String) + +instance Label (String, String) where + labelPairs (k1, k2) (v1, v2) = [(k1, v1), (k2, v2)] + +type Label3 = (String, String, String) + +instance Label (String, String, String) where + labelPairs (k1, k2, k3) (v1, v2, v3) = [(k1, v1), (k2, v2), (k3, v3)] + +type Label4 = (String, String, String, String) + +instance Label (String, String, String, String) where + labelPairs (k1, k2, k3, k4) (v1, v2, v3, v4) = + [(k1, v1), (k2, v2), (k3, v3), (k4, v4)] + +type Label5 = (String, String, String, String, String) + +instance Label (String, String, String, String, String) where + labelPairs (k1, k2, k3, k4, k5) (v1, v2, v3, v4, v5) = + [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5)] + +type Label6 = (String, String, String, String, String, String) + +instance Label (String, String, String, String, String, String) where + labelPairs (k1, k2, k3, k4, k5, k6) (v1, v2, v3, v4, v5, v6) = + [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6)] + +type Label7 = (String, String, String, String, String, String, String) + +instance Label (String, String, String, String, String, String, String) where + labelPairs (k1, k2, k3, k4, k5, k6, k7) (v1, v2, v3, v4, v5, v6, v7) = + [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6), + (k7, v7)] + +type Label8 = (String, String, String, String, String, String, String, String) + +instance Label (String, String, String, String, String, String, String, + String) where + labelPairs (k1, k2, k3, k4, k5, k6, k7, k8) + (v1, v2, v3, v4, v5, v6, v7, v8) = + [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6), + (k7, v7), (k8, v8)] + +type Label9 = (String, String, String, String, String, String, String, String, + String) + +instance Label (String, String, String, String, String, String, String, + String, String) where + labelPairs (k1, k2, k3, k4, k5, k6, k7, k8, k9) + (v1, v2, v3, v4, v5, v6, v7, v8, v9) = + [(k1, v1), (k2, v2), (k3, v3), (k4, v4), (k5, v5), (k6, v6), + (k7, v7), (k8, v8), (k9, v9)] diff --git a/src/Prometheus/Metric.hs b/src/Prometheus/Metric.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Metric.hs @@ -0,0 +1,48 @@ +module Prometheus.Metric ( + Metric (..) +, Sample (..) +, SampleGroup (..) +, SampleType (..) +) where + +import Prometheus.Info +import Prometheus.Label + +import qualified Data.ByteString as BS + + +-- | The type of a sample. This corresponds to the 5 types of metrics supported +-- by Prometheus. +data SampleType + = CounterType + | GaugeType + | SummaryType + | HistogramType + | UntypedType + +instance Show SampleType where + show CounterType = "counter" + show GaugeType = "gauge" + show SummaryType = "summary" + show HistogramType = "histogram" + show UntypedType = "untyped" + +-- | A single value recorded at a moment in time. The sample type contains the +-- name of the sample, a list of labels and their values, and the value encoded +-- as a ByteString. +data Sample = Sample String LabelPairs BS.ByteString + deriving (Show) + +-- | A Sample group is a list of samples that is tagged with meta data +-- including the name, help string, and type of the sample. +data SampleGroup = SampleGroup Info SampleType [Sample] + deriving (Show) + +-- | A metric represents a single value that is being monitored. It is comprised +-- of a handle value and a collect method. The handle value is typically a new +-- type wrapped value that provides access to the internal state of the metric. +-- The collect method samples the current value of the metric. +data Metric s = Metric { + handle :: s + , collect :: IO [SampleGroup] + } diff --git a/src/Prometheus/Metric/Counter.hs b/src/Prometheus/Metric/Counter.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Metric/Counter.hs @@ -0,0 +1,40 @@ +module Prometheus.Metric.Counter ( + Counter +, counter +, incCounter +, getCounter +) where + +import Prometheus.Info +import Prometheus.Metric +import Prometheus.MonadMonitor + +import qualified Data.Atomics.Counter as Atomics +import qualified Data.ByteString.UTF8 as BS + + +newtype Counter = MkCounter Atomics.AtomicCounter + +-- | Creates a new counter metric with a given name and help string. +counter :: Info -> IO (Metric Counter) +counter info = do + atomicCounter <- Atomics.newCounter 0 + return Metric { + handle = MkCounter atomicCounter + , collect = collectCounter info atomicCounter + } + +-- | Increments the value of a counter metric by 1. +incCounter :: MonadMonitor m => Metric Counter -> m () +incCounter (Metric {handle = MkCounter c}) = + doIO $ Atomics.incrCounter_ 1 c + +-- | Retrieves the current value of a counter metric. +getCounter :: Metric Counter -> IO Int +getCounter (Metric {handle = MkCounter c}) = Atomics.readCounter c + +collectCounter :: Info -> Atomics.AtomicCounter -> IO [SampleGroup] +collectCounter info c = do + value <- Atomics.readCounter c + let sample = Sample (metricName info) [] (BS.fromString $ show value) + return [SampleGroup info CounterType [sample]] diff --git a/src/Prometheus/Metric/Gauge.hs b/src/Prometheus/Metric/Gauge.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Metric/Gauge.hs @@ -0,0 +1,81 @@ +module Prometheus.Metric.Gauge ( + Gauge +, gauge +, incGauge +, decGauge +, addGauge +, subGauge +, setGauge +, setGaugeToDuration +, getGauge +) where + +import Prometheus.Info +import Prometheus.Metric +import Prometheus.MonadMonitor + +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import qualified Data.Atomics as Atomics +import qualified Data.ByteString.UTF8 as BS +import qualified Data.IORef as IORef + + +newtype Gauge = MkGauge (IORef.IORef Double) + +-- | Create a new gauge metric with a given name and help string. +gauge :: Info -> IO (Metric Gauge) +gauge info = do + ioref <- IORef.newIORef 0 + return Metric { + handle = MkGauge ioref + , collect = collectGauge info ioref + } + +withGauge :: MonadMonitor m + => Metric Gauge + -> (Double -> Double) + -> m () +withGauge (Metric {handle = MkGauge ioref}) f = + doIO $ Atomics.atomicModifyIORefCAS_ ioref f + +-- | Adds a value to a gauge metric. +addGauge :: MonadMonitor m => Double -> Metric Gauge -> m () +addGauge x g = withGauge g add + where add i = i `seq` x `seq` i + x + +-- | Subtracts a value from a gauge metric. +subGauge :: MonadMonitor m => Double -> Metric Gauge -> m () +subGauge x g = withGauge g sub + where sub i = i `seq` x `seq` i - x + +-- | Increments a gauge metric by 1. +incGauge :: MonadMonitor m => Metric Gauge -> m () +incGauge g = withGauge g (+ 1) + +-- | Decrements a gauge metric by 1. +decGauge :: MonadMonitor m => Metric Gauge -> m () +decGauge g = withGauge g (+ (-1)) + +-- | Sets a gauge metric to a specific value. +setGauge :: MonadMonitor m => Double -> Metric Gauge -> m () +setGauge r g = withGauge g set + where set _ = r + +-- | Retrieves the current value of a gauge metric. +getGauge :: Metric Gauge -> IO Double +getGauge (Metric {handle = MkGauge ioref}) = IORef.readIORef ioref + +-- | Sets a gauge metric to the duration in seconds of an IO action. +setGaugeToDuration :: IO a -> Metric Gauge -> IO a +setGaugeToDuration io metric = do + start <- getCurrentTime + result <- io + end <- getCurrentTime + setGauge (fromRational $ toRational $ end `diffUTCTime` start) metric + return result + +collectGauge :: Info -> IORef.IORef Double -> IO [SampleGroup] +collectGauge info c = do + value <- IORef.readIORef c + let sample = Sample (metricName info) [] (BS.fromString $ show value) + return [SampleGroup info GaugeType [sample]] diff --git a/src/Prometheus/Metric/Summary.hs b/src/Prometheus/Metric/Summary.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Metric/Summary.hs @@ -0,0 +1,198 @@ +module Prometheus.Metric.Summary ( + Summary +, Quantile +, summary +, defaultQuantiles +, observe +, observeDuration +, getSummary + +, dumpEstimator +, emptyEstimator +, Estimator (..) +, Item (..) +, insert +, compress +, query +, invariant +) where + +import Prometheus.Info +import Prometheus.Metric +import Prometheus.MonadMonitor + +import Data.Int (Int64) +import Data.Time.Clock (diffUTCTime, getCurrentTime) +import Data.Foldable (foldr') +import qualified Control.Concurrent.STM as STM +import qualified Data.ByteString.UTF8 as BS + + +newtype Summary = MkSummary (STM.TVar Estimator) + +-- | Creates a new summary metric with a given name, help string, and a list of +-- quantiles. A reasonable set set of quantiles is provided by +-- 'defaultQuantiles'. +summary :: Info -> [Quantile] -> IO (Metric Summary) +summary info quantiles = do + valueTVar <- STM.newTVarIO (emptyEstimator quantiles) + return Metric { + handle = MkSummary valueTVar + , collect = collectSummary info valueTVar + } + +withSummary :: MonadMonitor m + => Metric Summary -> (Estimator -> Estimator) -> m () +withSummary (Metric {handle = MkSummary valueTVar}) f = + doIO $ STM.atomically $ do + STM.modifyTVar' valueTVar compress + STM.modifyTVar' valueTVar f + +-- | Adds a new observation to a summary metric. +observe :: MonadMonitor m => Double -> Metric Summary -> m () +observe v s = withSummary s (insert v) + +-- | Adds the duration in seconds of an IO action as an observation to a summary +-- metric. +observeDuration :: IO a -> Metric Summary -> IO a +observeDuration io metric = do + start <- getCurrentTime + result <- io + end <- getCurrentTime + observe (fromRational $ toRational $ end `diffUTCTime` start) metric + return result + +-- | Retrieves a list of tuples containing a quantile and its associated value. +getSummary :: Metric Summary -> IO [(Rational, Double)] +getSummary (Metric {handle = MkSummary valueTVar}) = do + estimator <- STM.atomically $ do + STM.modifyTVar' valueTVar compress + STM.readTVar valueTVar + let quantiles = map fst $ estQuantiles estimator + let values = map (query estimator) quantiles + return $ zip quantiles values + +collectSummary :: Info -> STM.TVar Estimator -> IO [SampleGroup] +collectSummary info valueTVar = STM.atomically $ do + STM.modifyTVar' valueTVar compress + estimator@(Estimator count itemSum _ _) <- STM.readTVar valueTVar + let quantiles = map fst $ estQuantiles estimator + let samples = map (toSample estimator) quantiles + let sumSample = Sample (metricName info ++ "_sum") [] (bsShow itemSum) + let countSample = Sample (metricName info ++ "_count") [] (bsShow count) + return [SampleGroup info SummaryType $ samples ++ [sumSample, countSample]] + where + bsShow :: Show s => s -> BS.ByteString + bsShow = BS.fromString . show + + toSample estimator q = + Sample (metricName info) [("quantile", show $ toDouble q)] $ + bsShow $ query estimator q + + toDouble :: Rational -> Double + toDouble = fromRational + +dumpEstimator :: Metric Summary -> IO Estimator +dumpEstimator (Metric {handle = MkSummary valueTVar}) = + STM.atomically $ STM.readTVar valueTVar + +-- | A quantile is a pair of a quantile value and an associated acceptable error +-- value. +type Quantile = (Rational, Rational) + +data Item = Item { + itemValue :: Double +, itemG :: !Int64 +, itemD :: !Int64 +} deriving (Eq, Show) + +instance Ord Item where + compare a b = itemValue a `compare` itemValue b + +data Estimator = Estimator { + estCount :: !Int64 +, estSum :: !Double +, estQuantiles :: [Quantile] +, estItems :: [Item] +} deriving (Show) + +defaultQuantiles :: [Quantile] +defaultQuantiles = [(0.5, 0.05), (0.9, 0.01), (0.99, 0.001)] + +emptyEstimator :: [Quantile] -> Estimator +emptyEstimator quantiles = Estimator 0 0 quantiles [] + +insert :: Double -> Estimator -> Estimator +insert value estimator@(Estimator oldCount oldSum quantiles items) = + newEstimator $ insertItem 0 items + where + newEstimator = Estimator (oldCount + 1) (oldSum + value) quantiles + + insertItem _ [] = [Item value 1 0] + insertItem r [x] + -- The first two cases cover the scenario where the initial size of + -- the list is one. + | r == 0 && value < itemValue x = Item value 1 0 : [x] + | r == 0 = x : [Item value 1 0] + -- The last case covers the scenario where the we have walked off + -- the end of a list with more than 1 element in the final case of + -- insertItem in which case we already know that x < value. + | otherwise = x : [Item value 1 0] + insertItem r (x:y:xs) + -- This first case only covers the scenario where value is less than + -- the first item in a multi-item list. For subsequent steps of + -- a multi valued list, this case cannot happen as it would have + -- fallen through to the case below in the previous step. + | value <= itemValue x = Item value 1 0 : x : y : xs + | value <= itemValue y = x : Item value 1 (calcD $ r + itemG x) + : y : xs + | otherwise = x : insertItem (itemG x + r) (y : xs) + + calcD r = max 0 + $ floor (invariant estimator (fromIntegral r)) - 1 + + +compress :: Estimator -> Estimator +compress est@(Estimator _ _ _ []) = est +compress est@(Estimator _ _ _ items) = est { + estItems = (minItem :) + $ foldr' compressPair [] + $ drop 1 -- The exact minimum item must be kept exactly. + $ zip items + $ scanl (+) 0 (map itemG items) + } + where + minItem = head items + compressPair (a, _) [] = [a] + compressPair (a@(Item _ aG _), r) (b@(Item bVal bG bD):bs) + | bD == 0 = a : b : bs + | aG + bG + bD <= inv = Item bVal (aG + bG) bD : bs + | otherwise = a : b : bs + where + inv = floor $ invariant est (fromIntegral r) + +query :: Estimator -> Rational -> Double +query est@(Estimator count _ _ items) q = findQuantile allRs items + where + allRs = scanl (+) 0 $ map itemG items + + n = fromIntegral count + f = invariant est + + rank = q * n + bound = rank + (f rank / 2) + + findQuantile _ [] = 0 / 0 -- NaN + findQuantile _ [a] = itemValue a + findQuantile (_:bR:rs) (a@(Item{}):b@(Item _ bG bD):xs) + | fromIntegral (bR + bG + bD) > bound = itemValue a + | otherwise = findQuantile (bR:rs) (b:xs) + findQuantile _ _ = error "Query impossibility" + +invariant :: Estimator -> Rational -> Rational +invariant (Estimator count _ quantiles _) r = max 1 + $ minimum $ map fj quantiles + where + n = fromIntegral count + fj (q, e) | q * n <= r = 2 * e * r / q + | otherwise = 2 * e * (n - r) / (1 - q) diff --git a/src/Prometheus/Metric/Vector.hs b/src/Prometheus/Metric/Vector.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Metric/Vector.hs @@ -0,0 +1,114 @@ +module Prometheus.Metric.Vector ( + Vector (..) +, vector +, withLabel +, removeLabel +, clearLabels +, getVectorWith +) where + +import Prometheus.Label +import Prometheus.Metric +import Prometheus.MonadMonitor + +import Control.Applicative ((<$>)) +import Data.Traversable (forM) +import qualified Data.Atomics as Atomics +import qualified Data.IORef as IORef +import qualified Data.Map.Strict as Map + + +type VectorState l m = (IO (Metric m), Map.Map l (Metric m)) + +data Vector l m = MkVector (IORef.IORef (VectorState l m)) + +-- | Creates a new vector of metrics given a label. +vector :: Label l => l -> IO (Metric m) -> IO (Metric (Vector l m)) +vector labels gen = do + ioref <- checkLabelKeys labels $ IORef.newIORef (gen, Map.empty) + return Metric { + handle = MkVector ioref + , collect = collectVector labels ioref + } + +checkLabelKeys :: Label l => l -> a -> a +checkLabelKeys keys r = foldl check r $ map fst $ labelPairs keys keys + where + check _ "instance" = error "The label 'instance' is reserved." + check _ "job" = error "The label 'job' is reserved." + check _ "quantile" = error "The label 'quantile' is reserved." + check a (k:ey) + | validStart k && all validRest ey = a + | otherwise = error $ "The label '" ++ (k:ey) ++ "' is not valid." + check _ [] = error "Empty labels are not allowed." + + validStart c = ('a' <= c && c <= 'z') + || ('A' <= c && c <= 'Z') + || c == '_' + + validRest c = ('a' <= c && c <= 'z') + || ('A' <= c && c <= 'Z') + || ('0' <= c && c <= '9') + || c == '_' + +-- TODO(will): This currently makes the assumption that all the types and info +-- for all sample groups returned by a metric's collect method will be the same. +-- It is not clear that this will always be a valid assumption. +collectVector :: Label l => l -> IORef.IORef (VectorState l m) -> IO [SampleGroup] +collectVector keys ioref = do + (_, metricMap) <- IORef.readIORef ioref + joinSamples <$> concat <$> mapM collectInner (Map.assocs metricMap) + where + collectInner (labels, metric) = + map (adjustSamples labels) <$> collect metric + + adjustSamples labels (SampleGroup info ty samples) = + SampleGroup info ty (map (prependLabels labels) samples) + + prependLabels l (Sample name labels value) = + Sample name (labelPairs keys l ++ labels) value + + joinSamples [] = [] + joinSamples s@(SampleGroup i t _:_) = [SampleGroup i t (extract s)] + + extract [] = [] + extract (SampleGroup _ _ s:xs) = s ++ extract xs + +getVectorWith :: (Metric metric -> IO a) + -> Metric (Vector label metric) + -> IO [(label, a)] +getVectorWith f (Metric {handle = MkVector valueTVar}) = do + (_, metricMap) <- IORef.readIORef valueTVar + Map.assocs <$> forM metricMap f + +-- | Given a label, applies an operation to the corresponding metric in the +-- vector. +withLabel :: (Label label, MonadMonitor m) + => label + -> (Metric metric -> IO ()) + -> Metric (Vector label metric) + -> m () +withLabel label f (Metric {handle = MkVector ioref}) = doIO $ do + (gen, _) <- IORef.readIORef ioref + newMetric <- gen + metric <- Atomics.atomicModifyIORefCAS ioref $ \(_, metricMap) -> + let maybeMetric = Map.lookup label metricMap + updatedMap = Map.insert label newMetric metricMap + in case maybeMetric of + Nothing -> ((gen, updatedMap), newMetric) + Just metric -> ((gen, metricMap), metric) + f metric + +-- | Removes a label from a vector. +removeLabel :: (Label label, MonadMonitor m) + => Metric (Vector label metric) -> label -> m () +removeLabel (Metric {handle = MkVector valueTVar}) label = + doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f + where f (desc, metricMap) = (desc, Map.delete label metricMap) + +-- | Removes all labels from a vector. +clearLabels :: (Label label, MonadMonitor m) + => Metric (Vector label metric) -> m () +clearLabels (Metric {handle = MkVector valueTVar}) = + doIO $ Atomics.atomicModifyIORefCAS_ valueTVar f + where f (desc, _) = (desc, Map.empty) diff --git a/src/Prometheus/MonadMonitor.hs b/src/Prometheus/MonadMonitor.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/MonadMonitor.hs @@ -0,0 +1,51 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Prometheus.MonadMonitor ( + MonadMonitor (..) +, Monitor +, runMonitor +, MonitorT +, runMonitorT +) where + +import Control.Applicative (Applicative) +import Control.Monad.Identity (Identity, runIdentity) +import Control.Monad.Trans.Class (MonadTrans) +import Control.Monad.Writer.Strict (WriterT, runWriterT, tell) + + +-- | MonadMonitor describes a class of Monads that are capable of performing +-- asynchronous IO operations. +class Monad m => MonadMonitor m where + doIO :: IO () -> m () + +instance MonadMonitor IO where + doIO = id + +-- | Monitor allows the use of Prometheus metrics in pure code. When using +-- Monitor, all of the metric operations will be collected and queued into +-- a single IO () value that can be run from impure code. +-- +-- Because all of the operations are performed asynchronously use of this class +-- is not recommended for use with metrics that are time sensitive (e.g. for +-- measuring latency). +type Monitor a = MonitorT Identity a + +-- | MonitorT is the monad transformer analog of Monitor and allows for +-- monitoring pure monad transformer stacks. +newtype MonitorT m a = MkMonitorT (WriterT [IO ()] m a) + deriving (Applicative, Functor, Monad, MonadTrans) + +instance Monad m => MonadMonitor (MonitorT m) where + doIO f = MkMonitorT $ tell [f] + +-- | Extract a value and the corresponding monitor update value from the Monitor +-- monad. For an example use see 'Monitor'. +runMonitor :: Monitor a -> (a, IO ()) +runMonitor a = runIdentity $ runMonitorT a + +-- | Extract a value and the corresponding monitor update value from the +-- MonitorT monad transformer. +runMonitorT :: Monad m => MonitorT m a -> m (a, IO ()) +runMonitorT (MkMonitorT writerT) = do + (v, operations) <- runWriterT writerT + return (v, sequence_ operations) diff --git a/src/Prometheus/Registry.hs b/src/Prometheus/Registry.hs new file mode 100644 --- /dev/null +++ b/src/Prometheus/Registry.hs @@ -0,0 +1,79 @@ +{-# LANGUAGE ExistentialQuantification #-} +module Prometheus.Registry ( + register +, registerIO +, unsafeRegister +, unsafeRegisterIO +, collectMetrics +, unregisterAll +) where + +import Prometheus.Metric + +import Control.Applicative ((<$>)) +import System.IO.Unsafe (unsafePerformIO) +import qualified Control.Concurrent.STM as STM + + +-- $setup +-- >>> :module +Prometheus +-- >>> unregisterAll + +data RegisteredMetric = forall s. MkRegisteredMetric (Metric s) + +type Registry = [RegisteredMetric] + +{-# NOINLINE globalRegistry #-} +globalRegistry :: STM.TVar Registry +globalRegistry = unsafePerformIO $ STM.newTVarIO [] + +-- | Registers a metric with the global metric registry. +register :: Metric s -> IO (Metric s) +register metric = do + let addToRegistry = (MkRegisteredMetric metric :) + STM.atomically $ STM.modifyTVar' globalRegistry addToRegistry + return metric + +-- | Registers a metric with the global metric registry. +registerIO :: IO (Metric s) -> IO (Metric s) +registerIO metricGen = metricGen >>= register + +-- | Registers a metric with the global metric registry. +-- +-- __IMPORTANT__: This method should only be used to register metrics as top +-- level symbols, it should not be run from other pure code. +unsafeRegister :: Metric s -> Metric s +unsafeRegister = unsafePerformIO . register + +-- | Registers a metric with the global metric registry. +-- +-- __IMPORTANT__: This method should only be used to register metrics as top +-- level symbols, it should not be run from other pure code. +-- +-- For example, +-- +-- >>> :{ +-- {-# NOINLINE c #-} +-- let c = unsafeRegisterIO $ counter (Info "my_counter" "An example metric") +-- :} +-- ... +unsafeRegisterIO :: IO (Metric s) -> Metric s +unsafeRegisterIO = unsafePerformIO . registerIO + +-- | Removes all currently registered metrics from the registry. +unregisterAll :: IO () +unregisterAll = STM.atomically $ STM.writeTVar globalRegistry [] + +-- | Collect samples from all currently registered metrics. In typical use cases +-- there is no reason to use this function, instead you should use +-- `exportMetricsAsText` or a convenience library. +-- +-- This function is likely only of interest if you wish to export metrics in +-- a non-supported format for use with another monitoring service. +collectMetrics :: IO [SampleGroup] +collectMetrics = do + registry <- STM.atomically $ STM.readTVar globalRegistry + concat <$> mapM collectRegistered registry + +collectRegistered :: RegisteredMetric -> IO [SampleGroup] +collectRegistered (MkRegisteredMetric metric) = collect metric diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-} diff --git a/tests/doctest.hs b/tests/doctest.hs new file mode 100644 --- /dev/null +++ b/tests/doctest.hs @@ -0,0 +1,9 @@ +module Main where + +import Test.DocTest + +main :: IO () +main = doctest [ + "-isrc" + , "Prometheus" + ]