400 lines
19 KiB
Haskell
400 lines
19 KiB
Haskell
module Handler.Sheet.PersonalisedFiles
|
|
( sinkPersonalisedSheetFiles
|
|
, getSPersonalFilesR, getCPersonalFilesR
|
|
, PersonalisedSheetFilesKeyException(..)
|
|
, sourcePersonalisedSheetFiles, resolvePersonalisedSheetFiles
|
|
, PersonalisedSheetFilesDownloadAnonymous(..)
|
|
, PersonalisedSheetFileUnresolved(..)
|
|
, _PSFUnresolved, _PSFUnresolvedCollatable, _PSFUnresolvedDirectory
|
|
) where
|
|
|
|
import Import hiding (StateT(..))
|
|
|
|
import Handler.Utils
|
|
import Handler.Sheet.PersonalisedFiles.Meta
|
|
import Handler.Sheet.PersonalisedFiles.Types
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
import qualified Data.Conduit.List as C (mapMaybeM)
|
|
import Data.Conduit.ResumableSink
|
|
|
|
import qualified Crypto.MAC.KMAC as Crypto
|
|
import qualified Data.ByteArray as BA
|
|
import qualified Data.Binary as Binary
|
|
import Crypto.Hash.Algorithms (SHAKE256)
|
|
|
|
import Data.ByteString.Lazy.Base32
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
|
|
import Language.Haskell.TH (nameBase)
|
|
|
|
import qualified Data.CryptoID.ByteString as CryptoID
|
|
import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Text as Text
|
|
import Data.List (inits, tails)
|
|
|
|
import Text.Unidecode (unidecode)
|
|
import Data.Char (isAlphaNum)
|
|
|
|
import qualified System.FilePath as FilePath (joinPath)
|
|
import System.FilePath.Glob
|
|
|
|
import Control.Monad.Trans.State.Strict (StateT, runStateT)
|
|
import qualified Control.Monad.State as State
|
|
import Control.Monad.Memo (MemoStateT, MonadMemo(..), for2)
|
|
import Utils.Memo
|
|
|
|
|
|
data PersonalisedSheetFileUnresolved a
|
|
= PSFUnresolvedDirectory a
|
|
| PSFUnresolvedCollatable Text a
|
|
| PSFUnresolved a
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
makePrisms ''PersonalisedSheetFileUnresolved
|
|
|
|
|
|
personalisedSheetFileTypes :: [SheetFileType]
|
|
personalisedSheetFileTypes = filter (/= SheetMarking) universeF
|
|
|
|
|
|
resolvePersonalisedSheetFiles
|
|
:: forall m a.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m, MonadRandom m
|
|
)
|
|
=> Lens' a FilePath
|
|
-> (a -> Bool) -- ^ @isDirectory@
|
|
-> CourseId
|
|
-> SheetId
|
|
-> ConduitT a (Either (PersonalisedSheetFileUnresolved a) (a, FileReferenceResidual PersonalisedSheetFile)) (SqlPersistT m) ()
|
|
resolvePersonalisedSheetFiles fpL isDir cid sid = do
|
|
app <- getYesod
|
|
C.mapM $ \fRef -> exceptT (return . Left . ($ fRef)) (return . Right . swap) . flip runStateT fRef $ do
|
|
let
|
|
genRefOptions :: ConduitT () (UserId, SheetFileType, FilePath) (StateT FilePath (ExceptT _ (SqlPersistT m))) ()
|
|
genRefOptions = evalMemoStateC Map.empty $
|
|
transPipe lift (yieldMany <=< State.gets $ resolvePersonalisedFilesDirectory app)
|
|
.| C.mapMaybeM (runMaybeT . filterRefOption)
|
|
where
|
|
filterRefOption :: _ -> MaybeT (MemoStateT _ _ _ (StateT FilePath (ExceptT _ (SqlPersistT m)))) (UserId, SheetFileType, FilePath)
|
|
filterRefOption (mbIdx, cID, sfType, fPath) = hoist (hoistStateCache $ lift . lift) $ do
|
|
let
|
|
getUid :: _ -> _ -> MemoStateT _ _ _ (SqlPersistT m) (Maybe UserId)
|
|
getUid mbIdx' cID' = runMaybeT $ do
|
|
cIDKey <- catchMPlus (Proxy @PersonalisedSheetFilesKeyException) . lift . lift $ getPersonalisedFilesKey cid (Just sid) mbIdx'
|
|
uid <- either (const mzero) return . (runReaderT ?? cIDKey) $ I.decrypt cID'
|
|
guardM . lift . lift $ exists [CourseParticipantUser ==. uid, CourseParticipantCourse ==. cid]
|
|
return uid
|
|
|
|
fmap (, sfType, fPath) . hoistMaybeM . lift $ for2 memo getUid mbIdx cID
|
|
|
|
mbRef <- zoom fpL . runConduit $ genRefOptions .| C.head
|
|
case mbRef of
|
|
Just (uid, sfType, fPath) -> PersonalisedSheetFileResidual sid uid sfType <$ (fpL .= fPath)
|
|
Nothing -> do
|
|
isDirectory <- State.gets isDir
|
|
fPath <- use fpL
|
|
if | isDirectory
|
|
-> lift $ throwE PSFUnresolvedDirectory
|
|
| lstPtn : _ <- Map.keys $ Map.filter (`match'` fPath) personalisedSheetFilesCollatable
|
|
-> lift . throwE $ PSFUnresolvedCollatable lstPtn
|
|
| otherwise
|
|
-> lift $ throwE PSFUnresolved
|
|
where match' = matchWith $ matchDefault { matchDotsImplicitly = True }
|
|
|
|
|
|
sinkPersonalisedSheetFiles :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadCatch m, MonadRandom m
|
|
)
|
|
=> CourseId
|
|
-> SheetId
|
|
-> Bool -- ^ Keep existing?
|
|
-> ConduitT FileReference Void (SqlPersistT m) ()
|
|
sinkPersonalisedSheetFiles cid sid keep
|
|
= resolvePersonalisedSheetFiles _fileReferenceTitle (hasn't $ _fileReferenceContent . _Just) cid sid
|
|
.| evalRWSC () Map.empty fanoutReferences >>= msgUnreferenced
|
|
where
|
|
fanoutReferences = do
|
|
C.mapM_ $ \case
|
|
Left unresolved -> tell $ Set.singleton unresolved
|
|
Right (fRef, residual) -> do
|
|
let PersonalisedSheetFileResidual{..} = residual
|
|
redResidual = (personalisedSheetFileResidualSheet, personalisedSheetFileResidualUser)
|
|
mSinks <- State.gets $ Map.lookup redResidual
|
|
let mkSinks
|
|
| Just sinks' <- mSinks
|
|
= Left sinks'
|
|
| keep
|
|
= Right $ \residual' -> newResumableSink $ sinkFileReferences residual'
|
|
| otherwise
|
|
= Right $ \residual' -> newResumableSink . void $ replaceFileReferences' mkFilter residual'
|
|
sinks = case mkSinks of
|
|
Left sinks' -> sinks'
|
|
Right mkSinks' -> Map.fromList
|
|
[ (residual', mkSinks' residual')
|
|
| sfType <- personalisedSheetFileTypes
|
|
, let residual' = PersonalisedSheetFileResidual{ personalisedSheetFileResidualType = sfType, .. }
|
|
]
|
|
sink = Map.findWithDefault (error "No sink for SheetFileType") residual sinks
|
|
sink' <- lift $ yield fRef ++$$ sink
|
|
case sink' of
|
|
Left _ -> error "sinkFileReferences/replaceFileReferences returned prematurely"
|
|
Right nSink -> State.modify . Map.insert redResidual $ Map.insert residual nSink sinks
|
|
openSinks <- State.get
|
|
lift . lift . mapM_ closeResumableSink $ openSinks ^.. folded . folded
|
|
let (nub -> sinkSheets, nub -> sinkUsers) = unzip $ Map.keys openSinks
|
|
lift . lift $ deleteWhere [ PersonalisedSheetFileSheet <-. sinkSheets
|
|
, PersonalisedSheetFileUser /<-. sinkUsers
|
|
]
|
|
|
|
msgUnreferenced ((), unreferenced) = unless (null collated && null uncollated) $
|
|
addMessageModal msgStatus msgTrigger $ Right msgWidget
|
|
where collated = Map.fromListWith (<>)
|
|
[ (ptn, Sum 1)
|
|
| PSFUnresolvedCollatable ptn _fRef <- Set.toList unreferenced
|
|
]
|
|
collatedL = Map.toList collated
|
|
uncollated = [ fileReferenceTitle | PSFUnresolved FileReference{..} <- Set.toList unreferenced ]
|
|
|
|
Sum c = Sum (fromIntegral $ length uncollated) <> fold collated
|
|
|
|
msgStatus | null uncollated = Info
|
|
| otherwise = Warning
|
|
|
|
msgTrigger = i18n $ MsgPersonalisedSheetFilesIgnored c
|
|
msgWidget = $(widgetFile "messages/personalisedSheetFilesIgnored")
|
|
|
|
mkFilter :: FileReferenceResidual PersonalisedSheetFile -> [Filter PersonalisedSheetFile]
|
|
mkFilter PersonalisedSheetFileResidual{..} = [ PersonalisedSheetFileSheet ==. personalisedSheetFileResidualSheet
|
|
, PersonalisedSheetFileUser ==. personalisedSheetFileResidualUser
|
|
, PersonalisedSheetFileType ==. personalisedSheetFileResidualType
|
|
]
|
|
|
|
sinkFileReferences :: FileReferenceResidual PersonalisedSheetFile -> ConduitT FileReference Void (SqlPersistT m) ()
|
|
sinkFileReferences residual' = C.mapM_ $ \fRef -> void . put $ _FileReference # (fRef, residual')
|
|
|
|
|
|
|
|
sourcePersonalisedSheetFiles :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadThrow m
|
|
, MonadRandom m
|
|
)
|
|
=> CourseId
|
|
-> Maybe SheetId
|
|
-> Maybe (Set UserId)
|
|
-> PersonalisedSheetFilesDownloadAnonymous
|
|
-> ConduitT () (Either PersonalisedSheetFile DBFile) (SqlPersistT m) ()
|
|
sourcePersonalisedSheetFiles cId mbsid mbuids anonMode = do
|
|
(mbIdx, cIDKey) <- lift . newPersonalisedFilesKey $ maybe (Left cId) Right mbsid
|
|
let
|
|
genSuffixes uid = case anonMode of
|
|
PersonalisedSheetFilesDownloadGroups -> do
|
|
subGroups <- E.select . E.from $ \(submissionGroup `E.InnerJoin` submissionGroupUser) -> do
|
|
E.on $ submissionGroup E.^. SubmissionGroupId E.==. submissionGroupUser E.^. SubmissionGroupUserSubmissionGroup
|
|
E.where_ $ submissionGroup E.^. SubmissionGroupCourse E.==. E.val cId
|
|
E.where_ $ submissionGroupUser E.^. SubmissionGroupUserUser E.==. E.val uid
|
|
return $ submissionGroup E.^. SubmissionGroupName
|
|
return . nub . sort $ map (filter isAlphaNum . foldMap unidecode . unpack . CI.original . E.unValue) subGroups
|
|
otherAnon
|
|
| Just f <- userFeature otherAnon -> do
|
|
features <- E.select . E.from $ \user -> do
|
|
E.where_ $ user E.^. UserId E.==. E.val uid
|
|
return $ f user
|
|
return . sort $ mapMaybe (fmap (filter isAlphaNum . foldMap unidecode . unpack) . E.unValue) features
|
|
_other -> return mempty
|
|
where userFeature PersonalisedSheetFilesDownloadSurnames
|
|
= Just $ E.just . (E.^. UserSurname)
|
|
userFeature PersonalisedSheetFilesDownloadMatriculations
|
|
= Just $ E.castString . (E.^. UserMatrikelnummer)
|
|
userFeature _
|
|
= Nothing
|
|
|
|
sqlSource = E.selectSource . E.from $ \(courseParticipant `E.LeftOuterJoin` personalisedSheetFile) -> do
|
|
E.on $ E.just (courseParticipant E.^. CourseParticipantUser) E.==. personalisedSheetFile E.?. PersonalisedSheetFileUser
|
|
E.&&. E.val mbsid E.==. personalisedSheetFile E.?. PersonalisedSheetFileSheet
|
|
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. E.val cId
|
|
case mbuids of
|
|
Just uids -> E.where_ $ courseParticipant E.^. CourseParticipantUser `E.in_` E.valList (Set.toList uids)
|
|
Nothing -> E.where_ $ courseParticipant E.^. CourseParticipantState E.==. E.val CourseParticipantActive
|
|
return (courseParticipant, personalisedSheetFile)
|
|
|
|
toRefs = awaitForever $ \(Entity _ cPart@CourseParticipant{..}, mbPFile) -> do
|
|
MsgRenderer mr <- getMsgRenderer
|
|
suffix <- do
|
|
sufCache <- uses _sufCache $ Map.lookup courseParticipantUser
|
|
case sufCache of
|
|
Just suf -> return suf
|
|
Nothing -> do
|
|
suf <- lift . lift $ genSuffixes courseParticipantUser
|
|
_sufCache %= Map.insert courseParticipantUser suf
|
|
return suf
|
|
cID <- either throwM return . (runReaderT ?? cIDKey) $ I.encrypt courseParticipantUser
|
|
let dirName = unpack . Text.intercalate "_" . map pack $ suffix `snoc` mkPersonalisedFilesDirectory mbIdx cID
|
|
unlessM (uses _dirCache $ Set.member dirName) $ do
|
|
yield $ Right File
|
|
{ fileTitle = dirName
|
|
, fileContent = Nothing
|
|
, fileModified = courseParticipantRegistration
|
|
}
|
|
forM_ [SheetExercise, SheetHint, SheetSolution] $ \sfType ->
|
|
yield $ Right File
|
|
{ fileTitle = dirName <//> unpack (mr $ SheetArchiveFileTypeDirectory sfType)
|
|
, fileContent = Nothing
|
|
, fileModified = courseParticipantRegistration
|
|
}
|
|
yieldM . fmap Right $ do
|
|
fileContent' <- lift $ formatPersonalisedSheetFilesMeta anonMode cPart cID
|
|
let fileTitle = (dirName <//>) . ensureExtension "yaml" . unpack . mr $ MsgPersonalisedSheetFilesMetaFilename cID
|
|
fileModified = courseParticipantRegistration
|
|
fileContent = Just $ C.sourceLazy fileContent'
|
|
return File{..}
|
|
_dirCache %= Set.insert dirName
|
|
whenIsJust mbPFile $ \(Entity _ pFile@PersonalisedSheetFile{..}) -> do
|
|
let dirName' = dirName <//> unpack (mr $ SheetArchiveFileTypeDirectory personalisedSheetFileType)
|
|
yield . Left $ over (_FileReference . _1 . _fileReferenceTitle) (dirName' <//>) pFile
|
|
where
|
|
_sufCache :: Lens' _ _
|
|
_sufCache = _1
|
|
_dirCache :: Lens' _ _
|
|
_dirCache = _2
|
|
|
|
|
|
sqlSource .| evalStateC (Map.empty, Set.empty) toRefs
|
|
|
|
|
|
data PersonalisedSheetFilesKeyException
|
|
= PersonalisedSheetFilesKeyCouldNotDecodeRandom
|
|
| FallbackPersonalisedSheetFilesKeysExhausted
|
|
| PersonalisedSheetFilesKeyInsufficientContext
|
|
| PersonalisedSheetFilesKeyNotFound
|
|
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
deriving anyclass (Exception)
|
|
|
|
newPersonalisedFilesKey :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadThrow m, MonadRandom m
|
|
)
|
|
=> Either CourseId SheetId -> SqlPersistT m (Maybe Word24, CryptoIDKey)
|
|
newPersonalisedFilesKey (Right shId) = cryptoIDKey $ \cIDKey -> fmap (Nothing,) $
|
|
either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict . BA.convert $
|
|
Crypto.kmac @(SHAKE256 CryptoIDCipherKeySize) (encodeUtf8 . (pack :: String -> Text) $ nameBase 'newPersonalisedFilesKey) (toStrict $ Binary.encode shId) cIDKey
|
|
newPersonalisedFilesKey (Left cId) = do
|
|
now <- liftIO getCurrentTime
|
|
secret <- CryptoID.genKey
|
|
let secret' = toStrict $ Binary.encode secret
|
|
firstN <- getRandom
|
|
|
|
let loop :: Word24 -> SqlPersistT m (Maybe Word24, CryptoIDKey)
|
|
loop n = do
|
|
didInsert <- is _Just <$> insertUnique (FallbackPersonalisedSheetFilesKey cId n secret' now)
|
|
if | didInsert
|
|
-> return (Just n, secret)
|
|
| (firstN == minBound && n == maxBound)
|
|
|| n == pred firstN
|
|
-> throwM FallbackPersonalisedSheetFilesKeysExhausted
|
|
| n == maxBound
|
|
-> loop minBound
|
|
| otherwise
|
|
-> loop $ succ n
|
|
in loop firstN
|
|
|
|
getPersonalisedFilesKey :: forall m.
|
|
( MonadHandler m
|
|
, HandlerSite m ~ UniWorX
|
|
, MonadThrow m, MonadRandom m
|
|
)
|
|
=> CourseId -> Maybe SheetId -> Maybe Word24 -> SqlPersistT m CryptoIDKey
|
|
getPersonalisedFilesKey _ Nothing Nothing = throwM PersonalisedSheetFilesKeyInsufficientContext
|
|
getPersonalisedFilesKey _ (Just shId) Nothing = view _2 <$> newPersonalisedFilesKey (Right shId)
|
|
getPersonalisedFilesKey cId _ (Just idx) = maybeT (throwM PersonalisedSheetFilesKeyNotFound) $ do
|
|
Entity _ FallbackPersonalisedSheetFilesKey{..} <- MaybeT . getBy $ UniqueFallbackPersonalisedSheetFilesKey cId idx
|
|
either (const $ throwM PersonalisedSheetFilesKeyCouldNotDecodeRandom) (views _3 return) . Binary.decodeOrFail . fromStrict $ BA.convert fallbackPersonalisedSheetFilesKeySecret
|
|
|
|
mkPersonalisedFilesDirectory :: Maybe Word24 -> CryptoFileNameUser -> FilePath
|
|
mkPersonalisedFilesDirectory Nothing cID = unpack $ toPathPiece cID
|
|
mkPersonalisedFilesDirectory (Just idx) cID = unpack $ toPathPiece cID <> "-" <> CI.foldCase (toStrict . encodeBase32Unpadded $ Binary.encode idx)
|
|
|
|
resolvePersonalisedFilesDirectory :: forall master.
|
|
RenderMessage master SheetArchiveFileTypeDirectory
|
|
=> master
|
|
-> FilePath
|
|
-> [(Maybe Word24, CryptoFileNameUser, SheetFileType, FilePath)]
|
|
resolvePersonalisedFilesDirectory foundation (splitPath -> fPath) = do
|
|
(fPath', remFPath) <- inits fPath `zip` tails fPath
|
|
guard . not $ null remFPath
|
|
(SheetArchiveFileTypeDirectory sfType, fPath'') <- foldMap (\(seg, rest) -> (, rest) <$> unRenderMessageLenient foundation (pack seg)) $ foci fPath'
|
|
guard $ sfType `elem` personalisedSheetFileTypes
|
|
let cryptSegments = foldMap (filter (not . Text.null) . Text.split (flip Set.notMember cryptChars . CI.mk) . Text.pack) fPath''
|
|
(mIdx, cryptSegments') <- foldMap (\(inp, rest) -> (, rest) . Just <$> hoistMaybe (decodeIdx inp)) (foci cryptSegments) <|> pure (Nothing, cryptSegments)
|
|
cID <- foldMap (hoistMaybe . fromPathPiece) cryptSegments'
|
|
return (mIdx, cID, sfType, FilePath.joinPath remFPath)
|
|
where
|
|
foci :: forall a. [a] -> [(a, [a])]
|
|
foci [] = []
|
|
foci (x:xs) = (x, xs) : map (over _2 (x:)) (foci xs)
|
|
|
|
cryptoIdChars, base32Chars, cryptChars :: Set (CI Char)
|
|
cryptChars = base32Chars <> cryptoIdChars
|
|
cryptoIdChars = mappend base32Chars . Set.fromList $ map CI.mk "uwb"
|
|
base32Chars = Set.fromList $ map CI.mk "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"
|
|
|
|
decodeIdx :: Text -> Maybe Word24
|
|
decodeIdx inp
|
|
| Right inp' <- decodeBase32Unpadded . fromStrict $ encodeUtf8 inp
|
|
, Right (remInp, _, idx) <- Binary.decodeOrFail inp'
|
|
, null remInp
|
|
= Just idx
|
|
| otherwise = Nothing
|
|
|
|
|
|
|
|
getPersonalFilesR :: CourseId -> Maybe SheetId -> Handler TypedContent
|
|
getPersonalFilesR cId mbsid = do
|
|
(Course{..}, mbSheet) <- runDB $ (,)
|
|
<$> get404 cId
|
|
<*> traverse get404 mbsid
|
|
|
|
cRoute <- getCurrentRoute
|
|
((anonRes, anonFormWdgt), anonEnctype) <- runFormGet . renderAForm FormStandard $
|
|
apopt (selectField optionsFinite) (fslI MsgPersonalisedSheetFilesDownloadAnonymousField & setTooltip MsgPersonalisedSheetFilesDownloadAnonymousFieldTip) (Just PersonalisedSheetFilesDownloadAnonymous)
|
|
|
|
formResult anonRes $ \anonMode -> do
|
|
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ case mbSheet of
|
|
Nothing -> MsgCoursePersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand
|
|
Just Sheet{..} -> MsgPersonalisedSheetFilesArchiveName courseTerm courseSchool courseShorthand sheetName
|
|
sendResponse <=< serveZipArchive' archiveName $ sourcePersonalisedSheetFiles cId mbsid Nothing anonMode
|
|
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
|
|
fmap toTypedContent . siteLayoutMsg MsgMenuSheetPersonalisedFiles $ do
|
|
setTitleI MsgMenuSheetPersonalisedFiles
|
|
wrapForm anonFormWdgt def
|
|
{ formMethod = GET
|
|
, formAction = SomeRoute <$> cRoute
|
|
, formEncoding = anonEnctype
|
|
, formAttrs = formAttrs def <> bool mempty [("uw-no-navigate-away-prompt", ""), ("target", "_blank")] isModal
|
|
}
|
|
|
|
getSPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler TypedContent
|
|
getSPersonalFilesR tid ssh csh shn = do
|
|
Entity shId Sheet{..} <- runDB $ fetchSheet tid ssh csh shn
|
|
getPersonalFilesR sheetCourse $ Just shId
|
|
|
|
getCPersonalFilesR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
|
getCPersonalFilesR tid ssh csh = do
|
|
cId <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
|
getPersonalFilesR cId Nothing
|