109 lines
4.8 KiB
Haskell
109 lines
4.8 KiB
Haskell
module Handler.Course.Application.Files
|
|
( getCAFilesR
|
|
, getCAppsFilesR
|
|
) where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
import System.FilePath (addExtension, (</>))
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
|
|
getCAFilesR :: TermId -> SchoolId -> CourseShorthand -> CryptoFileNameCourseApplication -> Handler TypedContent
|
|
getCAFilesR tid ssh csh cID = do
|
|
appId <- decrypt cID
|
|
User{..} <- runDB $ do
|
|
CourseApplication{..} <- get404 appId
|
|
Course{..} <- get404 courseApplicationCourse
|
|
let matches = and
|
|
[ tid == courseTerm
|
|
, ssh == courseSchool
|
|
, csh == courseShorthand
|
|
]
|
|
unless matches . redirectWith movedPermanently301 $ CApplicationR courseTerm courseSchool courseShorthand cID CAFilesR
|
|
get404 courseApplicationUser
|
|
|
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseApplicationArchiveName tid ssh csh cID userDisplayName
|
|
let
|
|
fsSource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
|
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
|
return file
|
|
|
|
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
|
|
|
|
|
getCAppsFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
|
getCAppsFilesR tid ssh csh = do
|
|
runDB . existsBy404 $ TermSchoolCourseShort tid ssh csh
|
|
MsgRenderer mr <- getMsgRenderer
|
|
|
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgCourseAllApplicationsArchiveName tid ssh csh
|
|
|
|
let
|
|
fsSource :: Source DB File
|
|
fsSource = do
|
|
apps <- lift . E.select . E.from $ \((course `E.InnerJoin` courseApplication `E.InnerJoin` user) `E.LeftOuterJoin` allocation) -> do
|
|
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
|
|
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
|
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
|
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
|
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
|
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
|
return (allocation, user, courseApplication)
|
|
apps' <- flip filterM apps $ \(_, _, Entity appId _) -> do
|
|
cID <- cachedByBinary appId $ encrypt appId
|
|
hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR
|
|
let
|
|
applicationAllocs = setOf (folded . _1) apps'
|
|
|
|
allocations = applicationAllocs ^.. folded . _Just . _entityVal . $(multifocusG 3) _allocationTerm _allocationSchool _allocationShorthand
|
|
|
|
allEqualOn :: Eq x => Getter _ x -> Bool
|
|
allEqualOn l = maybe True (\x -> allOf (folded . l) (== x) allocations) (allocations ^? _head . l)
|
|
|
|
mkAllocationDir mbAlloc
|
|
| not $ allEqualOn _1
|
|
, Just Allocation{..} <- mbAlloc
|
|
= (</>) $ unpack [st|#{CI.foldCase (termToText (unTermKey allocationTerm))}-#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
|
|
| not $ allEqualOn _2
|
|
, Just Allocation{..} <- mbAlloc
|
|
= (</>) $ unpack [st|#{CI.foldedCase (unSchoolKey allocationSchool)}-#{CI.foldedCase allocationShorthand}|]
|
|
| not $ allEqualOn _3
|
|
, Just Allocation{..} <- mbAlloc
|
|
= (</>) . unpack $ CI.foldedCase allocationShorthand
|
|
| Just Allocation{} <- mbAlloc
|
|
, not $ all (is _Just) applicationAllocs
|
|
= (</>) . unpack $ mr MsgCourseApplicationsAllocatedDirectory
|
|
| Nothing <- mbAlloc
|
|
, any (is _Just) applicationAllocs
|
|
= (</>) . unpack $ mr MsgCourseApplicationsNotAllocatedDirectory
|
|
| otherwise
|
|
= id
|
|
|
|
forM_ apps' $ \(mbAlloc, Entity _ User{..}, Entity appId CourseApplication{..}) -> do
|
|
cID <- cachedByBinary appId $ encrypt appId :: _ CryptoFileNameCourseApplication
|
|
let mkAppDir = mkAllocationDir (entityVal <$> mbAlloc) . (</>) (unpack [st|#{CI.foldedCase $ ciphertext cID}-#{CI.foldCase userSurname}|])
|
|
dirFiles = C.map $ over _fileTitle mkAppDir . entityVal
|
|
fileEntitySource = E.selectSource . E.from $ \(courseApplicationFile `E.InnerJoin` file) -> do
|
|
E.on $ courseApplicationFile E.^. CourseApplicationFileFile E.==. file E.^. FileId
|
|
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. E.val appId
|
|
return file
|
|
|
|
yield File
|
|
{ fileModified = courseApplicationTime
|
|
, fileTitle = mkAppDir ""
|
|
, fileContent = Nothing
|
|
}
|
|
|
|
fileEntitySource .| dirFiles
|
|
|
|
|
|
serveSomeFiles archiveName fsSource
|