feat: pruning of unreferenced files

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 $@
+)

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"

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

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

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
 

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

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
+      ]

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 }

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

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

src/Utils/Lens.hs

@@ -210,6 +210,8 @@ makeLenses_ ''CourseNewsFile
 makeLenses_ ''AllocationCourse
 
 makeLenses_ ''Tutorial
+
+makeLenses_ ''SessionFile
   
 
 -- makeClassy_ ''Load

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