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))