183 lines
10 KiB
Haskell
183 lines
10 KiB
Haskell
module Handler.Allocation.Form
|
|
( AllocationForm(..)
|
|
, allocationForm
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
import qualified Data.Set as Set
|
|
|
|
import qualified Control.Monad.State.Class as State
|
|
|
|
import qualified Data.CaseInsensitive as CI
|
|
import qualified Data.Text as Text
|
|
|
|
|
|
data AllocationForm = AllocationForm
|
|
{ afTerm :: TermId
|
|
, afSchool :: SchoolId
|
|
, afShorthand :: AllocationShorthand
|
|
, afName :: AllocationName
|
|
, afLegacyShorthands :: Set AllocationShorthand
|
|
, afDescription, afStaffDescription :: Maybe StoredMarkup
|
|
, afStaffRegisterFrom, afStaffRegisterTo
|
|
, afRegisterFrom, afRegisterTo
|
|
, afStaffAllocationFrom, afStaffAllocationTo
|
|
, afRegisterByStaffFrom, afRegisterByStaffTo
|
|
, afRegisterByCourse, afOverrideDeregister :: Maybe UTCTime
|
|
} deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
|
|
|
|
|
allocationForm :: Maybe AllocationForm
|
|
-> AForm (YesodDB UniWorX) AllocationForm
|
|
allocationForm mTemplate = validateAForm validateAllocationForm . wFormToAForm $ do
|
|
mayEditTerms <- lift . lift $ hasWriteAccessTo TermEditR
|
|
now <- liftIO getCurrentTime
|
|
muid <- maybeAuthId
|
|
termOptions <-
|
|
let termQuery :: E.SqlQuery (E.SqlExpr (E.Value TermId))
|
|
termQuery = E.from $ \t -> do
|
|
unless mayEditTerms $
|
|
E.where_ $ E.just (t E.^. TermId) E.==. E.val (afTerm <$> mTemplate)
|
|
E.||. termIsActiveE (E.val now) (E.val muid) (t E.^. TermId)
|
|
E.orderBy [E.desc $ t E.^. TermStart]
|
|
return $ t E.^. TermId
|
|
in lift . lift $ mkOptionsE
|
|
termQuery
|
|
(return . toPathPiece . E.unValue)
|
|
(return . ShortTermIdentifier . unTermKey . E.unValue)
|
|
(return . E.unValue)
|
|
|
|
schoolOptions <-
|
|
let schoolQuery :: E.SqlQuery (E.SqlExpr (Entity School))
|
|
schoolQuery = E.from $ \s -> do
|
|
E.where_ $ E.exists (E.from $ \userFunction -> do
|
|
E.where_ $ userFunction E.^. UserFunctionSchool E.==. s E.^. SchoolId
|
|
E.&&. E.just (userFunction E.^. UserFunctionUser) E.==. E.val muid
|
|
E.&&. userFunction E.^. UserFunctionFunction `E.in_` E.valList [SchoolAdmin, SchoolAllocation]
|
|
)
|
|
E.||. E.just (s E.^. SchoolId) E.==. E.val (afSchool <$> mTemplate)
|
|
E.orderBy [E.asc $ s E.^. SchoolShorthand]
|
|
return s
|
|
in lift . lift $ mkOptionsE
|
|
schoolQuery
|
|
(return . toPathPiece . entityKey)
|
|
(return . schoolName . entityVal)
|
|
(return . entityKey)
|
|
|
|
template <- maybe (lift . lift $ suggestAllocationForm termOptions schoolOptions) (return . Just) mTemplate
|
|
|
|
let cfCommaSeparatedSet :: forall m. Functor m => Field m Text -> Field m (Set (CI Text))
|
|
cfCommaSeparatedSet = guardField (not . Set.null) . convertField (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip) . Text.splitOn ",") (Text.intercalate ", " . map CI.original . Set.toList)
|
|
|
|
aFormToWForm . hoistAForm liftHandler $ AllocationForm
|
|
<$> areq (selectField $ return termOptions) (fslI MsgAllocationFormTerm) (afTerm <$> template)
|
|
<*> areq (selectField $ return schoolOptions) (fslI MsgAllocationFormSchool) (afSchool <$> template)
|
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormShorthand) (afShorthand <$> template)
|
|
<*> areq (textField & cfStrip & cfCI) (fslI MsgAllocationFormName) (afName <$> template)
|
|
<*> (fromMaybe Set.empty <$> aopt (textField & cfCommaSeparatedSet) (fslI MsgAllocationFormLegacyShorthands & setTooltip MsgAllocationFormLegacyShorthandsTip) (fmap Just $ afLegacyShorthands <$> template))
|
|
<* aformSection MsgAllocationFormDescriptions
|
|
<*> aopt htmlField (fslI MsgAllocationFormDescription & setTooltip MsgAllocationFormDescriptionTip) (afDescription <$> template)
|
|
<*> aopt htmlField (fslI MsgAllocationFormStaffDescription & setTooltip MsgAllocationFormStaffDescriptionTip) (afStaffDescription <$> template)
|
|
<* aformSection MsgAllocationFormDeadlines
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormStaffRegisterFrom & setTooltip MsgAllocationFormStaffRegisterFromTip) (afStaffRegisterFrom <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormStaffRegisterTo & setTooltip MsgAllocationFormStaffRegisterToTip) (afStaffRegisterTo <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormRegisterFrom & setTooltip MsgAllocationFormRegisterFromTip) (afRegisterFrom <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormRegisterTo & setTooltip MsgAllocationFormRegisterToTip) (afRegisterTo <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormStaffAllocationFrom & setTooltip MsgAllocationFormStaffAllocationFromTip) (afStaffAllocationFrom <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormStaffAllocationTo & setTooltip MsgAllocationFormStaffAllocationToTip) (afStaffAllocationTo <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormRegisterByStaffFrom & setTooltip MsgAllocationFormRegisterByStaffFromTip) (afRegisterByStaffFrom <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormRegisterByStaffTo & setTooltip MsgAllocationFormRegisterByStaffToTip) (afRegisterByStaffTo <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormRegisterByCourse & setTooltip MsgAllocationFormRegisterByCourseTip) (afRegisterByCourse <$> template)
|
|
<*> aopt utcTimeField (fslI MsgAllocationFormOverrideDeregister & setTooltip MsgAllocationFormOverrideDeregisterTip) (afOverrideDeregister <$> template)
|
|
|
|
validateAllocationForm :: FormValidator AllocationForm (YesodDB UniWorX) ()
|
|
validateAllocationForm = do
|
|
State.modify $ \af -> af { afLegacyShorthands = Set.delete (afShorthand af) $ afLegacyShorthands af }
|
|
|
|
AllocationForm{..} <- State.get
|
|
|
|
guardValidation MsgAllocationFormStaffRegisterToMustBeAfterFrom
|
|
$ NTop afStaffRegisterFrom <= NTop afStaffRegisterTo
|
|
guardValidation MsgAllocationFormStaffAllocationToMustBeAfterFrom
|
|
$ NTop afStaffAllocationFrom <= NTop afStaffAllocationTo
|
|
guardValidation MsgAllocationFormRegisterToMustBeAfterFrom
|
|
$ NTop afRegisterFrom <= NTop afRegisterTo
|
|
guardValidation MsgAllocationFormRegisterByStaffToMustBeAfterFrom
|
|
$ NTop afRegisterByStaffFrom <= NTop afRegisterByStaffTo
|
|
|
|
guardValidation MsgAllocationFormStaffRegisterFromMustBeBeforeStaffAllocationFrom
|
|
$ NTop afStaffRegisterFrom <= NTop afStaffAllocationFrom
|
|
guardValidation MsgAllocationFormStaffRegisterToMustBeBeforeStaffAllocationTo
|
|
$ NTop afStaffRegisterTo <= NTop afStaffAllocationTo
|
|
|
|
guardValidation MsgAllocationFormStaffRegisterFromMustBeBeforeRegisterFrom
|
|
$ NTop afStaffRegisterFrom <= NTop afRegisterFrom
|
|
guardValidation MsgAllocationFormStaffRegisterToMustBeBeforeRegisterTo
|
|
$ NTop afStaffRegisterTo <= NTop afRegisterTo
|
|
|
|
warnValidation MsgAllocationFormStaffAllocationToShouldBeBeforeRegisterByStaffFrom
|
|
$ NTop afStaffAllocationTo <= NTop afRegisterByStaffFrom
|
|
warnValidation MsgAllocationFormStaffAllocationToShouldBeBeforeRegisterByCourse
|
|
$ NTop afStaffAllocationTo <= NTop afRegisterByCourse
|
|
warnValidation MsgAllocationFormStaffAllocationToShouldBeAfterRegisterTo
|
|
$ NTop afStaffAllocationTo >= NTop afRegisterTo
|
|
|
|
warnValidation MsgAllocationFormRegisterToShouldBeBeforeRegisterByStaffFrom
|
|
$ NTop afRegisterTo <= NTop afRegisterByStaffFrom
|
|
warnValidation MsgAllocationFormRegisterToShouldBeBeforeRegisterByCourse
|
|
$ NTop afRegisterTo <= NTop afRegisterByCourse
|
|
|
|
warnValidation MsgAllocationFormRegisterByStaffFromShouldBeBeforeRegisterByCourse
|
|
$ NTop afRegisterByStaffFrom <= NTop afRegisterByCourse
|
|
|
|
suggestAllocationForm :: OptionList TermId -> OptionList SchoolId
|
|
-> DB (Maybe AllocationForm)
|
|
suggestAllocationForm (Set.fromList . map optionInternalValue . olOptions -> terms) (Set.fromList . map optionInternalValue . olOptions -> schools) = runMaybeT $ do
|
|
allocs <- lift . E.select . E.from $ \alloc -> do
|
|
E.where_ $ alloc E.^. AllocationSchool `E.in_` E.valList (Set.toList schools)
|
|
return ( alloc E.^. AllocationTerm
|
|
, alloc E.^. AllocationSchool
|
|
, alloc E.^. AllocationShorthand
|
|
)
|
|
let allocTerms = Map.fromListWith (<>) $ do
|
|
(E.Value tid, E.Value ssh, E.Value ash) <- allocs
|
|
return ((ssh, ash), Set.singleton tid)
|
|
nextAlloc = flip Map.mapMaybe allocTerms $ \(Set.toDescList -> tids) -> case tids of
|
|
TermKey t1 : TermKey t2 : _ -> Just . TermKey . toEnum $ fromEnum t1 + (fromEnum t1 - fromEnum t2)
|
|
TermKey t1 : _ -> Just . TermKey $ succ t1
|
|
_other -> Nothing
|
|
maxAllocTerm <- hoistMaybe . fmap maximum . fromNullable $ Map.mapMaybe Set.lookupMax allocTerms
|
|
((ssh, ash), tid) <- hoistMaybe . fmap (minimumBy $ comparing (view _2) <> comparing (view _1)) . fromNullable . Map.toList $ Map.filter (\t -> t >= maxAllocTerm && t `Set.member` terms) nextAlloc
|
|
oldTid <- hoistMaybe $ Set.lookupMax =<< Map.lookup (ssh, ash) allocTerms
|
|
oldTerm <- MaybeT $ get oldTid
|
|
newTerm <- MaybeT $ get tid
|
|
Entity _ Allocation{..} <- MaybeT . getBy $ TermSchoolAllocationShort oldTid ssh ash
|
|
|
|
let addTime = addLocalDays $ (diffDays `on` termLectureStart) newTerm oldTerm
|
|
|
|
return AllocationForm
|
|
{ afTerm = tid
|
|
, afSchool = ssh
|
|
, afShorthand = ash
|
|
, afName = allocationName
|
|
, afLegacyShorthands = Set.delete ash $ Set.fromList allocationLegacyShorthands
|
|
, afDescription = allocationDescription
|
|
, afStaffDescription = allocationStaffDescription
|
|
, afStaffRegisterFrom = addTime <$> allocationStaffRegisterFrom
|
|
, afStaffRegisterTo = addTime <$> allocationStaffRegisterTo
|
|
, afStaffAllocationFrom = addTime <$> allocationStaffAllocationFrom
|
|
, afStaffAllocationTo = addTime <$> allocationStaffAllocationTo
|
|
, afRegisterFrom = addTime <$> allocationRegisterFrom
|
|
, afRegisterTo = addTime <$> allocationRegisterTo
|
|
, afRegisterByStaffFrom = addTime <$> allocationRegisterByStaffFrom
|
|
, afRegisterByStaffTo = addTime <$> allocationRegisterByStaffTo
|
|
, afRegisterByCourse = addTime <$> allocationRegisterByCourse
|
|
, afOverrideDeregister = addTime <$> allocationOverrideDeregister
|
|
}
|