From 52585c70e615f14835524a83bea2ed2372ae29e1 Mon Sep 17 00:00:00 2001
From: Timo von Holtz <tvh@anchor.com.au>
Date: Fri, 1 May 2015 16:06:24 +1000
Subject: [PATCH] Add testsuite to make sure it is usable

---
 ekg-servant.cabal  | 16 ++++++++++
 lib/Servant/Ekg.hs | 17 ++++++++---
 test/test.hs       | 74 ++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 103 insertions(+), 4 deletions(-)
 create mode 100644 test/test.hs

diff --git a/ekg-servant.cabal b/ekg-servant.cabal
index b8c8a06..02fdc02 100644
--- a/ekg-servant.cabal
+++ b/ekg-servant.cabal
@@ -26,3 +26,19 @@ library
                      , unordered-containers
                      , wai
   default-language:    Haskell2010
+
+test-suite spec
+  type: exitcode-stdio-1.0
+  ghc-options: -Wall
+  default-language: Haskell2010
+  hs-source-dirs: test
+  main-is: test.hs
+  build-depends:      base == 4.*
+                    , aeson
+                    , ekg
+                    , ekg-core
+                    , ekg-servant
+                    , servant-server
+                    , text
+                    , wai
+                    , warp
\ No newline at end of file
diff --git a/lib/Servant/Ekg.hs b/lib/Servant/Ekg.hs
index e53f19b..8629a59 100644
--- a/lib/Servant/Ekg.hs
+++ b/lib/Servant/Ekg.hs
@@ -18,7 +18,7 @@ import qualified Data.Text                   as T
 import qualified Data.Text.Encoding          as T
 import           Data.Time.Clock
 import           GHC.TypeLits
-import           Network.HTTP.Types
+import           Network.HTTP.Types          (Method, Status (..))
 import           Network.Wai
 import           Servant.API
 import           System.Metrics
@@ -53,7 +53,7 @@ responseTimeDistribution dist application request respond =
     stop t1 = do
         t2 <- getCurrentTime
         let dt = diffUTCTime t2 t1
-        Distribution.add dist $ fromRational $ toRational dt
+        Distribution.add dist $ fromRational $ (*1000) $ toRational dt
 
 data Meters = Meters
     { metersInflight :: Gauge.Gauge
@@ -82,7 +82,7 @@ monitorEndpoints proxy store meters application request respond = do
             metersC4XX <- createCounter (prefix <> "responses.4XX") store
             metersC5XX <- createCounter (prefix <> "responses.5XX") store
             metersCXXX <- createCounter (prefix <> "responses.XXX") store
-            metersTime <- createDistribution (prefix <> "time") store
+            metersTime <- createDistribution (prefix <> "time_ms") store
             let m = Meters{..}
             return (H.insert path m ms, m)
         Just m -> return (ms,m)
@@ -118,7 +118,16 @@ instance (KnownSymbol (capture :: Symbol), HasEndpoint (sub :: *)) => HasEndpoin
                 return (p:end, method)
             _ -> Nothing
 
-instance HasEndpoint (sub :: *) => HasEndpoint ((a :: *) :> sub) where
+instance HasEndpoint (sub :: *) => HasEndpoint (Header h a :> sub) where
+    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
+
+instance HasEndpoint (sub :: *) => HasEndpoint (QueryParam (h :: Symbol) a :> sub) where
+    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
+
+instance HasEndpoint (sub :: *) => HasEndpoint (QueryParams (h :: Symbol) a :> sub) where
+    getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
+
+instance HasEndpoint (sub :: *) => HasEndpoint (ReqBody a :> sub) where
     getEndpoint _ = getEndpoint (Proxy :: Proxy sub)
 
 instance HasEndpoint (Get a) where
diff --git a/test/test.hs b/test/test.hs
new file mode 100644
index 0000000..c32cc89
--- /dev/null
+++ b/test/test.hs
@@ -0,0 +1,74 @@
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE PolyKinds #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE OverlappingInstances #-}
+
+import Control.Concurrent
+import Data.Aeson
+import Data.Monoid
+import Data.Proxy
+import Data.Text
+import GHC.Generics
+import Network.Wai
+import Network.Wai.Handler.Warp
+import System.Metrics
+import Servant
+
+import Servant.Ekg
+
+-- * Example
+
+-- | A greet message data type
+newtype Greet = Greet { _msg :: Text }
+  deriving (Generic, Show)
+
+instance FromJSON Greet
+instance ToJSON Greet
+
+-- API specification
+type TestApi =
+       -- GET /hello/:name?capital={true, false}  returns a Greet as JSON
+       "hello" :> Capture "name" Text :> QueryParam "capital" Bool :> Get Greet
+
+       -- POST /greet with a Greet as JSON in the request body,
+       --             returns a Greet as JSON
+  :<|> "greet" :> ReqBody Greet :> Post Greet
+
+       -- DELETE /greet/:greetid
+  :<|> "greet" :> Capture "greetid" Text :> Delete
+
+testApi :: Proxy TestApi
+testApi = Proxy
+
+-- Server-side handlers.
+--
+-- There's one handler per endpoint, which, just like in the type
+-- that represents the API, are glued together using :<|>.
+--
+-- Each handler runs in the 'EitherT (Int, String) IO' monad.
+server :: Server TestApi
+server = helloH :<|> postGreetH :<|> deleteGreetH
+
+  where helloH name Nothing = helloH name (Just False)
+        helloH name (Just False) = return . Greet $ "Hello, " <> name
+        helloH name (Just True) = return . Greet . toUpper $ "Hello, " <> name
+
+        postGreetH greet = return greet
+
+        deleteGreetH _ = return ()
+
+-- Turn the server into a WAI app. 'serve' is provided by servant,
+-- more precisely by the Servant.Server module.
+test :: Application
+test = serve testApi server
+
+-- Put this all to work!
+main :: IO ()
+main = do
+    ekg <- newStore
+    ms <- newMVar mempty
+    _ <- forkIO $ run 8001 $ monitorEndpoints testApi ekg ms test
+    return ()