83 lines
3.4 KiB
Haskell
83 lines
3.4 KiB
Haskell
module Handler.Allocation.Prios
|
|
( getAPriosR, postAPriosR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
import Handler.Utils.Csv
|
|
import Handler.Utils.Allocation
|
|
|
|
import qualified Database.Esqueleto as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.Conduit.List as C
|
|
|
|
import qualified Data.Csv as Csv
|
|
|
|
|
|
data AllocationPrioritiesMode
|
|
= AllocationPrioritiesNumeric
|
|
| AllocationPrioritiesOrdinal
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe AllocationPrioritiesMode
|
|
instance Finite AllocationPrioritiesMode
|
|
|
|
nullaryPathPiece ''AllocationPrioritiesMode $ camelToPathPiece' 2
|
|
|
|
embedRenderMessage ''UniWorX ''AllocationPrioritiesMode id
|
|
|
|
|
|
getAPriosR, postAPriosR :: TermId -> SchoolId -> AllocationShorthand -> Handler Html
|
|
getAPriosR = postAPriosR
|
|
postAPriosR tid ssh ash = do
|
|
doNumericPrios <- runDB $ do
|
|
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
|
|
numericPrios <- E.selectCountRows . E.from $ \allocationUser -> do
|
|
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
|
|
E.where_ . E.maybe E.false sqlAllocationPriorityNumeric $ allocationUser E.^. AllocationUserPriority
|
|
|
|
ordinalPrios <- E.selectCountRows . E.from $ \allocationUser -> do
|
|
E.where_ $ allocationUser E.^. AllocationUserAllocation E.==. E.val aId
|
|
E.where_ . E.maybe E.false (E.not_ . sqlAllocationPriorityNumeric) $ allocationUser E.^. AllocationUserPriority
|
|
let doNumericPrios = ((>=) :: Int64 -> Int64 -> Bool) numericPrios ordinalPrios
|
|
|
|
return doNumericPrios
|
|
|
|
let explainAllocationPrioMode = \case
|
|
AllocationPrioritiesNumeric -> return $(i18nWidgetFile "allocation-priority-explanation/numeric")
|
|
AllocationPrioritiesOrdinal -> return $(i18nWidgetFile "allocation-priority-explanation/ordinal")
|
|
|
|
((priosRes, priosView), priosEnctype) <- runFormPost . renderAForm FormStandard $ (,)
|
|
<$> apopt (explainedSelectionField Nothing (explainOptionList optionsFinite explainAllocationPrioMode)) (fslI MsgAllocationPrioritiesMode) (Just $ bool AllocationPrioritiesOrdinal AllocationPrioritiesNumeric doNumericPrios)
|
|
<*> areq fileField (fslI MsgAllocationPrioritiesFile) Nothing
|
|
|
|
formResult priosRes $ \(mode, fInfo) -> do
|
|
let sourcePrios = case mode of
|
|
AllocationPrioritiesNumeric -> fileSourceCsvPositional Csv.NoHeader fInfo
|
|
AllocationPrioritiesOrdinal -> fileSourceCsvPositional Csv.NoHeader fInfo .| C.map Csv.fromOnly .| ordinalPriorities
|
|
|
|
(matrSunk, matrMissing) <- runDB $ do
|
|
Entity aId _ <- getBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
updateWhere
|
|
[ AllocationUserAllocation ==. aId ]
|
|
[ AllocationUserPriority =. Nothing ]
|
|
matrSunk <- runConduit $ sourcePrios .| sinkAllocationPriorities aId
|
|
matrMissing <- fromIntegral <$> count [ AllocationUserAllocation ==. aId, AllocationUserPriority ==. Nothing ]
|
|
return (matrSunk, matrMissing)
|
|
|
|
when (matrSunk > 0) $
|
|
addMessageI Success $ MsgAllocationPrioritiesSunk matrSunk
|
|
when (matrMissing > 0) $
|
|
addMessageI Error $ MsgAllocationPrioritiesMissing matrMissing
|
|
redirect $ AllocationR tid ssh ash AUsersR
|
|
|
|
siteLayoutMsg MsgMenuAllocationPriorities $ do
|
|
setTitleI $ MsgAllocationPrioritiesTitle tid ssh ash
|
|
|
|
wrapForm priosView def
|
|
{ formEncoding = priosEnctype
|
|
, formAction = Just . SomeRoute $ AllocationR tid ssh ash APriosR
|
|
}
|