diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index 4346cd381..ede249af1 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -108,7 +108,7 @@ instance PersistField TermIdentifier where fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x instance PersistFieldSql TermIdentifier where - sqlType _ = SqlNumeric 5 1 + sqlType _ = SqlNumeric 9 5 -- total significant digits; significant digits after decimal point instance ToHttpApiData TermIdentifier where toUrlPiece = termToText @@ -145,10 +145,10 @@ guessDay :: TermIdentifier -> Day guessDay TermIdentifier{..} TermDayLectureStart = getTermDay guessDay TermIdentifier{..} TermDayLectureEnd = addDays 8 getTermDay -- courses last only a week -guessDay tid TermDayStart = fromWeekDate year weekStart 1 -- Monday before lecture time - where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureStart -guessDay tid TermDayEnd = fromWeekDate year weekStart 7 -- Sunday after lecture time - where ( year, weekStart, _) = toWeekDate $ guessDay tid TermDayLectureEnd +guessDay tid TermDayStart = fromWeekDate year week 1 -- Monday before lecture time + where ( year, week, _) = toWeekDate $ addDays (-7*4*3) $ guessDay tid TermDayLectureStart +guessDay tid TermDayEnd = fromWeekDate year week 7 -- Sunday after lecture time + where ( year, week, _) = toWeekDate $ addDays (7*3) $ guessDay tid TermDayLectureEnd withinTerm :: Day -> TermIdentifier -> Bool withinTerm d tid = guessDay tid TermDayStart <= d && d <= guessDay tid TermDayEnd diff --git a/test/Database/Fill.hs b/test/Database/Fill.hs index 6f80532eb..b47723cb4 100644 --- a/test/Database/Fill.hs +++ b/test/Database/Fill.hs @@ -3,17 +3,17 @@ module Database.Fill ) where import "uniworx" Import hiding (Option(..), currentYear) -import Handler.Utils.Form (SheetGrading'(..), SheetGroup'(..)) +-- import Handler.Utils.Form (SheetGrading'(..), SheetGroup'(..)) import qualified Data.ByteString.Lazy as LBS -import qualified Data.Text as Text +-- import qualified Data.Text as Text -- import Data.Text.IO (hPutStrLn) import qualified Data.Set as Set import qualified Data.Map as Map -- import Data.Time.Calendar.OrdinalDate -import Data.Time.Calendar.WeekDate +-- import Data.Time.Calendar.WeekDate import Utils.Holidays import Control.Applicative (ZipList(..)) @@ -21,22 +21,22 @@ import Control.Applicative (ZipList(..)) import Handler.Utils.DateTime import Handler.Utils.AuthorshipStatement (insertAuthorshipStatement) -import Control.Monad.Random.Class (weighted) +-- import Control.Monad.Random.Class (weighted) import System.Random.Shuffle (shuffleM) import qualified Data.CaseInsensitive as CI import qualified Data.Csv as Csv -import Crypto.Random (getRandomBytes) -import Data.List (genericLength) -import qualified Data.List as List (splitAt) - -import qualified Data.Conduit.Combinators as C +-- import Crypto.Random (getRandomBytes) +import Data.List (foldl) +-- import qualified Data.List as List (splitAt) import System.Directory (getModificationTime, doesDirectoryExist) import System.FilePath.Glob (glob) +{- Needed for File Tests only +import qualified Data.Conduit.Combinators as C import Paths_uniworx (getDataFileName) testdataFile :: MonadIO m => FilePath -> m FilePath @@ -48,6 +48,8 @@ insertFile residual fileTitle = do let fileContent = Just $ C.sourceFile filepath fileModified <- liftIO getCurrentTime sinkFile' File{..} residual >>= insert +-} + fillDb :: DB () fillDb = do @@ -56,23 +58,21 @@ fillDb = do let insert' :: (PersistRecordBackend r (YesodPersistBackend UniWorX), AtLeastOneUniqueKey r) => r -> YesodDB UniWorX (Key r) insert' = fmap (either entityKey id) . insertBy - + addBDays = addBusinessDays Fraport -- holiday area to use currentTerm = TermIdentifier $ utctDay now - (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm + -- (currentYear, currentMonth, currentDay) = toGregorian $ getTermDay currentTerm nextTerm n = TermIdentifier $ addBDays n $ getTermDay currentTerm - termTime :: Integer -- ^ Term Offset to current Term (i.e. Days) - -> Integer -- ^ Days Offset from Start/End of Term - -> Bool -- ^ Relative to end of Term? - -> Maybe WeekDay -- ^ Move to weekday - -> (Day -> UTCTime) -- ^ Add time to day + termTime :: TermIdentifier -- ^ Term + -> TermDay -- ^ Relative to which day? + -> Integer -- ^ Business Days Offset from Start/End of Term + -> Maybe WeekDay -- ^ Move to weekday + -> (Day -> UTCTime) -- ^ Add time to day -> UTCTime - termTime next doff fromEnd mbWeekDay = ($ utctDay) - where - gTid = nextTerm next - gDay | fromEnd = addBDays (negate doff) $ guessDay gTid TermDayLectureEnd - | otherwise = addBDays doff $ guessDay gTid TermDayLectureStart + termTime gTid gTD gOff mbWeekDay = ($ utctDay) + where + gDay = addBDays gOff $ guessDay gTid gTD utctDay = maybe gDay (`firstDayOfWeekOnAfter` gDay) mbWeekDay gkleen <- insert User @@ -345,17 +345,27 @@ fillDb = do matrikel <- toMatrikel <$> getRandomRs (0 :: Int, 9 :: Int) manyUsers <- insertMany . getZipList $ manyUser <$> ZipList ((,,) <$> firstNames <*> middlenames <*> surnames) <*> ZipList matrikel - terms <- forM [-7..31*6] $ \nr -> do - let tid = nextTerm nr tid - term = Term { termName = termToText' tid - , termStart = guessDay tid TermDayStart - , termEnd = guessDay tid TermDayEnd - , termHolidays = bankHolidaysArea Fraport + let tmin = -8 + tmax = 29*6 + trange = [tmin..tmax] + dmin = guessDay (nextTerm tmin) TermDayStart + dmax = guessDay (nextTerm tmax) TermDayEnd + hdys = foldl (<>) mempty $ [bankHolidaysAreaSet Fraport y | y <- [getYear dmin..getYear dmax]] + terms <- forM trange $ \nr -> do + let tid = nextTerm nr + tk = TermKey tid + tStart = guessDay tid TermDayStart + tEnd = guessDay tid TermDayEnd + term = Term { termName = tid + , termStart = tStart + , termEnd = tEnd + , termHolidays = toList $ Set.filter (\d -> tStart <= d && d <= tEnd) hdys , termLectureStart = guessDay tid TermDayLectureStart , termLectureEnd = guessDay tid TermDayLectureEnd } - void $ repsert (TermKey tid) term - insert $ TermActive (TermKey tid) (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing + repsert tk term + insert_ $ TermActive tk (toMidnight $ addDays (-60) $ termStart term) (Just . beforeMidnight $ addDays 60 $ termEnd term) Nothing + return tk ifiAuthorshipStatement <- insertAuthorshipStatement I18n { i18nFallback = htmlToStoredMarkup @@ -575,574 +585,138 @@ fillDb = do -- Fahrschule F - fdf <- insert' Course - { courseName = "F - Vorfeldführerschein" - , courseDescription = Just $ htmlToStoredMarkup [shamlet| -

- Berechtigung zum Führen eines Fahrzeuges auf den Fahrstrassen des Vorfeldes. -

-

Benötigte Unterlagen -