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)