IDynamic-0.1: Data/IResource.hs
module Data.IResource where
import System.Directory
import Control.Exception as Exception
import System.IO.Error
import Data.List(elemIndices)
import System.IO
import Control.Monad(when,replicateM)
--import Debug.Trace
--debug a b= trace b a
{- | A general interface for indexable, serializable and input-output objects.
'readResource' and 'writeResource' are implemented by default as read-write to files with its key as filename
'serialize' and 'deserialize' are specified just to allow these defaults. If you define your own persistence, then
@serialize@ and @deserialize@ are not needed. The package 'Workflow' need them anyway.
minimal definition: keyResource, serialize, deserialize
While serialize and deserialize are agnostic about the way of converison to strings, either binary or textual, treadp and
tshowp use the monad defined in the RefSerialize package. Both ways of serialization are alternative. one is defined
by default in terms of the other. the RefSerialize monad has been introduced to permit IResource objects to be
serialized as part of larger structures that embody them. This is necessary for the Workdlow package.
The keyResource string must be a unique since this is used to index it in the hash table.
when accessing a resource, the user must provide a partial object for wich the key can be obtained.
for example:
@data Person= Person{name, surname:: String, account :: Int ....)
keyResource Person n s ...= n++s@
the data being accesed must have the fields used by keyResource filled. For example
@ readResource Person {name="John", surname= "Adams"}@
leaving the rest of the fields undefined
-}
-- | IResource has defaults definitions for all the methods except keyResource
-- Either one or other serializer must be defiened for default witeResource, readResource and delResource
class IResource a where
keyResource :: a -> String -- ^ must be defined
serialize :: a -> String -- ^ must be defined by the user
deserialize :: String -> a -- ^ must be defined by the user
defPath :: a-> String -- ^ additional extension for default file paths or key prefixes
defPath _ = ""
-- get object content from the file
-- (NOTE: reads and writes can't collide, so they-- Not really needed since no write is done while read
-- must be strict, not lazy )
readResource :: a-> IO (Maybe a)
readResource x=handleJust (\e -> fromException e) handleIt $ do
s <- readFileStrict filename :: IO String
return $ Just $ deserialize s -- `debug` ("read "++ filename)
where
filename= defPath x++ keyResource x
--handleIt :: IResource a => IOError -> IO (Maybe a)
handleIt e
|isAlreadyInUseError e = readResource x -- maybe is being written. try again.
| isDoesNotExistError e = return Nothing
| isPermissionError e = error $ "readResource: no permissions for opening file: "++filename
| otherwise= error $ "readResource: " ++ show e
writeResource:: a-> IO()
writeResource x=handleJust (\e -> fromException e) (handleIt x) $ writeFile filename (serialize x) -- `debug` ("write "++filename)
where
filename= defPath x ++ keyResource x
--handleIt :: a -> IOError -> IO ()
handleIt x e
| isDoesNotExistError e=do
createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename --maybe the path does not exist
writeResource x
-- | isAlreadyInUseError e= writeResource x -- maybe is being read. try again
-- Not really needed since no write is done while read
| otherwise =do
hPutStrLn stderr $ "writeResource: " ++ show e ++ " in file: " ++ filename ++ " retrying"
writeResource x
{-
| isAlreadyExistsError e =
do
hPutStrLn stderr $ "writeResource: already exist file: " ++ filename ++ " retrying"
writeResource x
| isAlreadyInUseError e =
do
hPutStrLn stderr $ "writeResource: already in use: " ++ filename ++ " retrying"
writeResource x
| isFullError e =
do
hPutStrLn stderr $ "writeResource: file full: " ++ filename ++ " retrying"
writeResource x
| isEOFError e =
do
hPutStrLn stderr $ "writeResource: EOF in file: " ++ filename ++ " retrying"
writeResource x
| isIllegalOperation e=
do
hPutStrLn stderr $ "writeResource: illegal Operation in file: " ++ filename ++ " retrying"
writeResource x
| isPermissionError e =
do
hPutStrLn stderr $ "writeResource:permission error in file: " ++ filename ++ " retrying"
writeResource x
| isUserError e =
do
hPutStrLn stderr $ "writeResource:user error in file: " ++ filename ++ " retrying"
writeResource x
| otherwise =do
hPutStrLn stderr $ "writeResource: error " ++ show e ++ " in file: " ++ filename
writeResource x
-}
delResource:: a-> IO()
delResource x= handleJust (\e -> fromException e) (handleIt filename) $ removeFile filename --`debug` ("delete "++filename)
where
filename= defPath x ++ keyResource x
handleIt :: String -> IOError -> IO ()
handleIt file e
| isDoesNotExistError e= return ()
| isAlreadyInUseError e= delResource x
| isPermissionError e= delResource x
| otherwise = error ("delResource: " ++ show e ++ "for the file: "++ filename)
type AccessTime = Integer
type ModifTime = Integer
infinite=10000000000
-- | Resources returned by 'withSTMResources''
data Resources a b
= Retry -- ^ forces a retry
| Resources
{ toAdd :: [a] -- ^ resources to be inserted back in the cache
, toDelete :: [a] -- ^ resources to be deleted from the cache and from permanent storage
, toReturn :: b -- ^ result to be returned
}
-- | @resources= Resources [] [] ()@
resources :: Resources a ()
resources= Resources [] [] ()
-- Strict file read, needed for the default file persistence
readFileStrict f = openFile f ReadMode >>= \ h -> readIt h `finally` hClose h
where
readIt h= do
s <- hFileSize h
let n= fromIntegral s
str <- replicateM n (hGetChar h)
return str