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