Cache.icl 2.22 KB
Newer Older
Camil Staps's avatar
Camil Staps committed
1
implementation module Util.Cache
2

3
import StdFile
4 5
from StdFunc import seqList, :: St
import StdFunctions
6
import StdList
7
import StdOrdList
8
import StdString
9
import StdTuple
10

11
import Control.Applicative
12
import Control.Monad
13 14
import Crypto.Hash.MD5
import Data.Error
Camil Staps's avatar
Camil Staps committed
15
from Data.Func import $, on, instance Functor ((->) r)
16
import Data.Functor
17
import Data.Maybe
18
import Data.Tuple
19 20 21
import System.Directory
import System.File
import System.FilePath
22
import System.Time
23
from Text import class Text(endsWith), instance Text String
24
import Text.GenJSON
25 26 27

cache_types :== [Brief, LongTerm]

28
typeToDir :: !CacheType -> FilePath
29 30 31
typeToDir LongTerm = "lt"
typeToDir Brief = "brief"

32
cache_dir :: !CacheType -> FilePath
33
cache_dir t = "." </> "cache" </> typeToDir t
34 35 36 37

cacheKey :: (a -> CacheKey) | toString a
cacheKey = md5 o toString

38
toCacheFile :: !CacheType -> a -> FilePath | toString a
39 40
toCacheFile t = (</>) (cache_dir t) o cacheKey

41
readCache :: !a !*World -> (!Maybe b, !*World) | toString a & JSONDecode{|*|} b
42 43 44 45
readCache k w
# (files,w) = seqList [appFst error2mb o readFile (toCacheFile t k) \\ t <- cache_types] w
= (join $ fromJSON <$> fromString <$> foldl (<|>) empty files, w)

46 47 48 49 50
allCacheKeys :: !CacheType !*World -> (![a], !*World) | JSONDecode{|*|} a
allCacheKeys t w
# (fps,w) = appFst (fmap (map ((</>) (cache_dir t)) o filter (endsWith ".key")))
	$ readDirectory (cache_dir t) w
| isError fps = ([], w)
51 52 53 54
# (infos,w) = appFst catMaybes $ seqList
	[appFst (fmap (tuple f) o error2mb) o getFileInfo f \\ f <- fromOk fps] w
# infos = sortByAccessTime infos
# (files,w) = seqList [appFst error2mb o readFile f \\ (f,_) <- infos] w
55
= (catMaybes $ catMaybes $ map (fmap (fromJSON o fromString)) files, w)
56 57 58 59
where
	sortByAccessTime = sortBy (on (<) (\(_,i)->i.lastAccessedTime))

instance < Tm where < a b = timeGm a < timeGm b
60

61
writeCache :: !CacheType !a !b !*World -> *World | toString, JSONEncode{|*|} a & JSONEncode{|*|} b
62 63 64 65 66 67
writeCache t k v w
# (_,w) = writeFile file (toString $ toJSON v) w
# (_,w) = writeFile (file +++ ".key") (toString $ toJSON k) w
= w
where
	file = toCacheFile t k
68 69 70 71 72

removeFromCache :: !CacheType !a -> *World -> *World | toString a
removeFromCache t k =
	snd o deleteFile (cache_dir t </> cacheKey k +++ ".key") o
	snd o deleteFile (cache_dir t </> cacheKey k)