This repository has been archived on 2024-10-24. You can view files and clone it, but cannot push or open issues or pull requests.
fradrive-old/src/Handler/Allocation/Matchings.hs

40 lines
1.5 KiB
Haskell

module Handler.Allocation.Matchings
( getAMatchingListR
, getAMLogR
) where
import Import
import Handler.Utils
import Data.ByteString.Base32
import qualified Data.ByteArray as BA
import qualified Data.CaseInsensitive as CI
getAMatchingListR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
getAMatchingListR tid ssh ash = do
(Allocation{..}, matchings) <- runDB $ do
Entity aId alloc <- getBy404 $ TermSchoolAllocationShort tid ssh ash
matchings <- selectList [ AllocationMatchingAllocation ==. aId ] [ Desc AllocationMatchingTime ]
matchings' <- forM matchings $ \(Entity matchingId m) -> (, m) <$> encrypt matchingId
return (alloc, matchings')
siteLayoutMsg (MsgHeadingAllocationMatchings allocationTerm allocationSchool allocationName) $ do
setTitleI $ MsgTitleAllocationMatchings allocationTerm allocationSchool allocationShorthand
$(widgetFile "allocation/matchings")
where
showFingerprint = CI.foldCase . encodeBase32Unpadded . BA.convert
getAMLogR :: TermId -> SchoolId -> AllocationShorthand -> CryptoUUIDAllocationMatching -> Handler TypedContent
getAMLogR tid ssh ash cID = serveOneFile $ do
matchingId <- decrypt @AllocationMatchingId cID
AllocationMatching{..} <- lift $ get404 matchingId
mr <- getMessageRender
let fileReferenceTitle = unpack . mr $ MsgAllocationMatchingLogFileName tid ssh ash cID
yield FileReference
{ fileReferenceTitle
, fileReferenceContent = Just allocationMatchingLog
, fileReferenceModified = allocationMatchingTime
}