78 lines
2.8 KiB
Haskell
78 lines
2.8 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.Term
|
|
( groupHolidays
|
|
, getCurrentTerm
|
|
, getActiveTerms
|
|
, fetchTermByCID
|
|
, module Utils.Term
|
|
) where
|
|
|
|
import Import
|
|
|
|
import qualified Data.Set as Set
|
|
import qualified Data.Sequence as Seq
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import Utils.Term
|
|
|
|
import qualified Data.Conduit.Combinators as C
|
|
|
|
|
|
groupHolidays :: ( MonoFoldable mono
|
|
, Enum (Element mono)
|
|
, Ord (Element mono)
|
|
)
|
|
=> mono -> [Either (Element mono) (Element mono, Element mono)]
|
|
groupHolidays = go Seq.empty . foldMap Set.singleton
|
|
where go (acc Seq.:|> Left x') (Set.minView -> Just (x, xs))
|
|
| x <= succ x' = go (acc Seq.:|> Right (x', x)) xs
|
|
go (acc Seq.:|> Right (x', x'')) (Set.minView -> Just (x, xs))
|
|
| x <= succ x'' = go (acc Seq.:|> Right (x', x)) xs
|
|
go acc xs'
|
|
| Just (x, xs) <- Set.minView xs' = go (acc Seq.:|> Left x) xs
|
|
| otherwise = toList acc
|
|
|
|
getCurrentTerm :: MonadIO m => SqlReadT m (Maybe TermId)
|
|
-- ^ Current, generally active, term (i.e. `termIsActiveE` with `Nothing` as `maybeAuthId`)
|
|
getCurrentTerm = do
|
|
now <- liftIO getCurrentTime
|
|
fmap (fmap E.unValue) . E.selectMaybe . E.from $ \term -> do
|
|
E.where_ . termIsActiveE (E.val now) E.nothing $ term E.^. TermId
|
|
E.orderBy [E.desc $ term E.^. TermName]
|
|
return $ term E.^. TermId
|
|
|
|
getActiveTerms :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
|
, BackendCompatible SqlBackend backend
|
|
, IsPersistBackend backend
|
|
, PersistQueryRead backend, PersistUniqueRead backend
|
|
)
|
|
=> ReaderT backend m (Set TermId)
|
|
getActiveTerms = do
|
|
now <- liftIO getCurrentTime
|
|
muid <- maybeAuthId
|
|
|
|
let activeTermsQuery = E.from $ \term -> E.distinctOnOrderBy [E.asc $ term E.^. TermId] $ do
|
|
E.where_ . termIsActiveE (E.val now) (E.val muid) $ term E.^. TermId
|
|
return $ term E.^. TermId
|
|
|
|
fmap Set.fromDistinctAscList . runConduit $
|
|
E.selectSource activeTermsQuery .| C.map E.unValue .| C.sinkList
|
|
|
|
fetchTermByCID :: ( MonadHandler m
|
|
, BackendCompatible SqlBackend backend
|
|
, PersistQueryRead backend, PersistUniqueRead backend
|
|
)
|
|
=> CourseId -> ReaderT backend m Term
|
|
fetchTermByCID cid = do
|
|
termList <- E.select . E.distinct . E.from $ \(course `E.InnerJoin` term) -> do
|
|
E.on $ course E.^. CourseTerm E.==. term E.^. TermId
|
|
E.where_ $ course E.^. CourseId E.==. E.val cid
|
|
return term
|
|
case termList of
|
|
[term] -> return $ entityVal term
|
|
_other -> notFound |