{- |

This module provides default persistence , understood as retrievong and storing thje object in serialized blobs
for Indexable and serializable instances. The user can define it with setPersist. If the user does not
set it, persistence in files is used.


-}
{-# LANGUAGE   FlexibleInstances, UndecidableInstances
               , MultiParamTypeClasses, FunctionalDependencies
               , ExistentialQuantification
                #-}
module Data.TCache.DefaultPersistence(Indexable(..),Serializable(..),setPersist,Persist(..)) where


import Data.TCache.IResource
import Data.Typeable
import System.IO.Unsafe
import Data.IORef
import System.Directory
import Control.Monad(when,replicateM)
import System.IO
import System.IO.Error
import Control.Exception as Exception
import Control.Concurrent
import Data.List(elemIndices,isInfixOf)
import Data.Maybe(fromJust)
import Data.TCache.Defs(castErr)
import qualified Data.ByteString.Lazy.Char8 as B

import Debug.Trace

--debug a b = trace b 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.
                                -- The default value is "data/".

                                -- IMPORTANT:  defPath must depend on the datatype, not the value (must be constant). Default is "TCacheData/"
    defPath =  const "TCacheData/"

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

{- | Serialize is an abstract serialization ionterface in order to define implicit instances of IResource.
The deserialization must be as lazy as possible if deserialized objects contain DBRefs,
lazy deserialization avoid unnecesary DBRef instantiations when they are not accessed,
since DBRefs instantiations involve extra cache lookups
For this reason serialization/deserialization is to/from ordinary Strings
serialization/deserialization are not performance critical in TCache

Read, Show,  instances are implicit instances of Serializable

>    serialize  = show
>    deserialize= read
-}
class Serializable a {-serialFormat-} | a -> {-serialFormat-} where
  serialize   :: a -> B.ByteString --serialFormat
  deserialize :: {-serialFormat-} B.ByteString -> a

{-
instance (Show a, Read a)=> Serializable a where
  serialize= show
  deserialize= read
-}


-- |
data Persist = Persist{
       readByKey   ::  (String -> IO(Maybe B.ByteString)) -- ^  read
     , write       ::  (String -> B.ByteString -> IO())   -- ^  write
     , delete      ::  (String -> IO())}       -- ^  delete

defaultPersist= Persist
    {readByKey= defaultReadByKey
    ,write= defaultWrite
    ,delete= defaultDelete}


persist :: IORef  Persist
persist = unsafePerformIO $ newIORef $  defaultPersist

-- | set an alternative persistence for Indexable and Serializable objects
setPersist ::  Persist -> IO ()
setPersist p = writeIORef persist   p


instance  (Typeable a,  Indexable a, Serializable a ) => IResource a where

  keyResource = key
  writeResource s=do
      Persist _ f _ <- readIORef persist
      f (defPath s ++ key s) $ castErr $ serialize s

  readResourceByKey k= iox where
    iox= do
      Persist f _ _ <- readIORef persist
      f  file >>= return . fmap  deserialize . castErr
      where
      file= defPath x ++ k
      x= undefined `asTypeOf` (fromJust $ unsafePerformIO iox)

  delResource s= do
      Persist _ _ f <- readIORef persist
      f $ defPath s ++ key s




defaultReadByKey ::   String-> IO (Maybe B.ByteString)
defaultReadByKey k= iox
     where
     iox = handle handler $ do   
             s <-  readFileStrict  k 
             return $ Just   s                                                       -- `debug` ("read "++ filename)

 
     handler ::  IOError ->  IO (Maybe B.ByteString)
     handler  e
      | isAlreadyInUseError e = defaultReadByKey  k                         
      | isDoesNotExistError e = return Nothing
      | otherwise= if ("invalid" `isInfixOf` ioeGetErrorString e)
         then
            error $ ( "readResource: " ++ show e) ++ " defPath and/or keyResource are not suitable for a file path"
              
         else defaultReadByKey  k


defaultWrite :: String-> B.ByteString -> IO()
defaultWrite filename x= safeWrite filename  x     --`debug` ("write "++filename)
safeWrite filename str= handle  handler  $ B.writeFile filename str
     where          
     handler e-- (e :: IOError)
       | isDoesNotExistError e=do 
                  createDirectoryIfMissing True $ take (1+(last $ elemIndices '/' filename)) filename   --maybe the path does not exist
                  safeWrite filename str               

       | otherwise =do
                --phPutStrLn stderr $ "defaultWriteResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying"
                safeWrite filename str
              
defaultDelete :: String -> IO()
defaultDelete filename =do
     removeFile filename
     --print  ("delete "++filename)
     where

     handler :: String -> IOException -> IO ()
     handler file e
       | isDoesNotExistError e= return ()  --`debug` "isDoesNotExistError"
       | isAlreadyInUseError e= do
            hPutStrLn stderr $ "defaultDelResource: busy"  ++  " in file: " ++ filename ++ " retrying"
--            threadDelay 100000   --`debug`"isAlreadyInUseError"
            defaultDelete filename  
       | otherwise = do
           hPutStrLn stderr $ "defaultDelResource:  " ++ show e ++  " in file: " ++ filename ++ " retrying"
--           threadDelay 100000  --`debug` ("otherwise " ++ show e)
           defaultDelete filename




-- | Strict read from file, needed for 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 <- B.hGet h n -- replicateM n (B.hGetChar h) 
      return str