diff --git a/Handler/Home.hs b/Handler/Home.hs --- a/Handler/Home.hs +++ b/Handler/Home.hs @@ -1,6 +1,6 @@ {-# LANGUAGE TemplateHaskell, QuasiQuotes, OverloadedStrings #-} module Handler.Home where -import TKYProf +import TKYProf hiding (reports) import Yesod.Form (Enctype(Multipart)) import Data.Maybe (listToMaybe) import Handler.Reports.Helpers (getAllReports) diff --git a/Handler/Reports.hs b/Handler/Reports.hs --- a/Handler/Reports.hs +++ b/Handler/Reports.hs @@ -3,18 +3,20 @@ ( getReportsR , postReportsR , getReportsIdR + , getReportsIdTimeR + , getReportsIdAllocR ) where -import TKYProf -import ProfilingReport -import Control.Applicative -import Yesod.Request import Data.Maybe (listToMaybe) +import Data.Text (Text) import Handler.Reports.Helpers (getAllReports, getProfilingReport, postProfilingReport) +import ProfilingReport +import TKYProf +import Yesod.Request +import qualified Data.Aeson as A (encode) import qualified Data.Attoparsec as A import qualified Data.ByteString as S import qualified Data.ByteString.Lazy as L -import qualified Data.Aeson as A (encode) import qualified Data.Text.Lazy.Encoding as T (decodeUtf8) getReportsR :: Handler RepHtml @@ -26,30 +28,48 @@ postReportsR :: Handler () postReportsR = do - FileInfo {fileContent} <- getPostedReport - prof <- parseFileContent fileContent - postProfilingReport prof + files <- getPostedReports + case files of + [fileInfo] -> do reportId <- postFileInfo fileInfo + sendResponseCreated $ ReportsIdR reportId + _ -> do mapM_ postFileInfo files + sendResponseCreated ReportsR getReportsIdR :: ReportID -> Handler RepHtml -getReportsIdR reportId = do - report@ProfilingReport {..} <- getProfilingReport reportId - let json = T.decodeUtf8 $ A.encode reportCostCentres - defaultLayout $ do - setTitle $ "TKYProf Reports" - addScript $ StaticR js_d3_min_js - addScript $ StaticR js_d3_layout_min_js - addWidget $(widgetFile "reports-id") +getReportsIdR reportId = redirect RedirectSeeOther (ReportsIdTimeR reportId []) +getReportsIdTimeR :: ReportID -> [a] -> Handler RepHtml +getReportsIdTimeR reportId _ = getReportsIdCommon reportId "time" + +getReportsIdAllocR :: ReportID -> [a] -> Handler RepHtml +getReportsIdAllocR reportId _ = getReportsIdCommon reportId "alloc" + -- Helper functions -getPostedReport :: Handler FileInfo -getPostedReport = do +getPostedReports :: Handler [FileInfo] +getPostedReports = do (_, files) <- runRequestBody - case lookup "reports" files of - Nothing -> invalidArgs ["Missing files"] - Just file -> return file + case [ file | (header, file) <- files, header == "reports" ] of + [] -> invalidArgs ["Missing files"] + found -> return found +postFileInfo :: FileInfo -> Handler ReportID +postFileInfo FileInfo {fileContent} = do + prof <- parseFileContent fileContent + postProfilingReport prof + parseFileContent :: L.ByteString -> Handler ProfilingReport parseFileContent content = case A.parseOnly profilingReport (S.concat $ L.toChunks content) of Left err -> invalidArgs ["Invalid format", toMessage err] Right tree -> return tree + +getReportsIdCommon :: ReportID -> Text -> Handler RepHtml +getReportsIdCommon reportId profilingType = do + report@ProfilingReport {..} <- getProfilingReport reportId + let json = T.decodeUtf8 $ A.encode reportCostCentres + defaultLayout $ do + setTitle $ "TKYProf Reports" + addScript $ StaticR js_tkyprof_js + addScript $ StaticR js_d3_min_js + addScript $ StaticR js_d3_layout_min_js + addWidget $(widgetFile "reports-id") diff --git a/Handler/Reports/Helpers.hs b/Handler/Reports/Helpers.hs --- a/Handler/Reports/Helpers.hs +++ b/Handler/Reports/Helpers.hs @@ -12,8 +12,8 @@ import Control.Monad.Trans (liftIO) import Model (Reports(..), ReportID, allReports, lookupReport, insertReport) import ProfilingReport (ProfilingReport) -import TKYProf (Handler, TKYProf(getReports), TKYProfRoute(..)) -import Yesod.Core (getYesod, sendResponseCreated) +import TKYProf (Handler, TKYProf(getReports)) +import Yesod.Core (getYesod) import Yesod.Handler (notFound) runReports :: STM a -> Handler a @@ -38,10 +38,7 @@ Just r -> return r Nothing -> notFound -postProfilingReport :: ProfilingReport -> Handler () +postProfilingReport :: ProfilingReport -> Handler ReportID postProfilingReport prof = do rs <- getReports' - reportId <- runReports $ insertReport prof rs - sendResponseCreated (ReportsIdR reportId) - - + runReports $ insertReport prof rs diff --git a/TKYProf.hs b/TKYProf.hs --- a/TKYProf.hs +++ b/TKYProf.hs @@ -102,7 +102,8 @@ return $ Just $ Right (StaticR $ StaticRoute ["tmp", T.pack fn] [], []) instance YesodBreadcrumbs TKYProf where - breadcrumb HomeR = return ("Home", Nothing) - breadcrumb ReportsR = return ("Reports", Just HomeR) - breadcrumb (ReportsIdR rid) = return ("Report #" `T.append` T.pack (show rid), Just ReportsR) - breadcrumb _ = return ("Not found", Just HomeR) + breadcrumb HomeR = return ("Home", Nothing) + breadcrumb ReportsR = return ("Reports", Just HomeR) + breadcrumb (ReportsIdTimeR rid _) = return ("Report #" `T.append` T.pack (show rid), Just ReportsR) + breadcrumb (ReportsIdAllocR rid _) = return ("Report #" `T.append` T.pack (show rid), Just ReportsR) + breadcrumb _ = return ("Not found", Just HomeR) diff --git a/config/routes b/config/routes --- a/config/routes +++ b/config/routes @@ -1,6 +1,8 @@ -/ HomeR GET -/reports ReportsR GET POST -/reports/#Integer ReportsIdR GET -/static StaticR Static getStatic -/favicon.png FaviconR GET -/robots.txt RobotsR GET +/ HomeR GET +/reports ReportsR GET POST +/reports/#Integer ReportsIdR GET +/reports/#Integer/time/*Texts ReportsIdTimeR GET +/reports/#Integer/alloc/*Texts ReportsIdAllocR GET +/static StaticR Static getStatic +/favicon.png FaviconR GET +/robots.txt RobotsR GET diff --git a/hamlet/home.hamlet b/hamlet/home.hamlet --- a/hamlet/home.hamlet +++ b/hamlet/home.hamlet @@ -1,19 +1,17 @@ -
-

Instructions -

1. Select your profiling reports -
-
-
-

Drop files here! -

-

Click to select files. - -

- 2. View reports - $maybe _ <- listToMaybe reports -