1 {-# LANGUAGE OverloadedStrings #-} 2 module Controller.CSV 3 ( csvResponse 4 , csvVolume 5 , volumeCSV 6 ) where 7 8 import Control.Arrow (second) 9 import qualified Data.ByteString as BS 10 import qualified Data.ByteString.Char8 as BSC 11 import Data.Foldable (fold) 12 import Data.Function (on) 13 import Data.List (foldl', nubBy, groupBy) 14 import Data.Monoid ((<>)) 15 import Data.Ord (comparing) 16 import qualified Data.Text as T 17 import qualified Data.Text.Encoding as TE 18 import Network.HTTP.Types (hContentType) 19 20 import Model.Id 21 import Model.Permission 22 import Model.Volume 23 import Model.Container 24 import Model.Record 25 import Model.Category 26 import Model.RecordSlot 27 import Model.Metric 28 import Model.Measure 29 import Model.VolumeMetric 30 import Service.DB 31 import Store.Filename 32 import Store.CSV 33 import HTTP 34 import HTTP.Path.Parser 35 import Action 36 import Controller.Paths 37 import Controller.Volume 38 39 csvResponse :: [[BS.ByteString]] -> BS.ByteString -> Response 40 csvResponse csv save = okResponse 41 [ (hContentType, "text/csv;charset=utf-8") 42 , ("content-disposition", "attachment; filename=" <> quoteHTTP (save <> ".csv")) 43 ] $ buildCSV csv 44 45 type Records = [[Record]] 46 type Metrics = [[Metric]] 47 type Header = (Category, Metrics) 48 type Headers = [Header] 49 50 tshow :: Show a => a -> BS.ByteString 51 tshow = BSC.pack . show 52 53 tmaybe :: (a -> BS.ByteString) -> Maybe a -> BS.ByteString 54 tmaybe = maybe BS.empty 55 56 tenc :: T.Text -> BS.ByteString 57 tenc = TE.encodeUtf8 58 59 updateHeaders :: [(Category, Int)] -> Records -> [(Category, Int)] 60 updateHeaders h [] = h 61 updateHeaders [] l = map (\rl@(r:_) -> (recordCategory $ recordRow r, length rl)) l 62 updateHeaders hl@(cm@(c,m):hl') rll@(~rl@(r:_):rll') = case comparing categoryId c rc of 63 LT -> cm : updateHeaders hl' rll 64 EQ -> (c, m `max` length rl) : updateHeaders hl' rll' 65 GT -> (rc, length rl) : updateHeaders hl rll' 66 where rc = recordCategory $ recordRow r 67 68 metricHeader :: [Metric] -> [BS.ByteString] 69 metricHeader = map (tenc . metricName) 70 71 metricsHeader :: BS.ByteString -> Metrics -> [BS.ByteString] 72 metricsHeader p [m] = map (BSC.snoc p '-' <>) $ metricHeader m 73 metricsHeader p ml = mh 0 ml where 74 mh _ [] = [] 75 mh i (m:l) = map (p' <>) (metricHeader m) ++ mh i' l where 76 p' = p <> BSC.snoc (tshow i') '-' 77 i' = succ i :: Integer 78 79 headerRow :: Headers -> [BS.ByteString] 80 headerRow = concatMap $ uncurry $ metricsHeader . tenc . categoryName 81 82 metricsRow :: [Metric] -> [Measure] -> [BS.ByteString] 83 metricsRow mh@(m:h) dl@(d:l) = case compare m dm of 84 LT -> fold (metricAssumed m) : metricsRow h dl 85 EQ -> measureDatum d : metricsRow h l 86 GT -> metricsRow mh l 87 where dm = measureMetric d 88 metricsRow m _ = map (fold . metricAssumed) m 89 90 recordsRow :: Metrics -> [Record] -> [BS.ByteString] 91 recordsRow h [] = concatMap (`metricsRow` []) h 92 recordsRow ~(h:hl) (r:rl) = metricsRow h (recordMeasures r) ++ recordsRow hl rl 93 94 dataRow :: Headers -> Records -> [BS.ByteString] 95 dataRow hl@((c,m):hl') rll@(~rl@(r:_):rll') = case comparing categoryId c rc of 96 LT -> recordsRow m [] ++ dataRow hl' rll 97 EQ -> recordsRow m rl ++ dataRow hl' rll' 98 GT -> dataRow hl rll' 99 where rc = recordCategory $ recordRow r 100 dataRow _ _ = [] 101 102 volumeCSV :: (MonadDB c m) => Volume -> [(Container, [RecordSlot])] -> m [[BS.ByteString]] 103 volumeCSV vol crsl = do 104 mets <- map getMetric' <$> lookupVolumeMetrics vol 105 -- FIXME if volume metrics can be reordered 106 let grm r = r{ recordMeasures = getRecordMeasures r } 107 crl = map (second $ map (nubBy ((==) `on` recordId . recordRow)) . groupBy ((==) `on` recordCategory . recordRow) . map (grm . slotRecord)) crsl 108 hl = map (\(c, n) -> (c, replicate n $ filter ((c ==) . metricCategory) mets)) $ 109 foldl' updateHeaders [] $ map snd crl 110 cr c r = tshow (containerId $ containerRow c) : tmaybe tenc (containerName $ containerRow c) : maybe (if containerTop (containerRow c) then "materials" else BS.empty) BSC.pack (formatContainerDate c) : tmaybe tshow (containerRelease c) : dataRow hl r 111 hr = "session-id" : "session-name" : "session-date" : "session-release" : headerRow hl 112 return $ hr : map (uncurry cr) crl 113 114 csvVolume :: ActionRoute (Id Volume) 115 csvVolume = action GET (pathId </< "csv") $ \vi -> withAuth $ do 116 vol <- getVolume PermissionPUBLIC vi 117 _ <- maybeAction (if volumeIsPublicRestricted vol then Nothing else Just ()) -- block if restricted 118 _:r <- lookupVolumeContainersRecords vol 119 csv <- volumeCSV vol r 120 return $ csvResponse csv (makeFilename (volumeDownloadName vol))