{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveGeneric #-}
module Codec.Xlsx.Types.Protection
( SheetProtection(..)
, fullSheetProtection
, noSheetProtection
, LegacyPassword
, legacyPassword
, sprLegacyPassword
, sprSheet
, sprObjects
, sprScenarios
, sprFormatCells
, sprFormatColumns
, sprFormatRows
, sprInsertColumns
, sprInsertRows
, sprInsertHyperlinks
, sprDeleteColumns
, sprDeleteRows
, sprSelectLockedCells
, sprSort
, sprAutoFilter
, sprPivotTables
, sprSelectUnlockedCells
) where
import GHC.Generics (Generic)
import Control.Arrow (first)
import Control.Lens (makeLenses)
import Control.DeepSeq (NFData)
import Data.Bits
import Data.Char
import Data.Maybe (catMaybes)
import Data.Text (Text)
import qualified Data.Text as T
import Data.Text.Lazy (toStrict)
import Data.Text.Lazy.Builder (toLazyText)
import Data.Text.Lazy.Builder.Int (hexadecimal)
import Codec.Xlsx.Parser.Internal
import Codec.Xlsx.Writer.Internal
newtype LegacyPassword =
LegacyPassword Text
deriving (Eq, Show, Generic)
instance NFData LegacyPassword
legacyPassword :: Text -> LegacyPassword
legacyPassword = LegacyPassword . hex . legacyHash . map ord . T.unpack
where
hex = toStrict . toLazyText . hexadecimal
legacyHash bs =
mutHash (foldr (\b hash -> b `xor` mutHash hash) 0 bs) `xor` (length bs) `xor`
0xCE4B
mutHash ph = ((ph `shiftR` 14) .&. 1) .|. ((ph `shiftL` 1) .&. 0x7fff)
data SheetProtection = SheetProtection
{ _sprLegacyPassword :: Maybe LegacyPassword
, _sprSheet :: Bool
, _sprAutoFilter :: Bool
, _sprDeleteColumns :: Bool
, _sprDeleteRows :: Bool
, _sprFormatCells :: Bool
, _sprFormatColumns :: Bool
, _sprFormatRows :: Bool
, _sprInsertColumns :: Bool
, _sprInsertHyperlinks :: Bool
, _sprInsertRows :: Bool
, _sprObjects :: Bool
, _sprPivotTables :: Bool
, _sprScenarios :: Bool
, _sprSelectLockedCells :: Bool
, _sprSelectUnlockedCells :: Bool
, _sprSort :: Bool
} deriving (Eq, Show, Generic)
instance NFData SheetProtection
makeLenses ''SheetProtection
noSheetProtection :: SheetProtection
noSheetProtection =
SheetProtection
{ _sprLegacyPassword = Nothing
, _sprSheet = False
, _sprAutoFilter = False
, _sprDeleteColumns = False
, _sprDeleteRows = False
, _sprFormatCells = False
, _sprFormatColumns = False
, _sprFormatRows = False
, _sprInsertColumns = False
, _sprInsertHyperlinks = False
, _sprInsertRows = False
, _sprObjects = False
, _sprPivotTables = False
, _sprScenarios = False
, _sprSelectLockedCells = False
, _sprSelectUnlockedCells = False
, _sprSort = False
}
fullSheetProtection :: SheetProtection
fullSheetProtection =
SheetProtection
{ _sprLegacyPassword = Nothing
, _sprSheet = True
, _sprAutoFilter = True
, _sprDeleteColumns = True
, _sprDeleteRows = True
, _sprFormatCells = True
, _sprFormatColumns = True
, _sprFormatRows = True
, _sprInsertColumns = True
, _sprInsertHyperlinks = True
, _sprInsertRows = True
, _sprObjects = True
, _sprPivotTables = True
, _sprScenarios = True
, _sprSelectLockedCells = True
, _sprSelectUnlockedCells = True
, _sprSort = True
}
instance FromCursor SheetProtection where
fromCursor cur = do
_sprLegacyPassword <- maybeAttribute "password" cur
_sprSheet <- fromAttributeDef "sheet" False cur
_sprAutoFilter <- fromAttributeDef "autoFilter" True cur
_sprDeleteColumns <- fromAttributeDef "deleteColumns" True cur
_sprDeleteRows <- fromAttributeDef "deleteRows" True cur
_sprFormatCells <- fromAttributeDef "formatCells" True cur
_sprFormatColumns <- fromAttributeDef "formatColumns" True cur
_sprFormatRows <- fromAttributeDef "formatRows" True cur
_sprInsertColumns <- fromAttributeDef "insertColumns" True cur
_sprInsertHyperlinks <- fromAttributeDef "insertHyperlinks" True cur
_sprInsertRows <- fromAttributeDef "insertRows" True cur
_sprObjects <- fromAttributeDef "objects" False cur
_sprPivotTables <- fromAttributeDef "pivotTables" True cur
_sprScenarios <- fromAttributeDef "scenarios" False cur
_sprSelectLockedCells <- fromAttributeDef "selectLockedCells" False cur
_sprSelectUnlockedCells <- fromAttributeDef "selectUnlockedCells" False cur
_sprSort <- fromAttributeDef "sort" True cur
return SheetProtection {..}
instance FromXenoNode SheetProtection where
fromXenoNode root =
parseAttributes root $ do
_sprLegacyPassword <- maybeAttr "password"
_sprSheet <- fromAttrDef "sheet" False
_sprAutoFilter <- fromAttrDef "autoFilter" True
_sprDeleteColumns <- fromAttrDef "deleteColumns" True
_sprDeleteRows <- fromAttrDef "deleteRows" True
_sprFormatCells <- fromAttrDef "formatCells" True
_sprFormatColumns <- fromAttrDef "formatColumns" True
_sprFormatRows <- fromAttrDef "formatRows" True
_sprInsertColumns <- fromAttrDef "insertColumns" True
_sprInsertHyperlinks <- fromAttrDef "insertHyperlinks" True
_sprInsertRows <- fromAttrDef "insertRows" True
_sprObjects <- fromAttrDef "objects" False
_sprPivotTables <- fromAttrDef "pivotTables" True
_sprScenarios <- fromAttrDef "scenarios" False
_sprSelectLockedCells <- fromAttrDef "selectLockedCells" False
_sprSelectUnlockedCells <- fromAttrDef "selectUnlockedCells" False
_sprSort <- fromAttrDef "sort" True
return SheetProtection {..}
instance FromAttrVal LegacyPassword where
fromAttrVal = fmap (first LegacyPassword) . fromAttrVal
instance FromAttrBs LegacyPassword where
fromAttrBs = fmap LegacyPassword . fromAttrBs
instance ToElement SheetProtection where
toElement nm SheetProtection {..} =
leafElement nm $
catMaybes
[ "password" .=? _sprLegacyPassword
, "sheet" .=? justTrue _sprSheet
, "autoFilter" .=? justFalse _sprAutoFilter
, "deleteColumns" .=? justFalse _sprDeleteColumns
, "deleteRows" .=? justFalse _sprDeleteRows
, "formatCells" .=? justFalse _sprFormatCells
, "formatColumns" .=? justFalse _sprFormatColumns
, "formatRows" .=? justFalse _sprFormatRows
, "insertColumns" .=? justFalse _sprInsertColumns
, "insertHyperlinks" .=? justFalse _sprInsertHyperlinks
, "insertRows" .=? justFalse _sprInsertRows
, "objects" .=? justTrue _sprObjects
, "pivotTables" .=? justFalse _sprPivotTables
, "scenarios" .=? justTrue _sprScenarios
, "selectLockedCells" .=? justTrue _sprSelectLockedCells
, "selectUnlockedCells" .=? justTrue _sprSelectUnlockedCells
, "sort" .=? justFalse _sprSort
]
instance ToAttrVal LegacyPassword where
toAttrVal (LegacyPassword hash) = hash