analyze-client (empty) → 0.1.0.0

raw patch · 4 files changed

+149/−0 lines, 4 filesdep +MonadCatchIO-transformersdep +basedep +bytestringsetup-changed

Dependencies added: MonadCatchIO-transformers, base, bytestring, http-conduit, mtl, snap, snap-core, time

Files

• LICENSE +30/−0
• Setup.hs +2/−0
• analyze-client.cabal +26/−0
• src/Web/Analyze/Client.hs +91/−0

@@ -0,0 +1,30 @@+Copyright (c) 2014, Daniel Patterson++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Daniel Patterson nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

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

@@ -0,0 +1,26 @@+name:                analyze-client+version:             0.1.0.0+synopsis:            Client for analyze service+-- description:+homepage:            https://github.com/dbp/analyze-client+license:             BSD3+license-file:        LICENSE+author:              Daniel Patterson+maintainer:          dbp@dbpmail.net+-- copyright:+category:            Web+build-type:          Simple+cabal-version:       >=1.8++library+  exposed-modules:+        Web.Analyze.Client+  hs-source-dirs: src+  build-depends:       base == 4.*,+                       snap == 0.13.*,+                       snap-core == 0.9.*,+                       http-conduit == 2.*,+                       time == 1.4.*,+                       bytestring >= 0.9.1 && < 0.11,+                       mtl >= 2 && < 3,+                       MonadCatchIO-transformers

@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings, ScopedTypeVariables #-}++module Web.Analyze.Client (+       wrap,+       wrap'+  ) where++import Prelude hiding (catch)+import qualified Snap.Core as S (Request)+import Snap.Core (rqContextPath, rqPathInfo, rqMethod, getRequest, urlEncode, Method(..))+import Snap.Snaplet (Handler)+import Control.Monad (void)+import Control.Monad.Trans (liftIO)+import Control.Concurrent (forkIO)+import Data.Time.Clock (UTCTime, getCurrentTime, diffUTCTime)+import Network.HTTP.Conduit (Manager, parseUrl, Request(..), httpLbs)+import Data.ByteString (ByteString)+import qualified Data.ByteString as B (concat, append)+import qualified Data.ByteString.Char8 as B8 (pack)+import Control.Monad.CatchIO (catch)+import Control.Exception.Base (SomeException)++wrap :: Handler b v a -> Manager+     -> ByteString -> Handler b v a+     -> Handler b v a+wrap = wrap' (return Nothing)++wrap' :: Handler b v (Maybe ByteString) -> Handler b v a+      -> Manager -> ByteString -> Handler b v a+      -> Handler b v a+wrap' userh errh man token h =+  handleErrors userh errh man token $ do+    start <- liftIO getCurrentTime+    res <- h+    end <- liftIO getCurrentTime+    req <- getRequest+    liftIO $ forkIO (sendResult man token req start end)+    return res++handleErrors :: Handler b v (Maybe ByteString) -> Handler b v a -> Manager -> ByteString+             -> Handler b v a -> Handler b v a+handleErrors userh errh man token h =+  catch h $ \(e::SomeException) -> do+    req <- getRequest+    uid <- userh+    liftIO $ forkIO (sendError man token req (B8.pack (show e)) uid)+    errh++sendResult :: Manager -> ByteString+           -> S.Request -> UTCTime+           -> UTCTime -> IO ()+sendResult man token req start end = do+    let time = milliseconds (diffUTCTime end start) :: Int+    initreq <- parseUrl "http://analyze.positionstudios.com/submit/visit"+    let url = B.append (rqContextPath req) (rqPathInfo req)+    let meth = methodtobs (rqMethod req)+    let httpreq =+         initreq { method = "POST"+                , queryString =+                   B.concat ["url="+                            , url+                            , "&render="+                            , B8.pack (show time)+                            , "&method="+                            , meth+                            , "&token="+                            , token]}+    void (httpLbs httpreq man)+  where milliseconds = floor . fromRational . (1000 *) . toRational+        methodtobs GET = "get"+        methodtobs POST = "post"+        methodtobs PUT = "put"+        methodtobs DELETE = "delete"+++sendError :: Manager -> ByteString -> S.Request -> ByteString -> Maybe ByteString -> IO ()+sendError man token req message muid = do+    initreq <- parseUrl "http://analyze.positionstudios.com/submit/error"+    let url = B.append (rqContextPath req) (rqPathInfo req)+    let user = maybe "" (B.append "&uid=") muid+    let httpreq =+         initreq { method = "POST"+                 , queryString =+                 B.concat ["url="+                          , url+                          , "&message="+                          , urlEncode message+                          , user+                          , "&token="+                          , token]}+    void (httpLbs httpreq man)