From dbb208112f78ee26a0451e515ec83ac6513e38df Mon Sep 17 00:00:00 2001 From: Gregor Kleen Date: Mon, 27 May 2019 14:23:58 +0200 Subject: [PATCH] Aggressively refactor Model.Types --- src/Data/Aeson/Types/Instances.hs | 6 +- src/Data/Time/Calendar/Instances.hs | 18 ++ src/Data/Time/Clock/Instances.hs | 11 +- src/Data/Time/Format/Instances.hs | 14 ++ src/Data/Time/LocalTime/Instances.hs | 23 ++ src/Data/UUID/Instances.hs | 27 +++ src/Database/Persist/Class/Instances.hs | 22 ++ src/Database/Persist/Sql/Instances.hs | 33 --- src/Database/Persist/Types/Instances.hs | 16 +- src/Handler/Utils/Communication.hs | 3 - src/Handler/Utils/Form/MassInput.hs | 4 +- src/Handler/Utils/Invitations.hs | 1 - src/Handler/Utils/Table/Pagination.hs | 2 - src/Import/NoFoundation.hs | 100 +------- src/Import/NoModel.hs | 105 ++++++++ src/Mail.hs | 8 +- src/Model.hs | 8 +- src/Model/Migration/Types.hs | 2 +- src/Model/Types.hs | 80 +----- src/Model/Types/Common.hs | 29 +++ src/Model/Types/Course.hs | 20 ++ src/Model/Types/DateTime.hs | 69 ++++-- src/Model/Types/Exam.hs | 12 + src/Model/Types/Health.hs | 83 +++++++ src/Model/Types/Mail.hs | 70 ++++++ src/Model/Types/Misc.hs | 120 +-------- src/Model/Types/Security.hs | 309 +----------------------- src/Model/Types/Sheet.hs | 88 ++----- src/Model/Types/Submission.hs | 146 +++++++++++ src/Model/Types/{ => TH}/JSON.hs | 2 +- src/Model/Types/{ => TH}/Wordlist.hs | 4 +- src/Settings.hs | 11 +- src/System/FilePath/Instances.hs | 16 ++ src/Time/Types/Instances.hs | 6 + src/Utils.hs | 10 +- src/Utils/DateTime.hs | 13 +- test/MailSpec.hs | 2 +- test/Model/TypesSpec.hs | 2 - test/TestImport.hs | 1 + test/Utils/DateTimeSpec.hs | 3 + 40 files changed, 750 insertions(+), 749 deletions(-) create mode 100644 src/Data/Time/Calendar/Instances.hs create mode 100644 src/Data/Time/Format/Instances.hs create mode 100644 src/Data/Time/LocalTime/Instances.hs create mode 100644 src/Data/UUID/Instances.hs create mode 100644 src/Database/Persist/Class/Instances.hs delete mode 100644 src/Database/Persist/Sql/Instances.hs create mode 100644 src/Import/NoModel.hs create mode 100644 src/Model/Types/Common.hs create mode 100644 src/Model/Types/Course.hs create mode 100644 src/Model/Types/Exam.hs create mode 100644 src/Model/Types/Health.hs create mode 100644 src/Model/Types/Mail.hs create mode 100644 src/Model/Types/Submission.hs rename src/Model/Types/{ => TH}/JSON.hs (98%) rename src/Model/Types/{ => TH}/Wordlist.hs (95%) create mode 100644 src/System/FilePath/Instances.hs diff --git a/src/Data/Aeson/Types/Instances.hs b/src/Data/Aeson/Types/Instances.hs index 66ff1df61..4e87d05a9 100644 --- a/src/Data/Aeson/Types/Instances.hs +++ b/src/Data/Aeson/Types/Instances.hs @@ -14,9 +14,13 @@ import Data.Binary (Binary) import Data.HashMap.Strict.Instances () import Data.Vector.Instances () +import Model.Types.TH.JSON (derivePersistFieldJSON) + instance MonadThrow Parser where throwM = fail . show - instance Binary Value + + +derivePersistFieldJSON ''Value diff --git a/src/Data/Time/Calendar/Instances.hs b/src/Data/Time/Calendar/Instances.hs new file mode 100644 index 000000000..395f455f8 --- /dev/null +++ b/src/Data/Time/Calendar/Instances.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Time.Calendar.Instances + ( + ) where + +import ClassyPrelude +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +deriving newtype instance Hashable Day + +instance Binary Day where + get = ModifiedJulianDay <$> Binary.get + put = Binary.put . toModifiedJulianDay + diff --git a/src/Data/Time/Clock/Instances.hs b/src/Data/Time/Clock/Instances.hs index 1783ac465..b9721ab7d 100644 --- a/src/Data/Time/Clock/Instances.hs +++ b/src/Data/Time/Clock/Instances.hs @@ -11,14 +11,17 @@ import Data.Time.Clock import Data.Binary (Binary) import qualified Data.Binary as Binary +import Data.Time.Calendar.Instances () + + +instance Hashable DiffTime where + hashWithSalt s = hashWithSalt s . toRational + deriving instance Generic UTCTime +instance Hashable UTCTime -instance Binary Day where - get = ModifiedJulianDay <$> Binary.get - put = Binary.put . toModifiedJulianDay - instance Binary DiffTime where get = fromRational <$> Binary.get put = Binary.put . toRational diff --git a/src/Data/Time/Format/Instances.hs b/src/Data/Time/Format/Instances.hs new file mode 100644 index 000000000..dd2d68144 --- /dev/null +++ b/src/Data/Time/Format/Instances.hs @@ -0,0 +1,14 @@ +{-# OPTIONS -fno-warn-orphans #-} + +module Data.Time.Format.Instances + ( + ) where + +import qualified Language.Haskell.TH.Syntax as TH + +import Data.Time.Format + +import Data.Time.LocalTime.Instances () + + +deriving instance TH.Lift TimeLocale diff --git a/src/Data/Time/LocalTime/Instances.hs b/src/Data/Time/LocalTime/Instances.hs new file mode 100644 index 000000000..39c0d70f0 --- /dev/null +++ b/src/Data/Time/LocalTime/Instances.hs @@ -0,0 +1,23 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Time.LocalTime.Instances + ( + ) where + +import ClassyPrelude + +import Data.Time.LocalTime + +import Data.Binary (Binary) + +import qualified Language.Haskell.TH.Syntax as TH + + +deriving instance Generic TimeOfDay +deriving instance Typeable TimeOfDay + +instance Hashable TimeOfDay +instance Binary TimeOfDay + + +deriving instance TH.Lift TimeZone diff --git a/src/Data/UUID/Instances.hs b/src/Data/UUID/Instances.hs new file mode 100644 index 000000000..8a00de5e3 --- /dev/null +++ b/src/Data/UUID/Instances.hs @@ -0,0 +1,27 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.UUID.Instances + () where + +import ClassyPrelude +import Data.UUID (UUID) +import qualified Data.UUID as UUID + +import Database.Persist.Sql +import Web.PathPieces + + +instance PathPiece UUID where + fromPathPiece = UUID.fromString . unpack + toPathPiece = pack . UUID.toString + +instance PersistField UUID where + toPersistValue = PersistDbSpecific . UUID.toASCIIBytes + + fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t + fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs + fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x + +instance PersistFieldSql UUID where + sqlType _ = SqlOther "uuid" diff --git a/src/Database/Persist/Class/Instances.hs b/src/Database/Persist/Class/Instances.hs new file mode 100644 index 000000000..4864f0df3 --- /dev/null +++ b/src/Database/Persist/Class/Instances.hs @@ -0,0 +1,22 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Database.Persist.Class.Instances + ( + ) where + +import ClassyPrelude + +import Database.Persist.Class +import Database.Persist.Types.Instances () + +import Data.Binary (Binary) +import qualified Data.Binary as Binary + + +instance PersistEntity record => Hashable (Key record) where + hashWithSalt s = hashWithSalt s . toPersistValue + +instance PersistEntity record => Binary (Key record) where + put = Binary.put . toPersistValue + putList = Binary.putList . map toPersistValue + get = either (fail . unpack) return . fromPersistValue =<< Binary.get diff --git a/src/Database/Persist/Sql/Instances.hs b/src/Database/Persist/Sql/Instances.hs deleted file mode 100644 index 2d0044164..000000000 --- a/src/Database/Persist/Sql/Instances.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Database.Persist.Sql.Instances - ( - ) where - -import ClassyPrelude.Yesod - -import Data.Binary (Binary) -import qualified Data.Binary as B - -import Database.Persist.Sql - - -instance Binary (BackendKey SqlWriteBackend) where - put = B.put . unSqlWriteBackendKey - putList = B.putList . map unSqlWriteBackendKey - get = SqlWriteBackendKey <$> B.get -instance Binary (BackendKey SqlReadBackend) where - put = B.put . unSqlReadBackendKey - putList = B.putList . map unSqlReadBackendKey - get = SqlReadBackendKey <$> B.get -instance Binary (BackendKey SqlBackend) where - put = B.put . unSqlBackendKey - putList = B.putList . map unSqlBackendKey - get = SqlBackendKey <$> B.get - - -instance {-# OVERLAPPABLE #-} ToBackendKey SqlBackend record => Binary (Key record) where - put = B.put . fromSqlKey - putList = B.putList . map fromSqlKey - get = toSqlKey <$> B.get diff --git a/src/Database/Persist/Types/Instances.hs b/src/Database/Persist/Types/Instances.hs index db5957d54..eb02f5a22 100644 --- a/src/Database/Persist/Types/Instances.hs +++ b/src/Database/Persist/Types/Instances.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE UndecidableInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Database.Persist.Types.Instances @@ -6,7 +5,18 @@ module Database.Persist.Types.Instances ) where import ClassyPrelude + import Database.Persist.Types -instance (Hashable record, Hashable (Key record)) => Hashable (Entity record) where - s `hashWithSalt` Entity{..} = s `hashWithSalt` entityKey `hashWithSalt` entityVal +import Data.Time.Calendar.Instances () +import Data.Time.LocalTime.Instances () +import Data.Time.Clock.Instances () + +import Data.Binary (Binary) + + +deriving instance Generic PersistValue +deriving instance Typeable PersistValue + +instance Hashable PersistValue +instance Binary PersistValue diff --git a/src/Handler/Utils/Communication.hs b/src/Handler/Utils/Communication.hs index 042e90a52..7ee1f815a 100644 --- a/src/Handler/Utils/Communication.hs +++ b/src/Handler/Utils/Communication.hs @@ -20,9 +20,6 @@ import Data.Map ((!), (!?)) import qualified Data.Map as Map import qualified Data.Set as Set -import Data.Aeson.TH -import Data.Aeson.Types (ToJSONKey(..), FromJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..)) - data RecipientGroup = RGCourseParticipants | RGCourseLecturers | RGCourseCorrectors | RGCourseTutors | RGTutorialParticipants diff --git a/src/Handler/Utils/Form/MassInput.hs b/src/Handler/Utils/Form/MassInput.hs index e9121be5f..dab7f1d51 100644 --- a/src/Handler/Utils/Form/MassInput.hs +++ b/src/Handler/Utils/Form/MassInput.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} -- tupleBoxCoord {-# LANGUAGE GeneralizedNewtypeDeriving #-} module Handler.Utils.Form.MassInput @@ -20,8 +20,6 @@ import Utils.Lens import Handler.Utils.Form.MassInput.Liveliness import Handler.Utils.Form.MassInput.TH -import Data.Aeson hiding (Result(..)) - import Algebra.Lattice hiding (join) import Text.Blaze (Markup) diff --git a/src/Handler/Utils/Invitations.hs b/src/Handler/Utils/Invitations.hs index ba80dd1fe..510da890b 100644 --- a/src/Handler/Utils/Invitations.hs +++ b/src/Handler/Utils/Invitations.hs @@ -32,7 +32,6 @@ import qualified Data.HashSet as HashSet import Data.Aeson (fromJSON) import qualified Data.Aeson as JSON -import Data.Aeson.TH import Data.Proxy (Proxy(..)) import Data.Typeable diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 15a2952f5..063b06fd6 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -1,5 +1,3 @@ -{-# OPTIONS -fno-warn-orphans #-} - module Handler.Utils.Table.Pagination ( module Handler.Utils.Table.Pagination.Types , SortColumn(..), SortDirection(..) diff --git a/src/Import/NoFoundation.hs b/src/Import/NoFoundation.hs index 7043c799e..0577f3915 100644 --- a/src/Import/NoFoundation.hs +++ b/src/Import/NoFoundation.hs @@ -1,109 +1,17 @@ module Import.NoFoundation ( module Import - , MForm ) where -import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons) +import Import.NoModel as Import import Model as Import -import Model.Types.JSON as Import import Model.Migration as Import import Model.Rating as Import import Model.Submission as Import import Model.Tokens as Import +import Utils.Tokens as Import +import Utils.Frontend.Modal as Import + import Settings as Import import Settings.StaticFiles as Import -import Yesod.Auth as Import -import Yesod.Core.Types as Import (loggerSet) -import Yesod.Default.Config2 as Import -import Utils as Import -import Utils.Frontend.Modal as Import -import Utils.Frontend.I18n as Import -import Utils.DB as Import -import Yesod.Core.Json as Import (provideJson) -import Yesod.Core.Types.Instances as Import (CachedMemoT(..)) - -import Language.Haskell.TH.Instances as Import () - -import Utils.Tokens as Import - - -import Data.Fixed as Import import CryptoID as Import -import Data.UUID as Import (UUID) - -import Text.Lucius as Import - -import Text.Shakespeare.Text as Import hiding (text, stext) - -import Data.Universe as Import -import Data.Universe.TH as Import -import Data.Pool as Import (Pool) -import Network.HaskellNet.SMTP as Import (SMTPConnection) - -import Mail as Import - -import Data.Data as Import (Data) -import Data.Typeable as Import (Typeable) -import GHC.Generics as Import (Generic) -import GHC.Exts as Import (IsList) - -import Data.Hashable as Import -import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) -import Data.List.NonEmpty.Instances as Import () -import Data.NonNull.Instances as Import () -import Data.Text.Encoding.Error as Import(UnicodeException(..)) -import Data.Semigroup as Import (Semigroup) -import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..)) -import Data.Monoid.Instances as Import () -import Data.Set.Instances as Import () -import Data.HashMap.Strict.Instances as Import () -import Data.HashSet.Instances as Import () -import Data.Vector.Instances as Import () -import Data.Time.Clock.Instances as Import () - -import Data.Binary as Import (Binary) - -import Control.Monad.Morph as Import (MFunctor(..)) - -import Control.Monad.Trans.Resource as Import (ReleaseKey) - -import Network.Mail.Mime.Instances as Import () -import Yesod.Core.Instances as Import () -import Data.Aeson.Types.Instances as Import () - -import Ldap.Client.Pool as Import - -import Database.Esqueleto.Instances as Import () -import Database.Persist.Sql.Instances as Import () -import Database.Persist.Sql as Import (SqlReadT,SqlWriteT) -import Database.Persist.Types.Instances as Import () - -import Numeric.Natural.Instances as Import () -import System.Random as Import (Random) -import Control.Monad.Random.Class as Import (MonadRandom(..)) - -import Text.Blaze.Instances as Import () -import Jose.Jwt.Instances as Import () -import Jose.Jwt as Import (Jwt) -import Web.PathPieces.Instances as Import () - -import Data.Time.Calendar as Import -import Data.Time.Clock as Import -import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) -import Time.Types as Import (WeekDay(..)) - -import Time.Types.Instances as Import () - -import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase) - -import Data.Ratio as Import ((%)) - -import Network.Mime as Import - -import Data.Universe.Instances.Reverse.MonoTraversable () - - -import Control.Monad.Trans.RWS (RWST) - -type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m diff --git a/src/Import/NoModel.hs b/src/Import/NoModel.hs new file mode 100644 index 000000000..639eca131 --- /dev/null +++ b/src/Import/NoModel.hs @@ -0,0 +1,105 @@ +module Import.NoModel + ( module Import + , MForm + ) where + +import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons) + +import Model.Types.TH.JSON as Import +import Model.Types.TH.Wordlist as Import + +import Mail as Import + +import Yesod.Auth as Import +import Yesod.Core.Types as Import (loggerSet) +import Yesod.Default.Config2 as Import +import Yesod.Core.Json as Import (provideJson) +import Yesod.Core.Types.Instances as Import (CachedMemoT(..)) + +import Utils as Import +import Utils.Frontend.I18n as Import +import Utils.DB as Import + +import Data.Fixed as Import + +import Data.UUID as Import (UUID) + +import Data.CaseInsensitive as Import (CI, FoldCase(..), foldedCase) + +import Text.Lucius as Import +import Text.Shakespeare.Text as Import hiding (text, stext) + +import Data.Universe as Import +import Data.Universe.TH as Import +import Data.Pool as Import (Pool) +import Network.HaskellNet.SMTP as Import (SMTPConnection) + +import Data.Data as Import (Data) +import Data.Typeable as Import (Typeable) +import GHC.Generics as Import (Generic) +import GHC.Exts as Import (IsList) +import Data.Ix as Import (Ix) + +import Data.Hashable as Import +import Data.List.NonEmpty as Import (NonEmpty(..), nonEmpty) +import Data.Text.Encoding.Error as Import(UnicodeException(..)) +import Data.Semigroup as Import (Semigroup) +import Data.Monoid as Import (Last(..), First(..), Any(..), All(..), Sum(..)) +import Data.Binary as Import (Binary) + +import Numeric.Natural as Import (Natural) +import Data.Ratio as Import ((%)) + +import Database.Persist.Sql as Import (SqlReadT, SqlWriteT, fromSqlKey, toSqlKey) + +import Ldap.Client.Pool as Import + +import System.Random as Import (Random(..)) +import Control.Monad.Random.Class as Import (MonadRandom(..)) + +import Control.Monad.Morph as Import (MFunctor(..)) +import Control.Monad.Trans.Resource as Import (ReleaseKey) + +import Jose.Jwt as Import (Jwt) + +import Data.Time.Calendar as Import +import Data.Time.Clock as Import +import Data.Time.LocalTime as Import hiding (utcToLocalTime, localTimeToUTC) +import Time.Types as Import (WeekDay(..)) + +import Network.Mime as Import + +import Data.Aeson.TH as Import +import Data.Aeson.Types as Import (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), toJSONKeyText, FromJSONKeyFunction(..), ToJSONKeyFunction(..), Value) + +import Language.Haskell.TH.Instances as Import () +import Data.List.NonEmpty.Instances as Import () +import Data.NonNull.Instances as Import () +import Data.Monoid.Instances as Import () +import Data.Set.Instances as Import () +import Data.HashMap.Strict.Instances as Import () +import Data.HashSet.Instances as Import () +import Data.Vector.Instances as Import () +import Data.Time.Clock.Instances as Import () +import Data.Time.LocalTime.Instances as Import () +import Data.Time.Calendar.Instances as Import () +import Data.Time.Format.Instances as Import () +import Time.Types.Instances as Import () +import Network.Mail.Mime.Instances as Import () +import Yesod.Core.Instances as Import () +import Data.Aeson.Types.Instances as Import () +import Database.Esqueleto.Instances as Import () +import Numeric.Natural.Instances as Import () +import Text.Blaze.Instances as Import () +import Jose.Jwt.Instances as Import () +import Web.PathPieces.Instances as Import () +import Data.Universe.Instances.Reverse.MonoTraversable () +import Database.Persist.Class.Instances as Import () +import Database.Persist.Types.Instances as Import () +import Data.UUID.Instances as Import () +import System.FilePath.Instances as Import () + + +import Control.Monad.Trans.RWS (RWST) + +type MForm m = RWST (Maybe (Env, FileEnv), HandlerSite m, [Lang]) Enctype Ints m diff --git a/src/Mail.hs b/src/Mail.hs index 82bac2273..8cfa03200 100644 --- a/src/Mail.hs +++ b/src/Mail.hs @@ -35,7 +35,9 @@ module Mail , _partType, _partEncoding, _partFilename, _partHeaders, _partContent ) where -import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender) +import ClassyPrelude.Yesod hiding (snoc, (.=), getMessageRender, derivePersistFieldJSON) + +import Model.Types.TH.JSON import Network.Mail.Mime hiding (addPart, addAttachment) import qualified Network.Mail.Mime as Mime (addPart) @@ -159,6 +161,7 @@ instance Default MailLanguages where instance Hashable MailLanguages + data MailContext = MailContext { mcLanguages :: MailLanguages , mcDateTimeFormat :: SelDateTimeFormat -> DateTimeFormat @@ -506,3 +509,6 @@ setMailSmtpData = do in tell $ mempty { smtpEnvelopeFrom = Last $ Just verp } | otherwise -> tell $ mempty { smtpEnvelopeFrom = Last $ Just from } + + +derivePersistFieldJSON ''MailLanguages diff --git a/src/Model.hs b/src/Model.hs index 1e1ecf062..c86406275 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -6,7 +6,7 @@ module Model , module Cron.Types ) where -import ClassyPrelude.Yesod +import Import.NoModel import Database.Persist.Quasi import Database.Persist.TH.Directory -- import Data.Time @@ -23,8 +23,6 @@ import Utils.Message (MessageStatus) import Settings.Cluster (ClusterSettingsKey) -import Data.Binary (Binary) - -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities -- at: @@ -38,9 +36,5 @@ deriving instance Eq (Unique Sheet) -- instance Eq CourseSheet deriving instance Eq (Unique Material) -- instance Eq UniqueMaterial deriving instance Eq (Unique Tutorial) -- instance Eq Tutorial --- Primary keys mentioned in dbtable row-keys must be Binary --- Automatically generated (i.e. numeric) ids are already taken care of -deriving instance Binary (Key Term) - submissionRatingDone :: Submission -> Bool submissionRatingDone Submission{..} = isJust submissionRatingTime diff --git a/src/Model/Migration/Types.hs b/src/Model/Migration/Types.hs index 4720bf099..e5ed53362 100644 --- a/src/Model/Migration/Types.hs +++ b/src/Model/Migration/Types.hs @@ -7,7 +7,7 @@ import Data.Aeson.TH (deriveJSON, defaultOptions) import Utils.PathPiece import qualified Model as Current -import qualified Model.Types.JSON as Current +import qualified Model.Types.TH.JSON as Current import Data.Universe diff --git a/src/Model/Types.hs b/src/Model/Types.hs index b1692283c..a8e2fc90c 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -1,72 +1,14 @@ -{-# LANGUAGE UndecidableInstances #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) - - - module Model.Types - ( module Model.Types - , module Model.Types.Sheet - , module Model.Types.DateTime - , module Model.Types.Security - , module Model.Types.Misc - , module Numeric.Natural - , module Mail - , module Utils.DateTime - , module Data.UUID.Types + ( module Types ) where -import ClassyPrelude -import Data.UUID.Types (UUID) -import qualified Data.UUID.Types as UUID -import Data.NonNull.Instances () - -import Data.Text (Text) -import qualified Data.Text as Text -import Data.CaseInsensitive (CI) -import Data.CaseInsensitive.Instances () - -import Data.Universe.Instances.Reverse () - -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Yesod.Auth.Util.PasswordStore as PWStore -import Web.PathPieces - -import Mail (MailLanguages(..)) -import Utils.DateTime (DateTimeFormat(..), SelDateTimeFormat(..)) -import Numeric.Natural - -import Model.Types.Sheet -import Model.Types.DateTime -import Model.Types.Security -import Model.Types.Misc - ----- --- Just bringing together the different Model.Types submodules. - -instance PathPiece UUID where - fromPathPiece = UUID.fromString . unpack - toPathPiece = pack . UUID.toString - -instance {-# OVERLAPS #-} PathMultiPiece FilePath where - fromPathMultiPiece = Just . unpack . intercalate "/" - toPathMultiPiece = Text.splitOn "/" . pack - - --- Type synonyms - -type Email = Text - -type SchoolName = CI Text -type SchoolShorthand = CI Text -type CourseName = CI Text -type CourseShorthand = CI Text -type SheetName = CI Text -type MaterialName = CI Text -type UserEmail = CI Email -type TutorialName = CI Text - -type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString -type InstanceId = UUID -type ClusterId = UUID -type TokenId = UUID -type TermCandidateIncidence = UUID +import Model.Types.Common as Types +import Model.Types.Course as Types +import Model.Types.DateTime as Types +import Model.Types.Exam as Types +import Model.Types.Health as Types +import Model.Types.Mail as Types +import Model.Types.Security as Types +import Model.Types.Sheet as Types +import Model.Types.Submission as Types +import Model.Types.Misc as Types diff --git a/src/Model/Types/Common.hs b/src/Model/Types/Common.hs new file mode 100644 index 000000000..ae8f79f83 --- /dev/null +++ b/src/Model/Types/Common.hs @@ -0,0 +1,29 @@ +module Model.Types.Common + ( module Model.Types.Common + ) where + +import Import.NoModel + +import qualified Yesod.Auth.Util.PasswordStore as PWStore + + +type Count = Sum Integer +type Points = Centi + + +type Email = Text + +type SchoolName = CI Text +type SchoolShorthand = CI Text +type CourseName = CI Text +type CourseShorthand = CI Text +type SheetName = CI Text +type MaterialName = CI Text +type UserEmail = CI Email +type TutorialName = CI Text + +type PWHashAlgorithm = ByteString -> PWStore.Salt -> Int -> ByteString +type InstanceId = UUID +type ClusterId = UUID +type TokenId = UUID +type TermCandidateIncidence = UUID diff --git a/src/Model/Types/Course.hs b/src/Model/Types/Course.hs new file mode 100644 index 000000000..ca619a77a --- /dev/null +++ b/src/Model/Types/Course.hs @@ -0,0 +1,20 @@ +module Model.Types.Course + ( module Model.Types.Course + ) where + +import Import.NoModel + + +data LecturerType = CourseLecturer | CourseAssistant + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe LecturerType +instance Finite LecturerType + +nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''LecturerType +derivePersistFieldJSON ''LecturerType + +instance Hashable LecturerType diff --git a/src/Model/Types/DateTime.hs b/src/Model/Types/DateTime.hs index cb7b2999d..795647003 100644 --- a/src/Model/Types/DateTime.hs +++ b/src/Model/Types/DateTime.hs @@ -1,34 +1,22 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +module Model.Types.DateTime + ( module Model.Types.DateTime + ) where -module Model.Types.DateTime where - - -import ClassyPrelude -import GHC.Generics (Generic) -import Utils +import Import.NoModel import Control.Lens -import Data.NonNull.Instances () -import Data.Typeable (Typeable) -import Data.Universe.Instances.Reverse () -import Data.Binary (Binary) -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.CaseInsensitive as CI -import Data.CaseInsensitive.Instances () import Text.Read (readMaybe) -import Database.Persist.Class import Database.Persist.Sql import Web.HttpApiData -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Data.Aeson as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), withText) +import Data.Aeson.Types as Aeson + +import Time.Types (WeekDay(..)) +import Data.Time.LocalTime (LocalTime, TimeOfDay) ---- @@ -156,3 +144,44 @@ time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100 timeYear = fst3 $ toGregorian time termYear = year term + +data OccurenceSchedule = ScheduleWeekly + { scheduleDayOfWeek :: WeekDay + , scheduleStart :: TimeOfDay + , scheduleEnd :: TimeOfDay + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , tagSingleConstructors = True + , sumEncoding = TaggedObject "repeat" "schedule" + } ''OccurenceSchedule + +data OccurenceException = ExceptOccur + { exceptDay :: Day + , exceptStart :: TimeOfDay + , exceptEnd :: TimeOfDay + } + | ExceptNoOccur + { exceptTime :: LocalTime + } + deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + , constructorTagModifier = camelToPathPiece' 1 + , sumEncoding = TaggedObject "exception" "for" + } ''OccurenceException + +data Occurences = Occurences + { occurencesScheduled :: Set OccurenceSchedule + , occurencesExceptions :: Set OccurenceException + } deriving (Eq, Ord, Read, Show, Generic, Typeable) + +deriveJSON defaultOptions + { fieldLabelModifier = camelToPathPiece' 1 + } ''Occurences +derivePersistFieldJSON ''Occurences + diff --git a/src/Model/Types/Exam.hs b/src/Model/Types/Exam.hs new file mode 100644 index 000000000..f037ce79b --- /dev/null +++ b/src/Model/Types/Exam.hs @@ -0,0 +1,12 @@ +module Model.Types.Exam + ( module Model.Types.Exam + ) where + +import Import.NoModel + +import Database.Persist.TH (derivePersistField) + + +data ExamStatus = Attended | NoShow | Voided + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) +derivePersistField "ExamStatus" diff --git a/src/Model/Types/Health.hs b/src/Model/Types/Health.hs new file mode 100644 index 000000000..788ca54f7 --- /dev/null +++ b/src/Model/Types/Health.hs @@ -0,0 +1,83 @@ +module Model.Types.Health + ( module Model.Types.Health + ) where + +import Import.NoModel + + +data HealthCheck + = HealthCheckMatchingClusterConfig + | HealthCheckHTTPReachable + | HealthCheckLDAPAdmins + | HealthCheckSMTPConnect + | HealthCheckWidgetMemcached + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) +instance Universe HealthCheck +instance Finite HealthCheck +instance Hashable HealthCheck + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 2 + } ''HealthCheck +nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2 +pathPieceJSONKey ''HealthCheck + +data HealthReport + = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool } + -- ^ Is the database-stored configuration we're running under still up to date? + -- + -- Also tests database connection as a side effect + | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool } + -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? + | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational } + -- ^ Proportion of school admins that could be found in LDAP + | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool } + -- ^ Can we connect to the SMTP server and say @NOOP@? + | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool } + -- ^ Can we store values in memcached and retrieve them via HTTP? + deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) + +instance NFData HealthReport + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + , fieldLabelModifier = camelToPathPiece' 1 + , omitNothingFields = True + , sumEncoding = TaggedObject "test" "result" + , tagSingleConstructors = True + } ''HealthReport + +classifyHealthReport :: HealthReport -> HealthCheck +classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig +classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins +classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable +classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect +classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached + +-- | `HealthReport` classified (`classifyHealthReport`) by badness +-- +-- > a < b = a `worseThan` b +-- +-- Currently all consumers of this type check for @(== HealthSuccess)@; this +-- needs to be adjusted on a case-by-case basis if new constructors are added +data HealthStatus = HealthFailure | HealthSuccess + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe HealthStatus +instance Finite HealthStatus + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece' 1 + } ''HealthStatus +nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 + +healthReportStatus :: HealthReport -> HealthStatus +-- ^ Classify `HealthReport` by badness +healthReportStatus = \case + HealthMatchingClusterConfig False -> HealthFailure + HealthHTTPReachable (Just False) -> HealthFailure + HealthLDAPAdmins (Just prop ) + | prop <= 0 -> HealthFailure + HealthSMTPConnect (Just False) -> HealthFailure + HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? + _other -> maxBound -- Minimum badness diff --git a/src/Model/Types/Mail.hs b/src/Model/Types/Mail.hs new file mode 100644 index 000000000..5aeb1d14a --- /dev/null +++ b/src/Model/Types/Mail.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE UndecidableInstances #-} + +module Model.Types.Mail + ( module Model.Types.Mail + ) where + +import Import.NoModel + +import qualified Data.Aeson.Types as Aeson + +import qualified Data.HashMap.Strict as HashMap + + +-- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ +-- +-- Could maybe be replaced with `Structure Notification` in the long term +data NotificationTrigger + = NTSubmissionRatedGraded + | NTSubmissionRated + | NTSheetActive + | NTSheetSoonInactive + | NTSheetInactive + | NTCorrectionsAssigned + | NTCorrectionsNotDistributed + | NTUserRightsUpdate + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) + +instance Universe NotificationTrigger +instance Finite NotificationTrigger + +instance Hashable NotificationTrigger + +deriveJSON defaultOptions + { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel + } ''NotificationTrigger + +instance ToJSONKey NotificationTrigger where + toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t + +instance FromJSONKey NotificationTrigger where + fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String + + +newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } + deriving (Generic, Typeable) + deriving newtype (Eq, Ord, Read, Show) + +instance Default NotificationSettings where + def = NotificationSettings $ \case + NTSubmissionRatedGraded -> True + NTSubmissionRated -> False + NTSheetActive -> True + NTSheetSoonInactive -> False + NTSheetInactive -> True + NTCorrectionsAssigned -> True + NTCorrectionsNotDistributed -> True + NTUserRightsUpdate -> True + +instance ToJSON NotificationSettings where + toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF + +instance FromJSON NotificationSettings where + parseJSON = Aeson.withObject "NotificationSettings" $ \o -> do + o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) + return . NotificationSettings $ \n -> case HashMap.lookup n o' of + Nothing -> notificationAllowed def n + Just b -> b + +derivePersistFieldJSON ''NotificationSettings diff --git a/src/Model/Types/Misc.hs b/src/Model/Types/Misc.hs index aa3811f9d..8d45e6798 100644 --- a/src/Model/Types/Misc.hs +++ b/src/Model/Types/Misc.hs @@ -1,50 +1,20 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +module Model.Types.Misc + ( module Model.Types.Misc + ) where -module Model.Types.Misc where - - -import ClassyPrelude -import Utils +import Import.NoModel import Control.Lens -import Data.NonNull.Instances () -import Data.Set (Set) import Data.Maybe (fromJust) -import Data.Universe -import Data.Universe.Helpers import qualified Data.Text as Text import qualified Data.Text.Lens as Text -import Data.CaseInsensitive.Instances () -import Database.Persist.TH hiding (derivePersistFieldJSON) -import Model.Types.JSON - -import Data.Aeson (Value()) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) - -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - -import Data.Universe.Instances.Reverse () - -import Data.Time.LocalTime (LocalTime, TimeOfDay) -import Time.Types (WeekDay(..)) - - ------ --- Miscellaneous Model.Types - -derivePersistFieldJSON ''Value data StudyFieldType = FieldPrimary | FieldSecondary deriving (Eq, Ord, Enum, Show, Read, Bounded, Generic) derivePersistField "StudyFieldType" --- instance DisplayAble StudyFieldType data Theme = ThemeDefault @@ -59,89 +29,11 @@ deriveJSON defaultOptions { constructorTagModifier = fromJust . stripPrefix "Theme" } ''Theme -instance Universe Theme where universe = universeDef +instance Universe Theme instance Finite Theme -nullaryPathPiece ''Theme (camelToPathPiece' 1) +nullaryPathPiece ''Theme $ camelToPathPiece' 1 $(deriveSimpleWith ''DisplayAble 'display (over Text.packed $ Text.intercalate " " . unsafeTail . splitCamel) ''Theme) -- describe theme to user derivePersistField "Theme" - - -data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) - -deriveJSON defaultOptions - { constructorTagModifier = fromJust . stripPrefix "Corrector" - } ''CorrectorState - -instance Universe CorrectorState -instance Finite CorrectorState - -instance Hashable CorrectorState - -nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) - -derivePersistField "CorrectorState" - - -data LecturerType = CourseLecturer | CourseAssistant - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe LecturerType -instance Finite LecturerType - -nullaryPathPiece ''LecturerType $ camelToPathPiece' 1 -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''LecturerType -derivePersistFieldJSON ''LecturerType - -instance Hashable LecturerType - - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece - } ''WeekDay - -data OccurenceSchedule = ScheduleWeekly - { scheduleDayOfWeek :: WeekDay - , scheduleStart :: TimeOfDay - , scheduleEnd :: TimeOfDay - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , tagSingleConstructors = True - , sumEncoding = TaggedObject "repeat" "schedule" - } ''OccurenceSchedule - -data OccurenceException = ExceptOccur - { exceptDay :: Day - , exceptStart :: TimeOfDay - , exceptEnd :: TimeOfDay - } - | ExceptNoOccur - { exceptTime :: LocalTime - } - deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - , constructorTagModifier = camelToPathPiece' 1 - , sumEncoding = TaggedObject "exception" "for" - } ''OccurenceException - -data Occurences = Occurences - { occurencesScheduled :: Set OccurenceSchedule - , occurencesExceptions :: Set OccurenceException - } deriving (Eq, Ord, Read, Show, Generic, Typeable) - -deriveJSON defaultOptions - { fieldLabelModifier = camelToPathPiece' 1 - } ''Occurences -derivePersistFieldJSON ''Occurences - diff --git a/src/Model/Types/Security.hs b/src/Model/Types/Security.hs index 04aad122b..cba46f371 100644 --- a/src/Model/Types/Security.hs +++ b/src/Model/Types/Security.hs @@ -1,80 +1,22 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +{-# LANGUAGE GeneralizedNewtypeDeriving #-} -module Model.Types.Security where +module Model.Types.Security + ( module Model.Types.Security + ) where - -import ClassyPrelude -import Utils -import Control.Lens hiding (universe) +import Import.NoModel import Data.Set (Set) -import qualified Data.Set as Set -import Data.Universe -import Data.UUID.Types (UUID) -import qualified Data.UUID.Types as UUID -import Data.NonNull.Instances () - -import Data.Default - -import Model.Types.JSON -import Database.Persist.Class -import Database.Persist.Sql - -import Data.Text (Text) import qualified Data.Text as Text import qualified Data.HashMap.Strict as HashMap -import Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import Data.CaseInsensitive.Instances () - -import Yesod.Core.Dispatch (PathPiece(..)) -import qualified Data.Aeson as Aeson import qualified Data.Aeson.Types as Aeson -import Data.Aeson (FromJSON(..), ToJSON(..), FromJSONKey(..), ToJSONKey(..), FromJSONKeyFunction(..), withObject) -import Data.Aeson.Types (toJSONKeyText) -import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..), mkToJSON, mkParseJSON) -import GHC.Generics (Generic) -import Data.Typeable (Typeable) - -import Data.Universe.Instances.Reverse () - -import Mail (MailLanguages(..)) - -import Data.Word.Word24 (Word24) -import Data.Bits -import Data.Ix -import Data.List (genericIndex, elemIndex) -import System.Random (Random(..)) -import Data.Data (Data) - -import Model.Types.Wordlist -import Data.Text.Metrics (damerauLevenshtein) - -import Data.Binary (Binary) import qualified Data.Binary as Binary ----- --- Security, Authentification, Notification Stuff - -instance PersistField UUID where - toPersistValue = PersistDbSpecific . UUID.toASCIIBytes - fromPersistValue (PersistText t) = maybe (Left "Failed to parse UUID") Right $ UUID.fromText t - fromPersistValue (PersistByteString bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue (PersistDbSpecific bs) = maybe (Left "Failed to parse UUID") Right $ UUID.fromASCIIBytes bs - fromPersistValue x = Left $ "Expected UUID, received: " <> tshow x - -instance PersistFieldSql UUID where - sqlType _ = SqlOther "uuid" - - data AuthenticationMode = AuthLDAP | AuthPWHash { authPWHash :: Text } deriving (Eq, Ord, Read, Show, Generic) @@ -88,167 +30,6 @@ deriveJSON defaultOptions derivePersistFieldJSON ''AuthenticationMode - --- ^ `NotificationSettings` is for now a series of boolean checkboxes, i.e. a mapping @NotificationTrigger -> Bool@ --- --- Could maybe be replaced with `Structure Notification` in the long term -data NotificationTrigger = NTSubmissionRatedGraded - | NTSubmissionRated - | NTSheetActive - | NTSheetSoonInactive - | NTSheetInactive - | NTCorrectionsAssigned - | NTCorrectionsNotDistributed - | NTUserRightsUpdate - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe NotificationTrigger -instance Finite NotificationTrigger - -instance Hashable NotificationTrigger - -deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 1 . splitCamel - } ''NotificationTrigger - -instance ToJSONKey NotificationTrigger where - toJSONKey = toJSONKeyText $ \v -> let Aeson.String t = toJSON v in t - -instance FromJSONKey NotificationTrigger where - fromJSONKey = FromJSONKeyTextParser $ parseJSON . Aeson.String - - -newtype NotificationSettings = NotificationSettings { notificationAllowed :: NotificationTrigger -> Bool } - deriving (Generic, Typeable) - deriving newtype (Eq, Ord, Read, Show) - -instance Default NotificationSettings where - def = NotificationSettings $ \case - NTSubmissionRatedGraded -> True - NTSubmissionRated -> False - NTSheetActive -> True - NTSheetSoonInactive -> False - NTSheetInactive -> True - NTCorrectionsAssigned -> True - NTCorrectionsNotDistributed -> True - NTUserRightsUpdate -> True - -instance ToJSON NotificationSettings where - toJSON v = toJSON . HashMap.fromList $ map (id &&& notificationAllowed v) universeF - -instance FromJSON NotificationSettings where - parseJSON = withObject "NotificationSettings" $ \o -> do - o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap NotificationTrigger Bool) - return . NotificationSettings $ \n -> case HashMap.lookup n o' of - Nothing -> notificationAllowed def n - Just b -> b - -derivePersistFieldJSON ''NotificationSettings - - -instance ToBackendKey SqlBackend record => Hashable (Key record) where - hashWithSalt s key = s `hashWithSalt` fromSqlKey key - -derivePersistFieldJSON ''MailLanguages - - -type PseudonymWord = CI Text - -newtype Pseudonym = Pseudonym Word24 - deriving (Eq, Ord, Read, Show, Generic, Data) - deriving newtype (Bounded, Enum, Integral, Num, Real, Ix) - - -instance PersistField Pseudonym where - toPersistValue p = toPersistValue (fromIntegral p :: Word32) - fromPersistValue v = do - w <- fromPersistValue v :: Either Text Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> Left "Pseudonym out of range" - -instance PersistFieldSql Pseudonym where - sqlType _ = SqlInt32 - -instance Random Pseudonym where - randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen - random = randomR (minBound, maxBound) - -instance FromJSON Pseudonym where - parseJSON v@(Aeson.Number _) = do - w <- parseJSON v :: Aeson.Parser Word32 - if - | 0 <= w - , w <= fromIntegral (maxBound :: Pseudonym) - -> return $ fromIntegral w - | otherwise - -> fail "Pseudonym out auf range" - parseJSON (Aeson.String t) - = case t ^? _PseudonymText of - Just p -> return p - Nothing -> fail "Could not parse pseudonym" - parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do - ws' <- toList . map CI.mk <$> mapM parseJSON ws - case ws' ^? _PseudonymWords of - Just p -> return p - Nothing -> fail "Could not parse pseudonym words" - -instance ToJSON Pseudonym where - toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) - -pseudonymWordlist :: [PseudonymWord] -pseudonymCharacters :: Set (CI Char) -(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") - -_PseudonymWords :: Prism' [PseudonymWord] Pseudonym -_PseudonymWords = prism' pToWords pFromWords - where - pFromWords :: [PseudonymWord] -> Maybe Pseudonym - pFromWords [w1, w2] - | Just i1 <- elemIndex w1 pseudonymWordlist - , Just i2 <- elemIndex w2 pseudonymWordlist - , i1 <= maxWord, i2 <= maxWord - = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 - pFromWords _ = Nothing - - pToWords :: Pseudonym -> [PseudonymWord] - pToWords (Pseudonym p) - = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord - , genericIndex pseudonymWordlist $ p .&. maxWord - ] - - maxWord :: Num a => a - maxWord = 0b111111111111 - -_PseudonymText :: Prism' Text Pseudonym -_PseudonymText = prism' tToWords tFromWords . _PseudonymWords - where - tFromWords :: Text -> Maybe [PseudonymWord] - tFromWords input - | [result] <- input ^.. pseudonymFragments - = Just result - | otherwise - = Nothing - - tToWords :: [PseudonymWord] -> Text - tToWords = Text.unwords . map CI.original - -pseudonymWords :: Fold Text PseudonymWord -pseudonymWords = folding - $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist - where - distance = damerauLevenshtein `on` CI.foldedCase - -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 - distanceCutoff = 2 - -pseudonymFragments :: Fold Text [PseudonymWord] -pseudonymFragments = folding - $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) - - data AuthTag -- sortiert nach gewünschter Reihenfolge auf /authpreds, d.h. Prädikate sind sortier nach Relevanz für Benutzer = AuthAdmin | AuthLecturer @@ -309,7 +90,7 @@ instance ToJSON AuthTagActive where toJSON v = toJSON . HashMap.fromList $ map (id &&& authTagIsActive v) universeF instance FromJSON AuthTagActive where - parseJSON = withObject "AuthTagActive" $ \o -> do + parseJSON = Aeson.withObject "AuthTagActive" $ \o -> do o' <- parseJSON $ Aeson.Object o :: Aeson.Parser (HashMap AuthTag Bool) return . AuthTagActive $ \n -> case HashMap.lookup n o' of Nothing -> authTagIsActive def n @@ -355,81 +136,3 @@ instance (Ord a, Binary a) => Binary (PredDNF a) where type AuthLiteral = PredLiteral AuthTag type AuthDNF = PredDNF AuthTag - - -data HealthCheck - = HealthCheckMatchingClusterConfig - | HealthCheckHTTPReachable - | HealthCheckLDAPAdmins - | HealthCheckSMTPConnect - | HealthCheckWidgetMemcached - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) -instance Universe HealthCheck -instance Finite HealthCheck -instance Hashable HealthCheck - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 2 - } ''HealthCheck -nullaryPathPiece ''HealthCheck $ camelToPathPiece' 2 -pathPieceJSONKey ''HealthCheck - -data HealthReport - = HealthMatchingClusterConfig { healthMatchingClusterConfig :: Bool } - -- ^ Is the database-stored configuration we're running under still up to date? - -- - -- Also tests database connection as a side effect - | HealthHTTPReachable { healthHTTPReachable :: Maybe Bool } - -- ^ Can we reach a uni2work-instance with the same `ClusterId` under our configured `approot` via HTTP? - | HealthLDAPAdmins { healthLDAPAdmins :: Maybe Rational } - -- ^ Proportion of school admins that could be found in LDAP - | HealthSMTPConnect { healthSMTPConnect :: Maybe Bool } - -- ^ Can we connect to the SMTP server and say @NOOP@? - | HealthWidgetMemcached { healthWidgetMemcached :: Maybe Bool } - -- ^ Can we store values in memcached and retrieve them via HTTP? - deriving (Eq, Ord, Read, Show, Data, Generic, Typeable) - -instance NFData HealthReport - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - , fieldLabelModifier = camelToPathPiece' 1 - , omitNothingFields = True - , sumEncoding = TaggedObject "test" "result" - , tagSingleConstructors = True - } ''HealthReport - -classifyHealthReport :: HealthReport -> HealthCheck -classifyHealthReport HealthMatchingClusterConfig{} = HealthCheckMatchingClusterConfig -classifyHealthReport HealthLDAPAdmins{} = HealthCheckLDAPAdmins -classifyHealthReport HealthHTTPReachable{} = HealthCheckHTTPReachable -classifyHealthReport HealthSMTPConnect{} = HealthCheckSMTPConnect -classifyHealthReport HealthWidgetMemcached{} = HealthCheckWidgetMemcached - --- | `HealthReport` classified (`classifyHealthReport`) by badness --- --- > a < b = a `worseThan` b --- --- Currently all consumers of this type check for @(== HealthSuccess)@; this --- needs to be adjusted on a case-by-case basis if new constructors are added -data HealthStatus = HealthFailure | HealthSuccess - deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable) - -instance Universe HealthStatus -instance Finite HealthStatus - -deriveJSON defaultOptions - { constructorTagModifier = camelToPathPiece' 1 - } ''HealthStatus -nullaryPathPiece ''HealthStatus $ camelToPathPiece' 1 - -healthReportStatus :: HealthReport -> HealthStatus --- ^ Classify `HealthReport` by badness -healthReportStatus = \case - HealthMatchingClusterConfig False -> HealthFailure - HealthHTTPReachable (Just False) -> HealthFailure - HealthLDAPAdmins (Just prop ) - | prop <= 0 -> HealthFailure - HealthSMTPConnect (Just False) -> HealthFailure - HealthWidgetMemcached (Just False) -> HealthFailure -- TODO: investigate this failure mode; do we just handle it gracefully? - _other -> maxBound -- Minimum badness diff --git a/src/Model/Types/Sheet.hs b/src/Model/Types/Sheet.hs index 426e375c5..961ea7400 100644 --- a/src/Model/Types/Sheet.hs +++ b/src/Model/Types/Sheet.hs @@ -1,62 +1,26 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving - , UndecidableInstances - #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} -- for instance PathPiece (CI Text) +module Model.Types.Sheet + ( module Model.Types.Sheet + ) where -module Model.Types.Sheet where - -import ClassyPrelude -import Utils -import Numeric.Natural +import Import.NoModel +import Model.Types.Common +import Utils.Lens.TH import Control.Lens -import Utils.Lens.TH -import GHC.Generics (Generic) import Generics.Deriving.Monoid (memptydefault, mappenddefault) -import Data.Typeable (Typeable) -import Data.Universe -import Data.Universe.Helpers -import Data.Universe.Instances.Reverse () -import Data.NonNull.Instances () import Data.Set (Set) import qualified Data.Set as Set import qualified Data.Map as Map -import Data.Fixed -import Data.Monoid (Sum(..)) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..), SumEncoding(..)) -import Data.CaseInsensitive.Instances () import Text.Blaze (Markup) -import Database.Persist.TH hiding (derivePersistFieldJSON) -import Model.Types.JSON import Yesod.Core.Dispatch (PathPiece(..)) -import Network.Mime +import Data.Maybe (fromJust) - ----- --- Sheet and Submission realted Model.Types - -type Count = Sum Integer -type Points = Centi - -toPoints :: Integral a => a -> Points -- deprecated -toPoints = fromIntegral - -pToI :: Points -> Integer -- deprecated -pToI = fromPoints - -fromPoints :: Integral a => Points -> a -- deprecated -fromPoints = round - -instance DisplayAble Points - -instance DisplayAble a => DisplayAble (Sum a) where - display (Sum x) = display x - data SheetGrading = Points { maxPoints :: Points } | PassPoints { maxPoints, passingPoints :: Points } @@ -179,7 +143,7 @@ data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) derivePersistField "SheetFileType" -instance Universe SheetFileType where universe = universeDef +instance Universe SheetFileType instance Finite SheetFileType instance PathPiece SheetFileType where @@ -208,22 +172,6 @@ sheetFile2markup SheetMarking = iconMarking partitionFileType :: Ord a => [(SheetFileType,a)] -> SheetFileType -> Set a partitionFileType fs t = Map.findWithDefault Set.empty t . Map.fromListWith Set.union $ map (over _2 Set.singleton) fs -data SubmissionFileType = SubmissionOriginal | SubmissionCorrected - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) - -instance Universe SubmissionFileType -instance Finite SubmissionFileType - -nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1 - -submissionFileTypeIsUpdate :: SubmissionFileType -> Bool -submissionFileTypeIsUpdate SubmissionOriginal = False -submissionFileTypeIsUpdate SubmissionCorrected = True - -isUpdateSubmissionFileType :: Bool -> SubmissionFileType -isUpdateSubmissionFileType False = SubmissionOriginal -isUpdateSubmissionFileType True = SubmissionCorrected - data UploadSpecificFile = UploadSpecificFile { specificFileLabel :: Text @@ -306,10 +254,6 @@ classifySubmissionMode (SubmissionMode False (Just _)) = SubmissionModeUser classifySubmissionMode (SubmissionMode True (Just _)) = SubmissionModeBoth -data ExamStatus = Attended | NoShow | Voided - deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) -derivePersistField "ExamStatus" - -- | Specify a corrector's workload data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rational } = Load { byTutorial :: Maybe Bool -- ^ @Just@ all from Tutorial, @True@ if counting towards overall workload @@ -340,3 +284,19 @@ instance Monoid Load where isByTutorial (ByTutorial {}) = True isByTutorial _ = False -} + +data CorrectorState = CorrectorNormal | CorrectorMissing | CorrectorExcused + deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic) + +deriveJSON defaultOptions + { constructorTagModifier = fromJust . stripPrefix "Corrector" + } ''CorrectorState + +instance Universe CorrectorState +instance Finite CorrectorState + +instance Hashable CorrectorState + +nullaryPathPiece ''CorrectorState (camelToPathPiece' 1) + +derivePersistField "CorrectorState" diff --git a/src/Model/Types/Submission.hs b/src/Model/Types/Submission.hs new file mode 100644 index 000000000..c70919195 --- /dev/null +++ b/src/Model/Types/Submission.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} + +module Model.Types.Submission + ( module Model.Types.Submission + ) where + +import Import.NoModel + +import Data.Aeson.Types (ToJSON(..), FromJSON(..)) +import qualified Data.Aeson.Types as Aeson + +import Database.Persist.Sql + +import Data.Word.Word24 + +import qualified Data.CaseInsensitive as CI + +import Control.Lens + +import qualified Data.Text as Text +import qualified Data.Set as Set + + +import Data.List (elemIndex, genericIndex) +import Data.Bits +import Data.Text.Metrics (damerauLevenshtein) + +------------------------- +-- Submission Download -- +------------------------- + +data SubmissionFileType = SubmissionOriginal | SubmissionCorrected + deriving (Show, Read, Eq, Ord, Enum, Bounded, Generic) + +instance Universe SubmissionFileType +instance Finite SubmissionFileType + +nullaryPathPiece ''SubmissionFileType $ camelToPathPiece' 1 + +submissionFileTypeIsUpdate :: SubmissionFileType -> Bool +submissionFileTypeIsUpdate SubmissionOriginal = False +submissionFileTypeIsUpdate SubmissionCorrected = True + +isUpdateSubmissionFileType :: Bool -> SubmissionFileType +isUpdateSubmissionFileType False = SubmissionOriginal +isUpdateSubmissionFileType True = SubmissionCorrected + +--------------------------- +-- Submission Pseudonyms -- +--------------------------- + +type PseudonymWord = CI Text + +newtype Pseudonym = Pseudonym Word24 + deriving (Eq, Ord, Read, Show, Generic, Data) + deriving newtype (Bounded, Enum, Integral, Num, Real, Ix) + + +instance PersistField Pseudonym where + toPersistValue p = toPersistValue (fromIntegral p :: Word32) + fromPersistValue v = do + w <- fromPersistValue v :: Either Text Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> Left "Pseudonym out of range" + +instance PersistFieldSql Pseudonym where + sqlType _ = SqlInt32 + +instance Random Pseudonym where + randomR (max minBound -> lo, min maxBound -> hi) gen = over _1 (fromIntegral :: Word32 -> Pseudonym) $ randomR (fromIntegral lo, fromIntegral hi) gen + random = randomR (minBound, maxBound) + +instance FromJSON Pseudonym where + parseJSON v@(Aeson.Number _) = do + w <- parseJSON v :: Aeson.Parser Word32 + if + | 0 <= w + , w <= fromIntegral (maxBound :: Pseudonym) + -> return $ fromIntegral w + | otherwise + -> fail "Pseudonym out auf range" + parseJSON (Aeson.String t) + = case t ^? _PseudonymText of + Just p -> return p + Nothing -> fail "Could not parse pseudonym" + parseJSON v = flip (Aeson.withArray "Pseudonym") v $ \ws -> do + ws' <- toList . map CI.mk <$> mapM parseJSON ws + case ws' ^? _PseudonymWords of + Just p -> return p + Nothing -> fail "Could not parse pseudonym words" + +instance ToJSON Pseudonym where + toJSON = toJSON . (review _PseudonymWords :: Pseudonym -> [PseudonymWord]) + +pseudonymWordlist :: [PseudonymWord] +pseudonymCharacters :: Set (CI Char) +(pseudonymWordlist, pseudonymCharacters) = $(wordlist "config/wordlist.txt") + +_PseudonymWords :: Prism' [PseudonymWord] Pseudonym +_PseudonymWords = prism' pToWords pFromWords + where + pFromWords :: [PseudonymWord] -> Maybe Pseudonym + pFromWords [w1, w2] + | Just i1 <- elemIndex w1 pseudonymWordlist + , Just i2 <- elemIndex w2 pseudonymWordlist + , i1 <= maxWord, i2 <= maxWord + = Just . Pseudonym $ shiftL (fromIntegral i1) 12 .|. fromIntegral i2 + pFromWords _ = Nothing + + pToWords :: Pseudonym -> [PseudonymWord] + pToWords (Pseudonym p) + = [ genericIndex pseudonymWordlist $ shiftR p 12 .&. maxWord + , genericIndex pseudonymWordlist $ p .&. maxWord + ] + + maxWord :: Num a => a + maxWord = 0b111111111111 + +_PseudonymText :: Prism' Text Pseudonym +_PseudonymText = prism' tToWords tFromWords . _PseudonymWords + where + tFromWords :: Text -> Maybe [PseudonymWord] + tFromWords input + | [result] <- input ^.. pseudonymFragments + = Just result + | otherwise + = Nothing + + tToWords :: [PseudonymWord] -> Text + tToWords = Text.unwords . map CI.original + +pseudonymWords :: Fold Text PseudonymWord +pseudonymWords = folding + $ \(CI.mk -> input) -> map (view _2) . fromMaybe [] . listToMaybe . groupBy ((==) `on` view _1) . sortBy (comparing $ view _1) . filter ((<= distanceCutoff) . view _1) $ map (distance input &&& id) pseudonymWordlist + where + distance = damerauLevenshtein `on` CI.foldedCase + -- | Arbitrary cutoff point, for reference: ispell cuts off at 1 + distanceCutoff = 2 + +pseudonymFragments :: Fold Text [PseudonymWord] +pseudonymFragments = folding + $ mapM (toListOf pseudonymWords) . (\l -> guard (length l == 2) *> l) . filter (not . null) . Text.split (\(CI.mk -> c) -> not $ Set.member c pseudonymCharacters) diff --git a/src/Model/Types/JSON.hs b/src/Model/Types/TH/JSON.hs similarity index 98% rename from src/Model/Types/JSON.hs rename to src/Model/Types/TH/JSON.hs index 66ed78163..34a752350 100644 --- a/src/Model/Types/JSON.hs +++ b/src/Model/Types/TH/JSON.hs @@ -1,4 +1,4 @@ -module Model.Types.JSON +module Model.Types.TH.JSON ( derivePersistFieldJSON , predNFAesonOptions ) where diff --git a/src/Model/Types/Wordlist.hs b/src/Model/Types/TH/Wordlist.hs similarity index 95% rename from src/Model/Types/Wordlist.hs rename to src/Model/Types/TH/Wordlist.hs index 5cfecd662..de3d159d8 100644 --- a/src/Model/Types/Wordlist.hs +++ b/src/Model/Types/TH/Wordlist.hs @@ -1,4 +1,6 @@ -module Model.Types.Wordlist (wordlist) where +module Model.Types.TH.Wordlist + ( wordlist + ) where import ClassyPrelude hiding (lift) diff --git a/src/Settings.hs b/src/Settings.hs index 884b1bd35..c53e90269 100644 --- a/src/Settings.hs +++ b/src/Settings.hs @@ -10,14 +10,13 @@ module Settings , module Settings.Cluster ) where -import ClassyPrelude.Yesod +import Import.NoModel import Data.UUID (UUID) import qualified Control.Exception as Exception -import Data.Aeson (Result (..), fromJSON, withObject +import Data.Aeson (fromJSON, withObject ,(.!=), (.:?), withScientific ) import qualified Data.Aeson.Types as Aeson -import Data.Aeson.TH import Data.FileEmbed (embedFile) import Data.Yaml (decodeEither') import Database.Persist.Postgresql (PostgresConf) @@ -45,7 +44,6 @@ import qualified Data.Text.Encoding as Text import qualified Ldap.Client as Ldap -import Utils hiding (MessageStatus(..)) import Control.Lens import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..)) @@ -70,7 +68,6 @@ import Jose.Jwt (JwtEncoding(..)) import System.FilePath.Glob import Handler.Utils.Submission.TH -import Network.Mime import Network.Mime.TH import qualified Data.Map as Map @@ -483,5 +480,5 @@ configSettingsYmlValue = either Exception.throw id compileTimeAppSettings :: AppSettings compileTimeAppSettings = case fromJSON $ applyEnvValue False mempty configSettingsYmlValue of - Error e -> error e - Success settings -> settings + Aeson.Error e -> error e + Aeson.Success settings -> settings diff --git a/src/System/FilePath/Instances.hs b/src/System/FilePath/Instances.hs new file mode 100644 index 000000000..b37e2291a --- /dev/null +++ b/src/System/FilePath/Instances.hs @@ -0,0 +1,16 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module System.FilePath.Instances + ( + ) where + +import ClassyPrelude + +import qualified Data.Text as Text + +import Web.PathPieces + + +instance {-# OVERLAPS #-} PathMultiPiece FilePath where + fromPathMultiPiece = Just . unpack . intercalate "/" + toPathMultiPiece = Text.splitOn "/" . pack diff --git a/src/Time/Types/Instances.hs b/src/Time/Types/Instances.hs index af91312e3..fa61bca45 100644 --- a/src/Time/Types/Instances.hs +++ b/src/Time/Types/Instances.hs @@ -12,8 +12,14 @@ import Data.Universe import Utils.PathPiece +import Data.Aeson.TH + instance Universe WeekDay instance Finite WeekDay nullaryPathPiece ''WeekDay camelToPathPiece + +deriveJSON defaultOptions + { constructorTagModifier = camelToPathPiece + } ''WeekDay diff --git a/src/Utils.hs b/src/Utils.hs index 81f08b684..2080947ec 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -1,5 +1,3 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -- Monad FormResult - module Utils ( module Utils ) where @@ -68,7 +66,7 @@ import qualified Crypto.Saltine.Core.SecretBox as SecretBox import qualified Crypto.Saltine.Class as Saltine import qualified Crypto.Data.PKCS7 as PKCS7 -import Data.Fixed (Centi) +import Data.Fixed import Data.Ratio ((%)) import qualified Data.Binary as Binary @@ -277,6 +275,12 @@ instance DisplayAble a => DisplayAble (E.Value a) where instance DisplayAble a => DisplayAble (CI a) where display = display . CI.original +instance HasResolution a => DisplayAble (Fixed a) where + display = pack . showFixed True + +instance DisplayAble a => DisplayAble (Sum a) where + display = display . getSum + {- We do not want DisplayAble for every Show-Class: We want to explicitly verify that the resulting text can be displayed to the User! For example: UTCTime values were shown without proper format rendering! diff --git a/src/Utils/DateTime.hs b/src/Utils/DateTime.hs index 0b5855566..3f66c65ee 100644 --- a/src/Utils/DateTime.hs +++ b/src/Utils/DateTime.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} module Utils.DateTime ( timeLocaleMap @@ -14,10 +13,9 @@ module Utils.DateTime import ClassyPrelude.Yesod hiding (lift) import System.Locale.Read -import Data.Time (TimeZone(..), TimeLocale(..)) +import Data.Time (TimeLocale(..)) import Data.Time.Zones (TZ) import Data.Time.Zones.TH (includeSystemTZ) -import Data.Time.Clock.POSIX import Language.Haskell.TH import Language.Haskell.TH.Syntax (Lift(..)) @@ -35,11 +33,8 @@ import Data.Aeson.TH import Utils.PathPiece -deriving instance Lift TimeZone -deriving instance Lift TimeLocale - -instance Hashable UTCTime where - hashWithSalt s = hashWithSalt s . toRational . utcTimeToPOSIXSeconds +import Data.Time.Format.Instances () + -- $(timeLocaleMap _) :: [Lang] -> TimeLocale timeLocaleMap :: [(Lang, String)] -- ^ Languages and matching locales, first is taken as default @@ -91,7 +86,7 @@ instance Finite SelDateTimeFormat instance Hashable SelDateTimeFormat deriveJSON defaultOptions - { constructorTagModifier = intercalate "-" . map toLower . drop 2 . splitCamel + { constructorTagModifier = camelToPathPiece' 2 } ''SelDateTimeFormat instance ToJSONKey SelDateTimeFormat where diff --git a/test/MailSpec.hs b/test/MailSpec.hs index c9972548d..ad54385c6 100644 --- a/test/MailSpec.hs +++ b/test/MailSpec.hs @@ -27,7 +27,7 @@ spec = do lawsCheckHspec (Proxy @MailSmtpData) [ eqLaws, ordLaws, showReadLaws, monoidLaws ] lawsCheckHspec (Proxy @MailLanguages) - [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws ] + [ eqLaws, ordLaws, showReadLaws, isListLaws, jsonLaws, hashableLaws, persistFieldLaws ] lawsCheckHspec (Proxy @MailContext) [ eqLaws, ordLaws, showReadLaws, jsonLaws, hashableLaws ] lawsCheckHspec (Proxy @VerpMode) diff --git a/test/Model/TypesSpec.hs b/test/Model/TypesSpec.hs index ad74f5831..3805809db 100644 --- a/test/Model/TypesSpec.hs +++ b/test/Model/TypesSpec.hs @@ -267,8 +267,6 @@ spec = do [ eqLaws, ordLaws, showReadLaws, jsonLaws, boundedEnumLaws, finiteLaws, hashableLaws, jsonLaws, jsonKeyLaws ] lawsCheckHspec (Proxy @NotificationSettings) [ eqLaws, ordLaws, showReadLaws, jsonLaws, persistFieldLaws ] - lawsCheckHspec (Proxy @MailLanguages) - [ persistFieldLaws ] lawsCheckHspec (Proxy @Pseudonym) [ eqLaws, ordLaws, showReadLaws, boundedEnumLaws, integralLaws, jsonLaws, persistFieldLaws ] lawsCheckHspec (Proxy @AuthTag) diff --git a/test/TestImport.hs b/test/TestImport.hs index a9c5cd88d..4fb09576b 100644 --- a/test/TestImport.hs +++ b/test/TestImport.hs @@ -32,6 +32,7 @@ import Data.Proxy as X import Data.UUID as X (UUID) import System.IO as X (hPrint, hPutStrLn, stderr) import Jobs (handleJobs, stopJobCtl) +import Numeric.Natural as X import Control.Lens as X hiding ((<.), elements) diff --git a/test/Utils/DateTimeSpec.hs b/test/Utils/DateTimeSpec.hs index b2480749d..2e0d086eb 100644 --- a/test/Utils/DateTimeSpec.hs +++ b/test/Utils/DateTimeSpec.hs @@ -2,6 +2,9 @@ module Utils.DateTimeSpec where import TestImport +import Utils.DateTime + + instance Arbitrary DateTimeFormat where arbitrary = DateTimeFormat <$> arbitrary shrink = genericShrink