Verified Commit fe0d3976 authored by Camil Staps's avatar Camil Staps 🚀

Resolve #142: option to reload all entries in the cache; auto-reload on container startup

parent 9c002fe2
......@@ -9,8 +9,17 @@ from Text.JSON import generic JSONEncode, generic JSONDecode, :: JSONNode
cacheKey :: (a -> CacheKey) | toString a
// Check if for the hash of the argument a JSON file exists of type b
readCache :: !a *World -> (Maybe b, !*World) | toString a & JSONDecode{|*|} b
/**
* Check if for the hash of the argument a JSON file exists of type `b`
*/
readCache :: !a !*World -> (!Maybe b, !*World) | toString a & JSONDecode{|*|} b
// Write for the hash of a a JSON file of type b
writeCache :: CacheType !a !b -> *World -> *World | toString a & JSONEncode{|*|} b
/**
* All keys of a certain type currently in the cache
*/
allCacheKeys :: !CacheType !*World -> (![a], !*World) | JSONDecode{|*|} a
/**
* Write for the hash of `a` a JSON file of type `b`
*/
writeCache :: CacheType !a !b !*World -> *World | toString, JSONEncode{|*|} a & JSONEncode{|*|} b
implementation module Cache
import StdFile
import StdFunc
import StdTuple
from Data.Func import $
import Control.Monad
import Control.Applicative
import Data.Functor
import Control.Monad
import Crypto.Hash.MD5
import Text.JSON
import Data.Error
import StdFile
import System.FilePath
import System.File
from Data.Func import $
import Data.Functor
import Data.Tuple
import System.Directory
import System.File
import System.FilePath
from Text import class Text(endsWith), instance Text String
import Text.JSON
cache_types :== [Brief, LongTerm]
typeToDir :: CacheType -> FilePath
typeToDir LongTerm = "lt"
typeToDir Brief = "brief"
cache_dir :: CacheType -> FilePath
cache_dir LongTerm = "./cache/lt"
cache_dir Brief = "./cache/brief"
cache_dir t = "." </> "cache" </> typeToDir t
cacheKey :: (a -> CacheKey) | toString a
cacheKey = md5 o toString
......@@ -26,10 +32,23 @@ cacheKey = md5 o toString
toCacheFile :: CacheType -> a -> FilePath | toString a
toCacheFile t = (</>) (cache_dir t) o cacheKey
readCache :: !a *World -> (Maybe b, !*World) | toString a & JSONDecode{|*|} b
readCache :: !a !*World -> (!Maybe b, !*World) | toString a & JSONDecode{|*|} b
readCache k w
# (files,w) = seqList [appFst error2mb o readFile (toCacheFile t k) \\ t <- cache_types] w
= (join $ fromJSON <$> fromString <$> foldl (<|>) empty files, w)
writeCache :: CacheType !a !b -> *World -> *World | toString a & JSONEncode{|*|} b
writeCache t k v = snd o writeFile (toCacheFile t k) (toString $ toJSON v)
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)
# (files,w) = seqList [appFst error2mb o readFile f \\ f <- fromOk fps] w
= (catMaybes $ catMaybes $ map (fmap (fromJSON o fromString)) files, w)
writeCache :: CacheType !a !b !*World -> *World | toString, JSONEncode{|*|} a & JSONEncode{|*|} b
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
......@@ -3,8 +3,8 @@ module CloogleServer
import StdArray
import StdBool
import StdFile
from StdFunc import o, seq
from StdMisc import abort, undef
from StdFunc import id, o, seq
from StdMisc import undef
import StdOrdList
import StdOverloaded
import StdTuple
......@@ -13,6 +13,7 @@ from TCPIP import :: IPAddress, :: Port, instance toString IPAddress
import Control.Applicative
import Control.Monad
import Data.Error
import qualified Data.Foldable as Foldable
from Data.Foldable import class Foldable, instance Foldable Maybe
from Data.Func import $
......@@ -22,7 +23,7 @@ import Data.Tuple
import System._Posix
import System.CommandLine
import System.Time
from Text import class Text(concat), instance Text String
from Text import class Text(concat), instance Text String, <+
import Text.JSON
import Cloogle
......@@ -51,6 +52,7 @@ CACHE_PREFETCH :== 5
}
derive JSONEncode Kind, Type, RequestCacheKey, TypeRestriction
derive JSONDecode Kind, Type, RequestCacheKey, TypeRestriction
instance toString RequestCacheKey
where toString rck = toString $ toJSON rck
......@@ -67,29 +69,67 @@ toRequestCacheKey r =
, c_include_apps = fromJust (r.include_apps <|> Just DEFAULT_INCLUDE_APPS)
, c_page = fromJust (r.page <|> Just 0)
}
fromRequestCacheKey :: RequestCacheKey -> Request
fromRequestCacheKey k =
{ unify = concat <$> print False <$> k.c_unify
, name = k.c_name
, className = k.c_className
, typeName = k.c_typeName
, modules = k.c_modules
, libraries = k.c_libraries
, include_builtins = Just k.c_include_builtins
, include_core = Just k.c_include_core
, include_apps = Just k.c_include_apps
, page = Just k.c_page
}
:: Options =
{ port :: Int
, help :: Bool
, reload_cache :: Bool
}
instance zero Options where zero = {port=31215, help=False, reload_cache=False}
parseOptions :: Options [String] -> MaybeErrorString Options
parseOptions opt [] = Ok opt
parseOptions opt ["-p":p:rest] = case (toInt p, p) of
(0, "0") -> Error "Cannot use port 0"
(0, p) -> Error $ "'" <+ p <+ "' is not an integer"
(p, _) -> parseOptions {Options | opt & port=p} rest
parseOptions opt ["-h":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--help":rest] = parseOptions {opt & help=True} rest
parseOptions opt ["--reload-cache":rest] = parseOptions {opt & reload_cache=True} rest
parseOptions opt [arg:_] = Error $ "Unknown option '" <+ arg <+ "'"
Start w
# (cmdline, w) = getCommandLine w
| length cmdline <> 2
= help w
# [_,port:_] = cmdline
# opts = parseOptions zero (tl cmdline)
| isError opts
# (io,w) = stdio w
# io = io <<< fromError opts <<< "\n"
# (_,w) = fclose io w
= w
# opts = fromOk opts
| opts.help = help (hd cmdline) w
# w = disableSwap w
#! (_,f,w) = fopen "types.json" FReadText w
#! (db,f) = openDb f
#! db = eval_all_nodes db
#! w = if opts.reload_cache (reloadCache db) id w
#! (_,w) = fclose f w
= serve
{ handler = handle db
, logger = Just log
, port = toInt port
, port = opts.Options.port
, connect_timeout = Just 3600000 // 1h
, keepalive_timeout = Just 5000 // 5s
} w
where
help :: *World -> *World
help w
help :: String *World -> *World
help pgm w
# (io, w) = stdio w
# io = io <<< "Usage: ./CloogleServer <port>\n"
# io = io <<< "Usage: " <<< pgm <<< " [--reload-cache] [-p <port>] [-h] [--help]\n"
= snd $ fclose io w
disableSwap :: *World -> *World
......@@ -179,6 +219,16 @@ where
\\ is` <- permutations is | is` <> is]
suggs _ _ _ = Nothing
reloadCache :: !CloogleDB !*World -> *World
reloadCache db w
# (keys,w) = allCacheKeys LongTerm w
# w = search (map fromRequestCacheKey keys) w
= w
where
search :: ![Request] !*World -> *World
search [] w = w
search [r:rs] w = search rs $ thd3 $ handle db (Just r) w
:: LogMemory =
{ mem_ip :: IPAddress
, mem_time_start :: Tm
......
......@@ -2,7 +2,7 @@ BIN:=CloogleServer builddb
DB=types.json
MAN:=builddb.1 # Others don't have --help/--version # $(addsuffix .1,$(BIN))
CLM:=clm
CLMFLAGS:=-h 250M -nr -nt\
CLMFLAGS:=-h 250M -nr -nt -nortsopts\
-I $$CLEAN_HOME/lib/ArgEnv\
-I $$CLEAN_HOME/lib/Generics\
-I $$CLEAN_HOME/lib/TCPIP\
......
#!/bin/sh
mkdir -p ./cache/lt ./cache/brief
RELOAD="--reload-cache"
while :
do
stdbuf -i0 -o0 -e0 \
./CloogleServer 31215 \
| tee -a cloogle.log
stdbuf -i0 -o0 -e0 ./CloogleServer -p 31215 $RELOAD | tee -a cloogle.log
RELOAD=""
done
#!/usr/bin/env bash
CACHE_SIZE=1000
CACHE_SIZE=2000
INTERVAL=600
CACHE_DIR=/var/cache
......
......@@ -12,9 +12,25 @@ sudo docker-compose up -d
echo "All done."
echo
read -p "Do you want to clear the caches? (y/[n]) " confirm
case "$confirm" in
y|Y ) echo "Clearing the cache..."; sudo bash -c 'rm -f cache/*/*';;
* ) echo "Not clearing the cache.";;
esac
CLEAR_CACHE=""
if [ "$1" == "--clear-cache" ]; then
CLEAR_CACHE="yes"
else if [ "$1" == "--no-clear-cache" ]; then
CLEAR_CACHE="no"
fi; fi
if [ "$CLEAR_CACHE" == "" ]; then
echo
read -p "Do you want to clear the caches? (y/[n]) " confirm
case "$confirm" in
y|Y ) CLEAR_CACHE="yes";;
* ) CLEAR_CACHE="no";;
esac
fi
if [ "$CLEAR_CACHE" == "yes" ]; then
echo "Clearing the cache..."
sudo bash -c 'rm -f cache/*/*'
else
echo "Not clearing the cache."
fi
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment