plist-buddy (empty) → 0.1.0.0
raw patch · 10 files changed
+1705/−0 lines, 10 filesdep +QuickCheckdep +basedep +base16-bytestringsetup-changed
Dependencies added: QuickCheck, base, base16-bytestring, base64-bytestring, bytestring, cryptohash, directory, hspec, mtl, plist-buddy, posix-pty, process, text, time, xml
Files
- LICENSE +29/−0
- README.md +16/−0
- Setup.hs +2/−0
- plist-buddy.cabal +60/−0
- src/Database/PlistBuddy.hs +521/−0
- src/Database/PlistBuddy/Audit.hs +121/−0
- src/Database/PlistBuddy/Command.hs +106/−0
- src/Database/PlistBuddy/Open.hs +41/−0
- src/Database/PlistBuddy/Types.hs +110/−0
- tests/Main.hs +699/−0
+ LICENSE view
@@ -0,0 +1,29 @@+Copyright (c) 2015, Andy Gill+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Andy Gill nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,16 @@+# plist-buddy++Remote monad wrapper around the plistbuddy shell command for editing plists.++From the manual: The following commands are used to manipulate plist data:++ * Help -- Prints this information.+ * Exit -- Exits the program. Changes are not saved to the file.+ * Save -- Saves the current changes to the file.+ * Revert -- Reloads the last saved version of the file.+ * Clear type -- Clears out all existing entries, and creates root of type type. See below for a list of types.+ * Print [entry] -- Prints value of entry. If an entry is not specified, prints entire file. + * Set entry value -- Sets the value at entry to value.+ * Add entry type [value] -- Adds entry with type type and optional value value. See below for a list of types.+ * Delete entry -- Deletes entry from the plist.+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ plist-buddy.cabal view
@@ -0,0 +1,60 @@+-- Initial plist-buddy.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: plist-buddy+version: 0.1.0.0+synopsis: Remote monad for editing plists+description: Remote monad wrapper around the plistbuddy shell command for editing plists+license: BSD3+license-file: LICENSE+author: Andy Gill+maintainer: andygill@ku.edu+copyright: (c) 2015 Andy Gill+category: Database+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++library+ exposed-modules: Database.PlistBuddy+ other-modules: Database.PlistBuddy.Audit+ , Database.PlistBuddy.Command+ , Database.PlistBuddy.Types+ , Database.PlistBuddy.Open+ other-extensions: GeneralizedNewtypeDeriving+ build-depends: base >=4.8 && <4.9+ , base16-bytestring == 0.1.*+ , base64-bytestring == 1.0.*+ , bytestring == 0.10.*+ , cryptohash == 0.11.*+ , directory == 1.2.*+ , mtl >=2.2 && <2.3+ , process >=1.2 && <1.5+ , posix-pty >= 0.2.1 && < 0.3+ , text == 1.2.*+ , time == 1.5.*+ , xml >= 1.3.14 && < 1.4+ hs-source-dirs: src+ default-language: Haskell2010+ +test-suite test-plist-buddy+ hs-source-dirs: tests+ main-is: Main.hs+ type: exitcode-stdio-1.0+ build-depends: base >=4.7 && <4.9+ , directory >= 1.2 && < 1.3+ , plist-buddy == 0.1.0.0+ , bytestring == 0.10.*+ , mtl >=2.2 && <2.3+ , hspec+ , process >=1.2 && <1.5+ , posix-pty == 0.2.1+ , QuickCheck == 2.8.*+ , text == 1.2.*+ , time == 1.5.*+ default-language: Haskell2010 + GHC-options: -threaded++source-repository head+ type: git+ location: git://github.com/ku-fpg/plist-buddy.git
+ src/Database/PlistBuddy.hs view
@@ -0,0 +1,521 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+module Database.PlistBuddy + ( -- * Remote Monad+ PlistBuddy()+ , openPlist+ , Plist()+ , send+ , throwPlistError+ , catchPlistError+ -- * The Remote Monad operators+ , help+ , exit+ , save+ , revert+ , clear+ , get+ , set+ , add+ , delete+ -- * Other types+ , Value(..)+ , valueType+ -- * Debugging+ , debugOn+ -- * Exception+ , PlistBuddyException(..)+ -- * Audit+ , Trail(..)+ , AuditTrail(..)+ , auditOn+ , auditOff+ , replay+ , recover+ , hashcode+ , findTrail+ -- * Background version of Plist+ , BackgroundPlist+ , backgroundPlist+ , bgSend+ , bgAutoSave+ ) where++import Control.Concurrent+import Control.Concurrent.MVar+import Control.Exception+import Control.Monad+import Control.Monad.Reader+import Control.Monad.Except++import Data.Char (ord,isSpace,isDigit)+import Data.IORef+import Data.Text(Text)+import qualified Data.Text as T+import Data.Text.Encoding as E+import Database.PlistBuddy.Audit+import Database.PlistBuddy.Command+import Database.PlistBuddy.Open+import Database.PlistBuddy.Types as Types++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as B64+import Data.List ()+import Data.Monoid ((<>))++import System.Directory (removeFile)+import System.Process+import System.IO+import System.Posix.Pty+import System.Timeout++import Text.XML.Light as X++import Data.Time+import Data.Either(either)++import GHC.Generics+import Debug.Trace+import System.IO.Error (catchIOError)+++------------------------------------------------------------------------------++-- | Generate a version of Plist that outputs debuging information.+debugOn :: Plist -> Plist+debugOn p = p { plist_debug = True }++-- | Send the (remote) 'PlistBuddy' monad to given 'Plist'.+send :: Plist -> PlistBuddy a -> IO a+send dev (PlistBuddy m) = bracket (takeMVar lock) (putMVar lock) $ \ () -> do+ d <- readIORef (plist_dirty dev)+ case d of+ Just {} -> do+ v <- runReaderT (runExceptT m) dev+ case v of+ Left (PlistError msg) -> fail msg -- an unhandled PlistError turns into an IO fail+ Right val -> return val+ Nothing -> throw $ PlistBuddyException $ "plist handle has been closed with exit"+ where lock = plist_lock dev++-- | Returns Help Text+help :: PlistBuddy Text+help = do+ plist <- ask+ res <- liftIO $ command plist "Help"+ return $ E.decodeUtf8 $ res++-- | Exits the program, changes are not saved to the file+exit :: PlistBuddy ()+exit = do+ plist <- ask+ liftIO $ plist_trail plist Exit+ liftIO $ do+ (void $ command plist "Exit") `catch` \ (e :: IOException) -> do { return () }+ debug ("waiting for Process on exit")+ r <- liftIO $ do+ waitForProcess (plist_proc plist)+ debug ("closing pty after process closed",r)+ liftIO $ do+ closePty (plist_pty plist)+ debug ("done with exit, including closing pty")+ liftIO $ writeIORef (plist_dirty plist) $ Nothing -- closed+ return ()++-- | Saves the current changes to the file+save :: PlistBuddy ()+save = do+ plist <- ask+ res <- liftIO $ command plist "Save"+ case res of+ "Saving..." -> do+ bs <- liftIO $ hashcode (plist_file plist)+ liftIO $ plist_trail plist $ Save bs+ dirty False+ return ()+ _ -> error $ "save failed: " <> show res+++-- | Reloads the last saved version of the file+revert :: PlistBuddy ()+revert = do+ plist <- ask+ res <- liftIO $ command plist "Revert"+ case res of+ "Reverting to last saved state..." -> do+ liftIO $ plist_trail plist Revert+ dirty False+ return ()+ _ -> error $ "revert failed: " ++ show res++-- | Clear Type - Clears out all existing entries, and creates root of a value,+-- where the value is an empty Dict or Array.+clear :: Value -> PlistBuddy ()+clear value = do+ plist <- ask+ ty <- case value of+ Array [] -> return $ valueType value+ Array _ -> error "add: array not empty"+ Dict [] -> return $ valueType value+ Dict _ -> error "add: dict not empty"+ _ -> error "adding a non dict/array to the root path"+ res <- liftIO $ command plist $ "Clear " <> ty+ case res of+ "Initializing Plist..." -> do+ liftIO $ plist_trail plist $ Clear value+ dirty True+ return ()+ _ -> fail $ "add failed: " ++ show res++-- | Print Entry - Gets value of Entry.+get :: [Text] -> PlistBuddy Value+get entry = do+ debug ("get",entry)+ plist <- ask+ res <- liftIO $ command plist $ "Print" <> BS.concat [ ":" <> quoteText e | e <- entry ]+ if "Print: Entry, " `BS.isPrefixOf` res && ", Does Not Exist" `BS.isSuffixOf` res+ then throwPlistError $ PlistError $ "value not found"+ else case parseXMLDoc (BS.filter (/= fromIntegral (ord '\r')) res) of+ Nothing -> error "get: early parse error"+ Just (Element _ _ xml _) -> case parse (onlyElems xml) of+ Nothing -> error ("get: late parse error : " ++ show (onlyElems xml))+ Just v -> return $ v+ where+ parse :: [Element] -> Maybe Value+ parse [] = Nothing+ parse (Element nm attr cs _:_) = + case showQName nm of+ "integer" -> Integer <$> parseInteger cs+ "string" -> String <$> parseString cs+ "dict" -> Dict <$> parseDict cs+ "array" -> Array <$> parseArray cs+ "false" -> return $ Bool False+ "true" -> return $ Bool True+ "real" -> Real <$> parseReal cs+ "data" -> Data <$> parseData cs+ "date" -> Date <$> parseDate cs+ x -> error $ show ("other",x,cs)++ parseInteger :: [Content] -> Maybe Integer+ parseInteger = return . read . concatMap showContent ++ parseReal :: [Content] -> Maybe Double+ parseReal = return . read . concatMap showContent ++ -- The content must be encoded as an ISO-8601 string in the UTC timezone+ -- https://code.google.com/p/networkpx/wiki/PlistSpec#date+ parseDate :: [Content] -> Maybe UTCTime+ parseDate = parseTimeM True defaultTimeLocale "%FT%XZ"+ . concatMap showContent ++ parseData :: [Content] -> Maybe ByteString+ parseData = either (const Nothing)+ (Just) + . B64.decode+ . E.encodeUtf8+ . T.filter (not . isSpace)+ . T.pack+ . showContents++ -- "\t" messes up+ parseString :: [Content] -> Maybe Text+ parseString = return . T.pack . showContents ++ showContents :: [Content] -> String+ showContents = concatMap showContent+ where + showContent :: Content -> String+ showContent (Elem e) = error "internal Elem"+ showContent (Text e) = case cdVerbatim e of+ CDataText -> cdData e+ CDataVerbatim -> error "internal CDataVerbatim"+ CDataRaw -> error "internal CDataRaw"+ showContent (CRef e) = error "internal CRef"++ parseDict :: [Content] -> Maybe [(Text,Value)]+ parseDict cs = parseDict' (onlyElems cs)+ where+ parseDict' :: [Element] -> Maybe [(Text,Value)]+ parseDict' [] = return []+ parseDict' (Element nm attr cs _+ : e+ : rest) | showQName nm == "key"+ = do v <- parse [e]+ ivs <- parseDict' rest+ return $ (T.pack $ concatMap showContent $ cs, v) : ivs+ parseDict' _ = Nothing++ parseArray :: [Content] -> Maybe [Value]+ parseArray cs = parseArray' (onlyElems cs)+ where+ parseArray' :: [Element] -> Maybe [Value]+ parseArray' [] = return []+ parseArray' (e : rest)+ = do v <- parse [e]+ vs <- parseArray' rest+ return $ v : vs+ parseDict' _ = Nothing+++-- | Set Entry Value - Sets the value at Entry to Value+-- You can not set dictionaries or arrays.+set :: [Text] -> Value -> PlistBuddy ()+set [] value = error "Can not set empty path"+set entry (Date d) = mergeDate entry d (Set entry $ Date $ d)+set entry (Data d) = importData entry d (Set entry $ Data $ d)+set entry (Dict xs) = error "set: dict not allowed"+set entry (Array xs) = error "set: array not allowed"+set entry value = do+ debug ("set",entry,value,valueType value)+ plist <- ask+ dirty True+ res <- liftIO $ command plist $ "Set " <> BS.concat [ ":" <> quoteText e | e <- entry ]+ <> " " <> quoteValue value+ case res of+ "" -> do + liftIO $ plist_trail plist $ Set entry value+ return ()+ "Unrecognized Date Format" -> error $ "Unrecognized"+ _ -> throwPlistError $ PlistError $ "set failed: " ++ show res+ +-- | Add Entry Type [Value] - Adds Entry to the plist, with value Value+-- You can add *empty* dictionaries or arrays.+add :: [Text] -> Value -> PlistBuddy ()+add [] value = error "Can not add to an empty path"+add entry (Date d) = mergeDate entry d (Add entry $ Date $ d)+add entry (Data d) = importData entry d (Add entry $ Data $ d)+add entry (Dict xs) | not (null xs) = error "add: dict not empty"+add entry (Array xs) | not (null xs) = error "add: array not empty"+add entry value = do+ debug ("add",entry,value,valueType value)+ plist <- ask+ dirty True+ res <- liftIO $ command plist $ "Add " <> BS.concat [ ":" <> quoteText e | e <- entry ]+ <> " " <> valueType value <> " "+ <> quoteValue value+ case res of+ "" -> do+ liftIO $ plist_trail plist $ Add entry value+ return ()+ _ -> throwPlistError $ PlistError $ "add failed: " ++ show res++-- | Delete Entry - Deletes Entry from the plist+delete :: [Text] -> PlistBuddy ()+delete entry = do+ debug ("delete",entry)+ plist <- ask+ dirty True+ res <- liftIO $ command plist $ "delete " <> BS.concat [ ":" <> quoteText e | e <- entry ]+ case res of+ "" -> do+ liftIO $ plist_trail plist $ Delete entry+ return ()+ _ -> throwPlistError $ PlistError $ "delete failed: " ++ show res+++importData :: [Text] -> ByteString -> Trail -> PlistBuddy ()+importData entry d t = do+ debug ("import(add/set)",entry,d)+ plist <- ask+ dirty True+ nm <- liftIO $ do+ (nm,h) <- openBinaryTempFile "/tmp" "plist-data-.tmp"+ BS.hPutStr h d -- write temp file with the binary data+ hClose h+ return nm+ res <- liftIO $ command plist $ "Import " <> BS.concat [ ":" <> quoteText e | e <- entry ]+ <> " "+ <> (quoteText $ T.pack $ nm)+ liftIO $ removeFile nm+ case res of+ "" -> do+ liftIO $ plist_trail plist t+ return ()+ _ -> throwPlistError $ PlistError $ "import(add/set) failed: " ++ show res+++-- a version of add/set that uses merge, because the date writing format+-- has a missing hour in Fall, because of timezones.+mergeDate :: [Text] -> UTCTime -> Trail -> PlistBuddy ()+mergeDate entry d t = do+ debug ("merge(set/get)",entry,d)+ plist <- ask+ dirty True+ v <- get (init entry) -- 'orable way of doing this. Best of bad options+ case v of+ Dict env -> do+ res <- liftIO $ do+ (nm,h) <- openBinaryTempFile "/tmp" "plist-date-.tmp"+ hPutStr h $ showTopElement $ + unode "dict" $+ [ unode "key" $ T.unpack $ last entry+ , unode "date" $ formatTime defaultTimeLocale "%FT%XZ" d+ ]+ hClose h+ when (last entry `elem` map fst env) $ do+ void $ command plist $ "delete " <> BS.concat [ ":" <> quoteText e | e <- entry ]+ res <- command plist $ "merge " <> quoteText (T.pack nm) <> " "+ <> BS.concat [ ":" <> quoteText e | e <- (init entry) ]+ removeFile nm+ return res+ case res of+ "" -> do+ liftIO $ plist_trail plist t+ return ()+ _ -> throwPlistError $ PlistError $ "merge(set/get) failed: " ++ show res+ Array vs | T.all isDigit (last entry) -> do+ res <- liftIO $ do+ (nm,h) <- openBinaryTempFile "/tmp" "plist-date-.tmp"+ hPutStr h $ showTopElement $ + unode "array" $+ [ unode "date" $ formatTime defaultTimeLocale "%FT%XZ" d+ ]+ hClose h+ -- add to end of list+ res <- command plist $ "merge " <> quoteText (T.pack nm) <> " "+ <> BS.concat [ ":" <> quoteText e | e <- (init entry) ]+ removeFile nm+ -- now, move the inserted value to the correct place+ let n = if T.null (last entry)+ then length vs -- "" inserts at the end+ else read $ T.unpack $ last $ entry++ when (n < length vs) $ do+ -- We need to move it+ let path x = BS.concat [ ":" <> quoteText e + | e <- init entry ++ [T.pack $ show $ x]+ ] + void $ command plist $ "copy " <> path (length vs) <> " " <> path n+ void $ command plist $ "delete " <> path (length vs)+ return res+ case res of+ "" -> return ()+ _ -> throwPlistError $ PlistError $ "merge(set/get) failed: " ++ show res++ _ -> error $ "add/set error for date; path type error"+ ++dirty :: Bool -> PlistBuddy ()+dirty b = do+ plist <- ask+ liftIO $ writeIORef (plist_dirty plist) $ Just b+++{- +-- Not (yet) supported+-- Copy <EntrySrc> <EntryDst> - Copies the EntrySrc property to EntryDst+-- Merge <file.plist> [<Entry>] - Adds the contents of file.plist to Entry+-- Import <Entry> <file> - Creates or sets Entry the contents of file+-}++quoteText :: Text -> ByteString+quoteText = quoteBS . E.encodeUtf8++quoteBS :: ByteString -> ByteString+quoteBS q = "'" <> BS.concatMap esc q <> "'"+ where esc 39 = "\\'"+ esc 92 = "\\\\" -- RTT moment+ esc 10 = "\\n"+ esc 34 = "\\\""+ esc c = BS.pack [c]+++quoteValue :: Value -> ByteString+quoteValue (String txt) = quoteBS $ E.encodeUtf8 $ txt+quoteValue (Array {}) = ""+quoteValue (Dict {}) = ""+quoteValue (Bool True) = "true"+quoteValue (Bool False) = "false"+quoteValue (Real r) = E.encodeUtf8 $ T.pack $ show r+quoteValue (Integer i) = E.encodeUtf8 $ T.pack $ show i+quoteValue other = error $ "can not quote " ++ show other++valueType :: Value -> ByteString+valueType (String txt) = "string"+valueType (Array {}) = "array"+valueType (Dict {}) = "dict"+valueType (Bool True) = "bool"+valueType (Bool False) = "bool"+valueType (Real r) = "real"+valueType (Integer i) = "integer"+valueType (Date {}) = "date"+valueType (Data {}) = "data"++------------------------------------------------------------------------------++debug :: (Show a) => a -> PlistBuddy ()+debug a = do+ plist <- ask+ when (plist_debug plist) $ do+ liftIO $ do+ tid <- myThreadId+ print (tid,a)+++------------------------------------------------------------------------------+++-- | 'replay' invokes the respective 'PlistBuddy' function. It is uses+-- when replying an audit replay.+replay :: Trail -> PlistBuddy ()+replay (Save {}) = save+replay Revert = revert+replay Exit = exit+replay (Clear v) = clear v+replay (Set p v) = set p v+replay (Add p v) = add p v+replay (Delete p) = delete p+replay (Types.Start {}) = return ()+++--------------------------------------++-- | This is a version of Plist that saves the database on regular occasions,+-- and suspends itself when not used.+data BackgroundPlist = BackgroundPlist Int (IO Plist) (MVar BackgroundState)++data BackgroundState+ = Sleeping+ | Awake Plist++-- | This creates a background Plist. The 'Int' argument is the number of seconds+-- to wait before saveing and sleeping the Plist. The 'IO Plist' may be called many times. +backgroundPlist :: Int -> IO Plist -> IO BackgroundPlist+backgroundPlist n p = do+ v <- newMVar Sleeping+ return $ BackgroundPlist n p v++-- | Send a command to a background Plist.+-- The semantics of bgSend is the same as saving after every command, provided you wait long enough.+bgSend :: BackgroundPlist -> PlistBuddy a -> IO a+bgSend bg@(BackgroundPlist n p v) m = do+ st <- takeMVar v+ case st of+ Sleeping -> do+ dev <- p+ forkIO $ do+ threadDelay (n * 1000 * 1000)+ bgAutoSave bg+ r <- send dev m -- TODO: handle exceptions here+ putMVar v $ Awake dev + return r+ Awake dev -> do+ r <- send dev m -- TODO: handle exceptions here+ putMVar v $ Awake dev + return r++-- | Save (if needed) and exit. The BackgroundPlist goes to sleep. +bgAutoSave :: BackgroundPlist -> IO ()+bgAutoSave bg@(BackgroundPlist n p v) = do+ st <- takeMVar v+ case st of+ Sleeping -> putMVar v Sleeping+ Awake dev -> do+ -- assumes no one else is read/writing. The MVar BackgroundState is acting as a lock+ d <- readIORef (plist_dirty dev)+ (case d of+ Nothing -> return ()+ Just True -> send dev $ do { save ; exit } + Just False -> send dev $ do { exit }) `finally` putMVar v Sleeping + +
+ src/Database/PlistBuddy/Audit.hs view
@@ -0,0 +1,121 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+module Database.PlistBuddy.Audit ( auditOn, auditOff, hashcode, recover, findTrail ) where++import Control.Concurrent+import Control.Exception+import Control.Monad.Reader+import Control.Monad.Except++import Data.Char(isSpace)+import Data.Text(Text)+import Data.ByteString (ByteString)+import qualified Data.ByteString.Base16 as B16+import qualified Data.ByteString.Lazy as LB+import Database.PlistBuddy.Types++import System.IO+import System.Process++import Data.Time++import GHC.Generics++import qualified Crypto.Hash.MD5 as MD5++import Debug.Trace++auditOn :: FilePath -> Plist -> IO Plist+auditOn auditFile plist = do+ -- if there is no file, then this creates an empty file first+ au <- openFile auditFile AppendMode+ -- state what we are auditing, with blank line(s)+ -- in case the previous line was incomplete+ hPutStr au $ "\n\n" ++ take 72 (cycle "-") ++ "\n" + t <- getCurrentTime+ h <- hashcode (plist_file plist)+ issue au $ t :! Start h+ -- and append to the audit file+ let up u = do+ o <- hIsOpen au+ if o then do+ t <- getCurrentTime+ issue au $ t :! u+ case u of+ Exit -> hClose au+ _ -> return ()+ else return () -- putStrLn $ "audit log failure: " ++ show u ++ "\n"+ return $ plist { plist_trail = up, plist_launder = hClose au }++-- | Turn off audit.+auditOff :: Plist -> IO ()+auditOff = plist_launder++hashcode :: FilePath -> IO ByteString+hashcode fileName = do+ bs <- LB.readFile fileName+ return $! B16.encode $! MD5.hashlazy bs+ +issue :: Show a => Handle -> a -> IO ()+issue h u = do+ hPutStr h $ show u ++ "\n"+ hFlush h++maybeRead :: Read a => String -> Maybe a+maybeRead str = case reads str of+ [(r,rest)] | all isSpace rest -> return r+ _ -> Nothing+ +-- | Find the list of 'PlistBuddy' commands to recover the plist.+-- Be careful when running recover with the audit capability turned on; it can duplicate+-- the audit trail, because recovery is also write. (This should not break anything)+recover :: FilePath -> IO [AuditTrail]+recover auditFile = do+ txt <- readFile auditFile+ let trails = [ v | Just (_ :! v) <- map maybeRead $ lines $ txt ]+ return $ runTrails trails+ +runTrails :: [Trail] -> [AuditTrail]+runTrails [] = []+runTrails (inst :rest) = case inst of+ Save bs -> runTrails' bs [] rest+ Start bs -> runTrails' bs [] rest+ _ -> runTrails rest -- find a 'Save/Start' checkpoint+ where+ runTrails' :: ByteString -> RList Trail -> [Trail] -> [AuditTrail] + runTrails' bs [] [] = []+ runTrails' bs insts [] = [AuditTrail bs (reverse insts) Nothing]+ runTrails' bs insts (inst : rest) = case inst of+ Save bs' -> mkTrail (Just bs') $ runTrails' bs' [] rest -- save is start of next trail+ Start bs' -> mkTrail Nothing $ runTrails' bs' [] rest -- start ignores trail before, because of no save+ Revert -> runTrails' bs [] rest -- revert wipes all unsaved instructions+ Exit -> runTrails rest -- abandon the changes; start trail again+ Clear _ -> runTrails' bs [inst] rest -- anything *before* clear is now lost+ _ -> runTrails' bs (inst : insts) rest -- Set / Add / Delete+ where+ mkTrail done k = + if null insts+ then k+ else (AuditTrail bs (reverse insts) done) : k++type RList a = [a] -- a reversed list, often a stack++-- Find the last trail with this hashcode+findTrail :: ByteString -> [AuditTrail] -> [Trail]+findTrail bs trails = combine $ dropMe trails+ where+ combine [] = []+ combine ( AuditTrail bs ts (Just bs') + : AuditTrail bs'' ts2 done+ : more) | bs' == bs'' =+ combine (AuditTrail bs (ts ++ ts2) done : more)+ combine (AuditTrail bs ts _ : _) = ts++ takeMe [] acc = reverse acc+ takeMe (x@(AuditTrail bs' _ _) : xs) acc+ | bs == bs' = takeMe xs [x] --- restart+ | otherwise = takeMe xs (x : acc)++ dropMe [] = []+ dropMe (x@(AuditTrail bs' _ _) : xs) + | bs == bs' = takeMe xs [x]+ | otherwise = dropMe xs
+ src/Database/PlistBuddy/Command.hs view
@@ -0,0 +1,106 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+module Database.PlistBuddy.Command+ ( command+ , recvReply0+ , myWritePty+ )+ where++import Control.Exception+import Control.Monad++import Data.Word (Word8)+import Data.Char (ord)+import Database.PlistBuddy.Types++import qualified Data.ByteString as BS+import Data.ByteString (ByteString)+import Data.Monoid ((<>))++import System.Posix.Pty+import System.Timeout++-- Single threaded; assumes a lock above it.+command :: Plist -> ByteString -> IO ByteString+command plist input = todo+ where+ d = plist_debug plist+ pty = plist_pty plist+ write txt = do+ when d $ print ("write"::String,txt)+ myWritePty pty txt++ todo = do+ write (input <> "\n")+ r <- recvReply pty+ when d $ print ("read"::String,r)+ return $ r+++recvReply0 :: Pty -> IO ByteString+recvReply0 pty = readMe []+ where+ readMe rbs = do+ v <- myReadPty pty+ testMe ( BS.filter (`notElem` toIgnore) v : rbs)++ toIgnore :: [Word8]+ toIgnore = BS.unpack "\r\n#"++ testMe rbs | "Command: Unrecognized CommandCommand: " `isSuffixOf` rbs+ = return $ ""+ | otherwise+ = readMe rbs+ where+ bs = rbsToByteString rbs++recvReply :: Pty -> IO ByteString+recvReply pty = readMe []+ where+ prompt = "\nCommand: "++ readMe rbs = do+ v <- myReadPty pty+ testMe ( BS.filter (/= fromIntegral (ord '\r')) v : rbs)++ testMe rbs | prompt `isSuffixOf` rbs+ = return $ BS.take (BS.length bs - BS.length prompt) bs+ | "Command: " == bs+ = return $ ""+ | otherwise+ = readMe rbs+ where+ bs = rbsToByteString rbs++type RBS = [ByteString] -- reversed list of strict bytestring++rbsToByteString :: RBS -> ByteString+rbsToByteString = BS.concat . reverse+ +isSuffixOf :: ByteString -> RBS -> Bool+isSuffixOf bs rbs = bs `BS.isSuffixOf` rbsToByteString rbs++myWritePty :: Pty -> ByteString -> IO ()+myWritePty pty msg = do+ r <- myTimeout $ do+ threadWaitWritePty pty+ writePty pty msg+ case r of+ Just () -> return ()+ Nothing -> do+ throw $ PlistBuddyException "timeout when writing"++myReadPty :: Pty -> IO ByteString+myReadPty pty = do+ r <- myTimeout $ do+ threadWaitReadPty pty+ tryReadPty pty+ case r of+ Just (Left {}) -> myReadPty pty+ Just (Right v) -> return v+ Nothing -> do+ throw $ PlistBuddyException "timeout when reading"++myTimeout :: IO a -> IO (Maybe a)+myTimeout = timeout (1000 * 1000)+
+ src/Database/PlistBuddy/Open.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+module Database.PlistBuddy.Open + ( -- * Remote Monad+ openPlist+ ) where++import Control.Concurrent+import Control.Exception++import Data.IORef+import Database.PlistBuddy.Types+import Database.PlistBuddy.Command++import System.Posix.Pty++import System.IO.Error (catchIOError)+++handleIOErrors :: IO a -> IO a+handleIOErrors m =+ m `catchIOError` \ e -> throw $ PlistBuddyException $ "IO error, " ++ show e++-- | Open a specific Plist, returning a Plist handle.+openPlist :: FilePath -> IO Plist+openPlist fileName = handleIOErrors $ do+ (pty,ph) <- spawnWithPty+ Nothing+ False+ "/usr/libexec/PlistBuddy"+ ["-x",fileName]+ (80,24)++ myWritePty pty "#\n" -- 1 times in 100, you need to poke the plist-buddy+ _ <- recvReply0 pty+ attr <- getTerminalAttributes pty+ setTerminalAttributes pty ((attr `withoutMode` EnableEcho) `withoutMode` ProcessInput) Immediately+ lock <- newMVar ()+ dirty <- newIORef $ Just False+ return $ Plist pty lock ph False fileName (const $ return $ ()) (return ()) dirty++
+ src/Database/PlistBuddy/Types.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+module Database.PlistBuddy.Types+ ( -- * Remote Monad+ PlistBuddy(..)+ , throwPlistError+ , catchPlistError+ -- * Remote monad handle+ , Plist(..)+ -- * Other types+ , Value(..)+ -- * Exception+ , PlistBuddyException(..)+ , PlistError(..)+ -- * Audit+ , Audit(..)+ , Trail(..)+ , AuditTrail(..)+ ) where++import Control.Concurrent+import Control.Exception+import Control.Monad.Reader+import Control.Monad.Except+++import Data.Text(Text)+import Data.ByteString (ByteString)+import Data.IORef++import System.Process+import System.Posix.Pty++import Data.Time++import GHC.Generics++------------------------------------------------------------------------------++-- | The Remote Monad+newtype PlistBuddy a = PlistBuddy (ExceptT PlistError (ReaderT Plist IO) a)+ deriving (Functor,Applicative, Monad, MonadError PlistError, MonadReader Plist, MonadIO)++newtype PlistError = PlistError String + deriving (Show, Eq)++-- | A version of 'catchError' with the type specialized to 'PlistBuddy'. Using+-- this will cause a static error if used on a non-'PlistBuddy' monad.++catchPlistError :: PlistBuddy a -> (PlistError -> PlistBuddy a) -> PlistBuddy a+catchPlistError = catchError++-- | Throw a 'PlistError'. Uncaught 'PlistError' exceptions will+-- be thrown by 'send' as IO Exceptions.++throwPlistError :: PlistError -> PlistBuddy a+throwPlistError = throwError++-- | The Remote Plist +data Plist = Plist + { plist_pty :: Pty+ , plist_lock :: MVar () + , plist_proc :: ProcessHandle+ , plist_debug :: Bool+ , plist_file :: FilePath+ , plist_trail :: Trail -> IO () -- audit information+ , plist_launder :: IO () -- close audit without issuing an exit; for testing+ , plist_dirty :: IORef (Maybe Bool) -- if the database has been changed; Nothing == closed+ }+ +------------------------------------------------------------------------------++data Value = String Text+ | Array [Value] + | Dict [(Text,Value)] + | Bool Bool+ | Real Double+ | Integer Integer+ | Date UTCTime+ | Data ByteString+ deriving (Show, Read, Generic)++------------------------------------------------------------------------------++-- | 'PlistBuddyException' is for fatal things,+-- like the sub-process blocks, for some reason.+data PlistBuddyException = PlistBuddyException String+ deriving (Show, Generic)++instance Exception PlistBuddyException++------------------------------------------------------------------------------++data AuditTrail = AuditTrail ByteString [Trail] (Maybe ByteString)+ deriving (Show,Read,Generic) + +data Audit+ = UTCTime :! Trail + deriving (Show,Read,Generic) + +data Trail + = Save ByteString -- ^ hash code of saved file+ | Revert+ | Exit+ | Clear Value+ | Set [Text] Value+ | Add [Text] Value+ | Delete [Text]+ | Start ByteString -- ^ hash code at start of audit capture+ deriving (Show,Read,Generic) +
+ tests/Main.hs view
@@ -0,0 +1,699 @@+{-# LANGUAGE GeneralizedNewtypeDeriving, DeriveGeneric, OverloadedStrings, ScopedTypeVariables #-}+import Database.PlistBuddy ++import Data.Monoid+import Control.Monad (when)+import Data.Text(Text,pack,unpack)+import qualified Data.Text as T+import Data.Text.IO as TIO+import Data.Time+import qualified Data.ByteString as BS++import Test.Hspec+import Test.Hspec.QuickCheck+import Test.QuickCheck hiding (replay)+import Test.QuickCheck.Exception+import Control.Exception (evaluate, bracket, catch)++import qualified System.IO as IO+import System.Timeout+import Control.Concurrent (threadDelay)+import System.Mem+import System.Directory (removeFile, doesFileExist)++import Data.List (sortBy, sort, nub, transpose,lookup)++import GHC.Generics+import Control.Monad.Reader++import System.Environment+import Data.Char (isDigit)++clearAudit :: IO ()+clearAudit = do+ TIO.writeFile "test.audit" "" ++clearDB :: IO ()+clearDB = do+ TIO.writeFile "test.plist" "{}" + TIO.writeFile "test.audit" "" ++rmDB :: IO ()+rmDB = do+ doesFileExist "test.plist" >>= \ b -> when b (removeFile "test.plist")++openConnection :: Bool -> IO Plist+openConnection audit = do+ d <- openPlist "test.plist"+ send d $ clear (Dict [])+ if audit + then auditOn "test.audit" d+ else return d+ +closeConnection :: Plist -> IO ()+closeConnection d = send d $ exit++-- only for tests that write then read+withPlistConnection :: Bool -> (Plist -> IO ()) -> IO ()+withPlistConnection audit + = guardPlistBuddyException + . bracket (openConnection audit)+ closeConnection++guardPlistBuddyException :: IO a -> IO a+guardPlistBuddyException m = m `catch` \ (PlistBuddyException msg) -> do+ IO.putStrLn $ "\ndiscarded: " ++ show msg+ discard++main :: IO ()+main = hspec $ do++ beforeAll clearDB $ do+ describe "initial plist" $ modifyMaxSuccess (\ x -> 100) $ do++ it "check initial dict is an dictionary" $ withPlistConnection False $ \ d -> do+ r0 <- send d $ get []+ r0 `shouldBe` Dict []++ it "check reset to array" $ withPlistConnection False $ \ d -> do+ _ <- send d $ clear (Array [])+ r0 <- send d $ get []+ r0 `shouldBe` Array []+ + it "check reset to back to an dict" $ withPlistConnection False $ \ d -> do+ _ <- send d $ clear (Array [])+ _ <- send d $ clear (Dict [])+ r0 <- send d $ get []+ r0 `shouldBe` Dict []++ it "check adding a value at top level" $ + property $ \ (Label lbl) (OneValue v) audit -> withPlistConnection audit $ \ d -> do+ debug $ ("add val top",lbl,v)+ _ <- send d $ add [lbl] v+ r0 <- send d $ get []+ r0 `shouldBe` Dict [(lbl,v)]++ it "check adding then setting a value at top level" $ + property $ \ (Label lbl) (PrimValue v1) audit ->+ forAll (arbitrarySameType v1) $ \ v2 ->+ withPlistConnection audit $ \ d -> do+ debug $ ("add then set top",lbl,v1,v2)+ _ <- send d $ add [lbl] v1+ _ <- send d $ set [lbl] v2+ r0 <- send d $ get []+ r0 `shouldBe` Dict [(lbl,v2)]++ it "populate a DB" $ + property $ \ (DictValue v) audit -> withPlistConnection audit $ \ d -> do+ debug $ ("populate",v)+ r0 <- send d $ do+ populateDict v+ get []+ r0 `shouldBe` v++ it "test deeper get" $ + property $ \ (DictValue v) audit -> + forAll (arbitraryReadPath 0.8 v) $ \ (Path ps,v') -> do+ withPlistConnection audit $ \ d -> do+ send d $ populateDict v+ r0 <- send d $ get ps+ r0 `shouldBe` v'++ it "test deepest get" $ + property $ \ (DictValue v) audit -> + forAll (arbitraryReadPath 1.0 v) $ \ (Path ps,v') -> do+ withPlistConnection audit $ \ d -> do+ send d $ populateDict v+ r0 <- send d $ get ps+ r0 `shouldBe` v'+++ it "test deepest set then get" $ + property $ \ (DictValue v) audit -> + forAll (arbitraryReadPath 1.0 v) $ \ (Path ps,v1) -> + not (null ps) && (case v1 of { Dict {} -> False; Array {} -> False ; _-> True}) ==>+ forAll (arbitrarySameType v1) $ \ v2 ->+ withPlistConnection audit $ \ d -> do+ debug (v1,v2,ps)+ send d $ populateDict v+ send d $ set ps v2+ r0 <- send d $ get ps+ r0 `shouldBe` v2++ it "test delete" $ + property $ \ (DictValue v) audit -> + forAll (arbitraryReadPath 1.0 v) $ \ (Path ps,v1) -> + not (null ps) ==>+ withPlistConnection audit $ \ d -> do+-- print (v1,ps)+ (r1,parent) <- send d $ do+ populateDict v+ r1 <- get ps+ parent <- get (init ps)+ delete ps+ return (r1,parent)+ case parent of+ Dict {} -> do+ r2 <- send d $ ((Just <$> get ps) `catchPlistError` \ _ -> return Nothing)+ (r1,r2) `shouldBe` (v1,Nothing)+ Array xs -> do+ xs' <- send d $ do+ Array xs' <- get (init ps)+ return xs'+ (r1,length xs) `shouldBe` (v1,length xs' + 1)++ it "check for bad path error handling" $ + property $ \ (DictValue v) (Path p) audit -> p `notIn` v ==> withPlistConnection audit $ \ d -> do+ debug $ ("bad path",v,p)+ r <- (send d $ (do+ populateDict v+ get p+ return False) `catchPlistError` \ e -> do+ return True)++ r `shouldBe` True++ it "test get/set/delete sequences" $ + property $ \ audit ->+ forAll (modSized 8 return) $ \ n ->+ forAll (Blind <$> arbitraryUpdates n (Dict [])) $ \ (Blind updates) ->+ withPlistConnection audit $ \ d -> do+ send d $ clear (Dict [])+ let xs = []+ xs <- sequence [ send d $ do+ u -- the update+ r <- get []+ return (v,r)+ | (u,v) <- updates + ]+ map fst xs `shouldBe` map snd xs++ beforeAll clearDB $ do+ describe "plist modification" $ do + it "test save of DB" $ + property $ \ (DictValue v) -> guardPlistBuddyException $ do+ d <- openPlist "test.plist"+ send d $ clear (Dict []) -- clear dict+ send d $ do+ populateDict v+ save+ exit+ d <- openPlist "test.plist"+ r0 <- send d $ get []+ send d $ exit+ r0 `shouldBe` v++ it "test save of DB, with changes in between" $ + property $ \ (DictValue v) (DictValue v') -> guardPlistBuddyException $ do+ d <- openPlist "test.plist"+ send d $ clear (Dict []) -- clear dict+ send d $ do+ populateDict v+ save+ clear $ Dict []+ populateDict v'+ exit+ d <- openPlist "test.plist"+ r0 <- send d $ get []+ send d $ exit+ r0 `shouldBe` v++ it "test save and revert of DB" $ + property $ \ (DictValue v) (DictValue v') -> guardPlistBuddyException $ do+ d <- openPlist "test.plist"+ send d $ clear (Dict []) -- clear dict+ r0 <- send d $ do+ populateDict v+ save+ clear $ Dict []+ populateDict v'+ revert+ r <- get []+ exit+ return r+ r0 `shouldBe` v ++ it "test double exit" $ + property $ \ (DictValue v) (DictValue v') -> guardPlistBuddyException $ do+ d <- openPlist "test.plist"+ send d $ clear (Dict []) -- clear dict+ send d $ do+ populateDict v+ save+ exit+ d <- openPlist "test.plist"+ r0 <- send d $ get []+ send d $ exit+ res <- (send d $ do { clear $ Dict [] ; populateDict v' ; return True}) + `catch` \ (e :: PlistBuddyException) -> do { return False }+ (r0,res) `shouldBe` (v,False)++ beforeAll clearDB $ do+ describe "plist audit test" $ do + it "test get/set/delete sequences, with basic audit trail usage" $ + forAll (modSized 8 return) $ \ n1 ->+ forAll (modSized 8 return) $ \ n2 ->+ forAll (modSized 8 return) $ \ n3 ->+ let s = Dict [] in+ forAll (Blind <$> arbitraryUpdates n1 (s) ) $ \ (Blind updates1) ->+ forAll (Blind <$> arbitraryUpdates n2 (lastOf s $ updates1)) $ \ (Blind updates2) ->+ forAll (Blind <$> arbitraryUpdates n3 (lastOf s $ updates1 ++ updates2)) $ \ (Blind updates3) ->+ do d <- openPlist "test.plist"++ -- Populate dictionary randomly+ send d $ clear (Dict []) -- clear dict+ sequence_ [ send d u | (u,_) <- updates1 ]+ send d $ save+ send d $ exit++ -- Reload, with (new) audit+ clearAudit+ d <- openPlist "test.plist"+ d <- auditOn "test.audit" d+ sequence_ [ send d u | (u,_) <- updates2 ]+ send d $ save++ -- And do more stuff, without saving, but with audit+ sequence_ [ send d u | (u,_) <- updates3 ] + auditOff d -- turn off audit, before turning exiting the plist+ send d $ exit++ -- now need to restore+ h <- hashcode "test.plist"+-- print ("hashcode",h)+ auditTrails <- recover "test.audit"+-- print ("audit trails",auditTrails)+ let trail = findTrail h auditTrails+ d <- openPlist "test.plist"+ send d $ sequence_ $ map replay trail+ let target = lastOf s $ updates1 ++ updates2 ++ updates3+ r0 <- send d $ get []+ send d $ exit+ r0 `shouldBe` target++ beforeAll rmDB $ do+ describe "create plists" $ do + it "open non-existent plist" $ do+ property $ do+ d <- openPlist "test.plist"+ r0 <- send d $ get []+ send d $ exit+ r0 `shouldBe` Dict []++ beforeAll clearDB $ do+ describe "auto-save plists" $ modifyMaxSuccess (\ x -> 3) $ do + it "test bg save of DB, with changes in between" $ + property $ noShrinking $ \ (DictValue v) (DictValue v') -> guardPlistBuddyException $ do+ bg <- backgroundPlist 1 $ openPlist "test.plist"+ bgSend bg $ clear (Dict []) -- clear dict+ bgSend bg $ do+ populateDict v+ save+ clear $ Dict []+ populateDict v'+ threadDelay $ 2 * 1000 * 1000+ -- the save should have automatically happened+ d <- openPlist "test.plist"+ r0 <- send d $ get []+ send d $ exit+ r0 `shouldBe` v'++ it "auto-restart" $ + property $ noShrinking $ \ (DictValue v) (DictValue v') -> guardPlistBuddyException $ do+ bg <- backgroundPlist 1 $ openPlist "test.plist"+ bgSend bg $ clear (Dict []) -- clear dict+ bgSend bg $ do+ populateDict v+ save+ clear $ Dict []+ populateDict v'+ threadDelay $ 2 * 1000 * 1000+ -- the save should have automatically happened+ r0 <- bgSend bg $ get []+ bgSend bg $ exit+ r0 `shouldBe` v'++lastOf :: Value -> [(a,Value)] -> Value+lastOf v xs = last (v : map snd xs)++populateDict :: Value -> PlistBuddy ()+populateDict (Dict xs) = + do sequence_ [ populate (Path $ [i]) v | (i,v) <- xs ]+populateDict _ = error "expecting a Dict"+ +populate :: Path -> Value -> PlistBuddy ()+populate (Path ps) val = + case val of+ Dict xs -> do+ add ps (Dict [])+ sequence_ [ populate (Path $ ps ++ [i]) v | (i,v) <- xs ]+ Array vs -> do+ add ps (Array [])+ sequence_ [ populate (Path $ ps ++ [pack (show i)]) v | (i,v) <- [0..] `zip` vs ]+ _ -> do+ add ps val+++[] `notIn` _ = False+(p:ps) `notIn` (Dict xs) = case lookup p xs of+ Nothing -> True+ Just v -> ps `notIn` v +(p:ps) `notIn` (Array vs) + | T.all isDigit p && not (T.null p) + = case drop (read (unpack p)) vs of+ [] -> False+ (v:_) -> ps `notIn` v+_ `notIn` _ = True+++arbitraryUpdates :: Int -> Value -> Gen [(PlistBuddy (),Value)]+arbitraryUpdates 0 v = return []+arbitraryUpdates n v = do+ (u,v') <- arbitraryUpdate v+ rest <- arbitraryUpdates (n-1) v' + return $ (u,v') : rest++arbitraryUpdate :: Value -> Gen (PlistBuddy (),Value)+arbitraryUpdate v = frequency+ [ (200, arbitraryAdd v)+ , (200, arbitrarySet v)+ , (100, arbitraryDelete v)+ , (1, return (clear $ Dict [],Dict [])) -- Infrequently!+ ]++-- for now, does not go deep+-- TODO: make this go deeper (randomly)+arbitraryAdd :: Value -> Gen (PlistBuddy (),Value)+arbitraryAdd = addMe []+ where+ addMe p (Dict xs) = do+ Label lbl <- arbitrary+ OneValue val <- arbitrary+ if (lbl `elem` map fst xs)+ then addMe p (Dict xs) -- try again+ else return (add (p ++ [lbl]) val,Dict $ xs ++ [(lbl,val)])+ addMe p (Array vs) = do+ let lbl = T.pack (show $ length vs) -- for now, append at end+ OneValue val <- arbitrary+ return (add (p ++ [lbl]) val,Array $ vs ++ [val]) + addMe p other = return (return (), other)+ +arbitrarySet :: Value -> Gen (PlistBuddy (),Value)+arbitrarySet = setMe []+ where+ setMe p (Dict []) = return (return (), Dict [])+ setMe p (Dict xs) = do+ Label lbl <- Label <$> elements (map fst xs)+ case lookup lbl xs of+ Just v -> do + if valueType v `elem` ["array","dict"]+ then return (return (), Dict xs)+ else do + v' <- arbitrarySameType v+ return ( set (p ++ [lbl]) v'+ , Dict [ if l == lbl then (l,v') else (l,x) | (l,x) <- xs ]+ )+ Nothing -> error $ "should never happen" ++ show (lbl,map fst xs,xs)+-- for now+-- setMe p (Array vs) = + setMe p other = return (return (), other)+ +arbitraryDelete :: Value -> Gen (PlistBuddy (),Value)+arbitraryDelete = delMe []+ where+ delMe p (Dict []) = return (return (), Dict [])+ delMe p (Dict xs) = do+ Label lbl <- Label <$> elements (map fst xs)+ return ( delete (p ++ [lbl])+ , Dict [ (l,x) | (l,x) <- xs, l /= lbl ]+ )+ delMe p other = return (return (), other)++{-+ addMe p (Array vs) = do+ let lbl = T.pack (show $ length vs) -- for now, append at end+ OneValue val <- arbitrary+ vs <- sequence $ + [ return [ addMe (p ++ [T.pack $ show $ i]) v | (v,i) <- xs `zip` [(0::Int)..] ]+ return $ concat xs+ addMe p (Dict xs) = do+ Label lbl <- arbitrary+ OneValue val <- arbitrary+ xs <- sequence $ + [ return [ (add (p ++ [lbl]) val, Dict (xs ++ [(lbl,val)]))] + | not (lbl `elem` map fst xs) ] +++ [ addMe (p ++ [l]) v | (l,v) <- xs ]+ return $ concat xs+ addMe p other = return []+-} ++{-+arbitraryAdd :: Value -> Gen [(PlistBuddy (),Value)]+addInValue = addMe []+ where+ addMe p (Array vs) = do+ let lbl = T.pack (show $ length vs) -- for now, append at end+ OneValue val <- arbitrary+ vs <- sequence $ + [ return [ addMe (p ++ [T.pack $ show $ i]) v | (v,i) <- xs `zip` [(0::Int)..] ]+ return $ concat xs+ + addMe p (Dict xs) = do+ Label lbl <- arbitrary+ OneValue val <- arbitrary+ xs <- sequence $ + [ return [ (add (p ++ [lbl]) val, Dict (xs ++ [(lbl,val)]))] + | not (lbl `elem` map fst xs) ] +++ [ addMe (p ++ [l]) v | (l,v) <- xs ]+ return $ concat xs+ addMe p other = return []+-}+{-+-- Set of commands that change the value somehow+deleteInValue :: Value -> Gen [PlistBuddy ()]+deleteInValue = del []+ where+ del (Dict xs)+ del (Array vs) = [ n <- [0..(length n - 1)]+ del p other = delete p+-}++{-+ -- TO ADD+ -- try get type error+ + r <- send d $ ((set ["I1"] (String "foo")>>return "no failed") `catchPlistError` \ msg -> return msg)+ check "check for type error" r $ "set failed: \"Unrecognized Integer Format\""++ _ <- send d $ exit++ d <- openPlist "test.plist"++ now <- getCurrentTime++ send d $ add ["S5"] (Date now)++ Date r0 <- send d $ get ["S5"]+ + check "check for date storage" (abs (diffUTCTime now r0) < 1) $ True+ _ <- send d $ exit++ d <- debugOn <$> openPlist "test.plist"+-}+++check :: (Eq a, Show a) => Text -> a -> a -> IO ()+check msg t1 t2 = if t1 /= t2 then fail ("check failed: " ++ show (msg,t1,t2)) else TIO.putStrLn msg+ +arbitraryValue :: Int -> Gen Value+arbitraryValue n = frequency + [(7,(\ (PrimValue v) -> v) <$> arbitrary),+ (2,mysized $ \ n' -> mkDict <$> sequence [ arbitraryDict (n-1) | _ <- [1..n]]),+ (1,mysized $ \ n' -> Array <$> sequence [ arbitraryValue (n-1) | _ <- [1..n]])+ ]+ where mysized k | n == 0 = k 0+ | otherwise = modSized 8 k+++-- removes dup labels+mkDict :: [(Text,Value)] -> Value+mkDict xs = Dict [ (lbl,v) | (lbl,v) <- nub (map fst xs) `zip` map snd xs ]++arbitraryDict :: Int -> Gen (Text,Value)+arbitraryDict n = do+ Label nm <- arbitrary+ v <- arbitraryValue n+ return (nm,v)++arbitraryDate :: Gen UTCTime+arbitraryDate =+ UTCTime <$> ((\ d -> addDays d (fromGregorian 1950 1 1)) -- 2003 10 25+ <$> choose (0, 85 * 365) -- dates after 2038 have issues (wordsize?)+ -- +2+ )+ <*> (fromInteger <$> choose (0,60 * 60 * 24 - 1))+ +arbitraryText :: Gen Text+arbitraryText = modSized 10 $ \ n -> pack <$> (vectorOf n $ elements ('\n':[' '..'~']))++-- 28+arbitraryData :: Gen BS.ByteString+arbitraryData = modSized 32 $ \ n -> BS.pack <$> (vectorOf n $ elements ([0..255]))++instance Eq Value where+ (==) = eqValue++eqValue :: Value -> Value -> Bool+eqValue (String s1) (String s2) = s1 == s2+eqValue (Array a1) (Array a2) = a1 == a2+eqValue (Dict d1) (Dict d2) = sortBy f d1 == sortBy f d2 -- order should not matter+ where f (a,_) (b,_) = a `compare` b+eqValue (Bool a1) (Bool a2) = a1 == a2+eqValue (Real a1) (Real a2) = abs (a1 - a2) <= abs ((a1 + a2) / 1e6)+eqValue (Integer a1) (Integer a2) = a1 == a2+eqValue (Date d1) (Date d2) = d1 == d2+eqValue (Data d1) (Data d2) = d1 == d2+eqValue _ _ = False++---------------------------------------++---------------------------------------+valueShrink :: Value -> [Value]+valueShrink (Dict []) = []+valueShrink (Dict [(lbl,x)]) = [x]+valueShrink (Dict xs) =+ [ Dict (take i xs ++ drop (i + 1) xs)+ | i <- [0..length xs - 1]+ ] ++ + [ Dict (map fst xs `zip` vs)+ | vs <- transpose $ fmap valueShrink (map snd xs) + ]+valueShrink (Array []) = []+valueShrink (Array [x]) = [x]+valueShrink (Array vs) =+ [ Array (take i vs ++ drop (i + 1) vs)+ | i <- [0..length vs - 1]+ ] ++ + [ Array vs+ | vs <- transpose $ map valueShrink vs+ ]+--valueShrink (Date d) = [Date $ addUTCTime (60*60) d,Date $ addUTCTime (60) d,Date $ addUTCTime (1) d]++valueShrink other = []+ ++---------------------------------------++arbitrarySameType :: Value -> Gen Value+arbitrarySameType v0 = do+ (OneValue v) <- arbitrary+ if valueType v0 == valueType v+ then return v+ else arbitrarySameType v0 ++newtype PrimValue = PrimValue Value -- any primitive+ deriving (Show,Generic)++instance Arbitrary PrimValue where+ arbitrary = PrimValue <$> oneof + [ Integer <$> arbitrary+ , String <$> arbitraryText+ , Bool <$> arbitrary+ , Real <$> arbitrary+ , Date <$> arbitraryDate -- for now+ , Data <$> arbitraryData + ]+ shrink (PrimValue v) = [ PrimValue v' | v' <- valueShrink v, valueType v == valueType v']++newtype OneValue = OneValue Value -- primitive + empty dict or empty array+ deriving (Show,Generic)+ +instance Arbitrary OneValue where+ arbitrary = OneValue <$> arbitraryValue 0+ shrink (OneValue v) = [ OneValue v' | v' <- valueShrink v, valueType v == valueType v']++newtype DeepValue = DeepValue Value -- any value, to any depth+ deriving (Show,Generic)+ +instance Arbitrary DeepValue where+ arbitrary = DeepValue <$> modSized 8 arbitraryValue+ shrink (DeepValue v) = [ DeepValue v' | v' <- valueShrink v, valueType v == valueType v']++newtype DictValue = DictValue Value -- any value, to any depth+ deriving (Show,Generic)++instance Arbitrary DictValue where+ arbitrary = (DictValue . mkDict) <$> (modSized 8 $ \ n -> vectorOf n (modSized 8 arbitraryDict))+ shrink (DictValue v) = [ DictValue v' | v' <- valueShrink v, valueType v == valueType v']+ +newtype Label = Label Text+ deriving (Show,Generic)++instance Arbitrary Label where+ arbitrary = modSized 32 $ \ n -> (Label . pack) <$> sequence+ [ elements (['0'..'9'] ++ ['a'..'z'] ++ ['A'..'Z'])+ | _ <- [0..n]+ ]++newtype Path = Path [Text] -- non-empty+ deriving (Show,Generic)++instance Arbitrary Path where+ arbitrary = Path <$> (modSized 8 $ \ n -> vectorOf (n+1) ((\ (Label t) -> t) <$> arbitrary))++modSized :: Int -> (Int -> Gen a) -> Gen a+modSized n k = choose (0,n-1) >>= k++newtype ReadPath = ReadPath [Text] -- can be empty, must be valid+ deriving (Show,Generic)++instance Arbitrary ReadPath where+ arbitrary = ReadPath <$> (modSized 8 $ \ n -> vectorOf n ((\ (Label t) -> t) <$> arbitrary))++arbitraryReadPath :: Double -> Value -> Gen (Path,Value)+arbitraryReadPath n v@(Dict xs) = do+ stop <- choose (0,1)+ if (stop > n) || null xs+ then return (Path [],v)+ else do nm <- elements (map fst xs)+ case lookup nm xs of+ Just v' -> do+ (Path ps,vr) <- arbitraryReadPath n v'+ return (Path (nm:ps),vr)+ Nothing -> error "arbitraryReadPath internal error"+arbitraryReadPath n v@(Array vs) = do+ stop <- choose (0,1)+ if (stop > n) || null vs+ then return (Path [],v)+ else do i <- elements [0..(length vs - 1)]+ (Path ps,vr) <- arbitraryReadPath n (vs !! i)+ return (Path (pack (show i):ps),vr)+arbitraryReadPath _ v = return (Path [],v)+++compareValue :: Path -> Value -> Value -> String+compareValue (Path ps) v1 v2 | valueType v1 /= valueType v2 = "different types : " ++ show (ps,v1,v2)+compareValue (Path ps) (Dict ds1) (Dict ds2) + | nm1 /= nm2 = "different names of fields in dict : " ++ show (ps,nm1,nm2)+ | otherwise = concat [ case (lookup nm ds1,lookup nm ds2) of+ (Just v1,Just v2) -> compareValue (Path (ps ++ [nm])) v1 v2 + _ -> "internal error in dict compare " ++ show ps+ | nm <- nm1 ]+ where+ nm1 = sort (nub (map fst ds1))+ nm2 = sort (nub (map fst ds2))++compareValue (Path ps) (Array ds1) (Array ds2) + | length ds1 /= length ds2 = "different lengths of array : " ++ show (ps,length ds1,length ds2)+ | otherwise = concat [ compareValue (Path (ps ++ [pack (show i)])) d1 d2 | (i,d1,d2) <- zip3 [0..] ds1 ds2 ]+compareValue (Path ps) v1 v2 + | v1 /= v2 = "different values : " ++ show (ps,v1,v2)+ | otherwise = ""+++debug :: Show a => a -> IO ()+debug = const $ return ()+--debug = print+++-- TODO: make all labels length 1, and test for testing