62 lines
2.2 KiB
Haskell
62 lines
2.2 KiB
Haskell
module Handler.Allocation.Register
|
|
( AllocationRegisterForm(..)
|
|
, AllocationRegisterButton(..)
|
|
, allocationRegisterForm
|
|
, allocationUserToForm
|
|
, postARegisterR
|
|
) where
|
|
|
|
import Import
|
|
|
|
import Handler.Utils.Form
|
|
|
|
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
|
|
|
|
|
data AllocationRegisterForm = AllocationRegisterForm
|
|
{ arfTotalCourses :: Natural
|
|
}
|
|
|
|
allocationRegisterForm :: Maybe AllocationRegisterForm -> AForm Handler AllocationRegisterForm
|
|
allocationRegisterForm template
|
|
= AllocationRegisterForm
|
|
<$> areq (posIntFieldI MsgAllocationTotalCoursesNegative) (fslI MsgAllocationTotalCourses & setTooltip MsgAllocationTotalCoursesTip) (arfTotalCourses <$> template <|> Just 1)
|
|
|
|
allocationUserToForm :: AllocationUser -> AllocationRegisterForm
|
|
allocationUserToForm AllocationUser{..} = AllocationRegisterForm
|
|
{ arfTotalCourses = allocationUserTotalCourses
|
|
}
|
|
|
|
data AllocationRegisterButton = BtnAllocationRegister | BtnAllocationRegistrationEdit
|
|
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
|
instance Universe AllocationRegisterButton
|
|
instance Finite AllocationRegisterButton
|
|
|
|
nullaryPathPiece ''AllocationRegisterButton $ camelToPathPiece' 1
|
|
embedRenderMessage ''UniWorX ''AllocationRegisterButton id
|
|
|
|
instance Button UniWorX AllocationRegisterButton where
|
|
btnClasses _ = [BCIsButton, BCPrimary]
|
|
|
|
postARegisterR :: TermId -> SchoolId -> AllocationShorthand -> Handler Void
|
|
postARegisterR tid ssh ash = do
|
|
uid <- requireAuthId
|
|
|
|
((registerRes, _), _) <- runFormPost . renderAForm FormStandard $ allocationRegisterForm Nothing
|
|
formResult registerRes $ \AllocationRegisterForm{..} -> runDB $ do
|
|
aId <- getKeyBy404 $ TermSchoolAllocationShort tid ssh ash
|
|
isRegistered <- existsBy $ UniqueAllocationUser aId uid
|
|
void $ upsert AllocationUser
|
|
{ allocationUserAllocation = aId
|
|
, allocationUserUser = uid
|
|
, allocationUserTotalCourses = arfTotalCourses
|
|
, allocationUserPriority = Nothing
|
|
}
|
|
[ AllocationUserTotalCourses =. arfTotalCourses
|
|
]
|
|
if
|
|
| isRegistered -> addMessageI Success MsgAllocationRegistrationEdited
|
|
| otherwise -> addMessageI Success MsgAllocationRegistered
|
|
|
|
redirect $ AllocationR tid ssh ash AShowR :#: ("allocation-participation" :: Text)
|