{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TupleSections #-} -- | This module provides a function for serializing structured `Xlsx` into lazy bytestring module Codec.Xlsx.Writer ( fromXlsx ) where import qualified Codec.Archive.Zip as Zip import Control.Arrow (second) import Control.Lens hiding (transform, (.=)) import Control.Monad (forM) import qualified Data.ByteString.Lazy as L import Data.ByteString.Lazy.Char8 () import Data.List (foldl', mapAccumL) import Data.Map (Map) import Data.STRef import Control.Monad.ST import qualified Data.Map as M import Data.Maybe import Data.Monoid ((<>)) import Data.Text (Text) import Data.Tuple.Extra (fst3, snd3, thd3) import qualified Data.Text as T import Data.Time (UTCTime) import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime) import Data.Time.Format (formatTime) #if MIN_VERSION_time(1,5,0) import Data.Time.Format (defaultTimeLocale) #else import System.Locale (defaultTimeLocale) #endif import Safe import Text.XML #if !MIN_VERSION_base(4,8,0) import Control.Applicative #endif import Codec.Xlsx.Types import Codec.Xlsx.Types.Internal import Codec.Xlsx.Types.Internal.CfPair import qualified Codec.Xlsx.Types.Internal.CommentTable as CommentTable import Codec.Xlsx.Types.Internal.CustomProperties import Codec.Xlsx.Types.Internal.DvPair import Codec.Xlsx.Types.Internal.Relationships as Relationships hiding (lookup) import Codec.Xlsx.Types.Internal.SharedStringTable import Codec.Xlsx.Types.PivotTable.Internal import Codec.Xlsx.Writer.Internal import Codec.Xlsx.Writer.Internal.PivotTable -- | Writes `Xlsx' to raw data (lazy bytestring) fromXlsx :: POSIXTime -> Xlsx -> L.ByteString fromXlsx pt xlsx = Zip.fromArchive $ foldr Zip.addEntryToArchive Zip.emptyArchive entries where t = round pt utcTime = posixSecondsToUTCTime pt entries = Zip.toEntry "[Content_Types].xml" t (contentTypesXml files) : map (\fd -> Zip.toEntry (fdPath fd) t (fdContents fd)) files files = workbookFiles ++ customPropFiles ++ [ FileData "docProps/core.xml" "application/vnd.openxmlformats-package.core-properties+xml" "metadata/core-properties" $ coreXml utcTime "xlsxwriter" , FileData "docProps/app.xml" "application/vnd.openxmlformats-officedocument.extended-properties+xml" "xtended-properties" $ appXml sheetNames , FileData "_rels/.rels" "application/vnd.openxmlformats-package.relationships+xml" "relationships" rootRelXml ] rootRelXml = renderLBS def . toDocument $ Relationships.fromList rootRels rootFiles = customPropFileRels ++ [ ("officeDocument", "xl/workbook.xml") , ("metadata/core-properties", "docProps/core.xml") , ("extended-properties", "docProps/app.xml") ] rootRels = [ relEntry (unsafeRefId i) typ trg | (i, (typ, trg)) <- zip [1..] rootFiles ] customProps = xlsx ^. xlCustomProperties (customPropFiles, customPropFileRels) = case M.null customProps of True -> ([], []) False -> ([ FileData "docProps/custom.xml" "application/vnd.openxmlformats-officedocument.custom-properties+xml" "custom-properties" (customPropsXml (CustomProperties customProps)) ], [ ("custom-properties", "docProps/custom.xml") ]) workbookFiles = bookFiles xlsx sheetNames = xlsx ^. xlSheets . to (map fst) singleSheetFiles :: Int -> Cells -> [FileData] -> Worksheet -> STRef s Int -> ST s (FileData, [FileData]) singleSheetFiles n cells pivFileDatas ws tblIdRef = do ref <- newSTRef 1 mCmntData <- genComments n cells ref mDrawingData <- maybe (return Nothing) (fmap Just . genDrawing n ref) (ws ^. wsDrawing) pivRefs <- forM pivFileDatas $ \fd -> do refId <- nextRefId ref return (refId, fd) refTables <- forM (_wsTables ws) $ \tbl -> do refId <- nextRefId ref tblId <- readSTRef tblIdRef modifySTRef' tblIdRef (+1) return (refId, genTable tbl tblId) let sheetFilePath = "xl/worksheets/sheet" <> show n <> ".xml" sheetFile = FileData sheetFilePath "application/vnd.openxmlformats-officedocument.spreadsheetml.worksheet+xml" "worksheet" $ sheetXml nss = [ ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] sheetXml= renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root [] root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ elementListSimple "worksheet" rootEls rootEls = catMaybes $ [ elementListSimple "sheetViews" . map (toElement "sheetView") <$> ws ^. wsSheetViews , nonEmptyElListSimple "cols" . map cwEl $ ws ^. wsColumns , Just . elementListSimple "sheetData" $ sheetDataXml cells (ws ^. wsRowPropertiesMap) , toElement "autoFilter" <$> (ws ^. wsAutoFilter) , nonEmptyElListSimple "mergeCells" . map mergeE1 $ ws ^. wsMerges ] ++ map (Just . toElement "conditionalFormatting") cfPairs ++ [ nonEmptyElListSimple "dataValidations" $ map (toElement "dataValidation") dvPairs , toElement "pageSetup" <$> ws ^. wsPageSetup , fst3 <$> mDrawingData , fst <$> mCmntData , nonEmptyElListSimple "tableParts" [leafElement "tablePart" [odr "id" .= rId] | (rId, _) <- refTables] ] cfPairs = map CfPair . M.toList $ ws ^. wsConditionalFormattings dvPairs = map DvPair . M.toList $ ws ^. wsDataValidations cwEl cw = leafElement "col" $ ["min" .= cwMin cw, "max" .= cwMax cw, "width" .= cwWidth cw] ++ catMaybes ["style" .=? (justNonDef 0 =<< cwStyle cw)] mergeE1 r = leafElement "mergeCell" [("ref" .= r)] sheetRels = if null referencedFiles then [] else [ FileData ("xl/worksheets/_rels/sheet" <> show n <> ".xml.rels") "application/vnd.openxmlformats-package.relationships+xml" "relationships" sheetRelsXml ] sheetRelsXml = renderLBS def . toDocument . Relationships.fromList $ [ relEntry i fdRelType (fdPath `relFrom` sheetFilePath) | (i, FileData{..}) <- referenced ] referenced = fromMaybe [] (snd <$> mCmntData) ++ catMaybes [ snd3 <$> mDrawingData ] ++ pivRefs ++ refTables referencedFiles = map snd referenced extraFiles = maybe [] thd3 mDrawingData otherFiles = sheetRels ++ referencedFiles ++ extraFiles return (sheetFile, otherFiles) nextRefId :: STRef s Int -> ST s RefId nextRefId r = do num <- readSTRef r modifySTRef' r (+1) return (unsafeRefId num) unsafeRefId :: Int -> RefId unsafeRefId num = RefId $ "rId" <> txti num sheetDataXml :: Cells -> Map Int RowProperties -> [Element] sheetDataXml rows rh = map rowEl rows where rowEl (r, cells) = elementList "row" (ht ++ s ++ [("r", txti r) ,("hidden", "false"), ("outlineLevel", "0"), ("collapsed", "false"), ("customFormat", "true"), ("customHeight", txtb hasHeight)]) $ map (cellEl r) cells where (ht, hasHeight, s) = case M.lookup r rh of Just (RowProps (Just h) (Just st)) -> ([("ht", txtd h)], True,[("s", txti st)]) Just (RowProps Nothing (Just st)) -> ([], True, [("s", txti st)]) Just (RowProps (Just h) Nothing ) -> ([("ht", txtd h)], True,[]) _ -> ([], False,[]) cellEl r (icol, cell) = elementList "c" (cellAttrs (singleCellRef (r, icol)) cell) (catMaybes [ elementContent "v" . value <$> xlsxCellValue cell , toElement "f" <$> xlsxCellFormula cell ]) cellAttrs ref cell = cellStyleAttr cell ++ [("r" .= ref), ("t" .= xlsxCellType cell)] cellStyleAttr XlsxCell{xlsxCellStyle=Nothing} = [] cellStyleAttr XlsxCell{xlsxCellStyle=Just s} = [("s", txti s)] genComments :: Int -> Cells -> STRef s Int -> ST s (Maybe (Element, [ReferencedFileData])) genComments n cells ref = if null comments then do return Nothing else do rId1 <- nextRefId ref rId2 <- nextRefId ref let el = refElement "legacyDrawing" rId2 return $ Just (el, [(rId1, commentsFile), (rId2, vmlDrawingFile)]) where comments = concatMap (\(row, rowCells) -> mapMaybe (maybeCellComment row) rowCells) cells maybeCellComment row (col, cell) = do comment <- xlsxComment cell return (singleCellRef (row, col), comment) commentTable = CommentTable.fromList comments commentsFile = FileData commentsPath "application/vnd.openxmlformats-officedocument.spreadsheetml.comments+xml" "comments" commentsBS commentsPath = "xl/comments" <> show n <> ".xml" commentsBS = renderLBS def $ toDocument commentTable vmlDrawingFile = FileData vmlPath "application/vnd.openxmlformats-officedocument.vmlDrawing" "vmlDrawing" vmlDrawingBS vmlPath = "xl/drawings/vmlDrawing" <> show n <> ".vml" vmlDrawingBS = CommentTable.renderShapes commentTable genDrawing :: Int -> STRef s Int -> Drawing -> ST s (Element, ReferencedFileData, [FileData]) genDrawing n ref dr = do rId <- nextRefId ref let el = refElement "drawing" rId return (el, (rId, drawingFile), referenced) where drawingFilePath = "xl/drawings/drawing" <> show n <> ".xml" drawingCT = "application/vnd.openxmlformats-officedocument.drawing+xml" drawingFile = FileData drawingFilePath drawingCT "drawing" drawingXml drawingXml = renderLBS def{rsNamespaces=nss} $ toDocument dr' nss = [ ("xdr", "http://schemas.openxmlformats.org/drawingml/2006/spreadsheetDrawing") , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") , ("r", "http://schemas.openxmlformats.org/officeDocument/2006/relationships") ] dr' = Drawing{ _xdrAnchors = reverse anchors' } (anchors', images, charts, _) = foldl' collectFile ([], [], [], 1) (dr ^. xdrAnchors) collectFile :: ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int) -> Anchor FileInfo ChartSpace -> ([Anchor RefId RefId], [Maybe (Int, FileInfo)], [(Int, ChartSpace)], Int) collectFile (as, fis, chs, i) anch0 = case anch0 ^. anchObject of Picture {..} -> let fi = (i,) <$> _picBlipFill ^. bfpImageInfo pic' = Picture { _picMacro = _picMacro , _picPublished = _picPublished , _picNonVisual = _picNonVisual , _picBlipFill = (_picBlipFill & bfpImageInfo ?~ RefId ("rId" <> txti i)) , _picShapeProperties = _picShapeProperties } anch = anch0 {_anchObject = pic'} in (anch : as, fi : fis, chs, i + 1) Graphic nv ch tr -> let gr' = Graphic nv (RefId ("rId" <> txti i)) tr anch = anch0 {_anchObject = gr'} in (anch : as, fis, (i, ch) : chs, i + 1) imageFiles = [ ( unsafeRefId i , FileData ("xl/media/" <> _fiFilename) _fiContentType "image" _fiContents) | (i, FileInfo {..}) <- reverse (catMaybes images) ] chartFiles = [ (unsafeRefId i, genChart n k chart) | (k, (i, chart)) <- zip [1 ..] (reverse charts) ] innerFiles = imageFiles ++ chartFiles drawingRels = FileData ("xl/drawings/_rels/drawing" <> show n <> ".xml.rels") relsCT "relationships" drawingRelsXml drawingRelsXml = renderLBS def . toDocument . Relationships.fromList $ map (refFileDataToRel drawingFilePath) innerFiles referenced = case innerFiles of [] -> [] _ -> drawingRels : (map snd innerFiles) genChart :: Int -> Int -> ChartSpace -> FileData genChart n i ch = FileData path contentType relType contents where path = "xl/charts/chart" <> show n <> "_" <> show i <> ".xml" contentType = "application/vnd.openxmlformats-officedocument.drawingml.chart+xml" relType = "chart" contents = renderLBS def {rsNamespaces = nss} $ toDocument ch nss = [ ("c", "http://schemas.openxmlformats.org/drawingml/2006/chart") , ("a", "http://schemas.openxmlformats.org/drawingml/2006/main") ] data PvGenerated = PvGenerated { pvgCacheFiles :: [(CacheId, FileData)] , pvgSheetTableFiles :: [[FileData]] , pvgOthers :: [FileData] } generatePivotFiles :: [[PivotTable]] -> PvGenerated generatePivotFiles tables = PvGenerated cacheFiles shTableFiles others where cacheFiles = [cacheFile | (cacheFile, _, _) <- flatRendered] shTableFiles = map (map (\(_, tableFile, _) -> tableFile)) rendered others = concat [other | (_, _, other) <- flatRendered] firstCacheId = 1 flatRendered = concat rendered (_, rendered) = mapAccumL (\c ts -> mapAccumL (\c' t -> (c' + 1, render c' t)) c ts) firstCacheId tables render cacheIdRaw tbl = let PivotTableFiles {..} = renderPivotTableFiles cacheIdRaw tbl cacheId = CacheId cacheIdRaw cacheIdStr = show cacheIdRaw cachePath = "xl/pivotCache/pivotCacheDefinition" <> cacheIdStr <> ".xml" cacheFile = FileData cachePath (smlCT "pivotCacheDefinition") "pivotCacheDefinition" pvtfCacheDefinition renderRels = renderLBS def . toDocument . Relationships.fromList tablePath = "xl/pivotTables/pivotTable" <> cacheIdStr <> ".xml" tableFile = FileData tablePath (smlCT "pivotTable") "pivotTable" pvtfTable tableRels = FileData ("xl/pivotTables/_rels/pivotTable" <> cacheIdStr <> ".xml.rels") relsCT "relationships" $ renderRels [refFileDataToRel tablePath (unsafeRefId 1, cacheFile)] in ((cacheId, cacheFile), tableFile, [tableRels]) genTable :: Table -> Int -> FileData genTable tbl tblId = FileData{..} where fdPath = "xl/tables/table" <> show tblId <> ".xml" fdContentType = smlCT "table" fdRelType = "table" fdContents = renderLBS def $ tableToDocument tbl tblId data FileData = FileData { fdPath :: FilePath , fdContentType :: Text , fdRelType :: Text , fdContents :: L.ByteString } type ReferencedFileData = (RefId, FileData) refFileDataToRel :: FilePath -> ReferencedFileData -> (RefId, Relationship) refFileDataToRel basePath (i, FileData {..}) = relEntry i fdRelType (fdPath `relFrom` basePath) type Cells = [(Int, [(Int, XlsxCell)])] coreXml :: UTCTime -> Text -> L.ByteString coreXml created creator = renderLBS def{rsNamespaces=nss} $ Document (Prologue [] Nothing []) root [] where nss = [ ("cp", "http://schemas.openxmlformats.org/package/2006/metadata/core-properties") , ("dc", "http://purl.org/dc/elements/1.1/") , ("dcterms", "http://purl.org/dc/terms/") , ("xsi","http://www.w3.org/2001/XMLSchema-instance") ] namespaced = nsName nss date = T.pack $ formatTime defaultTimeLocale "%FT%T%QZ" created root = Element (namespaced "cp" "coreProperties") M.empty [ nEl (namespaced "dcterms" "created") (M.fromList [(namespaced "xsi" "type", "dcterms:W3CDTF")]) [NodeContent date] , nEl (namespaced "dc" "creator") M.empty [NodeContent creator] , nEl (namespaced "cp" "lastModifiedBy") M.empty [NodeContent creator] ] appXml :: [Text] -> L.ByteString appXml sheetNames = renderLBS def $ Document (Prologue [] Nothing []) root [] where sheetCount = length sheetNames root = Element (extPropNm "Properties") nsAttrs [ extPropEl "TotalTime" [NodeContent "0"] , extPropEl "HeadingPairs" [ vTypeEl "vector" (M.fromList [ ("size", "2") , ("baseType", "variant")]) [ vTypeEl0 "variant" [vTypeEl0 "lpstr" [NodeContent "Worksheets"]] , vTypeEl0 "variant" [vTypeEl0 "i4" [NodeContent $ txti sheetCount]] ] ] , extPropEl "TitlesOfParts" [ vTypeEl "vector" (M.fromList [ ("size", txti sheetCount) , ("baseType", "lpstr")]) $ map (vTypeEl0 "lpstr" . return . NodeContent) sheetNames ] ] nsAttrs = M.fromList [("xmlns:vt", "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes")] extPropNm n = nm "http://schemas.openxmlformats.org/officeDocument/2006/extended-properties" n extPropEl n = nEl (extPropNm n) M.empty vTypeEl0 n = vTypeEl n M.empty vTypeEl = nEl . nm "http://schemas.openxmlformats.org/officeDocument/2006/docPropsVTypes" data XlsxCellData = XlsxSS Int | XlsxDouble Double | XlsxBool Bool deriving (Show, Eq) data XlsxCell = XlsxCell { xlsxCellStyle :: Maybe Int , xlsxCellValue :: Maybe XlsxCellData , xlsxComment :: Maybe Comment , xlsxCellFormula :: Maybe CellFormula } deriving (Show, Eq) xlsxCellType :: XlsxCell -> Text xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxSS _)} = "s" xlsxCellType XlsxCell{xlsxCellValue=Just(XlsxBool _)} = "b" xlsxCellType _ = "n" -- default in SpreadsheetML schema, TODO: add other types value :: XlsxCellData -> Text value (XlsxSS i) = txti i value (XlsxDouble d) = txtd d value (XlsxBool True) = "1" value (XlsxBool False) = "0" transformSheetData :: SharedStringTable -> Worksheet -> Cells transformSheetData shared ws = map transformRow $ toRows (ws ^. wsCells) where transformRow = second (map transformCell) transformCell (c, Cell{..}) = (c, XlsxCell _cellStyle (fmap transformValue _cellValue) _cellComment _cellFormula) transformValue (CellText t) = XlsxSS (sstLookupText shared t) transformValue (CellDouble dbl) = XlsxDouble dbl transformValue (CellBool b) = XlsxBool b transformValue (CellRich r) = XlsxSS (sstLookupRich shared r) bookFiles :: Xlsx -> [FileData] bookFiles xlsx = runST $ do ref <- newSTRef 1 ssRId <- nextRefId ref let sheets = xlsx ^. xlSheets . to (map snd) shared = sstConstruct sheets sharedStrings = (ssRId, FileData "xl/sharedStrings.xml" (smlCT "sharedStrings") "sharedStrings" $ ssXml shared) stRId <- nextRefId ref let style = (stRId, FileData "xl/styles.xml" (smlCT "styles") "styles" $ unStyles (xlsx ^. xlStyles)) let PvGenerated {pvgCacheFiles=cacheIdFiles, pvgOthers=pivotOtherFiles, pvgSheetTableFiles=sheetPivotTables} = generatePivotFiles (xlsx ^. xlSheets . to (map (^. _2 . wsPivotTables))) sheetCells = map (transformSheetData shared) sheets sheetInputs = zip3 sheetCells sheetPivotTables sheets tblIdRef <- newSTRef 1 allSheetFiles <- forM (zip [1..] sheetInputs) $ \(i, (cells, pvTables, sheet)) -> do rId <- nextRefId ref (sheetFile, others) <- singleSheetFiles i cells pvTables sheet tblIdRef return ((rId, sheetFile), others) let sheetFiles = map fst allSheetFiles sheetNameByRId = zip (map fst sheetFiles) (xlsx ^. xlSheets . to (map fst)) sheetOthers = concatMap snd allSheetFiles cacheRefFDsById <- forM cacheIdFiles $ \(cacheId, fd) -> do refId <- nextRefId ref return (cacheId, (refId, fd)) let cacheRefsById = [ (cId, rId) | (cId, (rId, _)) <- cacheRefFDsById ] cacheRefs = map snd cacheRefFDsById bookFile = FileData "xl/workbook.xml" (smlCT "sheet.main") "officeDocument" $ bookXml sheetNameByRId (xlsx ^. xlDefinedNames) cacheRefsById rels = FileData "xl/_rels/workbook.xml.rels" "application/vnd.openxmlformats-package.relationships+xml" "relationships" relsXml relsXml = renderLBS def . toDocument . Relationships.fromList $ [ relEntry i fdRelType (fdPath `relFrom` "xl/workbook.xml") | (i, FileData{..}) <- referenced ] referenced = sharedStrings:style:sheetFiles ++ cacheRefs otherFiles = concat [rels:(map snd referenced), pivotOtherFiles, sheetOthers] return $ bookFile:otherFiles bookXml :: [(RefId, Text)] -> DefinedNames -> [(CacheId, RefId)] -> L.ByteString bookXml rIdNames (DefinedNames names) cacheIdRefs = renderLBS def $ Document (Prologue [] Nothing []) root [] where -- The @bookViews@ element is not required according to the schema, but its -- absence can cause Excel to crash when opening the print preview -- (see ). It suffices however -- to define a bookViews with a single empty @workbookView@ element -- (the @bookViews@ must contain at least one @wookbookView@). root = addNS "http://schemas.openxmlformats.org/spreadsheetml/2006/main" Nothing $ elementListSimple "workbook" ([ elementListSimple "bookViews" [emptyElement "workbookView"] , elementListSimple "sheets" [ leafElement "sheet" ["name" .= name, "sheetId" .= i, (odr "id") .= rId] | (i, (rId, name)) <- zip [(1 :: Int) ..] rIdNames ] , elementListSimple "definedNames" [ elementContent0 "definedName" (definedName name lsId) val | (name, lsId, val) <- names ] ] ++ maybeToList (nonEmptyElListSimple "pivotCaches" $ map pivotCacheEl cacheIdRefs)) pivotCacheEl (CacheId cId, refId) = leafElement "pivotCache" ["cacheId" .= cId, (odr "id") .= refId] definedName :: Text -> Maybe Text -> [(Name, Text)] definedName name Nothing = ["name" .= name] definedName name (Just lsId) = ["name" .= name, "localSheetId" .= lsId] ssXml :: SharedStringTable -> L.ByteString ssXml = renderLBS def . toDocument customPropsXml :: CustomProperties -> L.ByteString customPropsXml = renderLBS def . toDocument contentTypesXml :: [FileData] -> L.ByteString contentTypesXml fds = renderLBS def $ Document (Prologue [] Nothing []) root [] where root = addNS "http://schemas.openxmlformats.org/package/2006/content-types" Nothing $ Element "Types" M.empty $ map (\fd -> nEl "Override" (M.fromList [("PartName", T.concat ["/", T.pack $ fdPath fd]), ("ContentType", fdContentType fd)]) []) fds -- | fully qualified XML name qName :: Text -> Text -> Text -> Name qName n ns p = Name { nameLocalName = n , nameNamespace = Just ns , namePrefix = Just p } -- | fully qualified XML name from prefix to ns URL mapping nsName :: [(Text, Text)] -> Text -> Text -> Name nsName nss p n = qName n ns p where ns = fromJustNote "ns name lookup" $ lookup p nss nm :: Text -> Text -> Name nm ns n = Name { nameLocalName = n , nameNamespace = Just ns , namePrefix = Nothing} nEl :: Name -> Map Name Text -> [Node] -> Node nEl name attrs nodes = NodeElement $ Element name attrs nodes -- | Creates element holding reference to some linked file refElement :: Name -> RefId -> Element refElement name rId = leafElement name [ odr "id" .= rId ] smlCT :: Text -> Text smlCT t = "application/vnd.openxmlformats-officedocument.spreadsheetml." <> t <> "+xml" relsCT :: Text relsCT = "application/vnd.openxmlformats-package.relationships+xml"