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