{-# LANGUAGE   FlexibleInstances, ScopedTypeVariables, DeriveDataTypeable #-}

{- | some internal definitions. To use default persistence, import
@Data.TCache.DefaultPersistence@ instead -}

module Data.TCache.Defs  where
import Data.Typeable
import Control.Concurrent.STM(TVar)

import System.IO.Unsafe
import Data.IORef
import System.Directory
import System.IO
import System.IO.Error
import Control.Exception as Exception
import Data.List(elemIndices,isInfixOf)
import Data.Maybe(fromJust, fromMaybe)

import qualified Data.ByteString.Lazy.Char8 as B

--import Debug.Trace
--(!>) = flip trace

type AccessTime = Integer
type ModifTime  = Integer


data Status a = NotRead | DoNotExist | Exist a deriving Typeable

data Elem a = Elem !a !AccessTime !ModifTime   deriving Typeable

type TPVar a =   TVar (Status(Elem a))

data DBRef a = DBRef !String  !(TPVar a)  deriving Typeable

instance  Show (DBRef a) where
  show :: DBRef a -> String
show (DBRef String
key1 TPVar a
_)= String
"DBRef \""forall a. [a] -> [a] -> [a]
++ String
key1 forall a. [a] -> [a] -> [a]
++ String
"\""

instance Eq (DBRef a) where
  DBRef String
k TPVar a
_ == :: DBRef a -> DBRef a -> Bool
== DBRef String
k' TPVar a
_ =  String
k forall a. Eq a => a -> a -> Bool
== String
k'

instance Ord (DBRef a) where
  compare :: DBRef a -> DBRef a -> Ordering
compare (DBRef String
k TPVar a
_) (DBRef String
k' TPVar a
_) = forall a. Ord a => a -> a -> Ordering
compare String
k String
k'

castErr :: (Typeable a1, Typeable a2) => a1 -> a2
castErr :: forall a1 a2. (Typeable a1, Typeable a2) => a1 -> a2
castErr a1
a= a2
r where
  r :: a2
r = forall a. a -> Maybe a -> a
fromMaybe
      (forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Type error: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf a1
a) forall a. [a] -> [a] -> [a]
++ String
" does not match " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf a2
r)
        forall a. [a] -> [a] -> [a]
++ String
"\nThis means that objects of these two types have the same key \nor the retrieved object type is not the previously stored one for the same key\n")
      (forall a b. (Typeable a, Typeable b) => a -> Maybe b
cast a1
a)


{- | Indexable is an utility class used to derive instances of IResource

Example:

@data Person= Person{ pname :: String, cars :: [DBRef Car]} deriving (Show, Read, Typeable)
data Car= Car{owner :: DBRef Person , cname:: String} deriving (Show, Read, Eq, Typeable)
@

Since Person and Car are instances of 'Read' ans 'Show', by defining the 'Indexable' instance
will implicitly define the IResource instance for file persistence:

@
instance Indexable Person where  key Person{pname=n} = \"Person \" ++ n
instance Indexable Car where key Car{cname= n} = \"Car \" ++ n
@
-}
class Indexable a where
    key :: a -> String
    defPath :: a -> String       -- ^ additional extension for default file paths.
    -- IMPORTANT:  defPath must depend on the datatype, not the value (must be constant). Default is ".tcachedata/"
    defPath =  forall a b. a -> b -> a
const String
".tcachedata/"

--instance IResource a => Indexable a where
--   key x= keyResource x


instance Indexable String where
  key :: ShowS
key= forall a. a -> a
id

instance Indexable Int where
  key :: Int -> String
key= forall a. Show a => a -> String
show

instance Indexable Integer where
  key :: Integer -> String
key= forall a. Show a => a -> String
show


instance Indexable () where
  key :: () -> String
key ()
_= String
"void"


{- | Serialize is an alternative to the IResource class for defining persistence in TCache.
The deserialization must be as lazy as possible.
serialization/deserialization are not performance critical in TCache

Read, Show,  instances are implicit instances of Serializable

>    serialize  = pack . show
>    deserialize= read . unpack

Since write and read to disk of to/from the cache are not be very frequent
The performance of serialization is not critical.
-}
class Serializable a  where
  serialize   :: a -> B.ByteString
  deserialize :: B.ByteString -> a
  deserialize = forall a. HasCallStack => String -> a
error String
"No deserialization defined for your data"
  deserialKey :: String -> B.ByteString -> a
  deserialKey String
_ = forall a. Serializable a => ByteString -> a
deserialize
  setPersist  :: a -> Maybe Persist              -- ^ `defaultPersist` if Nothing
  setPersist =  forall a b. a -> b -> a
const forall a. Maybe a
Nothing

-- |  Used by IndexQuery for index persistence(see "Data.TCache.IndexQuery".
class PersistIndex a where
   persistIndex :: a -> Maybe Persist


type Key= String
--instance (Show a, Read a)=> Serializable a where
--  serialize= show
--  deserialize= read


-- | a persist mechanism has to implement these three primitives
-- 'filePersist' is the default file persistence
data Persist = Persist{
       Persist -> String -> IO (Maybe ByteString)
readByKey   ::  Key -> IO(Maybe B.ByteString) -- ^  read by key. It must be strict
     , Persist -> String -> ByteString -> IO ()
write       ::  Key -> B.ByteString -> IO()   -- ^  write. It must be strict
     , Persist -> String -> IO ()
delete      ::  Key -> IO()}                  -- ^  delete

-- | Implements default default-persistence of objects in files with their keys as filenames
filePersist :: Persist
filePersist :: Persist
filePersist   = Persist
    {readByKey :: String -> IO (Maybe ByteString)
readByKey= String -> IO (Maybe ByteString)
defaultReadByKey
    ,write :: String -> ByteString -> IO ()
write    = String -> ByteString -> IO ()
defaultWrite
    ,delete :: String -> IO ()
delete   = String -> IO ()
defaultDelete}

defaultPersistIORef :: IORef Persist
{-# NOINLINE defaultPersistIORef #-}
defaultPersistIORef :: IORef Persist
defaultPersistIORef = forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef  Persist
filePersist

-- | Set the default persistence mechanism of all 'serializable' objects that have
-- @setPersist= const Nothing@. By default it is 'filePersist'
--
-- this statement must be the first one before any other TCache call
setDefaultPersist :: Persist -> IO ()
setDefaultPersist :: Persist -> IO ()
setDefaultPersist = forall a. IORef a -> a -> IO ()
writeIORef IORef Persist
defaultPersistIORef

{-# NOINLINE getDefaultPersist #-}
getDefaultPersist :: Persist
getDefaultPersist :: Persist
getDefaultPersist =  forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef Persist
defaultPersistIORef

getPersist :: (Serializable a, Typeable a) => a -> Persist
getPersist :: forall a. (Serializable a, Typeable a) => a -> Persist
getPersist a
x= forall a. IO a -> a
unsafePerformIO forall a b. (a -> b) -> a -> b
$ case forall a. Serializable a => a -> Maybe Persist
setPersist a
x of
     Maybe Persist
Nothing -> forall a. IORef a -> IO a
readIORef IORef Persist
defaultPersistIORef
     Just Persist
p  -> forall (m :: * -> *) a. Monad m => a -> m a
return Persist
p
  forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`Exception.catch` (\(SomeException
e:: SomeException) -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"setPersist must depend on the type, not the value of the parameter for: "
                                                         forall a. [a] -> [a] -> [a]
++  forall a. Show a => a -> String
show (forall a. Typeable a => a -> TypeRep
typeOf a
x)
                                                         forall a. [a] -> [a] -> [a]
++ String
"error was:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show SomeException
e)


defaultReadByKey ::   String-> IO (Maybe B.ByteString)
defaultReadByKey :: String -> IO (Maybe ByteString)
defaultReadByKey String
k= IO (Maybe ByteString)
iox   -- !> "defaultReadByKey"
     where
     iox :: IO (Maybe ByteString)
iox = forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle IOException -> IO (Maybe ByteString)
handler forall a b. (a -> b) -> a -> b
$ do
             ByteString
s <-  String -> IO ByteString
readFileStrict  String
k
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just   ByteString
s                                                       -- `debug` ("read "++ filename)


     handler ::  IOError ->  IO (Maybe B.ByteString)
     handler :: IOException -> IO (Maybe ByteString)
handler  IOException
e
      | IOException -> Bool
isAlreadyInUseError IOException
e = String -> IO (Maybe ByteString)
defaultReadByKey  String
k
      | IOException -> Bool
isDoesNotExistError IOException
e = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
      | Bool
otherwise= if String
"invalid" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` IOException -> String
ioeGetErrorString IOException
e
         then
            forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$  String
"defaultReadByKey: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
e forall a. [a] -> [a] -> [a]
++ String
" defPath and/or keyResource are not suitable for a file path:\n"forall a. [a] -> [a] -> [a]
++ String
kforall a. [a] -> [a] -> [a]
++String
"\""

         else String -> IO (Maybe ByteString)
defaultReadByKey  String
k


defaultWrite :: String-> B.ByteString -> IO()
defaultWrite :: String -> ByteString -> IO ()
defaultWrite = String -> ByteString -> IO ()
safeWrite

safeWrite :: FilePath -> B.ByteString -> IO ()
safeWrite :: String -> ByteString -> IO ()
safeWrite String
filename ByteString
str= forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle  IOException -> IO ()
handler  forall a b. (a -> b) -> a -> b
$ String -> ByteString -> IO ()
B.writeFile String
filename ByteString
str   -- !> ("write "++filename)
     where
     handler :: IOException -> IO ()
handler IOException
e-- (e :: IOError)
       | IOException -> Bool
isDoesNotExistError IOException
e=do
                  Bool -> String -> IO ()
createDirectoryIfMissing Bool
True forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (Int
1 forall a. Num a => a -> a -> a
+ forall a. [a] -> a
last (forall a. Eq a => a -> [a] -> [Int]
elemIndices Char
'/' String
filename)) String
filename   --maybe the path does not exist
                  String -> ByteString -> IO ()
safeWrite String
filename ByteString
str


       | Bool
otherwise= if String
"invalid" forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf` IOException -> String
ioeGetErrorString IOException
e
             then
                forall a. HasCallStack => String -> a
error  forall a b. (a -> b) -> a -> b
$ String
"defaultWriteResource: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
e forall a. [a] -> [a] -> [a]
++ String
" defPath and/or keyResource are not suitable for a file path: "forall a. [a] -> [a] -> [a]
++ String
filename
             else do
                Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"defaultWriteResource:  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
e forall a. [a] -> [a] -> [a]
++  String
" in file: " forall a. [a] -> [a] -> [a]
++ String
filename forall a. [a] -> [a] -> [a]
++ String
" retrying"
                String -> ByteString -> IO ()
safeWrite String
filename ByteString
str

defaultDelete :: String -> IO()
defaultDelete :: String -> IO ()
defaultDelete String
filename =
     forall e a. Exception e => (e -> IO a) -> IO a -> IO a
handle (String -> IOException -> IO ()
handler String
filename) forall a b. (a -> b) -> a -> b
$ String -> IO ()
removeFile String
filename

     where

     handler :: String -> IOException -> IO ()
     handler :: String -> IOException -> IO ()
handler String
_ IOException
e
       | IOException -> Bool
isDoesNotExistError IOException
e= forall (m :: * -> *) a. Monad m => a -> m a
return ()  --`debug` "isDoesNotExistError"
       | IOException -> Bool
isAlreadyInUseError IOException
e= do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"defaultDelResource: busy"  forall a. [a] -> [a] -> [a]
++  String
" in file: " forall a. [a] -> [a] -> [a]
++ String
filename forall a. [a] -> [a] -> [a]
++ String
" retrying"
--            threadDelay 100000   --`debug`"isAlreadyInUseError"
            String -> IO ()
defaultDelete String
filename
       | Bool
otherwise = do
            Handle -> String -> IO ()
hPutStrLn Handle
stderr forall a b. (a -> b) -> a -> b
$ String
"defaultDelResource:  " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show IOException
e forall a. [a] -> [a] -> [a]
++  String
" in file: " forall a. [a] -> [a] -> [a]
++ String
filename forall a. [a] -> [a] -> [a]
++ String
" retrying"
--           threadDelay 100000     --`debug` ("otherwise " ++ show e)
            String -> IO ()
defaultDelete String
filename



defReadResourceByKey :: (Indexable a, Serializable a, Typeable a) => String -> IO (Maybe a)
defReadResourceByKey :: forall a.
(Indexable a, Serializable a, Typeable a) =>
String -> IO (Maybe a)
defReadResourceByKey String
k= IO (Maybe a)
iox where
    iox :: IO (Maybe a)
iox= do
      let Persist String -> IO (Maybe ByteString)
f String -> ByteString -> IO ()
_ String -> IO ()
_ = forall a. (Serializable a, Typeable a) => a -> Persist
getPersist  a
x
      String -> IO (Maybe ByteString)
f  String
file forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>=  forall a. a -> IO a
evaluate forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap  (forall a. Serializable a => String -> ByteString -> a
deserialKey String
k)
      where
      file :: String
file= forall a. Indexable a => a -> String
defPath a
x forall a. [a] -> [a] -> [a]
++ String
k
      x :: a
x= forall a. HasCallStack => a
undefined forall a. a -> a -> a
`asTypeOf` forall a. HasCallStack => Maybe a -> a
fromJust (forall a. IO a -> a
unsafePerformIO IO (Maybe a)
iox)

defWriteResource :: (Indexable a, Serializable a, Typeable a) => a -> IO ()
defWriteResource :: forall a. (Indexable a, Serializable a, Typeable a) => a -> IO ()
defWriteResource a
s= do
      let Persist String -> IO (Maybe ByteString)
_ String -> ByteString -> IO ()
f String -> IO ()
_ = forall a. (Serializable a, Typeable a) => a -> Persist
getPersist  a
s
      String -> ByteString -> IO ()
f (forall a. Indexable a => a -> String
defPath a
s forall a. [a] -> [a] -> [a]
++ forall a. Indexable a => a -> String
key a
s) forall a b. (a -> b) -> a -> b
$ forall a. Serializable a => a -> ByteString
serialize a
s

defDelResource :: (Indexable a, Serializable a, Typeable a) => a -> IO ()
defDelResource :: forall a. (Indexable a, Serializable a, Typeable a) => a -> IO ()
defDelResource a
s= do
      let Persist String -> IO (Maybe ByteString)
_ String -> ByteString -> IO ()
_ String -> IO ()
f = forall a. (Serializable a, Typeable a) => a -> Persist
getPersist a
s
      String -> IO ()
f forall a b. (a -> b) -> a -> b
$ forall a. Indexable a => a -> String
defPath a
s forall a. [a] -> [a] -> [a]
++ forall a. Indexable a => a -> String
key a
s


-- | Strict read from file, needed for default file persistence
readFileStrict :: FilePath -> IO B.ByteString
readFileStrict :: String -> IO ByteString
readFileStrict String
f = String -> IOMode -> IO Handle
openFile String
f IOMode
ReadMode forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ Handle
h -> Handle -> IO ByteString
readIt Handle
h forall a b. IO a -> IO b -> IO a
`finally` Handle -> IO ()
hClose Handle
h
  where
  readIt :: Handle -> IO ByteString
readIt Handle
h= do
      Integer
s   <- Handle -> IO Integer
hFileSize Handle
h
      let n :: Int
n= forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
s
      Handle -> Int -> IO ByteString
B.hGet Handle
h Int
n