diff --git a/clean.sh b/clean.sh index 02487e8b2..d63a4deab 100755 --- a/clean.sh +++ b/clean.sh @@ -4,39 +4,39 @@ set -e [ "${FLOCKER}" != "$0" ] && exec env FLOCKER="$0" flock -en .stack-work.lock "$0" "$@" || : -case $1 in - "") - exec -- stack clean - ;; - *) - target=".stack-work-${1}" - shift +if [[ -n "${1}" ]]; then + target=".stack-work-${1}" +else + target=".stack-work" +fi +shift - if [[ ! -d "${target}" ]]; then - printf "%s does not exist or is no directory\n" "${target}" >&2 - exit 1 - fi - if [[ -e .stack-work-clean ]]; then - printf ".stack-work-clean exists\n" >&2 - exit 1 - fi +if [[ ! -d "${target}" ]]; then + printf "%s does not exist or is no directory\n" "${target}" >&2 + exit 1 +fi - move-back() { - if [[ -d .stack-work ]]; then - mv -v .stack-work "${target}" - else - mkdir -v "${target}" - fi - [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work - } +if [[ "${target}" != ".stack-work" ]]; then + if [[ -e .stack-work-clean ]]; then + printf ".stack-work-clean exists\n" >&2 + exit 1 + fi - mv -v .stack-work .stack-work-clean - mv -v "${target}" .stack-work - trap move-back EXIT + move-back() { + if [[ -d .stack-work ]]; then + mv -v .stack-work "${target}" + else + mkdir -v "${target}" + fi + [[ -d .stack-work-clean ]] && mv -v .stack-work-clean .stack-work + } - ( - set -ex - stack clean $@ - ) - ;; -esac + mv -v .stack-work .stack-work-clean + mv -v "${target}" .stack-work + trap move-back EXIT +fi + +( + set -ex + stack clean $@ +) diff --git a/config/settings.yml b/config/settings.yml index 63d2fcd88..df21d993c 100644 --- a/config/settings.yml +++ b/config/settings.yml @@ -30,6 +30,8 @@ session-timeout: 7200 jwt-expiration: 604800 jwt-encoding: HS256 maximum-content-length: "_env:MAX_UPLOAD_SIZE:134217728" +session-files-expire: 3600 +prune-unreferenced-files: 86400 health-check-interval: matching-cluster-config: "_env:HEALTHCHECK_INTERVAL_MATCHING_CLUSTER_CONFIG:600" http-reachable: "_env:HEALTHCHECK_INTERVAL_HTTP_REACHABLE:600" diff --git a/models/files.model b/models/files.model index f96745687..2ea0569ef 100644 --- a/models/files.model +++ b/models/files.model @@ -6,3 +6,9 @@ File content ByteString Maybe -- Nothing iff this is a directory modified UTCTime deriving Show Eq Generic + +SessionFile + user UserId + reference SessionFileReference + file FileId + touched UTCTime \ No newline at end of file diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs index eeef7957f..13d03d064 100644 --- a/src/Import/NoModel.hs +++ b/src/Import/NoModel.hs @@ -153,6 +153,8 @@ import Colonnade.Instances as Import () import Data.Bool.Instances as Import () import Data.Encoding.Instances as Import () +import Crypto.Hash as Import (Digest, SHA3_256) + import Control.Lens as Import hiding ( (<.>) , universe diff --git a/src/Jobs.hs b/src/Jobs.hs index 526af3b6f..98ebf0209 100644 --- a/src/Jobs.hs +++ b/src/Jobs.hs @@ -71,6 +71,7 @@ import Jobs.Handler.TransactionLog import Jobs.Handler.SynchroniseLdap import Jobs.Handler.PruneInvitations import Jobs.Handler.ChangeUserDisplayEmail +import Jobs.Handler.PruneFiles import Jobs.HealthReport diff --git a/src/Jobs/Crontab.hs b/src/Jobs/Crontab.hs index 7c0a9cf0c..29d8e0bf8 100644 --- a/src/Jobs/Crontab.hs +++ b/src/Jobs/Crontab.hs @@ -49,6 +49,15 @@ determineCrontab = execWriterT $ do , cronRateLimit = appJobCronInterval , cronNotAfter = Right CronNotScheduled } + whenIsJust appPruneUnreferencedFiles $ \pInterval -> + tell $ HashMap.singleton + (JobCtlQueue JobPruneUnreferencedFiles) + Cron + { cronInitial = CronAsap + , cronRepeat = CronRepeatScheduled CronAsap + , cronRateLimit = pInterval + , cronNotAfter = Right CronNotScheduled + } oldestInvitationMUTC <- lift $ preview (_head . _entityVal . _invitationExpiresAt . _Just) <$> selectList [InvitationExpiresAt !=. Nothing] [Asc InvitationExpiresAt, LimitTo 1] whenIsJust oldestInvitationMUTC $ \oldestInvUTC -> tell $ HashMap.singleton @@ -60,6 +69,16 @@ determineCrontab = execWriterT $ do , cronNotAfter = Right CronNotScheduled } + oldestSessionFile <- lift $ preview (_head . _entityVal . _sessionFileTouched) <$> selectList [] [Asc SessionFileTouched, LimitTo 1] + whenIsJust oldestSessionFile $ \oldest -> tell $ HashMap.singleton + (JobCtlQueue JobPruneSessionFiles) + Cron + { cronInitial = CronTimestamp . utcToLocalTime $ addUTCTime appSessionFilesExpire oldest + , cronRepeat = CronRepeatOnChange + , cronRateLimit = appSessionFilesExpire / 2 + , cronNotAfter = Right CronNotScheduled + } + tell . flip foldMap universeF $ \kind -> case appHealthCheckInterval kind of Just int -> HashMap.singleton diff --git a/src/Jobs/Handler/PruneFiles.hs b/src/Jobs/Handler/PruneFiles.hs new file mode 100644 index 000000000..43289dab6 --- /dev/null +++ b/src/Jobs/Handler/PruneFiles.hs @@ -0,0 +1,38 @@ +module Jobs.Handler.PruneFiles + ( dispatchJobPruneSessionFiles + , dispatchJobPruneUnreferencedFiles + ) where + +import Import hiding (matching) + +import Database.Persist.Sql (deleteWhereCount) + +import qualified Database.Esqueleto as E +import qualified Database.Esqueleto.Utils as E + + +dispatchJobPruneSessionFiles :: Handler () +dispatchJobPruneSessionFiles = do + now <- liftIO getCurrentTime + expires <- getsYesod $ view _appSessionFilesExpire + n <- runDB $ deleteWhereCount [ SessionFileTouched <. addUTCTime (- expires) now ] + $logInfoS "PruneSessionFiles" [st|Deleted #{n} expired session files|] + + +dispatchJobPruneUnreferencedFiles :: Handler () +dispatchJobPruneUnreferencedFiles = do + n <- runDB . E.deleteCount . E.from $ \file -> + E.where_ . E.not_ . E.any E.exists $ references file + $logInfoS "PruneUnreferencedFiles" [st|Deleted #{n} unreferenced files|] + where + references :: E.SqlExpr (Entity File) -> [E.SqlQuery ()] + references ((E.^. FileId) -> fId) = + [ E.from $ \matching -> E.where_ $ matching E.^. AllocationMatchingLog E.==. fId + , E.from $ \appInstr -> E.where_ $ appInstr E.^. CourseAppInstructionFileFile E.==. fId + , E.from $ \appFile -> E.where_ $ appFile E.^. CourseApplicationFileFile E.==. fId + , E.from $ \matFile -> E.where_ $ matFile E.^. MaterialFileFile E.==. fId + , E.from $ \newsFile -> E.where_ $ newsFile E.^. CourseNewsFileFile E.==. fId + , E.from $ \sessFile -> E.where_ $ sessFile E.^. SessionFileFile E.==. fId + , E.from $ \sheetFile -> E.where_ $ sheetFile E.^. SheetFileFile E.==. fId + , E.from $ \subFile -> E.where_ $ subFile E.^. SubmissionFileFile E.==. fId + ] diff --git a/src/Jobs/Types.hs b/src/Jobs/Types.hs index f1768c69c..058aa0219 100644 --- a/src/Jobs/Types.hs +++ b/src/Jobs/Types.hs @@ -67,6 +67,8 @@ data Job = JobSendNotification { jRecipient :: UserId, jNotification :: Notifica | JobChangeUserDisplayEmail { jUser :: UserId , jDisplayEmail :: UserEmail } + | JobPruneSessionFiles + | JobPruneUnreferencedFiles deriving (Eq, Ord, Show, Read, Generic, Typeable) data Notification = NotificationSubmissionRated { nSubmission :: SubmissionId } | NotificationSheetActive { nSheet :: SheetId } diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs index 50048eb42..33685c89b 100644 --- a/src/Model/Types/Common.hs +++ b/src/Model/Types/Common.hs @@ -51,3 +51,5 @@ type InstanceId = UUID type ClusterId = UUID type TokenId = UUID type TermCandidateIncidence = UUID + +type SessionFileReference = Digest SHA3_256 diff --git a/src/Settings.hs b/src/Settings.hs index aeae40ff2..a8103c531 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -126,6 +126,9 @@ data AppSettings = AppSettings , appSynchroniseLdapUsersWithin :: Maybe NominalDiffTime , appSynchroniseLdapUsersInterval :: NominalDiffTime + , appSessionFilesExpire :: NominalDiffTime + , appPruneUnreferencedFiles :: Maybe NominalDiffTime + , appInitialLogSettings :: LogSettings , appTransactionLogIPRetentionTime :: NominalDiffTime @@ -417,6 +420,9 @@ instance FromJSON AppSettings where appSynchroniseLdapUsersWithin <- o .:? "synchronise-ldap-users-within" appSynchroniseLdapUsersInterval <- o .: "synchronise-ldap-users-interval" + appSessionFilesExpire <- o .: "session-files-expire" + appPruneUnreferencedFiles <- o .:? "prune-unreferenced-files" + appMaximumContentLength <- o .: "maximum-content-length" appReloadTemplates <- o .:? "reload-templates" .!= defaultDev diff --git a/src/Utils/Lens.hs b/src/Utils/Lens.hs index 4ed056e10..688c3f9eb 100644 --- a/src/Utils/Lens.hs +++ b/src/Utils/Lens.hs @@ -210,6 +210,8 @@ makeLenses_ ''CourseNewsFile makeLenses_ ''AllocationCourse makeLenses_ ''Tutorial + +makeLenses_ ''SessionFile -- makeClassy_ ''Load diff --git a/test/Database.hs b/test/Database.hs index f4b136512..dfe4769a0 100755 --- a/test/Database.hs +++ b/test/Database.hs @@ -802,3 +802,5 @@ fillDb = do } insert_ $ AllocationCourse funAlloc pmo 100 insert_ $ AllocationCourse funAlloc ffp 2 + + void $ insertFile "H10-2.hs" -- unreferenced