diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. + diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/plist-buddy.cabal b/plist-buddy.cabal new file mode 100644 --- /dev/null +++ b/plist-buddy.cabal @@ -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 diff --git a/src/Database/PlistBuddy.hs b/src/Database/PlistBuddy.hs new file mode 100644 --- /dev/null +++ b/src/Database/PlistBuddy.hs @@ -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 - Copies the EntrySrc property to EntryDst +-- Merge [] - Adds the contents of file.plist to Entry +-- Import - 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 + + diff --git a/src/Database/PlistBuddy/Audit.hs b/src/Database/PlistBuddy/Audit.hs new file mode 100644 --- /dev/null +++ b/src/Database/PlistBuddy/Audit.hs @@ -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 diff --git a/src/Database/PlistBuddy/Command.hs b/src/Database/PlistBuddy/Command.hs new file mode 100644 --- /dev/null +++ b/src/Database/PlistBuddy/Command.hs @@ -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) + diff --git a/src/Database/PlistBuddy/Open.hs b/src/Database/PlistBuddy/Open.hs new file mode 100644 --- /dev/null +++ b/src/Database/PlistBuddy/Open.hs @@ -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 + + diff --git a/src/Database/PlistBuddy/Types.hs b/src/Database/PlistBuddy/Types.hs new file mode 100644 --- /dev/null +++ b/src/Database/PlistBuddy/Types.hs @@ -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) + diff --git a/tests/Main.hs b/tests/Main.hs new file mode 100644 --- /dev/null +++ b/tests/Main.hs @@ -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